git.iko.soy/rel8
on 07daf4f help sign in
6c038ec
swap
0 ahead, 84 behind
132 files changed+4831−5396
since splitsnapshots
unifiedsplit
.github/workflows/build.yaml+3−3 Changelog.md+1−130 README.md−4 cabal.project+5 cabal.project.haskell-nix+6 default.nix+5−5 docs/concepts/insert.rst+10−37 docs/cookbook.rst+7−9 nix/sources.json+9−9 nix/sources.nix+1−21 rel8.cabal+16−38 shell.nix+2−2 src/Rel8.hs+15−301 src/Rel8/Aggregate.hs+103−37 src/Rel8/Column.hs+77−5 src/Rel8/Column/ADT.hs+68−3 src/Rel8/Column/Either.hs+140−4 src/Rel8/Column/Lift.hs+67−3 src/Rel8/Column/List.hs+126−6 src/Rel8/Column/Maybe.hs+105−4 src/Rel8/Column/NonEmpty.hs+127−6 src/Rel8/Column/Null.hs−26 src/Rel8/Column/These.hs+142−5 src/Rel8/Expr.hs+41−17 src/Rel8/Expr.hs-boot+8−6 src/Rel8/Expr/Aggregate.hs+64−25 src/Rel8/Expr/Eq.hs+1−1 src/Rel8/Expr/Num.hs+6−39 src/Rel8/Expr/Opaleye.hs+3−12 src/Rel8/Expr/Sequence.hs+1−2 src/Rel8/Expr/Text.hs+2−23 src/Rel8/Expr/Window.hs−121 src/Rel8/FCF.hs+3−3 src/Rel8/Generic/Construction.hs+165−146 src/Rel8/Generic/Construction/ADT.hs+27−20 src/Rel8/Generic/Construction/Record.hs+3−3 src/Rel8/Generic/Map.hs+64−20 src/Rel8/Generic/Record.hs−2 src/Rel8/Generic/Reify.hs+24 src/Rel8/Generic/Rel8able.hs+71−178 tests/Rel8/Generic/Rel8able/Test.hs → src/Rel8/Generic/Rel8able/Test.hs+16−47 src/Rel8/Generic/Table.hs+109−24 src/Rel8/Generic/Table/ADT.hs+197−58 src/Rel8/Generic/Table/Record.hs+93−74 src/Rel8/Kind/Context.hs+21−8 src/Rel8/Order.hs+8−1 src/Rel8/Query.hs+9−28 src/Rel8/Query/Aggregate.hs−19 src/Rel8/Query/Distinct.hs+9−4 src/Rel8/Query/Each.hs+3−3 src/Rel8/Query/Either.hs+6−10 src/Rel8/Query/Evaluate.hs+22−3 src/Rel8/Query/Exists.hs+1−1 src/Rel8/Query/Indexed.hs−21 src/Rel8/Query/List.hs+16−19 src/Rel8/Query/Maybe.hs+14−22 src/Rel8/Query/Null.hs−15 src/Rel8/Query/Opaleye.hs+10−18 src/Rel8/Query/Rebind.hs−27 src/Rel8/Query/SQL.hs+59−6 src/Rel8/Query/Set.hs+6−6 src/Rel8/Query/These.hs+36−36 src/Rel8/Query/Window.hs−26 src/Rel8/Schema/Context.hs+20 src/Rel8/Schema/Context/Nullify.hs+148−105 src/Rel8/Schema/Field.hs−50 src/Rel8/Schema/HTable.hs+24−51 src/Rel8/Schema/HTable/Either.hs+2−2 src/Rel8/Schema/HTable/Identity.hs+28−16 src/Rel8/Schema/HTable/Label.hs+4−16 src/Rel8/Schema/HTable/MapTable.hs+12−22 src/Rel8/Schema/HTable/Maybe.hs+2−2 src/Rel8/Schema/HTable/Nullify.hs+29−44 src/Rel8/Schema/HTable/These.hs+3−3 src/Rel8/Schema/HTable/Vectorize.hs+41−39 src/Rel8/Schema/Kind.hs+15−6 src/Rel8/Schema/Name.hs+50−34 src/Rel8/Schema/Reify.hs+68 src/Rel8/Schema/Result.hs+33−16 src/Rel8/Schema/Spec.hs+30−16 src/Rel8/Schema/Spec/ConstrainDBType.hs+89 src/Rel8/Schema/Table.hs−20 src/Rel8/Statement/Delete.hs+48−35 src/Rel8/Statement/Insert.hs+72−43 src/Rel8/Statement/OnConflict.hs−106 src/Rel8/Statement/Returning.hs+10−114 src/Rel8/Statement/SQL.hs−29 src/Rel8/Statement/Select.hs+35−120 src/Rel8/Statement/Set.hs−33 src/Rel8/Statement/Update.hs+56−38 src/Rel8/Statement/Using.hs−36 src/Rel8/Statement/View.hs+28−43 src/Rel8/Statement/Where.hs−31 src/Rel8/Table.hs+245−88 src/Rel8/Table/ADT.hs+65−33 src/Rel8/Table/Aggregate.hs+13−24 src/Rel8/Table/Bool.hs+6−5 src/Rel8/Table/Cols.hs−50 src/Rel8/Table/Either.hs+125−126 src/Rel8/Table/Eq.hs+39−12 src/Rel8/Table/HKD.hs+105−65 src/Rel8/Table/List.hs+55−65 src/Rel8/Table/Maybe.hs+113−110 src/Rel8/Table/Name.hs+20−11 src/Rel8/Table/NonEmpty.hs+54−66 src/Rel8/Table/Null.hs−147 src/Rel8/Table/Nullify.hs−211 src/Rel8/Table/Opaleye.hs+64−78 src/Rel8/Table/Ord.hs+45−16 src/Rel8/Table/Order.hs+16−13 src/Rel8/Table/Projection.hs−73 src/Rel8/Table/Recontextualize.hs+107 src/Rel8/Table/Rel8able.hs+82−29 src/Rel8/Table/Serialize.hs+122−22 src/Rel8/Table/Tag.hs+97 src/Rel8/Table/These.hs+142−164 src/Rel8/Table/Transpose.hs−46 src/Rel8/Table/Undefined.hs+5−5 src/Rel8/Table/Unreify.hs+102 src/Rel8/Table/Window.hs−43 src/Rel8/Tabulate.hs−640 src/Rel8/Type.hs+8−9 src/Rel8/Type/Composite.hs+19−20 src/Rel8/Type/Enum.hs−1 src/Rel8/Type/JSONBEncoded.hs−4 src/Rel8/Type/JSONEncoded.hs−4 src/Rel8/Type/Num.hs+1−4 src/Rel8/Type/Ord.hs+2 src/Rel8/Type/ReadShow.hs−3 src/Rel8/Type/Tag.hs+1−2 src/Rel8/Window.hs−97 tests/Main.hs+178−288
.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−130
@@ -1,148 +1,19 @@
1−# 1.4.0.0 (2002-08-17)
1+# 1.1.0.0 (??)
22
33## Breaking changes
44
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))
1258
1269* The `Labelable` type class has been removed as it's no longer necessary. This class was mostly internal, though was visible in some public API functions. ([#76](https://github.com/circuithub/rel8/pull/76))
12710
128−* `EitherTable`, `ListTable`, `MaybeTable`, `NonEmptyTable` and `TheseTable` now all have an extra parameter which tracks the context of the table. If you manually specified any types before, you need to provide this parameter - usually `Expr` will be the correct choice. ([#101](https://github.com/circuithub/rel8/pull/101))
129−
130−* We've done a lot of work to simplify the internals of Rel8, but some of these are breaking changes. However, most of these API changes shouldn't affect users as they are mostly types used in type inference, or affect classes where users don't need to define their own instances.
131−
132− * The kind of a `Rel8able` is now `(Type -> Type) -> Type`. Previously it was `(X -> Type) -> Type`.
133− * `Table` has a new associated type - `FromExprs`. This was previously an open type family.
134− * `Table` has a new associated type - `Transpose` - and `Recontextualise` has been renamed to `Transposes`. This `Transposes` class now operates in terms of `Transpose`.
135−
136−* `select`, `insert`, `update` and `delete` now produce Hasql `Statement`s, rather than actually running the statement as IO. This allows Rel8 to be used with transaction/connection-managing monads like [`hasql-transaction`](https://hackage.haskell.org/package/hasql-transaction). ([#94](https://github.com/circuithub/rel8/pull/94))
137−
13811## Bug fixes
13912
14013* 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))
14114
14215* Require Opaleye 0.7.3.0. This version has better support for lateral queries, which can improve query plans, especially in `optional`/`LEFT JOIN` ([#72](https://github.com/circuithub/rel8/pull/72))
14316
144−* Rel8 now compiles with GHC 9. ([#97](https://github.com/circuithub/rel8/pull/97))
145−
14617## Other changes
14718
14819* `exists` is now implemented in terms of the SQL `EXISTS` keyword. ([#69](https://github.com/circuithub/rel8/pull/69))
README.md−4
@@ -10,8 +10,4 @@ The main objectives of Rel8 are:
1010
1111* *Familiar*: writing Rel8 queries should feel like normal Haskell programming.
1212
13−Rel8 was presented at ZuriHac 2021. If you want to have a brief overview of what Rel8 is, and a tour of the API - check out the video below:
14−
15−[![Rel8 presentation at ZuriHac 2021](https://img.youtube.com/vi/3uwrtjxiq6E/hqdefault.jpg)](http://www.youtube.com/watch?v=3uwrtjxiq6E)
16−
1713For more details, check out the [official documentation](https://rel8.readthedocs.io/en/latest/).
cabal.project+5
@@ -1 +1,6 @@
11packages: .
2+
3+allow-newer: generic-monoid:base
4+allow-newer: cryptohash-sha1:base
5+allow-newer: cryptohash-md5:base
6+allow-newer: entropy:Cabal
cabal.project.haskell-nix+6
@@ -2,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.
5+
6+source-repository-package
7+ type: git
8+ location: git://github.com/jcpetruzza/barbies
9+ tag: f99b05454874192e3511bd133555dfb6cc6a6ecb
10+ --sha256: 0yy2i2jbllwavv5d2176rf8lmm4l1ws90lxkmdlfgvfzqxidx0gi
default.nix+5−5
@@ -1,15 +1,15 @@
1−let
1+let
22 haskellNix = import (import ./nix/sources.nix)."haskell.nix" {};
33
4− nixpkgsSrc = haskellNix.sources.nixpkgs-unstable;
4+ nixpkgsSrc = haskellNix.sources.nixpkgs-2009;
55
66 nixpkgsArgs = haskellNix.nixpkgsArgs;
77
8− compiler-nix-name = "ghc924";
8+ compiler-nix-name = "ghc8104";
99
1010 pkgs = import nixpkgsSrc nixpkgsArgs;
1111
12−in
12+in
1313pkgs.haskell-nix.project {
1414 inherit compiler-nix-name;
1515
@@ -20,7 +20,7 @@ pkgs.haskell-nix.project {
2020 src = ./.;
2121 };
2222
23− modules = [
23+ modules = [
2424 { packages.rel8 = {
2525 preCheck = ''
2626 export PATH="${pkgs.postgresql}/bin:${"$PATH"}"
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+16−38
@@ -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,33 +20,28 @@ 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
27− , comonad
2826 , contravariant
29− , hasql ^>= 1.4.5.1 || ^>= 1.5.0.0 || ^>= 1.6.0.0
30− , opaleye ^>= 0.9.6.1
31− , pretty
27+ , hasql ^>= 1.4.5.1
28+ , opaleye ^>= 0.7.3.0
3229 , profunctors
33− , product-profunctors
3430 , scientific
3531 , semialign
3632 , semigroupoids
3733 , text
3834 , these
3935 , time
36+ , transformers
4037 , uuid
4138 default-language:
4239 Haskell2010
4340 ghc-options:
44− -Werror=missing-methods -Werror=incomplete-patterns -Werror=missing-fields
4541 -Weverything -Wno-unsafe -Wno-safe -Wno-missing-safe-haskell-mode
4642 -Wno-missing-import-lists -Wno-prepositive-qualified-module
4743 -Wno-monomorphism-restriction
4844 -Wno-missing-local-signatures
49− -Wno-missing-kind-signatures
5045 hs-source-dirs:
5146 src
5247 exposed-modules:
@@ -54,7 +49,6 @@ library
5449 Rel8.Expr.Num
5550 Rel8.Expr.Text
5651 Rel8.Expr.Time
57− Rel8.Tabulate
5852
5953 other-modules:
6054 Rel8.Aggregate
@@ -66,7 +60,6 @@ library
6660 Rel8.Column.List
6761 Rel8.Column.Maybe
6862 Rel8.Column.NonEmpty
69− Rel8.Column.Null
7063 Rel8.Column.These
7164
7265 Rel8.Expr
@@ -82,7 +75,6 @@ library
8275 Rel8.Expr.Order
8376 Rel8.Expr.Sequence
8477 Rel8.Expr.Serialize
85− Rel8.Expr.Window
8678
8779 Rel8.FCF
8880
@@ -94,7 +86,9 @@ library
9486 Rel8.Generic.Construction.Record
9587 Rel8.Generic.Map
9688 Rel8.Generic.Record
89+ Rel8.Generic.Reify
9790 Rel8.Generic.Rel8able
91+ Rel8.Generic.Rel8able.Test
9892 Rel8.Generic.Table
9993 Rel8.Generic.Table.ADT
10094 Rel8.Generic.Table.Record
@@ -109,23 +103,20 @@ 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
126118 Rel8.Schema.Context.Nullify
127119 Rel8.Schema.Dict
128− Rel8.Schema.Field
129120 Rel8.Schema.HTable
130121 Rel8.Schema.HTable.Either
131122 Rel8.Schema.HTable.Identity
@@ -141,28 +132,24 @@ library
141132 Rel8.Schema.Kind
142133 Rel8.Schema.Name
143134 Rel8.Schema.Null
135+ Rel8.Schema.Reify
144136 Rel8.Schema.Result
145137 Rel8.Schema.Spec
138+ Rel8.Schema.Spec.ConstrainDBType
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
162150 Rel8.Table.Aggregate
163151 Rel8.Table.Alternative
164152 Rel8.Table.Bool
165− Rel8.Table.Cols
166153 Rel8.Table.Either
167154 Rel8.Table.Eq
168155 Rel8.Table.HKD
@@ -170,18 +157,16 @@ library
170157 Rel8.Table.Maybe
171158 Rel8.Table.Name
172159 Rel8.Table.NonEmpty
173− Rel8.Table.Null
174− Rel8.Table.Nullify
175160 Rel8.Table.Opaleye
176161 Rel8.Table.Ord
177162 Rel8.Table.Order
178− Rel8.Table.Projection
163+ Rel8.Table.Recontextualize
179164 Rel8.Table.Rel8able
180165 Rel8.Table.Serialize
166+ Rel8.Table.Tag
181167 Rel8.Table.These
182− Rel8.Table.Transpose
183168 Rel8.Table.Undefined
184− Rel8.Table.Window
169+ Rel8.Table.Unreify
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,12 +203,8 @@ test-suite tests
221203 , text
222204 , time
223205 , tmp-postgres ^>=1.34.1.0
224− , transformers
225206 , uuid
226207
227− other-modules:
228− Rel8.Generic.Rel8able.Test
229−
230208 main-is: Main.hs
231209 hs-source-dirs: tests
232210 default-language: Haskell2010
shell.nix+2−2
@@ -1,11 +1,11 @@
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 {
77 withHoogle = false;
8− tools = { cabal = "latest"; };
8+ tools = { cabal = "latest"; haskell-language-server = "latest"; };
99 exactDeps = false;
1010 buildInputs = [ pkgs.postgresql pkgs.pythonPackages.sphinx ];
1111 }
src/Rel8.hs+15−301
@@ -38,31 +38,27 @@ module Rel8
3838 , HMaybe
3939 , HList
4040 , HNonEmpty
41− , HNull
4241 , HThese
4342 , Lift
4443
4544 , Table(..)
4645 , HTable
47− , Transposes
46+ , Recontextualize
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
65− , aggregateMaybeTable
6662 , nameMaybeTable
6763
6864 -- ** @EitherTable@
@@ -72,7 +68,6 @@ module Rel8
7268 , keepLeftTable
7369 , keepRightTable
7470 , bitraverseEitherTable
75− , aggregateEitherTable
7671 , nameEitherTable
7772
7873 -- ** @TheseTable@
@@ -81,7 +76,6 @@ module Rel8
8176 , isThisTable, isThatTable, isThoseTable
8277 , hasHereTable, hasThereTable
8378 , justHereTable, justThereTable
84− , alignMaybeTable
8579 , alignBy
8680 , keepHereTable, loseHereTable
8781 , keepThereTable, loseThereTable
@@ -89,12 +83,11 @@ module Rel8
8983 , keepThatTable, loseThatTable
9084 , keepThoseTable, loseThoseTable
9185 , bitraverseTheseTable
92− , aggregateTheseTable
9386 , nameTheseTable
9487
9588 -- ** @ListTable@
9689 , ListTable
97− , listTable, ($*)
90+ , listTable
9891 , nameListTable
9992 , many
10093 , manyExpr
@@ -103,44 +96,21 @@ module Rel8
10396
10497 -- ** @NonEmptyTable@
10598 , NonEmptyTable
106− , nonEmptyTable, ($+)
99+ , nonEmptyTable
107100 , nameNonEmptyTable
108101 , some
109102 , someExpr
110103 , catNonEmptyTable
111104 , catNonEmpty
112105
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
106+ -- ** @ADT@
127107 , ADT, ADTable
128−
129− -- *** Deconstruction of ADTs
130− -- $deconstruction
131− , DeconstructADT, deconstructADT
132−
133− -- *** Construction of ADTs
134− -- $construction
135108 , BuildADT, buildADT
136109 , ConstructADT, constructADT
137−
138− -- *** Other ADT operations
110+ , DeconstructADT, deconstructADT
111+ , NameADT, nameADT
139112 , AggregateADT, aggregateADT
140113
141− -- *** Miscellaneous notes
142− -- $misc-notes
143−
144114 -- ** @HKD@
145115 , HKD, HKDable
146116 , BuildHKD, buildHKD
@@ -165,7 +135,6 @@ module Rel8
165135 -- ** @null@
166136 , NotNull
167137 , Nullable
168− , Homonullable
169138 , null
170139 , nullify
171140 , nullable
@@ -184,7 +153,6 @@ module Rel8
184153 , (==.), (/=.), (==?), (/=?)
185154 , in_
186155 , boolExpr, caseExpr
187− , like, ilike
188156
189157 -- ** Ordering
190158 , DBOrd
@@ -202,13 +170,6 @@ module Rel8
202170 , Query
203171 , showQuery
204172
205− -- ** Projection
206− , Projection
207− , Projectable( project )
208− , Biprojectable( biproject )
209− , Projecting
210− , Field
211−
212173 -- ** Selecting rows
213174 , Selects
214175 , each
@@ -253,11 +214,10 @@ module Rel8
253214 , countRows
254215 , groupBy
255216 , listAgg, listAggExpr
256− , mode
257217 , nonEmptyAgg, nonEmptyAggExpr
258218 , DBMax, max
259219 , DBMin, min
260− , DBSum, sum, sumWhere, avg
220+ , DBSum, sum, sumWhere
261221 , DBString, stringAgg
262222 , count
263223 , countStar
@@ -274,35 +234,10 @@ module Rel8
274234 , nullsFirst
275235 , nullsLast
276236
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−
303237 -- * IO
304238 , Serializable
305− , ToExprs
239+ , ToExprs(..)
240+ , FromExprs
306241 , Result
307242
308243 -- * Running statements
@@ -314,31 +249,29 @@ module Rel8
314249 -- ** @INSERT@
315250 , Insert(..)
316251 , OnConflict(..)
317− , Upsert(..)
318252 , insert
319253 , unsafeDefault
320− , showInsert
321254
322255 -- ** @DELETE@
323256 , Delete(..)
324257 , delete
325− , showDelete
326258
327259 -- ** @UPDATE@
328260 , Update(..)
329261 , update
330− , showUpdate
331262
332263 -- ** @.. RETURNING@
333264 , Returning(..)
334265
335266 -- ** @CREATE VIEW@
336267 , createView
337− , createOrReplaceView
338268
339269 -- ** Sequences
340270 , nextval
341271 , evaluate
272+
273+ -- * Implementation details
274+ , HKDT(..)
342275 ) where
343276
344277-- base
@@ -353,7 +286,6 @@ import Rel8.Column.Lift
353286import Rel8.Column.List
354287import Rel8.Column.Maybe
355288import Rel8.Column.NonEmpty
356−import Rel8.Column.Null
357289import Rel8.Column.These
358290import Rel8.Expr
359291import Rel8.Expr.Aggregate
@@ -367,8 +299,6 @@ import Rel8.Expr.Ord
367299import Rel8.Expr.Order
368300import Rel8.Expr.Serialize
369301import Rel8.Expr.Sequence
370−import Rel8.Expr.Text ( like, ilike )
371−import Rel8.Expr.Window hiding ( cumulative )
372302import Rel8.Generic.Rel8able ( KRel8able, Rel8able )
373303import Rel8.Order
374304import Rel8.Query
@@ -379,19 +309,15 @@ import Rel8.Query.Either
379309import Rel8.Query.Evaluate
380310import Rel8.Query.Exists
381311import Rel8.Query.Filter
382−import Rel8.Query.Indexed
383312import Rel8.Query.Limit
384313import Rel8.Query.List
385314import Rel8.Query.Maybe
386315import Rel8.Query.Null
387316import Rel8.Query.Order
388−import Rel8.Query.Rebind
389317import Rel8.Query.SQL (showQuery)
390318import Rel8.Query.Set
391319import Rel8.Query.These
392320import Rel8.Query.Values
393−import Rel8.Query.Window
394−import Rel8.Schema.Field
395321import Rel8.Schema.HTable
396322import Rel8.Schema.Name
397323import Rel8.Schema.Null hiding ( nullable )
@@ -399,10 +325,8 @@ import Rel8.Schema.Result ( Result )
399325import Rel8.Schema.Table
400326import Rel8.Statement.Delete
401327import Rel8.Statement.Insert
402−import Rel8.Statement.OnConflict
403328import Rel8.Statement.Returning
404329import Rel8.Statement.Select
405−import Rel8.Statement.SQL
406330import Rel8.Statement.Update
407331import Rel8.Statement.View
408332import Rel8.Table
@@ -417,16 +341,12 @@ import Rel8.Table.List
417341import Rel8.Table.Maybe
418342import Rel8.Table.Name
419343import Rel8.Table.NonEmpty
420−import Rel8.Table.Null
421−import Rel8.Table.Opaleye ( castTable )
422344import Rel8.Table.Ord
423345import Rel8.Table.Order
424−import Rel8.Table.Projection
346+import Rel8.Table.Recontextualize
425347import Rel8.Table.Rel8able ()
426348import Rel8.Table.Serialize
427349import Rel8.Table.These
428−import Rel8.Table.Transpose
429−import Rel8.Table.Window
430350import Rel8.Type
431351import Rel8.Type.Composite
432352import Rel8.Type.Eq
@@ -441,7 +361,6 @@ import Rel8.Type.ReadShow
441361import Rel8.Type.Semigroup
442362import Rel8.Type.String
443363import Rel8.Type.Sum
444−import Rel8.Window
445364
446365
447366-- $running
@@ -449,208 +368,3 @@ import Rel8.Window
449368-- provides 'select', 'insert', 'update' and 'delete' functions. Note that
450369-- 'insert', 'update' and 'delete' will generally need the
451370-- `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+103−37
@@ -1,83 +1,149 @@
11{-# language DataKinds #-}
2+{-# language DerivingVia #-}
23{-# language FlexibleContexts #-}
34{-# language FlexibleInstances #-}
5+{-# language GADTs #-}
46{-# language MultiParamTypeClasses #-}
5−{-# language RankNTypes #-}
7+{-# language NamedFieldPuns #-}
8+{-# language PolyKinds #-}
69{-# language StandaloneKindSignatures #-}
710{-# language TypeFamilies #-}
811{-# language UndecidableInstances #-}
12+{-# language UndecidableSuperClasses #-}
913
1014module Rel8.Aggregate
11− ( Aggregate(..), zipOutputs
12− , unsafeMakeAggregate
15+ ( Aggregate(..), foldInputs, mapInputs
16+ , Aggregator(..), unsafeMakeAggregate
1317 , Aggregates
18+ , Col( A, unA )
1419 )
1520where
1621
1722-- base
18−import Control.Applicative ( liftA2 )
19−import Data.Functor.Identity ( Identity( Identity ) )
23+import Data.Functor.Const ( Const( Const ), getConst )
24+import Data.Functor.Identity ( Identity )
2025import Data.Kind ( Constraint, Type )
2126import Prelude
2227
23−-- profunctors
24−import Data.Profunctor ( dimap )
25−
2628-- opaleye
27−import qualified Opaleye.Aggregate as Opaleye
29+import qualified Opaleye.Internal.Aggregate as Opaleye
2830import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
29−import qualified Opaleye.Internal.Column as Opaleye
31+import qualified Opaleye.Internal.PackMap as Opaleye
3032
3133-- rel8
3234import Rel8.Expr ( Expr )
33−import Rel8.Schema.HTable.Identity ( HIdentity(..) )
34−import qualified Rel8.Schema.Kind as K
35+import Rel8.Schema.Context ( Interpretation(..) )
36+import Rel8.Schema.HTable.Identity ( HIdentity(..), HType )
37+import Rel8.Schema.Name ( Name )
3538import Rel8.Schema.Null ( Sql )
39+import Rel8.Schema.Reify ( notReify )
40+import Rel8.Schema.Result ( Result )
41+import Rel8.Schema.Spec ( Spec( Spec ) )
3642import Rel8.Table
3743 ( Table, Columns, Context, fromColumns, toColumns
38− , FromExprs, fromResult, toResult
39− , Transpose
44+ , reify, unreify
4045 )
41−import Rel8.Table.Transpose ( Transposes )
46+import Rel8.Table.Recontextualize ( Recontextualize )
4247import Rel8.Type ( DBType )
4348
4449
45−-- | 'Aggregate' is a special context used by 'Rel8.aggregate'.
46−type Aggregate :: K.Context
47−newtype Aggregate a = Aggregate (Opaleye.Aggregator () (Expr a))
50+-- | An @Aggregate a@ describes how to aggregate @Table@s of type @a@. You can
51+-- unpack an @Aggregate@ back to @a@ by running it with 'Rel8.aggregate'. As
52+-- @Aggregate@ is almost an 'Applicative' functor - but there is no 'pure'
53+-- operation. This means 'Aggregate' is an instance of 'Apply', and you can
54+-- combine @Aggregate@s using the @<.>@ combinator.
55+type Aggregate :: k -> Type
56+data Aggregate a where
57+ Aggregate :: !(Opaleye.Aggregator () (Expr a)) -> Aggregate a
58+
59+
60+instance Interpretation Aggregate where
61+ data Col Aggregate _spec where
62+ A :: ()
63+ => { unA :: !(Aggregate a) }
64+ -> Col Aggregate ('Spec a)
4865
4966
5067instance Sql DBType a => Table Aggregate (Aggregate a) where
51− type Columns (Aggregate a) = HIdentity a
68+ type Columns (Aggregate a) = HType a
5269 type Context (Aggregate a) = Aggregate
53− type FromExprs (Aggregate a) = a
54− type Transpose to (Aggregate a) = to a
5570
56− toColumns = HIdentity
57− fromColumns (HIdentity a) = a
58− toResult = HIdentity . Identity
59− fromResult (HIdentity (Identity a)) = a
71+ toColumns = HIdentity . A
72+ fromColumns (HIdentity (A a)) = a
73+
74+ reify = notReify
75+ unreify = notReify
76+
77+
78+instance Sql DBType a =>
79+ Recontextualize Aggregate Aggregate (Aggregate a) (Aggregate a)
80+
81+
82+instance Sql DBType a =>
83+ Recontextualize Aggregate Expr (Aggregate a) (Expr a)
84+
85+
86+instance Sql DBType a =>
87+ Recontextualize Aggregate Result (Aggregate a) (Identity a)
88+
6089
90+instance Sql DBType a =>
91+ Recontextualize Aggregate Name (Aggregate a) (Name a)
6192
62−-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate's
63−-- for the 'Expr' columns in @b@.
93+
94+instance Sql DBType a =>
95+ Recontextualize Expr Aggregate (Expr a) (Aggregate a)
96+
97+
98+instance Sql DBType a =>
99+ Recontextualize Result Aggregate (Identity a) (Aggregate a)
100+
101+
102+instance Sql DBType a =>
103+ Recontextualize Name Aggregate (Name a) (Aggregate a)
104+
105+
106+-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate' 'Expr's
107+-- for the columns in @b@.
64108type Aggregates :: Type -> Type -> Constraint
65−class Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs
66−instance Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs
109+class Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs
110+instance Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs
111+
112+
113+foldInputs :: Monoid b
114+ => (Maybe Aggregator -> Opaleye.PrimExpr -> b) -> Aggregate a -> b
115+foldInputs f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =
116+ getConst $ flip agg () $ \(aggregator, a) ->
117+ Const $ f (detuplize <$> aggregator) a
118+ where
119+ detuplize (operation, ordering, distinction) =
120+ Aggregator {operation, ordering, distinction}
121+
122+
123+mapInputs :: ()
124+ => (Opaleye.PrimExpr -> Opaleye.PrimExpr) -> Aggregate a -> Aggregate a
125+mapInputs transform (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =
126+ Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ agg . \f input ->
127+ f (fmap transform input)
67128
68129
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)
130+type Aggregator :: Type
131+data Aggregator = Aggregator
132+ { operation :: Opaleye.AggrOp
133+ , ordering :: [Opaleye.OrderExpr]
134+ , distinction :: Opaleye.AggrDistinct
135+ }
72136
73137
74−unsafeMakeAggregate :: forall (input :: Type) (output :: Type) n n' a a'. ()
138+unsafeMakeAggregate :: ()
75139 => (Expr input -> Opaleye.PrimExpr)
76140 -> (Opaleye.PrimExpr -> Expr output)
77− -> Opaleye.Aggregator (Opaleye.Field_ n a) (Opaleye.Field_ n' a')
141+ -> Maybe Aggregator
78142 -> Expr input
79143 -> Aggregate output
80144unsafeMakeAggregate input output aggregator expr =
81− Aggregate $ dimap in_ out aggregator
82− where out = output . Opaleye.unColumn
83− in_ = Opaleye.Column . input . const expr
145+ Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ \f _ ->
146+ output <$> f (tuplize <$> aggregator, input expr)
147+ where
148+ tuplize Aggregator {operation, ordering, distinction} =
149+ (operation, ordering, distinction)
src/Rel8/Column.hs+77−5
@@ -1,21 +1,38 @@
11{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language LambdaCase #-}
4+{-# language MultiParamTypeClasses #-}
25{-# language StandaloneKindSignatures #-}
36{-# language TypeFamilies #-}
47
58module Rel8.Column
6− ( Column
9+ ( Column, AColumn(..)
710 , TColumn
811 )
912where
1013
1114-- base
1215import Data.Kind ( Type )
13−import Prelude ()
16+import Prelude
1417
1518-- rel8
19+import Rel8.Aggregate ( Aggregate, Col( A ) )
20+import Rel8.Expr ( Expr, Col( E ) )
1621import Rel8.FCF ( Eval, Exp )
22+import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )
23+import Rel8.Schema.HTable.Identity ( HIdentity(..), HType )
1724import qualified Rel8.Schema.Kind as K
18−import Rel8.Schema.Result ( Result )
25+import Rel8.Schema.Name ( Name(..), Col( N ) )
26+import Rel8.Schema.Null ( Sql )
27+import Rel8.Schema.Reify ( Reify, Col(..) )
28+import Rel8.Schema.Result ( Col( R ), Result )
29+import Rel8.Schema.Spec ( Spec( Spec ) )
30+import Rel8.Table
31+ ( Table, Columns, Context, fromColumns, toColumns
32+ , Unreify, reify, unreify
33+ )
34+import Rel8.Table.Recontextualize ( Recontextualize )
35+import Rel8.Type ( DBType )
1936
2037
2138-- | This type family is used to specify columns in 'Rel8able's. In @Column f
@@ -23,8 +40,63 @@ import Rel8.Schema.Result ( Result )
2340-- 'Rel8able' definitions), and @a@ is the type of the column.
2441type Column :: K.Context -> Type -> Type
2542type family Column context a where
26− Column Result a = a
27− Column context a = context a
43+ Column (Reify context) a = AColumn context a
44+ Column Aggregate a = Aggregate a
45+ Column Expr a = Expr a
46+ Column Name a = Name a
47+ Column Result a = a
48+
49+
50+type AColumn :: K.Context -> Type -> Type
51+newtype AColumn context a = AColumn (Column context a)
52+
53+
54+instance (Reifiable context, Sql DBType a) =>
55+ Table (Reify context) (AColumn context a)
56+ where
57+ type Context (AColumn context a) = Reify context
58+ type Columns (AColumn context a) = HType a
59+ type Unreify (AColumn context a) = Column context a
60+
61+ fromColumns (HType (Reify a)) = sfromColumn contextSing a
62+ toColumns = HType . Reify . stoColumn contextSing
63+ reify _ = AColumn
64+ unreify _ (AColumn a) = a
65+
66+
67+instance
68+ ( Reifiable context, Reifiable context'
69+ , Sql DBType a
70+ ) =>
71+ Recontextualize
72+ (Reify context)
73+ (Reify context')
74+ (AColumn context a)
75+ (AColumn context' a)
76+
77+
78+sfromColumn :: ()
79+ => SContext context
80+ -> Col context ('Spec a)
81+ -> AColumn context a
82+sfromColumn = \case
83+ SAggregate -> \(A a) -> AColumn a
84+ SExpr -> \(E a) -> AColumn a
85+ SName -> \(N a) -> AColumn a
86+ SResult -> \(R a) -> AColumn a
87+ SReify context -> \(Reify a) -> AColumn (sfromColumn context a)
88+
89+
90+stoColumn :: ()
91+ => SContext context
92+ -> AColumn context a
93+ -> Col context ('Spec a)
94+stoColumn = \case
95+ SAggregate -> \(AColumn a) -> A a
96+ SExpr -> \(AColumn a) -> E a
97+ SName -> \(AColumn a) -> N a
98+ SResult -> \(AColumn a) -> R a
99+ SReify context -> \(AColumn a) -> Reify (stoColumn context a)
28100
29101
30102data TColumn :: K.Context -> Type -> Exp Type
src/Rel8/Column/ADT.hs+68−3
@@ -1,23 +1,88 @@
11{-# language DataKinds #-}
2+{-# language LambdaCase #-}
3+{-# language MultiParamTypeClasses #-}
24{-# language StandaloneKindSignatures #-}
35{-# language TypeFamilies #-}
6+{-# language UndecidableInstances #-}
47
58module Rel8.Column.ADT
6− ( HADT
9+ ( HADT, AHADT(..)
710 )
811where
912
1013-- base
1114import Data.Kind ( Type )
12−import Prelude ()
15+import Prelude
1316
1417-- rel8
18+import Rel8.Generic.Rel8able ( GColumns )
19+import Rel8.Kind.Context ( SContext(..), Reifiable, contextSing )
20+import Rel8.Schema.Context ( Col )
1521import qualified Rel8.Schema.Kind as K
22+import Rel8.Schema.Reify ( Reify, hreify, hunreify )
1623import Rel8.Schema.Result ( Result )
17−import Rel8.Table.ADT ( ADT )
24+import Rel8.Table
25+ ( Table, Columns, Context, fromColumns, toColumns
26+ , Unreify, reify, unreify
27+ )
28+import Rel8.Table.ADT ( ADT( ADT ), ADTable, fromADT, toADT )
29+import Rel8.Table.Recontextualize ( Recontextualize )
1830
1931
2032type HADT :: K.Context -> K.Rel8able -> Type
2133type family HADT context t where
34+ HADT (Reify context) t = AHADT context t
2235 HADT Result t = t Result
2336 HADT context t = ADT t context
37+
38+
39+type AHADT :: K.Context -> K.Rel8able -> Type
40+newtype AHADT context t = AHADT (HADT context t)
41+
42+
43+instance (ADTable t, Reifiable context) =>
44+ Table (Reify context) (AHADT context t)
45+ where
46+ type Context (AHADT context t) = Reify context
47+ type Columns (AHADT context t) = GColumns (ADT t)
48+ type Unreify (AHADT context t) = HADT context t
49+
50+ fromColumns = sfromColumnsADT contextSing
51+ toColumns = stoColumnsADT contextSing
52+ reify _ = AHADT
53+ unreify _ (AHADT a) = a
54+
55+
56+instance
57+ ( Reifiable context, Reifiable context'
58+ , ADTable t, t ~ t'
59+ )
60+ => Recontextualize
61+ (Reify context)
62+ (Reify context')
63+ (AHADT context t)
64+ (AHADT context' t')
65+
66+
67+sfromColumnsADT :: ADTable t
68+ => SContext context
69+ -> GColumns (ADT t) (Col (Reify context))
70+ -> AHADT context t
71+sfromColumnsADT = \case
72+ SAggregate -> AHADT . ADT . hunreify
73+ SExpr -> AHADT . ADT . hunreify
74+ SName -> AHADT . ADT . hunreify
75+ SResult -> AHADT . fromADT . ADT . hunreify
76+ SReify context -> AHADT . sfromColumnsADT context . hunreify
77+
78+
79+stoColumnsADT :: ADTable t
80+ => SContext context
81+ -> AHADT context t
82+ -> GColumns (ADT t) (Col (Reify context))
83+stoColumnsADT = \case
84+ SAggregate -> hreify . (\(AHADT (ADT a)) -> a)
85+ SExpr -> hreify . (\(AHADT (ADT a)) -> a)
86+ SName -> hreify . (\(AHADT (ADT a)) -> a)
87+ SResult -> hreify . (\(ADT a) -> a) . toADT . (\(AHADT a) -> a)
88+ SReify context -> hreify . stoColumnsADT context . (\(AHADT a) -> a)
src/Rel8/Column/Either.hs+140−4
@@ -1,26 +1,162 @@
11{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language LambdaCase #-}
4+{-# language MultiParamTypeClasses #-}
25{-# language StandaloneKindSignatures #-}
3−{-# language TypeFamilyDependencies #-}
6+{-# language TypeFamilies #-}
7+{-# language UndecidableInstances #-}
48
59module Rel8.Column.Either
6− ( HEither
10+ ( HEither, AHEither(..)
711 )
812where
913
1014-- base
15+import Control.Applicative ( liftA2 )
16+import Data.Bifunctor ( Bifunctor, bimap )
1117import Data.Kind ( Type )
1218import Prelude
1319
1420-- rel8
21+import Rel8.Aggregate ( Aggregate )
22+import Rel8.Expr ( Expr )
23+import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )
24+import Rel8.Schema.Context ( Col )
25+import Rel8.Schema.HTable.Either ( HEitherTable )
1526import qualified Rel8.Schema.Kind as K
27+import Rel8.Schema.Name ( Name(..) )
28+import Rel8.Schema.Reify ( Reify, hreify, hunreify )
1629import Rel8.Schema.Result ( Result )
30+import Rel8.Table
31+ ( Table, Columns, Context, fromColumns, toColumns
32+ , Unreify, reify, unreify
33+ )
1734import Rel8.Table.Either ( EitherTable )
35+import Rel8.Table.Recontextualize ( Recontextualize )
1836
1937
2038-- | Nest an 'Either' value within a 'Rel8able'. @HEither f a b@ will produce a
2139-- 'EitherTable' @a b@ in the 'Expr' context, and a 'Either' @a b@ in the
2240-- 'Result' context.
2341type HEither :: K.Context -> Type -> Type -> Type
24−type family HEither context = either | either -> context where
42+type family HEither context where
43+ HEither (Reify context) = AHEither context
44+ HEither Aggregate = EitherTable
45+ HEither Expr = EitherTable
46+ HEither Name = EitherTable
2547 HEither Result = Either
26− HEither context = EitherTable context
48+
49+
50+type AHEither :: K.Context -> Type -> Type -> Type
51+newtype AHEither context a b = AHEither (HEither context a b)
52+
53+
54+instance Reifiable context => Bifunctor (AHEither context) where
55+ bimap = sbimapEither contextSing
56+
57+
58+instance Reifiable context => Functor (AHEither context a) where
59+ fmap = bimap id
60+
61+
62+instance (Reifiable context, Table (Reify context) a, Table (Reify context) b)
63+ => Table (Reify context) (AHEither context a b)
64+ where
65+ type Context (AHEither context a b) = Reify context
66+ type Columns (AHEither context a b) = HEitherTable (Columns a) (Columns b)
67+ type Unreify (AHEither context a b) = HEither context (Unreify a) (Unreify b)
68+
69+ fromColumns = sfromColumnsEither contextSing
70+ toColumns = stoColumnsEither contextSing
71+ reify proof = liftA2 bimap reify reify proof . AHEither
72+ unreify proof = (\(AHEither a) -> a) . liftA2 bimap unreify unreify proof
73+
74+
75+instance
76+ ( Reifiable context, Reifiable context'
77+ , Recontextualize (Reify context) (Reify context') a a'
78+ , Recontextualize (Reify context) (Reify context') b b'
79+ ) =>
80+ Recontextualize
81+ (Reify context)
82+ (Reify context')
83+ (AHEither context a b)
84+ (AHEither context' a' b')
85+
86+
87+sbimapEither :: ()
88+ => SContext context
89+ -> (a -> c)
90+ -> (b -> d)
91+ -> AHEither context a b
92+ -> AHEither context c d
93+sbimapEither = \case
94+ SAggregate -> \f g (AHEither a) -> AHEither (bimap f g a)
95+ SExpr -> \f g (AHEither a) -> AHEither (bimap f g a)
96+ SResult -> \f g (AHEither a) -> AHEither (bimap f g a)
97+ SName -> \f g (AHEither a) -> AHEither (bimap f g a)
98+ SReify context -> \f g (AHEither a) -> AHEither (sbimapEither context f g a)
99+
100+
101+sfromColumnsEither :: (Table (Reify context) a, Table (Reify context) b)
102+ => SContext context
103+ -> HEitherTable (Columns a) (Columns b) (Col (Reify context))
104+ -> AHEither context a b
105+sfromColumnsEither = \case
106+ SAggregate ->
107+ AHEither .
108+ bimap (fromColumns . hreify) (fromColumns . hreify) .
109+ fromColumns .
110+ hunreify
111+ SExpr ->
112+ AHEither .
113+ bimap (fromColumns . hreify) (fromColumns . hreify) .
114+ fromColumns .
115+ hunreify
116+ SResult ->
117+ AHEither .
118+ bimap (fromColumns . hreify) (fromColumns . hreify) .
119+ fromColumns .
120+ hunreify
121+ SName ->
122+ AHEither .
123+ bimap (fromColumns . hreify) (fromColumns . hreify) .
124+ fromColumns .
125+ hunreify
126+ SReify context ->
127+ AHEither .
128+ sbimapEither context (fromColumns . hreify) (fromColumns . hreify) .
129+ sfromColumnsEither context .
130+ hunreify
131+
132+
133+stoColumnsEither :: (Table (Reify context) a, Table (Reify context) b)
134+ => SContext context
135+ -> AHEither context a b
136+ -> HEitherTable (Columns a) (Columns b) (Col (Reify context))
137+stoColumnsEither = \case
138+ SAggregate ->
139+ hreify .
140+ toColumns .
141+ bimap (hunreify . toColumns) (hunreify . toColumns) .
142+ (\(AHEither a) -> a)
143+ SExpr ->
144+ hreify .
145+ toColumns .
146+ bimap (hunreify . toColumns) (hunreify . toColumns) .
147+ (\(AHEither a) -> a)
148+ SResult ->
149+ hreify .
150+ toColumns .
151+ bimap (hunreify . toColumns) (hunreify . toColumns) .
152+ (\(AHEither a) -> a)
153+ SName ->
154+ hreify .
155+ toColumns .
156+ bimap (hunreify . toColumns) (hunreify . toColumns) .
157+ (\(AHEither a) -> a)
158+ SReify context ->
159+ hreify .
160+ stoColumnsEither context .
161+ sbimapEither context (hunreify . toColumns) (hunreify . toColumns) .
162+ (\(AHEither a) -> a)
src/Rel8/Column/Lift.hs+67−3
@@ -1,23 +1,87 @@
11{-# language DataKinds #-}
2+{-# language LambdaCase #-}
3+{-# language MultiParamTypeClasses #-}
24{-# language StandaloneKindSignatures #-}
35{-# language TypeFamilies #-}
46
57module Rel8.Column.Lift
6− ( Lift
8+ ( Lift, ALift(..)
79 )
810where
911
1012-- base
1113import Data.Kind ( Type )
12−import Prelude ()
14+import Prelude
1315
1416-- rel8
17+import Rel8.Generic.Rel8able ( GColumns )
18+import Rel8.Kind.Context ( Reifiable(..), SContext(..) )
19+import Rel8.Schema.Context ( Col )
1520import qualified Rel8.Schema.Kind as K
21+import Rel8.Schema.Reify ( Reify, hreify, hunreify )
1622import Rel8.Schema.Result ( Result )
17−import Rel8.Table.HKD ( HKD )
23+import Rel8.Table
24+ ( Table, Columns, Context, fromColumns, toColumns
25+ , Unreify, reify, unreify
26+ )
27+import Rel8.Table.Rel8able ()
28+import Rel8.Table.HKD ( HKD( HKD ), HKDable, fromHKD, toHKD )
29+import Rel8.Table.Recontextualize ( Recontextualize )
1830
1931
2032type Lift :: K.Context -> Type -> Type
2133type family Lift context a where
34+ Lift (Reify context) a = ALift context a
2235 Lift Result a = a
2336 Lift context a = HKD a context
37+
38+
39+type ALift :: K.Context -> Type -> Type
40+newtype ALift context a = ALift
41+ { unALift :: Lift context a
42+ }
43+
44+
45+instance (Reifiable context, HKDable a) =>
46+ Table (Reify context) (ALift context a)
47+ where
48+ type Context (ALift context a) = Reify context
49+ type Columns (ALift context a) = GColumns (HKD a)
50+ type Unreify (ALift context a) = Lift context a
51+
52+ fromColumns = sfromColumnsLift contextSing
53+ toColumns = stoColumnsLift contextSing
54+ reify _ = ALift
55+ unreify _ (ALift a) = a
56+
57+
58+instance (Reifiable context, Reifiable context', HKDable a) =>
59+ Recontextualize
60+ (Reify context)
61+ (Reify context')
62+ (ALift context a)
63+ (ALift context' a)
64+
65+
66+sfromColumnsLift :: HKDable a
67+ => SContext context
68+ -> GColumns (HKD a) (Col (Reify context))
69+ -> ALift context a
70+sfromColumnsLift = \case
71+ SAggregate -> ALift . fromColumns . hunreify
72+ SExpr -> ALift . fromColumns . hunreify
73+ SName -> ALift . fromColumns . hunreify
74+ SResult -> ALift . fromHKD . HKD . hunreify
75+ SReify context -> ALift . sfromColumnsLift context . hunreify
76+
77+
78+stoColumnsLift :: HKDable a
79+ => SContext context
80+ -> ALift context a
81+ -> GColumns (HKD a) (Col (Reify context))
82+stoColumnsLift = \case
83+ SAggregate -> hreify . toColumns . unALift
84+ SExpr -> hreify . toColumns . unALift
85+ SName -> hreify . toColumns . unALift
86+ SResult -> hreify . (\(HKD a) -> a) . toHKD . unALift
87+ SReify context -> hreify . stoColumnsLift context . unALift
src/Rel8/Column/List.hs+126−6
@@ -1,25 +1,145 @@
11{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language LambdaCase #-}
4+{-# language MultiParamTypeClasses #-}
25{-# language StandaloneKindSignatures #-}
3−{-# language TypeFamilyDependencies #-}
6+{-# language TypeFamilies #-}
7+{-# language UndecidableInstances #-}
48
59module Rel8.Column.List
6− ( HList
10+ ( HList, AHList(..)
711 )
812where
913
1014-- base
1115import Data.Kind ( Type )
12−import Prelude ()
16+import Data.Type.Equality ( (:~:)( Refl ) )
17+import Prelude
1318
1419-- rel8
20+import Rel8.Aggregate ( Aggregate )
21+import Rel8.Expr ( Expr )
22+import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )
23+import Rel8.Schema.Context ( Col )
24+import Rel8.Schema.HTable.List ( HListTable )
1525import qualified Rel8.Schema.Kind as K
26+import Rel8.Schema.Name ( Name )
27+import Rel8.Schema.Reify ( Reify, hreify, hunreify )
1628import Rel8.Schema.Result ( Result )
17−import Rel8.Table.List ( ListTable )
29+import Rel8.Table
30+ ( Table, Columns, Congruent, Context, fromColumns, toColumns
31+ , Unreify, reify, unreify
32+ )
33+import Rel8.Table.List ( ListTable( ListTable ) )
34+import Rel8.Table.Recontextualize ( Recontextualize )
35+import Rel8.Table.Unreify ( Unreifiability(..), Unreifiable, unreifiability )
1836
1937
2038-- | Nest a list within a 'Rel8able'. @HList f a@ will produce a 'ListTable'
2139-- @a@ in the 'Expr' context, and a @[a]@ in the 'Result' context.
2240type HList :: K.Context -> Type -> Type
23−type family HList context = list | list -> context where
41+type family HList context where
42+ HList (Reify context) = AHList context
43+ HList Aggregate = ListTable
44+ HList Expr = ListTable
45+ HList Name = ListTable
2446 HList Result = []
25− HList context = ListTable context
47+
48+
49+type AHList :: K.Context -> Type -> Type
50+newtype AHList context a = AHList (HList context a)
51+
52+
53+instance (Reifiable context, Unreifiable a, Table (Reify context) a) =>
54+ Table (Reify context) (AHList context a)
55+ where
56+ type Context (AHList context a) = Reify context
57+ type Columns (AHList context a) = HListTable (Columns a)
58+ type Unreify (AHList context a) = HList context (Unreify a)
59+
60+ fromColumns = sfromColumnsList contextSing
61+ toColumns = stoColumnsList contextSing
62+
63+ reify _ = sreifyList (unreifiability contextSing)
64+ unreify _ = sunreifyList (unreifiability contextSing)
65+
66+
67+instance
68+ ( Reifiable context, Reifiable context'
69+ , Unreifiable a, Unreifiable a'
70+ , Recontextualize (Reify context) (Reify context') a a'
71+ )
72+ => Recontextualize
73+ (Reify context)
74+ (Reify context')
75+ (AHList context a)
76+ (AHList context' a')
77+
78+
79+smapList :: Congruent a b
80+ => SContext context
81+ -> (a -> b)
82+ -> (HListTable (Columns a) (Col (Context a)) -> HListTable (Columns b) (Col (Context b)))
83+ -> AHList context a
84+ -> AHList context b
85+smapList = \case
86+ SAggregate -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
87+ SExpr -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
88+ SResult -> \f _ (AHList as) -> AHList (fmap f as)
89+ SName -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
90+ SReify context -> \f g (AHList as) -> AHList (smapList context f g as)
91+
92+
93+sfromColumnsList :: Table (Reify context) a
94+ => SContext context
95+ -> HListTable (Columns a) (Col (Reify context))
96+ -> AHList context a
97+sfromColumnsList = \case
98+ SAggregate -> AHList . ListTable
99+ SExpr -> AHList . ListTable
100+ SResult -> AHList . fmap (fromColumns . hreify) . fromColumns . hunreify
101+ SName -> AHList . ListTable
102+ SReify context ->
103+ AHList .
104+ smapList context (fromColumns . hreify) hreify .
105+ sfromColumnsList context .
106+ hunreify
107+
108+
109+stoColumnsList :: Table (Reify context) a
110+ => SContext context
111+ -> AHList context a
112+ -> HListTable (Columns a) (Col (Reify context))
113+stoColumnsList = \case
114+ SAggregate -> \(AHList (ListTable a)) -> a
115+ SExpr -> \(AHList (ListTable a)) -> a
116+ SResult ->
117+ hreify . toColumns . fmap (hunreify . toColumns) . (\(AHList a) -> a)
118+ SName -> \(AHList (ListTable a)) -> a
119+ SReify context ->
120+ hreify .
121+ stoColumnsList context .
122+ smapList context (hunreify . toColumns) hunreify .
123+ (\(AHList a) -> a)
124+
125+
126+sreifyList :: Table (Reify context) a
127+ => Unreifiability context a
128+ -> HList context (Unreify a)
129+ -> AHList context a
130+sreifyList = \case
131+ UResult -> AHList . fmap (reify Refl)
132+ Unreifiability context ->
133+ smapList context (reify Refl) hreify .
134+ AHList
135+
136+
137+sunreifyList :: Table (Reify context) a
138+ => Unreifiability context a
139+ -> AHList context a
140+ -> HList context (Unreify a)
141+sunreifyList = \case
142+ UResult -> fmap (unreify Refl) . (\(AHList a) -> a)
143+ Unreifiability context ->
144+ (\(AHList a) -> a) .
145+ smapList context (unreify Refl) hunreify
src/Rel8/Column/Maybe.hs+105−4
@@ -1,9 +1,14 @@
11{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language GADTs #-}
4+{-# language LambdaCase #-}
5+{-# language MultiParamTypeClasses #-}
26{-# language StandaloneKindSignatures #-}
3−{-# language TypeFamilyDependencies #-}
7+{-# language TypeFamilies #-}
8+{-# language UndecidableInstances #-}
49
510module Rel8.Column.Maybe
6− ( HMaybe
11+ ( HMaybe, AHMaybe(..)
712 )
813where
914
@@ -12,15 +17,111 @@ import Data.Kind ( Type )
1217import Prelude
1318
1419-- rel8
20+import Rel8.Aggregate ( Aggregate )
21+import Rel8.Expr ( Expr )
22+import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )
23+import Rel8.Schema.Context ( Col )
24+import Rel8.Schema.HTable.Maybe ( HMaybeTable )
1525import qualified Rel8.Schema.Kind as K
26+import Rel8.Schema.Name ( Name )
27+import Rel8.Schema.Reify ( Reify, hreify, hunreify )
1628import Rel8.Schema.Result ( Result )
29+import Rel8.Table
30+ ( Table, Columns, Context, fromColumns, toColumns
31+ , Unreify, reify, unreify
32+ )
1733import Rel8.Table.Maybe ( MaybeTable )
34+import Rel8.Table.Recontextualize ( Recontextualize )
1835
1936
2037-- | Nest a 'Maybe' value within a 'Rel8able'. @HMaybe f a@ will produce a
2138-- 'MaybeTable' @a@ in the 'Expr' context, and a 'Maybe' @a@ in the 'Result'
2239-- context.
2340type HMaybe :: K.Context -> Type -> Type
24−type family HMaybe context = maybe | maybe -> context where
41+type family HMaybe context where
42+ HMaybe (Reify context) = AHMaybe context
43+ HMaybe Aggregate = MaybeTable
44+ HMaybe Expr = MaybeTable
45+ HMaybe Name = MaybeTable
2546 HMaybe Result = Maybe
26− HMaybe context = MaybeTable context
47+
48+
49+type AHMaybe :: K.Context -> Type -> Type
50+newtype AHMaybe context a = AHMaybe (HMaybe context a)
51+
52+
53+instance Reifiable context => Functor (AHMaybe context) where
54+ fmap = smapMaybe contextSing
55+
56+
57+instance (Reifiable context, Table (Reify context) a) =>
58+ Table (Reify context) (AHMaybe context a)
59+ where
60+ type Context (AHMaybe context a) = Reify context
61+ type Columns (AHMaybe context a) = HMaybeTable (Columns a)
62+ type Unreify (AHMaybe context a) = HMaybe context (Unreify a)
63+
64+ fromColumns = sfromColumnsMaybe contextSing
65+ toColumns = stoColumnsMaybe contextSing
66+ reify proof = fmap fmap reify proof . AHMaybe
67+ unreify proof = (\(AHMaybe a) -> a) . fmap fmap unreify proof
68+
69+
70+instance
71+ ( Reifiable context, Reifiable context'
72+ , Recontextualize (Reify context) (Reify context') a a'
73+ ) =>
74+ Recontextualize
75+ (Reify context)
76+ (Reify context')
77+ (AHMaybe context a)
78+ (AHMaybe context' a')
79+
80+
81+smapMaybe :: ()
82+ => SContext context
83+ -> (a -> b)
84+ -> AHMaybe context a
85+ -> AHMaybe context b
86+smapMaybe = \case
87+ SAggregate -> \f (AHMaybe a) -> AHMaybe (fmap f a)
88+ SExpr -> \f (AHMaybe a) -> AHMaybe (fmap f a)
89+ SResult -> \f (AHMaybe a) -> AHMaybe (fmap f a)
90+ SName -> \f (AHMaybe a) -> AHMaybe (fmap f a)
91+ SReify context -> \f (AHMaybe a) -> AHMaybe (smapMaybe context f a)
92+
93+
94+sfromColumnsMaybe :: Table (Reify context) a
95+ => SContext context
96+ -> HMaybeTable (Columns a) (Col (Reify context))
97+ -> AHMaybe context a
98+sfromColumnsMaybe = \case
99+ SAggregate -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
100+ SExpr -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
101+ SResult -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
102+ SName -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
103+ SReify context ->
104+ AHMaybe .
105+ smapMaybe context (fromColumns . hreify) .
106+ sfromColumnsMaybe context .
107+ hunreify
108+
109+
110+stoColumnsMaybe :: Table (Reify context) a
111+ => SContext context
112+ -> AHMaybe context a
113+ -> HMaybeTable (Columns a) (Col (Reify context))
114+stoColumnsMaybe = \case
115+ SAggregate ->
116+ hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
117+ SExpr ->
118+ hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
119+ SResult ->
120+ hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
121+ SName ->
122+ hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
123+ SReify context ->
124+ hreify .
125+ stoColumnsMaybe context .
126+ smapMaybe context (hunreify . toColumns) .
127+ (\(AHMaybe a) -> a)
src/Rel8/Column/NonEmpty.hs+127−6
@@ -1,27 +1,148 @@
11{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language LambdaCase #-}
4+{-# language MultiParamTypeClasses #-}
25{-# language StandaloneKindSignatures #-}
3−{-# language TypeFamilyDependencies #-}
6+{-# language TypeFamilies #-}
7+{-# language UndecidableInstances #-}
48
59module Rel8.Column.NonEmpty
6− ( HNonEmpty
10+ ( HNonEmpty, AHNonEmpty(..)
711 )
812where
913
1014-- base
1115import Data.Kind ( Type )
1216import Data.List.NonEmpty ( NonEmpty )
13−import Prelude ()
17+import Data.Type.Equality ( (:~:)( Refl ) )
18+import Prelude
1419
1520-- rel8
21+import Rel8.Aggregate ( Aggregate )
22+import Rel8.Expr ( Expr )
23+import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )
24+import Rel8.Schema.Context ( Col )
25+import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
1626import qualified Rel8.Schema.Kind as K
27+import Rel8.Schema.Name ( Name )
28+import Rel8.Schema.Reify ( Reify, hreify, hunreify )
1729import Rel8.Schema.Result ( Result )
18−import Rel8.Table.NonEmpty ( NonEmptyTable )
30+import Rel8.Table
31+ ( Table, Columns, Congruent, Context, fromColumns, toColumns
32+ , Unreify, reify, unreify
33+ )
34+import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )
35+import Rel8.Table.Recontextualize ( Recontextualize )
36+import Rel8.Table.Unreify ( Unreifiability(..), Unreifiable, unreifiability )
1937
2038
2139-- | Nest a 'NonEmpty' list within a 'Rel8able'. @HNonEmpty f a@ will produce a
2240-- 'NonEmptyTable' @a@ in the 'Expr' context, and a 'NonEmpty' @a@ in the
2341-- 'Result' context.
2442type HNonEmpty :: K.Context -> Type -> Type
25−type family HNonEmpty context = nonEmpty | nonEmpty -> context where
43+type family HNonEmpty context where
44+ HNonEmpty (Reify context) = AHNonEmpty context
45+ HNonEmpty Aggregate = NonEmptyTable
46+ HNonEmpty Expr = NonEmptyTable
47+ HNonEmpty Name = NonEmptyTable
2648 HNonEmpty Result = NonEmpty
27− HNonEmpty context = NonEmptyTable context
49+
50+
51+type AHNonEmpty :: K.Context -> Type -> Type
52+newtype AHNonEmpty context a = AHNonEmpty (HNonEmpty context a)
53+
54+
55+instance (Reifiable context, Unreifiable a, Table (Reify context) a) =>
56+ Table (Reify context) (AHNonEmpty context a)
57+ where
58+ type Context (AHNonEmpty context a) = Reify context
59+ type Columns (AHNonEmpty context a) = HNonEmptyTable (Columns a)
60+ type Unreify (AHNonEmpty context a) = HNonEmpty context (Unreify a)
61+
62+ fromColumns = sfromColumnsNonEmpty contextSing
63+ toColumns = stoColumnsNonEmpty contextSing
64+
65+ reify _ = sreifyNonEmpty (unreifiability contextSing)
66+ unreify _ = sunreifyNonEmpty (unreifiability contextSing)
67+
68+
69+instance
70+ ( Reifiable context, Reifiable context'
71+ , Unreifiable a, Unreifiable a'
72+ , Recontextualize (Reify context) (Reify context') a a'
73+ )
74+ => Recontextualize
75+ (Reify context)
76+ (Reify context')
77+ (AHNonEmpty context a)
78+ (AHNonEmpty context' a')
79+
80+
81+smapNonEmpty :: Congruent a b
82+ => SContext context
83+ -> (a -> b)
84+ -> (HNonEmptyTable (Columns a) (Col (Context a)) -> HNonEmptyTable (Columns b) (Col (Context b)))
85+ -> AHNonEmpty context a
86+ -> AHNonEmpty context b
87+smapNonEmpty = \case
88+ SAggregate -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
89+ SExpr -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
90+ SResult -> \f _ (AHNonEmpty as) -> AHNonEmpty (fmap f as)
91+ SName -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
92+ SReify context -> \f g (AHNonEmpty as) -> AHNonEmpty (smapNonEmpty context f g as)
93+
94+
95+sfromColumnsNonEmpty :: Table (Reify context) a
96+ => SContext context
97+ -> HNonEmptyTable (Columns a) (Col (Reify context))
98+ -> AHNonEmpty context a
99+sfromColumnsNonEmpty = \case
100+ SAggregate -> AHNonEmpty . NonEmptyTable
101+ SExpr -> AHNonEmpty . NonEmptyTable
102+ SResult ->
103+ AHNonEmpty . fmap (fromColumns . hreify) . fromColumns . hunreify
104+ SName -> AHNonEmpty . NonEmptyTable
105+ SReify context ->
106+ AHNonEmpty .
107+ smapNonEmpty context (fromColumns . hreify) hreify .
108+ sfromColumnsNonEmpty context .
109+ hunreify
110+
111+
112+stoColumnsNonEmpty :: Table (Reify context) a
113+ => SContext context
114+ -> AHNonEmpty context a
115+ -> HNonEmptyTable (Columns a) (Col (Reify context))
116+stoColumnsNonEmpty = \case
117+ SAggregate -> \(AHNonEmpty (NonEmptyTable a)) -> a
118+ SExpr -> \(AHNonEmpty (NonEmptyTable a)) -> a
119+ SResult ->
120+ hreify . toColumns . fmap (hunreify . toColumns) . (\(AHNonEmpty a) -> a)
121+ SName -> \(AHNonEmpty (NonEmptyTable a)) -> a
122+ SReify context ->
123+ hreify .
124+ stoColumnsNonEmpty context .
125+ smapNonEmpty context (hunreify . toColumns) hunreify .
126+ (\(AHNonEmpty a) -> a)
127+
128+
129+sreifyNonEmpty :: Table (Reify context) a
130+ => Unreifiability context a
131+ -> HNonEmpty context (Unreify a)
132+ -> AHNonEmpty context a
133+sreifyNonEmpty = \case
134+ UResult -> AHNonEmpty . fmap (reify Refl)
135+ Unreifiability context ->
136+ smapNonEmpty context (reify Refl) hreify .
137+ AHNonEmpty
138+
139+
140+sunreifyNonEmpty :: Table (Reify context) a
141+ => Unreifiability context a
142+ -> AHNonEmpty context a
143+ -> HNonEmpty context (Unreify a)
144+sunreifyNonEmpty = \case
145+ UResult -> fmap (unreify Refl) . (\(AHNonEmpty a) -> a)
146+ Unreifiability context ->
147+ (\(AHNonEmpty a) -> a) .
148+ smapNonEmpty context (unreify Refl) hunreify
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+142−5
@@ -1,19 +1,38 @@
11{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language GADTs #-}
4+{-# language LambdaCase #-}
5+{-# language MultiParamTypeClasses #-}
26{-# language StandaloneKindSignatures #-}
3−{-# language TypeFamilyDependencies #-}
7+{-# language TypeFamilies #-}
8+{-# language UndecidableInstances #-}
49
510module Rel8.Column.These
6− ( HThese
11+ ( HThese, AHThese(..)
712 )
813where
914
1015-- base
16+import Control.Applicative ( liftA2 )
17+import Data.Bifunctor ( Bifunctor, bimap )
1118import Data.Kind ( Type )
12−import Prelude ()
19+import Prelude
1320
1421-- rel8
22+import Rel8.Aggregate ( Aggregate )
23+import Rel8.Expr ( Expr )
24+import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )
25+import Rel8.Schema.Context ( Col )
26+import Rel8.Schema.HTable.These ( HTheseTable )
1527import qualified Rel8.Schema.Kind as K
28+import Rel8.Schema.Name ( Name )
29+import Rel8.Schema.Reify ( Reify, hreify, hunreify )
1630import Rel8.Schema.Result ( Result )
31+import Rel8.Table
32+ ( Table, Columns, Context, fromColumns, toColumns
33+ , Unreify, reify, unreify
34+ )
35+import Rel8.Table.Recontextualize ( Recontextualize )
1736import Rel8.Table.These ( TheseTable )
1837
1938-- these
@@ -24,6 +43,124 @@ import Data.These ( These )
2443-- 'TheseTable' @a b@ in the 'Expr' context, and a 'These' @a b@ in the
2544-- 'Result' context.
2645type HThese :: K.Context -> Type -> Type -> Type
27−type family HThese context = these | these -> context where
46+type family HThese context where
47+ HThese (Reify context) = AHThese context
48+ HThese Aggregate = TheseTable
49+ HThese Expr = TheseTable
50+ HThese Name = TheseTable
2851 HThese Result = These
29− HThese context = TheseTable context
52+
53+
54+type AHThese :: K.Context -> Type -> Type -> Type
55+newtype AHThese context a b = AHThese (HThese context a b)
56+
57+
58+instance Reifiable context => Bifunctor (AHThese context) where
59+ bimap = sbimapThese contextSing
60+
61+
62+instance Reifiable context => Functor (AHThese context a) where
63+ fmap = bimap id
64+
65+
66+instance (Reifiable context, Table (Reify context) a, Table (Reify context) b)
67+ => Table (Reify context) (AHThese context a b)
68+ where
69+ type Context (AHThese context a b) = Reify context
70+ type Columns (AHThese context a b) = HTheseTable (Columns a) (Columns b)
71+ type Unreify (AHThese context a b) = HThese context (Unreify a) (Unreify b)
72+
73+ fromColumns = sfromColumnsThese contextSing
74+ toColumns = stoColumnsThese contextSing
75+ reify proof = liftA2 bimap reify reify proof . AHThese
76+ unreify proof = (\(AHThese a) -> a) . liftA2 bimap unreify unreify proof
77+
78+
79+instance
80+ ( Reifiable context, Reifiable context'
81+ , Recontextualize (Reify context) (Reify context') a a'
82+ , Recontextualize (Reify context) (Reify context') b b'
83+ ) =>
84+ Recontextualize
85+ (Reify context)
86+ (Reify context')
87+ (AHThese context a b)
88+ (AHThese context' a' b')
89+
90+
91+sbimapThese :: ()
92+ => SContext context
93+ -> (a -> c)
94+ -> (b -> d)
95+ -> AHThese context a b
96+ -> AHThese context c d
97+sbimapThese = \case
98+ SAggregate -> \f g (AHThese a) -> AHThese (bimap f g a)
99+ SExpr -> \f g (AHThese a) -> AHThese (bimap f g a)
100+ SResult -> \f g (AHThese a) -> AHThese (bimap f g a)
101+ SName -> \f g (AHThese a) -> AHThese (bimap f g a)
102+ SReify context -> \f g (AHThese a) -> AHThese (sbimapThese context f g a)
103+
104+
105+sfromColumnsThese :: (Table (Reify context) a, Table (Reify context) b)
106+ => SContext context
107+ -> HTheseTable (Columns a) (Columns b) (Col (Reify context))
108+ -> AHThese context a b
109+sfromColumnsThese = \case
110+ SAggregate ->
111+ AHThese .
112+ bimap (fromColumns . hreify) (fromColumns . hreify) .
113+ fromColumns .
114+ hunreify
115+ SExpr ->
116+ AHThese .
117+ bimap (fromColumns . hreify) (fromColumns . hreify) .
118+ fromColumns .
119+ hunreify
120+ SResult ->
121+ AHThese .
122+ bimap (fromColumns . hreify) (fromColumns . hreify) .
123+ fromColumns .
124+ hunreify
125+ SName ->
126+ AHThese .
127+ bimap (fromColumns . hreify) (fromColumns . hreify) .
128+ fromColumns .
129+ hunreify
130+ SReify context ->
131+ AHThese .
132+ sbimapThese context (fromColumns . hreify) (fromColumns . hreify) .
133+ sfromColumnsThese context .
134+ hunreify
135+
136+
137+stoColumnsThese :: (Table (Reify context) a, Table (Reify context) b)
138+ => SContext context
139+ -> AHThese context a b
140+ -> HTheseTable (Columns a) (Columns b) (Col (Reify context))
141+stoColumnsThese = \case
142+ SAggregate ->
143+ hreify .
144+ toColumns .
145+ bimap (hunreify . toColumns) (hunreify . toColumns) .
146+ (\(AHThese a) -> a)
147+ SExpr ->
148+ hreify .
149+ toColumns .
150+ bimap (hunreify . toColumns) (hunreify . toColumns) .
151+ (\(AHThese a) -> a)
152+ SResult ->
153+ hreify .
154+ toColumns .
155+ bimap (hunreify . toColumns) (hunreify . toColumns) .
156+ (\(AHThese a) -> a)
157+ SName ->
158+ hreify .
159+ toColumns .
160+ bimap (hunreify . toColumns) (hunreify . toColumns) .
161+ (\(AHThese a) -> a)
162+ SReify context ->
163+ hreify .
164+ stoColumnsThese context .
165+ sbimapThese context (hunreify . toColumns) (hunreify . toColumns) .
166+ (\(AHThese a) -> a)
src/Rel8/Expr.hs+41−17
@@ -1,21 +1,27 @@
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 #-}
1013{-# language UndecidableInstances #-}
14+{-# language UndecidableSuperClasses #-}
1115
1216module Rel8.Expr
1317 ( Expr(..)
18+ , Col( E, unE )
1419 )
1520where
1621
1722-- base
18−import Data.Functor.Identity ( Identity( Identity ) )
23+import Data.Functor.Identity ( Identity )
24+import Data.Kind ( Type )
1925import Data.String ( IsString, fromString )
2026import Prelude hiding ( null )
2127
@@ -32,14 +38,16 @@ import Rel8.Expr.Opaleye
3238 , zipPrimExprsWith
3339 )
3440import Rel8.Expr.Serialize ( litExpr )
35−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
36−import qualified Rel8.Schema.Kind as K
41+import Rel8.Schema.Context ( Interpretation, Col )
42+import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )
3743import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
44+import Rel8.Schema.Reify ( notReify )
45+import Rel8.Schema.Result ( Result )
46+import Rel8.Schema.Spec ( Spec( Spec ) )
3847import Rel8.Table
39− ( Table, Columns, Context, fromColumns, toColumns
40− , FromExprs, fromResult, toResult
41− , Transpose
48+ ( Table, Columns, Context, fromColumns, toColumns, reify, unreify
4249 )
50+import Rel8.Table.Recontextualize ( Recontextualize )
4351import Rel8.Type ( DBType )
4452import Rel8.Type.Monoid ( DBMonoid, memptyExpr )
4553import Rel8.Type.Num ( DBFloating, DBFractional, DBNum )
@@ -47,9 +55,13 @@ import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )
4755
4856
4957-- | Typed SQL expressions.
50−type Expr :: K.Context
51−newtype Expr a = Expr Opaleye.PrimExpr
52− deriving stock Show
58+type role Expr representational
59+type Expr :: k -> Type
60+data Expr a where
61+ Expr :: k ~ Type => !Opaleye.PrimExpr -> Expr (a :: k)
62+
63+
64+deriving stock instance Show (Expr a)
5365
5466
5567instance Sql DBSemigroup a => Semigroup (Expr a) where
@@ -113,13 +125,25 @@ instance Sql DBFloating a => Floating (Expr a) where
113125 atanh = function "atanh"
114126
115127
128+instance Interpretation Expr where
129+ data Col Expr _spec where
130+ E :: {unE :: !(Expr a)} -> Col Expr ('Spec a)
131+
132+
116133instance Sql DBType a => Table Expr (Expr a) where
117− type Columns (Expr a) = HIdentity a
134+ type Columns (Expr a) = HType a
118135 type Context (Expr a) = Expr
119− type FromExprs (Expr a) = a
120− type Transpose to (Expr a) = to a
121136
122− toColumns a = HIdentity a
123− fromColumns (HIdentity a) = a
124− toResult a = HIdentity (Identity a)
125− fromResult (HIdentity (Identity a)) = a
137+ toColumns a = HType (E a)
138+ fromColumns (HType (E a)) = a
139+ reify = notReify
140+ unreify = notReify
141+
142+
143+instance Sql DBType a => Recontextualize Expr Expr (Expr a) (Expr a)
144+
145+
146+instance Sql DBType a => Recontextualize Expr Result (Expr a) (Identity a)
147+
148+
149+instance Sql DBType a => Recontextualize Result Expr (Identity a) (Expr a)
src/Rel8/Expr.hs-boot+8−6
@@ -1,4 +1,6 @@
1−{-# language DataKinds #-}
1+{-# language GADTs #-}
2+{-# language PolyKinds #-}
3+{-# language RoleAnnotations #-}
24{-# language StandaloneKindSignatures #-}
35
46module Rel8.Expr
@@ -7,14 +9,14 @@ module Rel8.Expr
79where
810
911-- base
12+import Data.Kind ( Type )
1013import Prelude ()
1114
1215-- opaleye
1316import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
1417
15−-- rel8
16−import Rel8.Schema.Kind ( Context )
1718
18−
19−type Expr :: Context
20−newtype Expr a = Expr Opaleye.PrimExpr
19+type role Expr representational
20+type Expr :: k -> Type
21+data Expr a where
22+ Expr :: k ~ Type => !Opaleye.PrimExpr -> Expr (a :: k)
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/Eq.hs+1−1
@@ -22,7 +22,7 @@ import Prelude
2222import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
2323
2424-- rel8
25−import Rel8.Expr ( Expr )
25+import {-# SOURCE #-} Rel8.Expr ( Expr )
2626import Rel8.Expr.Bool ( (&&.), (||.), false, or_, coalesce )
2727import Rel8.Expr.Null ( isNull, unsafeLiftOpNull )
2828import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr, zipPrimExprsWith )
src/Rel8/Expr/Num.hs+6−39
@@ -4,24 +4,18 @@
44{-# options_ghc -fno-warn-redundant-constraints #-}
55
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/FCF.hs+3−3
@@ -5,7 +5,7 @@
55
66module Rel8.FCF
77 ( Exp, Eval
8− , Id
8+ , Compose
99 )
1010where
1111
@@ -22,5 +22,5 @@ type Eval :: Exp e -> e
2222type family Eval a
2323
2424
25−data Id :: a -> Exp a
26−type instance Eval (Id a) = a
25+data Compose :: (Type -> Type) -> (Type -> Exp Type) -> Type -> Exp Type
26+type instance Eval (Compose f g a) = f (Eval (g a))
src/Rel8/Generic/Construction.hs+165−146
@@ -2,6 +2,9 @@
22{-# language ConstraintKinds #-}
33{-# language DataKinds #-}
44{-# language FlexibleContexts #-}
5+{-# language FlexibleInstances #-}
6+{-# language LambdaCase #-}
7+{-# language MultiParamTypeClasses #-}
58{-# language NamedFieldPuns #-}
69{-# language ScopedTypeVariables #-}
710{-# language StandaloneKindSignatures #-}
@@ -25,17 +28,18 @@ where
2528import Data.Bifunctor ( first )
2629import Data.Kind ( Constraint, Type )
2730import Data.List.NonEmpty ( NonEmpty( (:|) ) )
31+import Data.Type.Equality ( (:~:)( Refl ) )
2832import GHC.TypeLits ( Symbol )
2933import Prelude
3034
3135-- rel8
32−import Rel8.Aggregate ( Aggregate( Aggregate ) )
33−import Rel8.Expr ( Expr )
36+import Rel8.Aggregate ( Col( A ), Aggregate( Aggregate ) )
37+import Rel8.Expr ( Col( E ), Expr )
3438import Rel8.Expr.Aggregate ( groupByExpr )
3539import Rel8.Expr.Eq ( (==.) )
3640import Rel8.Expr.Null ( nullify, snull, unsafeUnnullify )
3741import Rel8.Expr.Serialize ( litExpr )
38−import Rel8.FCF ( Eval, Exp, Id )
42+import Rel8.FCF ( Eval, Exp )
3943import Rel8.Generic.Construction.ADT
4044 ( GConstructorADT, GMakeableADT, gmakeADT
4145 , GConstructableADT
@@ -55,16 +59,18 @@ import Rel8.Kind.Algebra
5559 , KnownAlgebra, algebraSing
5660 )
5761import qualified Rel8.Kind.Algebra as K
58−import Rel8.Schema.Context.Nullify ( sguard, snullify )
62+import Rel8.Schema.Context.Nullify ( runTag )
5963import Rel8.Schema.HTable ( HTable )
60−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
64+import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )
6165import qualified Rel8.Schema.Kind as K
62−import Rel8.Schema.Name ( Name( Name ) )
66+import Rel8.Schema.Name ( Col( N ), Name( Name ) )
6367import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
64−import Rel8.Schema.Spec ( Spec( Spec, nullity, info ) )
68+import Rel8.Schema.Spec ( SSpec( SSpec, nullity, info ) )
69+import Rel8.Schema.Reify ( Col( Reify ), Reify, hreify, hunreify )
70+import Rel8.Schema.Result ( Result )
6571import Rel8.Table
66− ( TTable, TColumns
67− , Table, fromColumns, toColumns
72+ ( TTable, TColumns, TUnreify
73+ , Table, fromColumns, toColumns, reify, unreify
6874 )
6975import Rel8.Table.Bool ( case_ )
7076import Rel8.Type.Tag ( Tag )
@@ -73,10 +79,10 @@ import Rel8.Type.Tag ( Tag )
7379type GGBuildable :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Constraint
7480type GGBuildable algebra name rep =
7581 ( KnownAlgebra algebra
76− , Eval (GGColumns algebra TColumns (Eval (rep Aggregate))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))
77− , Eval (GGColumns algebra TColumns (Eval (rep Expr))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))
78− , Eval (GGColumns algebra TColumns (Eval (rep Name))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))
79− , HTable (Eval (GGColumns algebra TColumns (Eval (rep Expr))))
82+ , Eval (GGColumns algebra TColumns (Eval (rep (Reify Aggregate)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))
83+ , Eval (GGColumns algebra TColumns (Eval (rep (Reify Expr)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))
84+ , Eval (GGColumns algebra TColumns (Eval (rep (Reify Name)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))
85+ , HTable (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))))
8086 , GGBuildable' algebra name rep
8187 )
8288
@@ -84,63 +90,65 @@ type GGBuildable algebra name rep =
8490type GGBuildable' :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Constraint
8591type family GGBuildable' algebra name rep where
8692 GGBuildable' 'K.Product name rep =
87− ( name ~ GConstructor (Eval (rep Expr))
88− , Representable Id (Eval (rep Expr))
89− , GConstructable (TTable Expr) TColumns Id Expr (Eval (rep Expr))
93+ ( name ~ GConstructor (Eval (rep (Reify Expr)))
94+ , Representable TUnreify (Eval (rep (Reify Expr)))
95+ , GConstructable (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) (Eval (rep (Reify Expr)))
9096 )
9197 GGBuildable' 'K.Sum name rep =
92− ( Representable Id (GConstructorADT name (Eval (rep Expr)))
93− , GMakeableADT (TTable Expr) TColumns Id Expr name (Eval (rep Expr))
98+ ( Representable TUnreify (GConstructorADT name (Eval (rep (Reify Expr))))
99+ , GMakeableADT (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) name (Eval (rep (Reify Expr)))
94100 )
95101
96102
97103type GGBuild :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Type -> Type
98104type family GGBuild algebra name rep r where
99105 GGBuild 'K.Product _name rep r =
100− GConstruct Id (Eval (rep Expr)) r
106+ GConstruct TUnreify (Eval (rep (Reify Expr))) r
101107 GGBuild 'K.Sum name rep r =
102− GConstruct Id (GConstructorADT name (Eval (rep Expr))) r
108+ GConstruct TUnreify (GConstructorADT name (Eval (rep (Reify Expr)))) r
103109
104110
105111ggbuild :: forall algebra name rep a. GGBuildable algebra name rep
106− => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a)
112+ => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr) -> a)
107113 -> GGBuild algebra name rep a
108114ggbuild gfromColumns = case algebraSing @algebra of
109115 SProduct ->
110− gtabulate @Id @(Eval (rep Expr)) @a $
116+ gtabulate @TUnreify @(Eval (rep (Reify Expr))) @a $
111117 gfromColumns .
118+ hunreify .
112119 gconstruct
113− @(TTable Expr)
120+ @(TTable (Reify Expr))
114121 @TColumns
115− @Id
116− @Expr
117− @(Eval (rep Expr))
118− (const toColumns)
122+ @TUnreify
123+ @(Col (Reify Expr))
124+ @(Eval (rep (Reify Expr)))
125+ (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
119126 SSum ->
120− gtabulate @Id @(GConstructorADT name (Eval (rep Expr))) @a $
127+ gtabulate @TUnreify @(GConstructorADT name (Eval (rep (Reify Expr)))) @a $
121128 gfromColumns .
129+ hunreify .
122130 gmakeADT
123− @(TTable Expr)
131+ @(TTable (Reify Expr))
124132 @TColumns
125− @Id
126− @Expr
133+ @TUnreify
134+ @(Col (Reify Expr))
127135 @name
128− @(Eval (rep Expr))
129− (const toColumns)
130− (\Spec {info} -> snull info)
131− (\Spec {nullity} -> case nullity of
136+ @(Eval (rep (Reify Expr)))
137+ (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
138+ (\SSpec {info} -> Reify (E (snull info)))
139+ (\SSpec {nullity} -> case nullity of
132140 Null -> id
133− NotNull -> nullify)
134− (HIdentity . litExpr)
141+ NotNull -> \(Reify (E a)) -> Reify (E (nullify a)))
142+ (HType . Reify . E . litExpr)
135143
136144
137145type GGConstructable :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint
138146type GGConstructable algebra rep =
139147 ( KnownAlgebra algebra
140− , Eval (GGColumns algebra TColumns (Eval (rep Aggregate))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))
141− , Eval (GGColumns algebra TColumns (Eval (rep Expr))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))
142− , Eval (GGColumns algebra TColumns (Eval (rep Name))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))
143− , HTable (Eval (GGColumns algebra TColumns (Eval (rep Expr))))
148+ , Eval (GGColumns algebra TColumns (Eval (rep (Reify Aggregate)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))
149+ , Eval (GGColumns algebra TColumns (Eval (rep (Reify Expr)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))
150+ , Eval (GGColumns algebra TColumns (Eval (rep (Reify Name)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))
151+ , HTable (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))))
144152 , GGConstructable' algebra rep
145153 )
146154
@@ -148,100 +156,105 @@ type GGConstructable algebra rep =
148156type GGConstructable' :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint
149157type family GGConstructable' algebra rep where
150158 GGConstructable' 'K.Product rep =
151− ( Representable Id (Eval (rep Aggregate))
152− , Representable Id (Eval (rep Expr))
153− , Representable Id (Eval (rep Name))
154− , GConstructable (TTable Aggregate) TColumns Id Aggregate (Eval (rep Aggregate))
155− , GConstructable (TTable Expr) TColumns Id Expr (Eval (rep Expr))
156− , GConstructable (TTable Name) TColumns Id Name (Eval (rep Name))
159+ ( Representable TUnreify (Eval (rep (Reify Aggregate)))
160+ , Representable TUnreify (Eval (rep (Reify Expr)))
161+ , Representable TUnreify (Eval (rep (Reify Name)))
162+ , GConstructable (TTable (Reify Aggregate)) TColumns TUnreify (Col (Reify Aggregate)) (Eval (rep (Reify Aggregate)))
163+ , GConstructable (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) (Eval (rep (Reify Expr)))
164+ , GConstructable (TTable (Reify Name)) TColumns TUnreify (Col (Reify Name)) (Eval (rep (Reify Name)))
157165 )
158166 GGConstructable' 'K.Sum rep =
159− ( RepresentableConstructors Id (Eval (rep Expr))
160− , RepresentableFields Id (Eval (rep Aggregate))
161− , RepresentableFields Id (Eval (rep Expr))
162− , RepresentableFields Id (Eval (rep Name))
163− , Functor (GConstructors Id (Eval (rep Expr)))
164− , GConstructableADT (TTable Aggregate) TColumns Id Aggregate (Eval (rep Aggregate))
165− , GConstructableADT (TTable Expr) TColumns Id Expr (Eval (rep Expr))
166− , GConstructableADT (TTable Name) TColumns Id Name (Eval (rep Name))
167+ ( RepresentableConstructors TUnreify (Eval (rep (Reify Expr)))
168+ , RepresentableFields TUnreify (Eval (rep (Reify Aggregate)))
169+ , RepresentableFields TUnreify (Eval (rep (Reify Expr)))
170+ , RepresentableFields TUnreify (Eval (rep (Reify Name)))
171+ , Functor (GConstructors TUnreify (Eval (rep (Reify Expr))))
172+ , GConstructableADT (TTable (Reify Aggregate)) TColumns TUnreify (Col (Reify Aggregate)) (Eval (rep (Reify Aggregate)))
173+ , GConstructableADT (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) (Eval (rep (Reify Expr)))
174+ , GConstructableADT (TTable (Reify Name)) TColumns TUnreify (Col (Reify Name)) (Eval (rep (Reify Name)))
167175 )
168176
169177
170178type GGConstruct :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type
171179type family GGConstruct algebra rep r where
172− GGConstruct 'K.Product rep r = GConstruct Id (Eval (rep Expr)) r -> r
173− GGConstruct 'K.Sum rep r = GConstructADT Id (Eval (rep Expr)) r r
180+ GGConstruct 'K.Product rep r =
181+ GConstruct TUnreify (Eval (rep (Reify Expr))) r -> r
182+ GGConstruct 'K.Sum rep r =
183+ GConstructADT TUnreify (Eval (rep (Reify Expr))) r r
174184
175185
176186ggconstruct :: forall algebra rep a. GGConstructable algebra rep
177− => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a)
187+ => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr) -> a)
178188 -> GGConstruct algebra rep a -> a
179189ggconstruct gfromColumns f = case algebraSing @algebra of
180190 SProduct ->
181191 f $
182− gtabulate @Id @(Eval (rep Expr)) @a $
192+ gtabulate @TUnreify @(Eval (rep (Reify Expr))) @a $
183193 gfromColumns .
194+ hunreify .
184195 gconstruct
185− @(TTable Expr)
196+ @(TTable (Reify Expr))
186197 @TColumns
187− @Id
188− @Expr
189− @(Eval (rep Expr))
190− (const toColumns)
198+ @TUnreify
199+ @(Col (Reify Expr))
200+ @(Eval (rep (Reify Expr)))
201+ (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
191202 SSum ->
192− gcindex @Id @(Eval (rep Expr)) @a f $
193− fmap gfromColumns $
203+ gcindex @TUnreify @(Eval (rep (Reify Expr))) @a f $
204+ fmap (gfromColumns . hunreify) $
194205 gconstructADT
195− @(TTable Expr)
206+ @(TTable (Reify Expr))
196207 @TColumns
197− @Id
198− @Expr
199− @(Eval (rep Expr))
200− (const toColumns)
201− (\Spec {info} -> snull info)
202− (\Spec {nullity} -> case nullity of
208+ @TUnreify
209+ @(Col (Reify Expr))
210+ @(Eval (rep (Reify Expr)))
211+ (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
212+ (\SSpec {info} -> Reify (E (snull info)))
213+ (\SSpec {nullity} -> case nullity of
203214 Null -> id
204− NotNull -> nullify)
205− (HIdentity . litExpr)
215+ NotNull -> \(Reify (E a)) -> Reify (E (nullify a)))
216+ (HType . Reify . E . litExpr)
206217
207218
208219type GGDeconstruct :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type -> Type
209220type family GGDeconstruct algebra rep a r where
210221 GGDeconstruct 'K.Product rep a r =
211− GConstruct Id (Eval (rep Expr)) r -> a -> r
222+ GConstruct TUnreify (Eval (rep (Reify Expr))) r -> a -> r
212223 GGDeconstruct 'K.Sum rep a r =
213− GConstructADT Id (Eval (rep Expr)) r (a -> r)
224+ GConstructADT TUnreify (Eval (rep (Reify Expr))) r (a -> r)
214225
215226
216227ggdeconstruct :: forall algebra rep a r. (GGConstructable algebra rep, Table Expr r)
217− => (a -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)
228+ => (a -> Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr))
218229 -> GGDeconstruct algebra rep a r
219230ggdeconstruct gtoColumns = case algebraSing @algebra of
220231 SProduct -> \build ->
221− gindex @Id @(Eval (rep Expr)) @r build .
232+ gindex @TUnreify @(Eval (rep (Reify Expr))) @r build .
222233 gdeconstruct
223− @(TTable Expr)
234+ @(TTable (Reify Expr))
224235 @TColumns
225− @Id
226− @Expr
227− @(Eval (rep Expr))
228− (const fromColumns) .
236+ @TUnreify
237+ @(Col (Reify Expr))
238+ @(Eval (rep (Reify Expr)))
239+ (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns) .
240+ hreify .
229241 gtoColumns
230242 SSum ->
231− gctabulate @Id @(Eval (rep Expr)) @r @(a -> r) $ \constructors as ->
243+ gctabulate @TUnreify @(Eval (rep (Reify Expr))) @r @(a -> r) $ \constructors as ->
232244 let
233− (HIdentity tag, cases) =
245+ (HType (Reify (E tag)), cases) =
234246 gdeconstructADT
235− @(TTable Expr)
247+ @(TTable (Reify Expr))
236248 @TColumns
237− @Id
238− @Expr
239− @(Eval (rep Expr))
240− (const fromColumns)
241− (\Spec {nullity} -> case nullity of
249+ @TUnreify
250+ @(Col (Reify Expr))
251+ @(Eval (rep (Reify Expr)))
252+ (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns)
253+ (\SSpec {nullity} -> case nullity of
242254 Null -> id
243− NotNull -> unsafeUnnullify)
255+ NotNull -> \(Reify (E a)) -> Reify (E (unsafeUnnullify a)))
244256 constructors $
257+ hreify $
245258 gtoColumns as
246259 in
247260 case cases of
@@ -251,102 +264,108 @@ ggdeconstruct gtoColumns = case algebraSing @algebra of
251264
252265type GGName :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type
253266type family GGName algebra rep a where
254− GGName 'K.Product rep a = GConstruct Id (Eval (rep Name)) a
255− GGName 'K.Sum rep a = Name Tag -> GBuildADT Id (Eval (rep Name)) a
267+ GGName 'K.Product rep a = GConstruct TUnreify (Eval (rep (Reify Name))) a
268+ GGName 'K.Sum rep a = Name Tag -> GBuildADT TUnreify (Eval (rep (Reify Name))) a
256269
257270
258271ggname :: forall algebra rep a. GGConstructable algebra rep
259− => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Name -> a)
272+ => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Name) -> a)
260273 -> GGName algebra rep a
261274ggname gfromColumns = case algebraSing @algebra of
262275 SProduct ->
263− gtabulate @Id @(Eval (rep Name)) @a $
276+ gtabulate @TUnreify @(Eval (rep (Reify Name))) @a $
264277 gfromColumns .
278+ hunreify .
265279 gconstruct
266− @(TTable Name)
280+ @(TTable (Reify Name))
267281 @TColumns
268− @Id
269− @Name
270− @(Eval (rep Name))
271− (const toColumns)
282+ @TUnreify
283+ @(Col (Reify Name))
284+ @(Eval (rep (Reify Name)))
285+ (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
272286 SSum -> \tag ->
273− gftabulate @Id @(Eval (rep Name)) @a $
287+ gftabulate @TUnreify @(Eval (rep (Reify Name))) @a $
274288 gfromColumns .
289+ hunreify .
275290 gbuildADT
276− @(TTable Name)
291+ @(TTable (Reify Name))
277292 @TColumns
278− @Id
279− @Name
280− @(Eval (rep Name))
281− (const toColumns)
282− (\_ _ (Name a) -> Name a)
283− (HIdentity tag)
293+ @TUnreify
294+ @(Col (Reify Name))
295+ @(Eval (rep (Reify Name)))
296+ (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
297+ (\_ _ (Reify (N (Name a))) -> Reify (N (Name a)))
298+ (HType (Reify (N tag)))
284299
285300
286301type GGAggregate :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type
287302type family GGAggregate algebra rep r where
288303 GGAggregate 'K.Product rep r =
289− GConstruct Id (Eval (rep Aggregate)) r ->
290− GConstruct Id (Eval (rep Expr)) r
304+ GConstruct TUnreify (Eval (rep (Reify Aggregate))) r ->
305+ GConstruct TUnreify (Eval (rep (Reify Expr))) r
291306 GGAggregate 'K.Sum rep r =
292− GBuildADT Id (Eval (rep Aggregate)) r ->
293− GBuildADT Id (Eval (rep Expr)) r
307+ GBuildADT TUnreify (Eval (rep (Reify Aggregate))) r ->
308+ GBuildADT TUnreify (Eval (rep (Reify Expr))) r
294309
295310
296311ggaggregate :: forall algebra rep exprs agg. GGConstructable algebra rep
297− => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Aggregate -> agg)
298− -> (exprs -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)
312+ => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Aggregate) -> agg)
313+ -> (exprs -> Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr))
299314 -> GGAggregate algebra rep agg -> exprs -> agg
300315ggaggregate gfromColumns gtoColumns agg es = case algebraSing @algebra of
301316 SProduct -> flip f exprs $
302317 gfromColumns .
318+ hunreify .
303319 gconstruct
304− @(TTable Aggregate)
320+ @(TTable (Reify Aggregate))
305321 @TColumns
306− @Id
307− @Aggregate
308− @(Eval (rep Aggregate))
309− (const toColumns)
322+ @TUnreify
323+ @(Col (Reify Aggregate))
324+ @(Eval (rep (Reify Aggregate)))
325+ (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
310326 where
311327 f =
312− gindex @Id @(Eval (rep Expr)) @agg .
328+ gindex @TUnreify @(Eval (rep (Reify Expr))) @agg .
313329 agg .
314− gtabulate @Id @(Eval (rep Aggregate)) @agg
330+ gtabulate @TUnreify @(Eval (rep (Reify Aggregate))) @agg
315331 exprs =
316332 gdeconstruct
317− @(TTable Expr)
333+ @(TTable (Reify Expr))
318334 @TColumns
319− @Id
320− @Expr
321− @(Eval (rep Expr))
322− (const fromColumns) $
335+ @TUnreify
336+ @(Col (Reify Expr))
337+ @(Eval (rep (Reify Expr)))
338+ (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns) $
339+ hreify $
323340 gtoColumns es
324341 SSum -> flip f exprs $
325342 gfromColumns .
343+ hunreify .
326344 gbuildADT
327− @(TTable Aggregate)
345+ @(TTable (Reify Aggregate))
328346 @TColumns
329− @Id
330− @Aggregate
331− @(Eval (rep Aggregate))
332− (const toColumns)
333− (\tag' Spec {nullity} (Aggregate a) ->
334− Aggregate $ sguard (tag ==. litExpr tag') . snullify nullity <$> a)
335− (HIdentity (groupByExpr tag))
347+ @TUnreify
348+ @(Col (Reify Aggregate))
349+ @(Eval (rep (Reify Aggregate)))
350+ (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
351+ (\tag' SSpec {nullity} (Reify (A (Aggregate a))) ->
352+ Reify $ A $ Aggregate $ runTag nullity (tag ==. litExpr tag') <$> a)
353+ (HType (Reify (A (groupByExpr tag))))
336354 where
337355 f =
338− gfindex @Id @(Eval (rep Expr)) @agg .
356+ gfindex @TUnreify @(Eval (rep (Reify Expr))) @agg .
339357 agg .
340− gftabulate @Id @(Eval (rep Aggregate)) @agg
341− (HIdentity tag, exprs) =
358+ gftabulate @TUnreify @(Eval (rep (Reify Aggregate))) @agg
359+ (HType (Reify (E tag)), exprs) =
342360 gunbuildADT
343− @(TTable Expr)
361+ @(TTable (Reify Expr))
344362 @TColumns
345− @Id
346− @Expr
347− @(Eval (rep Expr))
348− (const fromColumns)
349− (\Spec {nullity} -> case nullity of
363+ @TUnreify
364+ @(Col (Reify Expr))
365+ @(Eval (rep (Reify Expr)))
366+ (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns)
367+ (\SSpec {nullity} -> case nullity of
350368 Null -> id
351− NotNull -> unsafeUnnullify) $
369+ NotNull -> \(Reify (E a)) -> Reify (E (unsafeUnnullify a))) $
370+ hreify $
352371 gtoColumns es
src/Rel8/Generic/Construction/ADT.hs+27−20
@@ -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
@@ -63,16 +62,24 @@ import Rel8.Type.Tag ( Tag( Tag ) )
6362import Data.Text ( pack )
6463
6564
66−type Null :: K.Context -> Type
67−type Null context = forall a. Spec a -> context (Nullify a)
65+type Null :: K.HContext -> Type
66+type Null context = forall a. ()
67+ => SSpec ('Spec a)
68+ -> context ('Spec (Nullify a))
6869
6970
70−type Nullifier :: K.Context -> Type
71−type Nullifier context = forall a. Spec a -> context a -> context (Nullify a)
71+type Nullifier :: K.HContext -> Type
72+type Nullifier context = forall a. ()
73+ => SSpec ('Spec a)
74+ -> context ('Spec a)
75+ -> context ('Spec (Nullify a))
7276
7377
74−type Unnullifier :: K.Context -> Type
75−type Unnullifier context = forall a. Spec a -> context (Nullify a) -> context a
78+type Unnullifier :: K.HContext -> Type
79+type Unnullifier context = forall a. ()
80+ => SSpec ('Spec a)
81+ -> context ('Spec (Nullify a))
82+ -> context ('Spec a)
7683
7784
7885type NoConstructor :: Symbol -> Symbol -> ErrorMessage
@@ -181,12 +188,12 @@ type GConstructableADT
181188 :: (Type -> Exp Constraint)
182189 -> (Type -> Exp K.HTable)
183190 -> (Type -> Exp Type)
184− -> K.Context -> (Type -> Type) -> Constraint
191+ -> K.HContext -> (Type -> Type) -> Constraint
185192class 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)
@@ -238,7 +245,7 @@ type GConstructableADT'
238245 :: (Type -> Exp Constraint)
239246 -> (Type -> Exp K.HTable)
240247 -> (Type -> Exp Type)
241− -> K.Context -> K.HTable -> (Type -> Type) -> Constraint
248+ -> K.HContext -> K.HTable -> (Type -> Type) -> Constraint
242249class GConstructableADT' _Table _Columns f context htable rep where
243250 gbuildADT' :: ()
244251 => ToColumns _Table _Columns f context
@@ -376,19 +383,19 @@ type GMakeableADT
376383 :: (Type -> Exp Constraint)
377384 -> (Type -> Exp K.HTable)
378385 -> (Type -> Exp Type)
379− -> K.Context -> Symbol -> (Type -> Type) -> Constraint
386+ -> K.HContext -> Symbol -> (Type -> Type) -> Constraint
380387class GMakeableADT _Table _Columns f context name rep where
381388 gmakeADT :: ()
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)
@@ -410,7 +417,7 @@ type GMakeableADT'
410417 :: (Type -> Exp Constraint)
411418 -> (Type -> Exp K.HTable)
412419 -> (Type -> Exp Type)
413− -> K.Context -> K.HTable -> Symbol -> (Type -> Type) -> Type -> Constraint
420+ -> K.HContext -> K.HTable -> Symbol -> (Type -> Type) -> Type -> Constraint
414421class GMakeableADT' _Table _Columns f context htable name rep fields where
415422 gmakeADT' :: ()
416423 => ToColumns _Table _Columns f context
src/Rel8/Generic/Construction/Record.hs+3−3
@@ -43,7 +43,7 @@ type FromColumns
4343 :: (Type -> Exp Constraint)
4444 -> (Type -> Exp K.HTable)
4545 -> (Type -> Exp Type)
46− -> K.Context
46+ -> K.HContext
4747 -> Type
4848type FromColumns _Table _Columns f context = forall proxy x.
4949 Eval (_Table x) => proxy x -> Eval (_Columns x) context -> Eval (f x)
@@ -53,7 +53,7 @@ type ToColumns
5353 :: (Type -> Exp Constraint)
5454 -> (Type -> Exp K.HTable)
5555 -> (Type -> Exp Type)
56− -> K.Context
56+ -> K.HContext
5757 -> Type
5858type ToColumns _Table _Columns f context = forall proxy x.
5959 Eval (_Table x) => proxy x -> Eval (f x) -> Eval (_Columns x) context
@@ -117,7 +117,7 @@ type GConstructable
117117 :: (Type -> Exp Constraint)
118118 -> (Type -> Exp K.HTable)
119119 -> (Type -> Exp Type)
120− -> K.Context -> (Type -> Type) -> Constraint
120+ -> K.HContext -> (Type -> Type) -> Constraint
121121class GConstructable _Table _Columns f context rep where
122122 gconstruct :: ()
123123 => ToColumns _Table _Columns f context
src/Rel8/Generic/Map.hs+64−20
@@ -1,19 +1,26 @@
1+{-# language AllowAmbiguousTypes #-}
12{-# language DataKinds #-}
3+{-# language EmptyCase #-}
4+{-# language FlexibleInstances #-}
5+{-# language LambdaCase #-}
6+{-# language MultiParamTypeClasses #-}
7+{-# language RankNTypes #-}
8+{-# language ScopedTypeVariables #-}
29{-# language StandaloneKindSignatures #-}
10+{-# language TypeApplications #-}
311{-# language TypeFamilies #-}
412{-# language TypeOperators #-}
513{-# language UndecidableInstances #-}
614
715module Rel8.Generic.Map
8− ( GMap
9− , Map
16+ ( GMap, GMappable (gmap, gunmap)
1017 )
1118where
1219
1320-- base
14−import Data.Kind ( Type )
21+import Data.Kind ( Constraint, Type )
1522import GHC.Generics
16− ( (:+:), (:*:), K1, M1, U1, V1
23+ ( (:+:)( L1, R1 ), (:*:)( (:*:) ), K1( K1 ), M1( M1 ), U1( U1 ), V1
1724 )
1825import Prelude ()
1926
@@ -31,19 +38,56 @@ type family GMap f rep where
3138 GMap f (K1 i a) = K1 i (Eval (f a))
3239
3340
34−-- | Map a @Type -> Type@ function over the @Type@-kinded type variables in
35−-- of a type constructor.
36−type Map :: (Type -> Exp Type) -> Type -> Type
37−type family Map f a where
38− Map p (t a b c d e f g) =
39− t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e))
40− (Eval (p f)) (Eval (p g))
41− Map p (t a b c d e f) =
42− t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e))
43− (Eval (p f))
44− Map p (t a b c d e) =
45− t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e))
46− Map p (t a b c d) = t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d))
47− Map p (t a b c) = t (Eval (p a)) (Eval (p b)) (Eval (p c))
48− Map p (t a b) = t (Eval (p a)) (Eval (p b))
49− Map p (t a) = t (Eval (p a))
41+type GMappable :: (Type -> Exp Constraint) -> (Type -> Type) -> Constraint
42+class GMappable constraint rep where
43+ gmap :: ()
44+ => proxy f
45+ -> (forall a. Eval (constraint a) => a -> Eval (f a))
46+ -> rep x
47+ -> GMap f rep x
48+
49+ gunmap :: ()
50+ => proxy f
51+ -> (forall a. Eval (constraint a) => Eval (f a) -> a)
52+ -> GMap f rep x
53+ -> rep x
54+
55+
56+instance GMappable constraint rep => GMappable constraint (M1 i c rep) where
57+ gmap proxy f (M1 a) = M1 (gmap @constraint proxy f a)
58+ gunmap proxy f (M1 a) = M1 (gunmap @constraint proxy f a)
59+
60+
61+instance GMappable constraint V1 where
62+ gmap _ _ = \case
63+ gunmap _ _ = \case
64+
65+
66+instance (GMappable constraint rep1, GMappable constraint rep2) =>
67+ GMappable constraint (rep1 :+: rep2)
68+ where
69+ gmap proxy f = \case
70+ L1 a -> L1 (gmap @constraint proxy f a)
71+ R1 a -> R1 (gmap @constraint proxy f a)
72+ gunmap proxy f = \case
73+ L1 a -> L1 (gunmap @constraint proxy f a)
74+ R1 a -> R1 (gunmap @constraint proxy f a)
75+
76+
77+instance GMappable constraint U1 where
78+ gmap _ _ U1 = U1
79+ gunmap _ _ U1 = U1
80+
81+
82+instance (GMappable constraint rep1, GMappable constraint rep2) =>
83+ GMappable constraint (rep1 :*: rep2)
84+ where
85+ gmap proxy f (a :*: b) =
86+ gmap @constraint proxy f a :*: gmap @constraint proxy f b
87+ gunmap proxy f (a :*: b) =
88+ gunmap @constraint proxy f a :*: gunmap @constraint proxy f b
89+
90+
91+instance Eval (constraint a) => GMappable constraint (K1 i a) where
92+ gmap _ f (K1 a) = K1 (f a)
93+ gunmap _ f (K1 a) = K1 (f a)
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/Reify.hsnew file+24
@@ -0,0 +1,24 @@
1+{-# language StandaloneKindSignatures #-}
2+{-# language TypeFamilies #-}
3+
4+module Rel8.Generic.Reify
5+ ( ARep
6+ )
7+where
8+
9+-- base
10+import Data.Functor.Contravariant ( Contravariant, contramap )
11+import Data.Kind ( Type )
12+import Data.Void ( Void, absurd )
13+import GHC.Generics ( Generic, Rep, from, to )
14+import Prelude
15+
16+
17+type ARep :: (Type -> Type) -> Type
18+newtype ARep rep = ARep (rep Void)
19+
20+
21+instance (Contravariant rep, Functor rep) => Generic (ARep rep) where
22+ type Rep (ARep rep) = rep
23+ from (ARep a) = fmap absurd a
24+ to = ARep . contramap absurd
src/Rel8/Generic/Rel8able.hs+71−178
@@ -1,18 +1,13 @@
11{-# language AllowAmbiguousTypes #-}
2−{-# language ConstraintKinds #-}
32{-# language DataKinds #-}
43{-# language DefaultSignatures #-}
54{-# language FlexibleContexts #-}
65{-# language FlexibleInstances #-}
7−{-# language LambdaCase #-}
86{-# language MultiParamTypeClasses #-}
9−{-# language PolyKinds #-}
10−{-# language QuantifiedConstraints #-}
117{-# language ScopedTypeVariables #-}
128{-# language StandaloneKindSignatures #-}
139{-# language TypeApplications #-}
14−{-# language TypeFamilyDependencies #-}
15−{-# language TypeOperators #-}
10+{-# language TypeFamilies #-}
1611{-# language UndecidableInstances #-}
1712
1813module Rel8.Generic.Rel8able
@@ -20,39 +15,35 @@ module Rel8.Generic.Rel8able
2015 , Algebra
2116 , GRep
2217 , GColumns, gfromColumns, gtoColumns
23− , GFromExprs, gfromResult, gtoResult
24− , TSerialize, serialize, deserialize
18+ , greify, gunreify
19+ , TUnreifyContext
2520 )
2621where
2722
2823-- base
29−import Data.Functor.Identity ( Identity )
3024import Data.Kind ( Constraint, Type )
31−import Data.Type.Bool ( type (&&) )
25+import Data.Proxy ( Proxy( Proxy ) )
26+import Data.Type.Equality ( (:~:)( Refl ) )
3227import GHC.Generics ( Generic, Rep, from, to )
3328import Prelude
3429
3530-- rel8
36−import Rel8.Aggregate ( Aggregate )
37−import Rel8.Expr ( Expr )
38−import Rel8.FCF ( Exp, Eval )
31+import Rel8.Kind.Context ( Reifiable )
32+import Rel8.FCF ( Eval, Exp )
33+import Rel8.Generic.Map ( GMap, GMappable, gmap, gunmap )
3934import Rel8.Generic.Record ( Record(..) )
4035import Rel8.Generic.Table ( GAlgebra )
4136import qualified Rel8.Generic.Table.Record as G
4237import qualified Rel8.Kind.Algebra as K ( Algebra(..) )
43−import Rel8.Kind.Context ( SContext(..) )
44−import Rel8.Schema.Field ( Field )
38+import Rel8.Schema.Context ( Col )
4539import Rel8.Schema.HTable ( HTable )
4640import qualified Rel8.Schema.Kind as K
47−import Rel8.Schema.Name ( Name )
41+import Rel8.Schema.Reify ( Reify, UnwrapReify )
4842import Rel8.Schema.Result ( Result )
4943import Rel8.Table
50− ( Table, Columns, Context, fromColumns, toColumns
51− , FromExprs, fromResult, toResult
52− , Transpose
53− , TTable, TColumns
44+ ( fromColumns, toColumns, reify, unreify
45+ , TTable, TColumns, TContext, TUnreify
5446 )
55−import Rel8.Table.Transpose ( Transposes )
5647
5748
5849-- | The kind of 'Rel8able' types
@@ -60,59 +51,6 @@ type KRel8able :: Type
6051type KRel8able = K.Rel8able
6152
6253
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−
11654-- | This type class allows you to define custom 'Table's using higher-kinded
11755-- data types. Higher-kinded data types are data types of the pattern:
11856--
@@ -146,7 +84,7 @@ type instance Eval (TSerialize expr a) =
14684-- [Supplying @Rel8able@ instances]
14785--
14886-- This type class should be derived generically for all table types in your
149−-- project. To do this, enable the @DeriveAnyClass@ and @DeriveGeneric@ language
87+-- project. To do this, enable the @DeriveAnyType@ and @DeriveGeneric@ language
15088-- extensions:
15189--
15290-- @
@@ -158,124 +96,79 @@ type instance Eval (TSerialize expr a) =
15896type Rel8able :: K.Rel8able -> Constraint
15997class HTable (GColumns t) => Rel8able t where
16098 type GColumns t :: K.HTable
161− type GFromExprs t :: Type
16299
163− gfromColumns :: SContext context -> GColumns t context -> t context
164− gtoColumns :: SContext context -> t context -> GColumns t context
100+ gfromColumns :: Reifiable context
101+ => GColumns t (Col (Reify context)) -> t (Reify context)
102+
103+ gtoColumns :: Reifiable context
104+ => t (Reify context) -> GColumns t (Col (Reify context))
165105
166− gfromResult :: GColumns t Result -> GFromExprs t
167− gtoResult :: GFromExprs t -> GColumns t Result
106+ greify :: Reifiable context
107+ => t context -> t (Reify context)
168108
169− type GColumns t = G.GColumns TColumns (GRep t Expr)
170− type GFromExprs t = t Result
109+ gunreify :: Reifiable context
110+ => t (Reify context) -> t context
111+
112+ type GColumns t = G.GColumns TColumns (GRep t (Reify Result))
171113
172114 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
115+ ( Generic (Record (t (Reify context)))
116+ , G.GTable (TTable (Reify context)) TColumns (Col (Reify context)) (GRep t (Reify context))
117+ , G.GColumns TColumns (GRep t (Reify context)) ~ GColumns t
178118 )
179− => SContext context -> GColumns t context -> t context
180− gfromColumns = \case
181− SAggregate -> sfromColumns
182− SExpr -> sfromColumns
183− SField -> sfromColumns
184− SName -> sfromColumns
185− SResult -> sfromResult
119+ => GColumns t (Col (Reify context)) -> t (Reify context)
120+ gfromColumns =
121+ unrecord .
122+ to .
123+ G.gfromColumns @(TTable (Reify context)) @TColumns fromColumns
186124
187125 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
126+ ( Generic (Record (t (Reify context)))
127+ , G.GTable (TTable (Reify context)) TColumns (Col (Reify context)) (GRep t (Reify context))
128+ , G.GColumns TColumns (GRep t (Reify context)) ~ GColumns t
193129 )
194− => SContext context -> t context -> GColumns t context
195− 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)
203− => GColumns t Result -> GFromExprs t
204− gfromResult = sfromResult
205−
206− default gtoResult :: (SSerialize t, GFromExprs t ~ t Result)
207− => GFromExprs t -> GColumns t Result
208− gtoResult = stoResult
130+ => t (Reify context) -> GColumns t (Col (Reify context))
131+ gtoColumns =
132+ G.gtoColumns @(TTable (Reify context)) @TColumns toColumns .
133+ from .
134+ Record
135+
136+ default greify :: forall context.
137+ ( Generic (Record (t context))
138+ , Generic (Record (t (Reify context)))
139+ , GMappable (TTable (Reify context)) (GRep t (Reify context))
140+ , GRep t context ~ GMap TUnreify (GRep t (Reify context))
141+ )
142+ => t context -> t (Reify context)
143+ greify =
144+ unrecord .
145+ to .
146+ gunmap @(TTable (Reify context)) (Proxy @TUnreify) (reify Refl) .
147+ from .
148+ Record
149+
150+ default gunreify :: forall context.
151+ ( Generic (Record (t context))
152+ , Generic (Record (t (Reify context)))
153+ , GMappable (TTable (Reify context)) (GRep t (Reify context))
154+ , GRep t context ~ GMap TUnreify (GRep t (Reify context))
155+ )
156+ => t (Reify context) -> t context
157+ gunreify =
158+ unrecord .
159+ to .
160+ gmap @(TTable (Reify context)) (Proxy @TUnreify) (unreify Refl) .
161+ from .
162+ Record
209163
210164
211165type Algebra :: K.Rel8able -> K.Algebra
212−type Algebra t = GAlgebra (GRep t Expr)
166+type Algebra t = GAlgebra (GRep t (Reify Result))
213167
214168
215169type GRep :: K.Rel8able -> K.Context -> Type -> Type
216170type GRep t context = Rep (Record (t context))
217171
218172
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
227− ( Generic (Record (t context))
228− , G.GTable (TTable context) TColumns (GRep t context)
229− , G.GColumns TColumns (GRep t context) ~ GColumns t
230− )
231− => SRel8able t context
232−
233−
234−type SSerialize :: K.Rel8able -> Constraint
235−type SSerialize t =
236− ( Generic (Record (t Result))
237− , G.GSerialize TSerialize TColumns (GRep t Expr) (GRep t Result)
238− , G.GColumns TColumns (GRep t Expr) ~ GColumns t
239− )
240−
241−
242−sfromColumns :: forall t context. SRel8able t context
243− => GColumns t context -> t context
244−sfromColumns =
245− unrecord .
246− to .
247− G.gfromColumns @(TTable context) @TColumns fromColumns
248−
249−
250−stoColumns :: forall t context. SRel8able t context
251− => t context -> GColumns t context
252−stoColumns =
253− G.gtoColumns @(TTable context) @TColumns toColumns .
254− from .
255− Record
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) .
280− from .
281− Record
173+data TUnreifyContext :: Type -> Exp K.Context
174+type instance Eval (TUnreifyContext a) = UnwrapReify (Eval (TContext a))
tests/Rel8/Generic/Rel8able/Test.hs → src/Rel8/Generic/Rel8able/Test.hsrenamed+16−47
@@ -1,11 +1,11 @@
11{-# language DataKinds #-}
22{-# language DeriveAnyClass #-}
33{-# language DeriveGeneric #-}
4−{-# language DerivingStrategies #-}
4+{-# language DerivingVia #-}
55{-# language DuplicateRecordFields #-}
66{-# language FlexibleInstances #-}
77{-# language MultiParamTypeClasses #-}
8−{-# language StandaloneKindSignatures #-}
8+{-# language StandaloneDeriving #-}
99{-# language TypeFamilies #-}
1010{-# language UndecidableInstances #-}
1111
@@ -98,20 +98,30 @@ data S3Object = S3Object
9898 deriving stock Generic
9999
100100
101−instance x ~ HKD S3Object Expr => ToExprs x S3Object
101+deriving via HKDT S3Object
102+ instance Table Result S3Object
103+
104+
105+deriving via HKDT S3Object
106+ instance x ~ HKD S3Object Expr => ToExprs x S3Object
102107
103108
104109data HKDSum = HKDSumA Text | HKDSumB Bool Char | HKDSumC
105110 deriving stock Generic
106111
107112
108−instance x ~ HKD HKDSum Expr => ToExprs x HKDSum
113+deriving via HKDT HKDSum
114+ instance Table Result HKDSum
115+
116+
117+deriving via HKDT HKDSum
118+ instance x ~ HKD HKDSum Expr => ToExprs x HKDSum
109119
110120
111121data HKDTest f = HKDTest
112122 { s3Object :: Lift f S3Object
113123 , hkdSum :: Lift f HKDSum
114− }
124+ }
115125 deriving stock Generic
116126 deriving anyclass Rel8able
117127
@@ -138,51 +148,10 @@ data TableSum f
138148 deriving stock Generic
139149
140150
141−data BarbieSum f
142− = BarbieSumA (f Bool) (f Text)
143− | BarbieSumB
144− | BarbieSumC (f Text)
145− deriving stock Generic
146−
147−
148151data TableProduct f = TableProduct
149− { sum :: HADT f BarbieSum
152+ { sum :: HADT f TableSum
150153 , list :: TableList f
151154 , foos :: HList f (HADT f TableSum, Lift f HKDSum, HKDTest f)
152155 }
153156 deriving stock Generic
154157 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
src/Rel8/Generic/Table.hs+109−24
@@ -12,7 +12,8 @@
1212{-# language UndecidableInstances #-}
1313
1414module Rel8.Generic.Table
15− ( GGSerialize, GGColumns, ggfromResult, ggtoResult
15+ ( GGTable, GGColumns, GGContext, ggfromColumns, ggtoColumns, ggtable
16+ , GGToExprs, ggfromResult, ggtoResult
1617 , GAlgebra
1718 )
1819where
@@ -25,19 +26,43 @@ import Prelude ()
2526-- rel8
2627import Rel8.FCF ( Eval, Exp )
2728import Rel8.Generic.Table.ADT
28− ( GSerializeADT, GColumnsADT, gtoResultADT, gfromResultADT
29+ ( GTableADT, GColumnsADT, gfromColumnsADT, gtoColumnsADT, gtableADT
30+ , GToExprsADT, gtoResultADT, gfromResultADT
31+ )
32+import Rel8.Generic.Table.Record
33+ ( GTable, GColumns, GContext, gfromColumns, gtoColumns, gtable
34+ , GToExprs, gtoResult, gfromResult
2935 )
30−import Rel8.Generic.Table.Record ( GSerialize, GColumns, gtoResult, gfromResult )
3136import Rel8.Kind.Algebra
3237 ( Algebra( Product, Sum )
3338 , SAlgebra( SProduct, SSum )
3439 , KnownAlgebra, algebraSing
3540 )
41+import Rel8.Schema.Context ( Col )
3642import qualified Rel8.Schema.Kind as K
43+import Rel8.Schema.Null ( Nullify )
44+import Rel8.Schema.Spec ( Spec( Spec ), SSpec )
3745import Rel8.Schema.Result ( Result )
3846
3947
40−data GGSerialize
48+data GGTable
49+ :: Algebra
50+ -> (Type -> Exp Constraint)
51+ -> (Type -> Exp K.HTable)
52+ -> K.HContext
53+ -> (Type -> Type)
54+ -> Exp Constraint
55+
56+
57+type instance Eval (GGTable 'Product _Table _Columns context rep) =
58+ GTable _Table _Columns context rep
59+
60+
61+type instance Eval (GGTable 'Sum _Table _Columns context rep) =
62+ GTableADT _Table _Columns context rep
63+
64+
65+data GGToExprs
4166 :: Algebra
4267 -> (Type -> Type -> Exp Constraint)
4368 -> (Type -> Exp K.HTable)
@@ -46,12 +71,12 @@ data GGSerialize
4671 -> Exp Constraint
4772
4873
49−type instance Eval (GGSerialize 'Product _Serialize _Columns exprs rep) =
50− GSerialize _Serialize _Columns exprs rep
74+type instance Eval (GGToExprs 'Product _ToExprs _Columns exprs rep) =
75+ GToExprs _ToExprs _Columns exprs rep
5176
5277
53−type instance Eval (GGSerialize 'Sum _Serialize _Columns exprs rep) =
54− GSerializeADT _Serialize _Columns exprs rep
78+type instance Eval (GGToExprs 'Sum _ToExprs _Columns exprs rep) =
79+ GToExprsADT _ToExprs _Columns exprs rep
5580
5681
5782data GGColumns
@@ -67,6 +92,19 @@ type instance Eval (GGColumns 'Product _Columns rep) = GColumns _Columns rep
6792type instance Eval (GGColumns 'Sum _Columns rep) = GColumnsADT _Columns rep
6893
6994
95+data GGContext
96+ :: Algebra
97+ -> (Type -> Exp K.Context)
98+ -> (Type -> Type)
99+ -> Exp K.Context
100+
101+
102+type instance Eval (GGContext 'Product _Context rep) = GContext _Context rep
103+
104+
105+type instance Eval (GGContext 'Sum _Context _rep) = Result
106+
107+
70108type GAlgebra :: (Type -> Type) -> Algebra
71109type family GAlgebra rep where
72110 GAlgebra (M1 _ _ rep) = GAlgebra rep
@@ -77,27 +115,74 @@ type family GAlgebra rep where
77115 GAlgebra (K1 _ _) = 'Product
78116
79117
80−ggfromResult :: forall algebra _Serialize _Columns exprs rep x.
118+ggfromColumns :: forall algebra _Table _Columns rep context x.
119+ ( KnownAlgebra algebra
120+ , Eval (GGTable algebra _Table _Columns context rep)
121+ )
122+ => (forall spec. algebra ~ 'Sum => context spec -> Col Result spec)
123+ -> (forall spec. algebra ~ 'Sum => Col Result spec -> context spec)
124+ -> (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)
125+ -> Eval (GGColumns algebra _Columns rep) context
126+ -> rep x
127+ggfromColumns = case algebraSing @algebra of
128+ SProduct -> \_ _ -> gfromColumns @_Table @_Columns
129+ SSum -> gfromColumnsADT @_Table @_Columns
130+
131+
132+ggtoColumns :: forall algebra _Table _Columns rep context x.
133+ ( KnownAlgebra algebra
134+ , Eval (GGTable algebra _Table _Columns context rep)
135+ )
136+ => (forall spec. algebra ~ 'Sum => context spec -> Col Result spec)
137+ -> (forall spec. algebra ~ 'Sum => Col Result spec -> context spec)
138+ -> (forall a. Eval (_Table a) => a -> Eval (_Columns a) context)
139+ -> rep x
140+ -> Eval (GGColumns algebra _Columns rep) context
141+ggtoColumns = case algebraSing @algebra of
142+ SProduct -> \_ _ -> gtoColumns @_Table @_Columns
143+ SSum -> gtoColumnsADT @_Table @_Columns
144+
145+
146+ggtable :: forall algebra _Table _Columns rep context.
147+ ( KnownAlgebra algebra
148+ , Eval (GGTable algebra _Table _Columns context rep)
149+ )
150+ => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)
151+ -> (forall a. ()
152+ => SSpec ('Spec a)
153+ -> context ('Spec a)
154+ -> context ('Spec (Nullify a)))
155+ -> Eval (GGColumns algebra _Columns rep) context
156+ggtable = case algebraSing @algebra of
157+ SProduct -> \table _ -> gtable @_Table @_Columns @_ @rep table
158+ SSum -> gtableADT @_Table @_Columns @_ @rep
159+
160+
161+ggfromResult :: forall algebra _ToExprs _Columns exprs rep x.
81162 ( KnownAlgebra algebra
82− , Eval (GGSerialize algebra _Serialize _Columns exprs rep)
163+ , Eval (GGToExprs algebra _ToExprs _Columns exprs rep)
83164 )
84− => (forall expr a proxy. Eval (_Serialize expr a)
85− => proxy expr -> Eval (_Columns expr) Result -> a)
86− -> Eval (GGColumns algebra _Columns exprs) Result
165+ => (forall expr a proxy. Eval (_ToExprs expr a)
166+ => proxy expr
167+ -> Eval (_Columns expr) (Col Result)
168+ -> a)
169+ -> Eval (GGColumns algebra _Columns exprs) (Col Result)
87170 -> rep x
88−ggfromResult f x = case algebraSing @algebra of
89− SProduct -> gfromResult @_Serialize @_Columns @exprs @rep f x
90− SSum -> gfromResultADT @_Serialize @_Columns @exprs @rep f x
171+ggfromResult = case algebraSing @algebra of
172+ SProduct -> gfromResult @_ToExprs @_Columns @exprs
173+ SSum -> gfromResultADT @_ToExprs @_Columns @exprs
91174
92175
93−ggtoResult :: forall algebra _Serialize _Columns exprs rep x.
176+ggtoResult :: forall algebra _ToExprs _Columns exprs rep x.
94177 ( KnownAlgebra algebra
95− , Eval (GGSerialize algebra _Serialize _Columns exprs rep)
178+ , Eval (GGToExprs algebra _ToExprs _Columns exprs rep)
96179 )
97− => (forall expr a proxy. Eval (_Serialize expr a)
98− => proxy expr -> a -> Eval (_Columns expr) Result)
180+ => (forall expr a proxy. Eval (_ToExprs expr a)
181+ => proxy expr
182+ -> a
183+ -> Eval (_Columns expr) (Col Result))
99184 -> rep x
100− -> Eval (GGColumns algebra _Columns exprs) Result
101−ggtoResult f x = case algebraSing @algebra of
102− SProduct -> gtoResult @_Serialize @_Columns @exprs @rep f x
103− SSum -> gtoResultADT @_Serialize @_Columns @exprs @rep f x
185+ -> Eval (GGColumns algebra _Columns exprs) (Col Result)
186+ggtoResult = case algebraSing @algebra of
187+ SProduct -> gtoResult @_ToExprs @_Columns @exprs
188+ SSum -> gtoResultADT @_ToExprs @_Columns @exprs
src/Rel8/Generic/Table/ADT.hs+197−58
@@ -4,6 +4,7 @@
44{-# language FlexibleInstances #-}
55{-# language LambdaCase #-}
66{-# language MultiParamTypeClasses #-}
7+{-# language PolyKinds #-}
78{-# language RankNTypes #-}
89{-# language ScopedTypeVariables #-}
910{-# language StandaloneKindSignatures #-}
@@ -13,13 +14,13 @@
1314{-# language UndecidableInstances #-}
1415
1516module Rel8.Generic.Table.ADT
16− ( GSerializeADT, GColumnsADT, gfromResultADT, gtoResultADT
17− , GSerializeADT', GColumnsADT'
17+ ( GTableADT, GColumnsADT, gfromColumnsADT, gtoColumnsADT, gtableADT
18+ , GTableADT', GColumnsADT'
19+ , GToExprsADT, gfromResultADT, gtoResultADT
1820 )
1921where
2022
2123-- base
22−import Data.Functor.Identity ( Identity( Identity ) )
2324import Data.Kind ( Constraint, Type )
2425import Data.Proxy ( Proxy( Proxy ) )
2526import GHC.Generics
@@ -32,14 +33,22 @@ import Prelude hiding ( null )
3233
3334-- rel8
3435import Rel8.FCF ( Eval, Exp )
35−import Rel8.Generic.Table.Record ( GSerialize, GColumns, gfromResult, gtoResult )
36−import Rel8.Schema.HTable ( HTable )
37−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
36+import Rel8.Generic.Table.Record
37+ ( GTable, GColumns, gtable
38+ , GToExprs, gfromResult, gtoResult
39+ )
40+import Rel8.Schema.HTable ( HTable, hmap )
41+import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )
3842import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
3943import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify )
4044import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
4145import qualified Rel8.Schema.Kind as K
42−import Rel8.Schema.Result ( Result, null, nullifier, unnullifier )
46+import Rel8.Schema.Null ( Nullify )
47+import Rel8.Schema.Spec ( Spec( Spec ), SSpec )
48+import Rel8.Schema.Result
49+ ( Col( R ), Result
50+ , null, nullifier, unnullifier
51+ )
4352import Rel8.Type.Tag ( Tag( Tag ) )
4453
4554-- text
@@ -51,7 +60,7 @@ type GColumnsADT
5160 -> (Type -> Type) -> K.HTable
5261type family GColumnsADT _Columns rep where
5362 GColumnsADT _Columns (M1 D _ rep) =
54− GColumnsADT' _Columns (HLabel "tag" (HIdentity Tag)) rep
63+ GColumnsADT' _Columns (HLabel "tag" (HType Tag)) rep
5564
5665
5766type GColumnsADT'
@@ -65,118 +74,244 @@ type family GColumnsADT' _Columns htable rep where
6574 HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))
6675
6776
68−type GSerializeADT
77+type GTableADT
78+ :: (Type -> Exp Constraint)
79+ -> (Type -> Exp K.HTable)
80+ -> K.HContext -> (Type -> Type) -> Constraint
81+class GTableADT _Table _Columns context rep where
82+ gfromColumnsADT :: ()
83+ => (forall spec. context spec -> Col Result spec)
84+ -> (forall spec. Col Result spec -> context spec)
85+ -> (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)
86+ -> GColumnsADT _Columns rep context
87+ -> rep x
88+
89+ gtoColumnsADT :: ()
90+ => (forall spec. context spec -> Col Result spec)
91+ -> (forall spec. Col Result spec -> context spec)
92+ -> (forall a. Eval (_Table a) => a -> Eval (_Columns a) context)
93+ -> rep x
94+ -> GColumnsADT _Columns rep context
95+
96+ gtableADT :: ()
97+ => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)
98+ -> (forall a. ()
99+ => SSpec ('Spec a)
100+ -> context ('Spec a)
101+ -> context ('Spec (Nullify a)))
102+ -> GColumnsADT _Columns rep context
103+
104+
105+instance
106+ ( htable ~ HLabel "tag" (HType Tag)
107+ , HTable (GColumnsADT _Columns (M1 D meta rep))
108+ , Eval (_Table (htable context))
109+ , Eval (_Columns (htable context)) ~ htable
110+ , GTableADT' _Table _Columns htable context rep
111+ , GToExprsADT' (Const _Table) _Columns htable rep rep
112+ )
113+ => GTableADT _Table _Columns context (M1 D meta rep)
114+ where
115+ gfromColumnsADT fromContext toContext fromColumns =
116+ gfromResultADT @(Const _Table) @_Columns @(M1 D meta rep) @(M1 D meta rep)
117+ (const (fromColumns . hmap toContext)) .
118+ hmap fromContext
119+
120+ gtoColumnsADT fromContext toContext toColumns =
121+ hmap toContext .
122+ gtoResultADT @(Const _Table) @_Columns @(M1 D meta rep) @(M1 D meta rep)
123+ (const (hmap fromContext . toColumns))
124+
125+ gtableADT table hnullifier =
126+ gtableADT' @_Table @_Columns @htable @context @rep table hnullifier htable
127+ where
128+ htable = table (Proxy @(htable context))
129+
130+
131+type GTableADT'
132+ :: (Type -> Exp Constraint)
133+ -> (Type -> Exp K.HTable)
134+ -> K.HTable -> K.HContext -> (Type -> Type) -> Constraint
135+class GTableADT' _Table _Columns htable context rep where
136+ gtableADT' :: ()
137+ => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)
138+ -> (forall a. ()
139+ => SSpec ('Spec a)
140+ -> context ('Spec a)
141+ -> context ('Spec (Nullify a)))
142+ -> htable context
143+ -> GColumnsADT' _Columns htable rep context
144+
145+
146+instance
147+ ( htable' ~ GColumnsADT' _Columns htable a
148+ , GTableADT' _Table _Columns htable context a
149+ , GTableADT' _Table _Columns htable' context b
150+ )
151+ => GTableADT' _Table _Columns htable context (a :+: b)
152+ where
153+ gtableADT' table hnullifier =
154+ gtableADT' @_Table @_Columns @_ @_ @b table hnullifier .
155+ gtableADT' @_Table @_Columns @_ @_ @a table hnullifier
156+
157+
158+instance meta ~ 'MetaCons label _fixity _isRecord =>
159+ GTableADT' _Table _Columns htable context (M1 C meta U1)
160+ where
161+ gtableADT' _ _ = id
162+
163+
164+instance {-# OVERLAPPABLE #-}
165+ ( HTable (GColumns _Columns rep)
166+ , GTable _Table _Columns context rep
167+ , meta ~ 'MetaCons label _fixity _isRecord
168+ , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) rep) ~
169+ HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))
170+ )
171+ => GTableADT' _Table _Columns htable context (M1 C meta rep)
172+ where
173+ gtableADT' table hnullifier htable =
174+ HProduct htable $
175+ hlabel $
176+ hnullify hnullifier $
177+ gtable @_Table @_Columns @_ @rep table
178+
179+
180+type GToExprsADT
69181 :: (Type -> Type -> Exp Constraint)
70182 -> (Type -> Exp K.HTable)
71183 -> (Type -> Type) -> (Type -> Type) -> Constraint
72−class GSerializeADT _Serialize _Columns exprs rep where
184+class GToExprsADT _ToExprs _Columns exprs rep where
73185 gfromResultADT :: ()
74− => (forall expr a proxy. Eval (_Serialize expr a)
75− => proxy expr -> Eval (_Columns expr) Result -> a)
76− -> GColumnsADT _Columns exprs Result
186+ => (forall expr a proxy.
187+ ( Eval (_ToExprs expr a)
188+ , HTable (Eval (_Columns expr))
189+ )
190+ => proxy expr
191+ -> Eval (_Columns expr) (Col Result)
192+ -> a)
193+ -> GColumnsADT _Columns exprs (Col Result)
77194 -> rep x
78195
79196 gtoResultADT :: ()
80− => (forall expr a proxy. Eval (_Serialize expr a)
81− => proxy expr -> a -> Eval (_Columns expr) Result)
197+ => (forall expr a proxy.
198+ ( Eval (_ToExprs expr a)
199+ , HTable (Eval (_Columns expr))
200+ )
201+ => proxy expr
202+ -> a
203+ -> Eval (_Columns expr) (Col Result))
82204 -> rep x
83− -> GColumnsADT _Columns exprs Result
205+ -> GColumnsADT _Columns exprs (Col Result)
84206
85207
86208instance
87− ( htable ~ HLabel "tag" (HIdentity Tag)
88− , GSerializeADT' _Serialize _Columns htable exprs rep
209+ ( htable ~ HLabel "tag" (HType Tag)
210+ , GToExprsADT' _ToExprs _Columns htable exprs rep
89211 )
90− => GSerializeADT _Serialize _Columns (M1 D meta exprs) (M1 D meta rep)
212+ => GToExprsADT _ToExprs _Columns (M1 D meta exprs) (M1 D meta rep)
91213 where
92214 gfromResultADT fromResult columns =
93− case gfromResultADT' @_Serialize @_Columns @htable @exprs @rep fromResult tag columns of
215+ case gfromResultADT' @_ToExprs @_Columns @_ @exprs fromResult tag columns of
94216 Just rep -> M1 rep
95217 _ -> error "ADT.fromColumns: mismatch between tag and data"
96218 where
97− tag = (\(HIdentity (Identity a)) -> a) . hunlabel @"tag"
219+ tag = (\(HType (R a)) -> a) . hunlabel @"tag"
98220
99221 gtoResultADT toResult (M1 rep) =
100− gtoResultADT' @_Serialize @_Columns @htable @exprs @rep toResult tag (Just rep)
222+ gtoResultADT' @_ToExprs @_Columns @_ @exprs toResult tag (Just rep)
101223 where
102− tag = hlabel @"tag" . HIdentity . Identity
224+ tag = hlabel @"tag" . HType . R
103225
104226
105−type GSerializeADT'
227+type GToExprsADT'
106228 :: (Type -> Type -> Exp Constraint)
107229 -> (Type -> Exp K.HTable)
108230 -> K.HTable -> (Type -> Type) -> (Type -> Type) -> Constraint
109−class GSerializeADT' _Serialize _Columns htable exprs rep where
110− gfromResultADT' :: context ~ Result
111− => (forall expr a proxy. Eval (_Serialize expr a)
112− => proxy expr -> Eval (_Columns expr) context -> a)
113− -> (htable Result -> Tag)
114− -> GColumnsADT' _Columns htable exprs context
231+class GToExprsADT' _ToExprs _Columns htable exprs rep where
232+ gfromResultADT' :: ()
233+ => (forall expr a proxy.
234+ ( Eval (_ToExprs expr a)
235+ , HTable (Eval (_Columns expr))
236+ )
237+ => proxy expr
238+ -> Eval (_Columns expr) (Col Result)
239+ -> a)
240+ -> (htable (Col Result) -> Tag)
241+ -> GColumnsADT' _Columns htable exprs (Col Result)
115242 -> Maybe (rep x)
116243
117− gtoResultADT' :: context ~ Result
118− => (forall expr a proxy. Eval (_Serialize expr a)
119− => proxy expr -> a -> Eval (_Columns expr) context)
120− -> (Tag -> htable Result)
244+ gtoResultADT' :: ()
245+ => (forall expr a proxy.
246+ ( Eval (_ToExprs expr a)
247+ , HTable (Eval (_Columns expr))
248+ )
249+ => proxy expr
250+ -> a
251+ -> Eval (_Columns expr) (Col Result))
252+ -> (Tag -> htable (Col Result))
121253 -> Maybe (rep x)
122− -> GColumnsADT' _Columns htable exprs context
254+ -> GColumnsADT' _Columns htable exprs (Col Result)
123255
124256 extract :: GColumnsADT' _Columns htable exprs context -> htable context
125257
126258
127259instance
128− ( htable' ~ GColumnsADT' _Columns htable exprs1
129− , GSerializeADT' _Serialize _Columns htable exprs1 a
130− , GSerializeADT' _Serialize _Columns htable' exprs2 b
260+ ( htable' ~ GColumnsADT' _Columns htable a
261+ , GToExprsADT' _ToExprs _Columns htable a rep1
262+ , GToExprsADT' _ToExprs _Columns htable' b rep2
131263 )
132− => GSerializeADT' _Serialize _Columns htable (exprs1 :+: exprs2) (a :+: b)
264+ => GToExprsADT' _ToExprs _Columns htable (a :+: b) (rep1 :+: rep2)
133265 where
134266 gfromResultADT' fromResult f columns =
135267 case ma of
136268 Just a -> Just (L1 a)
137269 Nothing -> R1 <$>
138− gfromResultADT' @_Serialize @_Columns @_ @exprs2 @b
270+ gfromResultADT' @_ToExprs @_Columns @_ @b @rep2
139271 fromResult
140− (f . extract @_Serialize @_Columns @_ @exprs1 @a)
272+ (f . extract @_ToExprs @_Columns @_ @a @rep1)
141273 columns
142274 where
143275 ma =
144− gfromResultADT' @_Serialize @_Columns @_ @exprs1 @a
276+ gfromResultADT' @_ToExprs @_Columns @_ @a @rep1
145277 fromResult
146278 f
147− (extract @_Serialize @_Columns @_ @exprs2 @b columns)
279+ (extract @_ToExprs @_Columns @_ @b @rep2 columns)
148280
149281 gtoResultADT' toResult tag = \case
150282 Just (L1 a) ->
151− gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b
283+ gtoResultADT' @_ToExprs @_Columns @_ @b @rep2
152284 toResult
153− (\_ -> gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a
285+ (\_ -> gtoResultADT' @_ToExprs @_Columns @_ @a @rep1
154286 toResult
155287 tag
156288 (Just a))
157289 Nothing
158290 Just (R1 b) ->
159− gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b
291+ gtoResultADT' @_ToExprs @_Columns @_ @b @rep2
160292 toResult
161293 (\tag' ->
162− gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a
294+ gtoResultADT' @_ToExprs @_Columns @_ @a @rep1
163295 toResult
164296 (\_ -> tag tag')
165297 Nothing)
166298 (Just b)
167299 Nothing ->
168− gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b
300+ gtoResultADT' @_ToExprs @_Columns @_ @b @rep2
169301 toResult
170− (\_ -> gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a toResult tag Nothing)
302+ (\_ -> gtoResultADT' @_ToExprs @_Columns @_ @a @rep1 toResult tag Nothing)
171303 Nothing
172304
173305 extract =
174− extract @_Serialize @_Columns @_ @exprs1 @a .
175− extract @_Serialize @_Columns @_ @exprs2 @b
306+ extract @_ToExprs @_Columns @_ @a @rep1 .
307+ extract @_ToExprs @_Columns @_ @b @rep2
176308
177309
178−instance (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) =>
179− GSerializeADT' _Serialize _Columns _htable (M1 C meta U1) (M1 C meta U1)
310+instance
311+ ( meta ~ 'MetaCons label _fixity _isRecord
312+ , KnownSymbol label
313+ )
314+ => GToExprsADT' _ToExprs _Columns htable (M1 C meta U1) (M1 C meta U1)
180315 where
181316 gfromResultADT' _ tag columns
182317 | tag columns == tag' = Just (M1 U1)
@@ -193,17 +328,17 @@ instance (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) =>
193328
194329instance {-# OVERLAPPABLE #-}
195330 ( HTable (GColumns _Columns exprs)
196− , GSerialize _Serialize _Columns exprs rep
331+ , GToExprs _ToExprs _Columns exprs rep
197332 , meta ~ 'MetaCons label _fixity _isRecord
198333 , KnownSymbol label
199− , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) exprs) ~
334+ , GColumnsADT' _Columns htable (M1 C meta exprs) ~
200335 HProduct htable (HLabel label (HNullify (GColumns _Columns exprs)))
201336 )
202− => GSerializeADT' _Serialize _Columns htable (M1 C meta exprs) (M1 C meta rep)
337+ => GToExprsADT' _ToExprs _Columns htable (M1 C meta exprs) (M1 C meta rep)
203338 where
204339 gfromResultADT' fromResult tag (HProduct a b)
205340 | tag a == tag' =
206− M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult <$>
341+ M1 . gfromResult @_ToExprs @_Columns @exprs fromResult <$>
207342 hunnullify unnullifier (hunlabel b)
208343 | otherwise = Nothing
209344 where
@@ -214,8 +349,12 @@ instance {-# OVERLAPPABLE #-}
214349 Just (M1 rep) -> HProduct (tag tag') $
215350 hlabel $
216351 hnullify nullifier $
217− gtoResult @_Serialize @_Columns @exprs @rep toResult rep
352+ gtoResult @_ToExprs @_Columns @exprs toResult rep
218353 where
219354 tag' = Tag $ pack $ symbolVal (Proxy @label)
220355
221356 extract (HProduct a _) = a
357+
358+
359+data Const :: (a -> Exp Constraint) -> a -> a -> Exp Constraint
360+type instance Eval (Const f x a) = (Eval (f a), x ~ a)
src/Rel8/Generic/Table/Record.hs+93−74
@@ -14,7 +14,7 @@
1414
1515module Rel8.Generic.Table.Record
1616 ( GTable, GColumns, GContext, gfromColumns, gtoColumns, gtable
17− , GSerialize, gfromResult, gtoResult
17+ , GToExprs, gfromResult, gtoResult
1818 )
1919where
2020
@@ -30,9 +30,12 @@ import Prelude hiding ( null )
3030
3131-- rel8
3232import Rel8.FCF ( Eval, Exp )
33+import Rel8.Schema.Context ( Col )
34+import Rel8.Schema.HTable ( HTable )
3335import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
3436import Rel8.Schema.HTable.Product ( HProduct(..) )
3537import qualified Rel8.Schema.Kind as K
38+import Rel8.Schema.Result ( Result )
3639
3740
3841type GColumns :: (Type -> Exp K.HTable) -> (Type -> Type) -> K.HTable
@@ -55,8 +58,8 @@ type family GContext _Context rep where
5558type GTable
5659 :: (Type -> Exp Constraint)
5760 -> (Type -> Exp K.HTable)
58− -> (Type -> Type) -> Constraint
59−class GTable _Table _Columns rep
61+ -> K.HContext -> (Type -> Type) -> Constraint
62+class GTable _Table _Columns context rep
6063 where
6164 gfromColumns :: ()
6265 => (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)
@@ -73,109 +76,125 @@ class GTable _Table _Columns rep
7376 -> GColumns _Columns rep context
7477
7578
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
79+instance GTable _Table _Columns context rep =>
80+ GTable _Table _Columns context (M1 D c rep)
8181 where
82− gfromResult :: ()
83− => (forall expr a proxy. Eval (_Serialize expr a)
84− => proxy expr -> Eval (_Columns expr) context -> a)
85− -> GColumns _Columns exprs context
86− -> rep x
87−
88− gtoResult :: ()
89− => (forall expr a proxy. Eval (_Serialize expr a)
90− => proxy expr -> a -> Eval (_Columns expr) context)
91− -> rep x
92− -> GColumns _Columns exprs context
82+ gfromColumns fromColumns =
83+ M1 . gfromColumns @_Table @_Columns @context @rep fromColumns
84+ gtoColumns toColumns (M1 a) =
85+ gtoColumns @_Table @_Columns @context @rep toColumns a
86+ gtable = gtable @_Table @_Columns @context @rep
9387
9488
95−instance GTable _Table _Columns rep => GTable _Table _Columns (M1 D c rep)
89+instance GTable _Table _Columns context rep =>
90+ GTable _Table _Columns context (M1 C c rep)
9691 where
9792 gfromColumns fromColumns =
98− M1 . gfromColumns @_Table @_Columns @rep fromColumns
93+ M1 . gfromColumns @_Table @_Columns @context @rep fromColumns
9994 gtoColumns toColumns (M1 a) =
100− gtoColumns @_Table @_Columns @rep toColumns a
101− gtable = gtable @_Table @_Columns @rep
95+ gtoColumns @_Table @_Columns @context @rep toColumns a
96+ gtable = gtable @_Table @_Columns @context @rep
10297
10398
104−instance GSerialize _Serialize _Columns exprs rep =>
105− GSerialize _Serialize _Columns (M1 D c exprs) (M1 D c rep)
99+instance
100+ ( GTable _Table _Columns context rep1
101+ , GTable _Table _Columns context rep2
102+ )
103+ => GTable _Table _Columns context (rep1 :*: rep2)
106104 where
107− gfromResult fromResult =
108− M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult
109− gtoResult toResult (M1 a) =
110− gtoResult @_Serialize @_Columns @exprs @rep toResult a
105+ gfromColumns fromColumns (HProduct a b) =
106+ gfromColumns @_Table @_Columns @context @rep1 fromColumns a :*:
107+ gfromColumns @_Table @_Columns @context @rep2 fromColumns b
108+ gtoColumns toColumns (a :*: b) = HProduct
109+ (gtoColumns @_Table @_Columns @context @rep1 toColumns a)
110+ (gtoColumns @_Table @_Columns @context @rep2 toColumns b)
111+ gtable table = HProduct
112+ (gtable @_Table @_Columns @context @rep1 table)
113+ (gtable @_Table @_Columns @context @rep2 table)
111114
112115
113−instance GTable _Table _Columns rep => GTable _Table _Columns (M1 C c rep)
116+instance
117+ ( Eval (_Table a)
118+ , meta ~ 'MetaSel ('Just label) _su _ss _ds
119+ , k1 ~ K1 i a
120+ )
121+ => GTable _Table _Columns context (M1 S meta k1)
114122 where
115− gfromColumns fromColumns =
116− M1 . gfromColumns @_Table @_Columns @rep fromColumns
117− gtoColumns toColumns (M1 a) =
118− gtoColumns @_Table @_Columns @rep toColumns a
119− gtable = gtable @_Table @_Columns @rep
123+ gfromColumns fromColumns = M1 . K1 . fromColumns . hunlabel
124+ gtoColumns toColumns (M1 (K1 a)) = hlabel (toColumns a)
125+ gtable table = hlabel (table (Proxy @a))
120126
121127
122−instance GSerialize _Serialize _Columns exprs rep =>
123− GSerialize _Serialize _Columns (M1 C c exprs) (M1 C c rep)
128+type GToExprs
129+ :: (Type -> Type -> Exp Constraint)
130+ -> (Type -> Exp K.HTable)
131+ -> (Type -> Type) -> (Type -> Type) -> Constraint
132+class GToExprs _ToExprs _Columns exprs rep where
133+ gfromResult :: ()
134+ => (forall expr a proxy.
135+ ( Eval (_ToExprs expr a)
136+ , HTable (Eval (_Columns expr))
137+ )
138+ => proxy expr
139+ -> Eval (_Columns expr) (Col Result)
140+ -> a)
141+ -> GColumns _Columns exprs (Col Result)
142+ -> rep x
143+ gtoResult :: ()
144+ => (forall expr a proxy.
145+ ( Eval (_ToExprs expr a)
146+ , HTable (Eval (_Columns expr))
147+ )
148+ => proxy expr
149+ -> a
150+ -> Eval (_Columns expr) (Col Result))
151+ -> rep x
152+ -> GColumns _Columns exprs (Col Result)
153+
154+
155+instance GToExprs _ToExprs _Columns exprs rep =>
156+ GToExprs _ToExprs _Columns (M1 D c exprs) (M1 D c rep)
124157 where
125158 gfromResult fromResult =
126− M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult
159+ M1 . gfromResult @_ToExprs @_Columns @exprs fromResult
127160 gtoResult toResult (M1 a) =
128− gtoResult @_Serialize @_Columns @exprs @rep toResult a
161+ gtoResult @_ToExprs @_Columns @exprs toResult a
129162
130163
131−instance (GTable _Table _Columns rep1, GTable _Table _Columns rep2) =>
132− GTable _Table _Columns (rep1 :*: rep2)
164+instance GToExprs _ToExprs _Columns exprs rep =>
165+ GToExprs _ToExprs _Columns (M1 C c exprs) (M1 C c rep)
133166 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)
167+ gfromResult fromResult =
168+ M1 . gfromResult @_ToExprs @_Columns @exprs fromResult
169+ gtoResult toResult (M1 a) =
170+ gtoResult @_ToExprs @_Columns @exprs toResult a
143171
144172
145173instance
146− ( GSerialize _Serialize _Columns expr1 rep1
147− , GSerialize _Serialize _Columns expr2 rep2
174+ ( GToExprs _ToExprs _Columns exprs1 rep1
175+ , GToExprs _ToExprs _Columns exprs2 rep2
148176 )
149− => GSerialize _Serialize _Columns (expr1 :*: expr2) (rep1 :*: rep2)
177+ => GToExprs _ToExprs _Columns (exprs1 :*: exprs2) (rep1 :*: rep2)
150178 where
151179 gfromResult fromResult (HProduct a b) =
152− gfromResult @_Serialize @_Columns @expr1 @rep1 fromResult a :*:
153− gfromResult @_Serialize @_Columns @expr2 @rep2 fromResult b
180+ gfromResult @_ToExprs @_Columns @exprs1 fromResult a :*:
181+ gfromResult @_ToExprs @_Columns @exprs2 fromResult b
154182 gtoResult toResult (a :*: b) =
155183 HProduct
156− (gtoResult @_Serialize @_Columns @expr1 @rep1 toResult a)
157− (gtoResult @_Serialize @_Columns @expr2 @rep2 toResult b)
184+ (gtoResult @_ToExprs @_Columns @exprs1 toResult a)
185+ (gtoResult @_ToExprs @_Columns @exprs2 toResult b)
158186
159187
160188instance
161− ( Eval (_Table a)
189+ ( Eval (_ToExprs exprs a)
190+ , HTable (Eval (_Columns exprs))
162191 , meta ~ 'MetaSel ('Just label) _su _ss _ds
163− , k1 ~ K1 i a
164− )
165− => GTable _Table _Columns (M1 S meta k1)
166− where
167− gfromColumns fromColumns = M1 . K1 . fromColumns . hunlabel
168− gtoColumns toColumns (M1 (K1 a)) = hlabel (toColumns a)
169− 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
192+ , k1 ~ K1 i exprs
176193 , k1' ~ K1 i a
177194 )
178− => GSerialize _Serialize _Columns (M1 S meta k1) (M1 S meta k1')
195+ => GToExprs _ToExprs _Columns (M1 S meta k1) (M1 S meta k1')
179196 where
180− gfromResult fromResult = M1 . K1 . fromResult (Proxy @expr) . hunlabel
181− gtoResult toResult (M1 (K1 a)) = hlabel (toResult (Proxy @expr) a)
197+ gfromResult fromResult =
198+ M1 . K1 . fromResult (Proxy @exprs) . hunlabel
199+ gtoResult toResult (M1 (K1 a)) =
200+ hlabel (toResult (Proxy @exprs) a)
src/Rel8/Kind/Context.hs+21−8
@@ -1,11 +1,12 @@
11{-# language DataKinds #-}
22{-# language GADTs #-}
3+{-# language LambdaCase #-}
34{-# language StandaloneKindSignatures #-}
4−{-# language TypeSynonymInstances #-}
55
66module Rel8.Kind.Context
77 ( Reifiable( contextSing )
88 , SContext(..)
9+ , sReifiable
910 )
1011where
1112
@@ -16,9 +17,11 @@ import Prelude ()
1617-- rel8
1718import Rel8.Aggregate ( Aggregate )
1819import Rel8.Expr ( Expr )
19−import Rel8.Schema.Field ( Field )
20+import Rel8.Schema.Dict ( Dict( Dict ) )
21+import Rel8.Schema.Context ( Interpretation )
2022import Rel8.Schema.Kind ( Context )
2123import Rel8.Schema.Name ( Name )
24+import Rel8.Schema.Reify ( Reify )
2225import Rel8.Schema.Result ( Result )
2326
2427
@@ -26,13 +29,13 @@ type SContext :: Context -> Type
2629data SContext context where
2730 SAggregate :: SContext Aggregate
2831 SExpr :: SContext Expr
29− SField :: SContext (Field table)
3032 SName :: SContext Name
3133 SResult :: SContext Result
34+ SReify :: SContext context -> SContext (Reify context)
3235
3336
3437type Reifiable :: Context -> Constraint
35−class Reifiable context where
38+class Interpretation context => Reifiable context where
3639 contextSing :: SContext context
3740
3841
@@ -44,13 +47,23 @@ instance Reifiable Expr where
4447 contextSing = SExpr
4548
4649
47−instance Reifiable (Field table) where
48− contextSing = SField
49−
50−
5150instance Reifiable Result where
5251 contextSing = SResult
5352
5453
5554instance Reifiable Name where
5655 contextSing = SName
56+
57+
58+instance Reifiable context => Reifiable (Reify context) where
59+ contextSing = SReify contextSing
60+
61+
62+sReifiable :: SContext context -> Dict Reifiable context
63+sReifiable = \case
64+ SAggregate -> Dict
65+ SExpr -> Dict
66+ SName -> Dict
67+ SResult -> Dict
68+ SReify context -> case sReifiable context of
69+ Dict -> Dict
src/Rel8/Order.hs+8−1
@@ -4,6 +4,7 @@
44
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 #-}
42
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 #-}
53
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 #-}
2+
13module Rel8.Query.Distinct
24 ( distinct
35 , distinctOn
@@ -6,11 +8,12 @@ module Rel8.Query.Distinct
68where
79
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/Each.hs+3−3
@@ -17,7 +17,7 @@ import Rel8.Query ( Query )
1717import Rel8.Query.Opaleye ( fromOpaleye )
1818import Rel8.Schema.Name ( Selects )
1919import Rel8.Schema.Table ( TableSchema )
20−import Rel8.Table.Cols ( fromCols, toCols )
20+import Rel8.Table ( fromColumns, toColumns )
2121import Rel8.Table.Opaleye ( table, unpackspec )
2222
2323
@@ -25,8 +25,8 @@ import Rel8.Table.Opaleye ( table, unpackspec )
2525-- table@.
2626each :: Selects names exprs => TableSchema names -> Query exprs
2727each =
28− fmap fromCols .
28+ fmap fromColumns .
2929 fromOpaleye .
3030 Opaleye.selectTableExplicit unpackspec .
3131 table .
32− fmap toCols
32+ fmap toColumns
src/Rel8/Query/Either.hs+6−10
@@ -10,11 +10,7 @@ where
1010-- base
1111import Prelude
1212
13−-- comonad
14−import Control.Comonad ( extract )
15−
1613-- rel8
17−import Rel8.Expr ( Expr )
1814import Rel8.Expr.Eq ( (==.) )
1915import Rel8.Query ( Query )
2016import Rel8.Query.Filter ( where_ )
@@ -27,17 +23,17 @@ import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
2723
2824
2925-- | Filter 'EitherTable's, keeping only 'leftTable's.
30−keepLeftTable :: EitherTable Expr a b -> Query a
26+keepLeftTable :: EitherTable a b -> Query a
3127keepLeftTable e@(EitherTable _ a _) = do
3228 where_ $ isLeftTable e
33− pure (extract a)
29+ pure a
3430
3531
3632-- | Filter 'EitherTable's, keeping only 'rightTable's.
37−keepRightTable :: EitherTable Expr a b -> Query b
33+keepRightTable :: EitherTable a b -> Query b
3834keepRightTable e@(EitherTable _ _ b) = do
3935 where_ $ isRightTable e
40− pure (extract b)
36+ pure b
4137
4238
4339-- | @bitraverseEitherTable f g x@ will pass all @leftTable@s through @f@ and
@@ -59,8 +55,8 @@ keepRightTable e@(EitherTable _ _ b) = do
5955bitraverseEitherTable :: ()
6056 => (a -> Query c)
6157 -> (b -> Query d)
62− -> EitherTable Expr a b
63− -> Query (EitherTable Expr c d)
58+ -> EitherTable a b
59+ -> Query (EitherTable c d)
6460bitraverseEitherTable f g e@(EitherTable tag _ _) = do
6561 mc@(MaybeTable _ c) <- optional (f =<< keepLeftTable e)
6662 md@(MaybeTable _ d) <- optional (g =<< keepRightTable e)
src/Rel8/Query/Evaluate.hs+22−3
@@ -3,6 +3,7 @@
33
44module Rel8.Query.Evaluate
55 ( evaluate
6+ , rebind
67 )
78where
89
@@ -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+16−19
@@ -19,18 +19,17 @@ import Prelude
1919import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
2020
2121-- rel8
22−import Rel8.Expr ( Expr )
22+import Rel8.Expr ( Col( E, unE ), Expr )
2323import Rel8.Expr.Aggregate ( listAggExpr, nonEmptyAggExpr )
2424import Rel8.Expr.Opaleye ( mapPrimExpr )
2525import Rel8.Query ( Query )
2626import Rel8.Query.Aggregate ( aggregate )
27+import Rel8.Query.Evaluate ( rebind )
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 ) )
32−import Rel8.Table ( Table, fromColumns )
33−import Rel8.Table.Cols ( toCols )
31+import Rel8.Schema.Spec ( SSpec( SSpec, info ) )
32+import Rel8.Table ( Table, fromColumns, toColumns )
3433import Rel8.Table.Aggregate ( listAgg, nonEmptyAgg )
3534import Rel8.Table.List ( ListTable( ListTable ) )
3635import Rel8.Table.Maybe ( maybeTable )
@@ -47,12 +46,12 @@ import Rel8.Type.Information ( TypeInformation )
4746--
4847-- @many@ is analogous to 'Control.Applicative.many' from
4948-- @Control.Applicative@.
50−many :: Table Expr a => Query a -> Query (ListTable Expr a)
49+many :: Table Expr a => Query a -> Query (ListTable a)
5150many =
5251 fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .
5352 optional .
5453 aggregate .
55− fmap (listAgg . toCols)
54+ fmap (listAgg . toColumns)
5655
5756
5857-- | Aggregate a 'Query' into a 'NonEmptyTable'. If the supplied query returns
@@ -63,11 +62,11 @@ many =
6362--
6463-- @some@ is analogous to 'Control.Applicative.some' from
6564-- @Control.Applicative@.
66−some :: Table Expr a => Query a -> Query (NonEmptyTable Expr a)
65+some :: Table Expr a => Query a -> Query (NonEmptyTable a)
6766some =
6867 fmap (\(NonEmptyTable a) -> NonEmptyTable a) .
6968 aggregate .
70− fmap (nonEmptyAgg . toCols)
69+ fmap (nonEmptyAgg . toColumns)
7170
7271
7372-- | A version of 'many' specialised to single expressions.
@@ -84,20 +83,18 @@ someExpr = aggregate . fmap nonEmptyAggExpr
8483-- element of the given @ListTable@.
8584--
8685-- @catListTable@ is an inverse to 'many'.
87−catListTable :: 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
86+catListTable :: Table Expr a => ListTable a -> Query a
87+catListTable (ListTable as) = rebind $ fromColumns $ runIdentity $
88+ hunvectorize (\SSpec {info} -> pure . E . sunnest info . unE) as
9189
9290
9391-- | Expand a 'NonEmptyTable' into a 'Query', where each row in the query is an
9492-- element of the given @NonEmptyTable@.
9593--
9694-- @catNonEmptyTable@ is an inverse to 'some'.
97−catNonEmptyTable :: 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
95+catNonEmptyTable :: Table Expr a => NonEmptyTable a -> Query a
96+catNonEmptyTable (NonEmptyTable as) = rebind $ fromColumns $ runIdentity $
97+ hunvectorize (\SSpec {info} -> pure . E . sunnest info . unE) as
10198
10299
103100-- | Expand an expression that contains a list into a 'Query', where each row
@@ -105,7 +102,7 @@ catNonEmptyTable (NonEmptyTable as) =
105102--
106103-- @catList@ is an inverse to 'manyExpr'.
107104catList :: Sql DBType a => Expr [a] -> Query (Expr a)
108−catList = rebind "unnest" . sunnest typeInformation
105+catList = rebind . sunnest typeInformation
109106
110107
111108-- | Expand an expression that contains a non-empty list into a 'Query', where
@@ -113,7 +110,7 @@ catList = rebind "unnest" . sunnest typeInformation
113110--
114111-- @catNonEmpty@ is an inverse to 'someExpr'.
115112catNonEmpty :: Sql DBType a => Expr (NonEmpty a) -> Query (Expr a)
116−catNonEmpty = rebind "unnest" . sunnest typeInformation
113+catNonEmpty = rebind . sunnest typeInformation
117114
118115
119116sunnest :: TypeInformation (Unnullify a) -> Expr (list a) -> Expr a
src/Rel8/Query/Maybe.hs+14−22
@@ -1,7 +1,3 @@
1−{-# language GADTs #-}
2−{-# language LambdaCase #-}
3−{-# language NamedFieldPuns #-}
4−
51module Rel8.Query.Maybe
62 ( optional
73 , catMaybeTable
@@ -12,20 +8,17 @@ where
128-- base
139import Prelude
1410
15−-- comonad
16−import Control.Comonad ( extract )
17−
1811-- opaleye
1912import qualified Opaleye.Internal.MaybeFields as Opaleye
2013
2114-- rel8
22−import Rel8.Expr ( Expr )
2315import Rel8.Expr.Eq ( (==.) )
2416import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )
2517import Rel8.Query ( Query )
2618import Rel8.Query.Filter ( where_ )
2719import Rel8.Query.Opaleye ( mapOpaleye )
28−import Rel8.Table.Maybe ( MaybeTable(..), isJustTable )
20+import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
21+import Rel8.Table.Tag ( Tag(..), fromExpr )
2922
3023
3124-- | Convert a query that might return zero rows to a query that always returns
@@ -33,11 +26,11 @@ import Rel8.Table.Maybe ( MaybeTable(..), isJustTable )
3326--
3427-- To speak in more concrete terms, 'optional' is most useful to write @LEFT
3528-- JOIN@s.
36−optional :: Query a -> Query (MaybeTable Expr a)
37−optional = mapOpaleye $ Opaleye.optionalInternal $ \tag a -> MaybeTable
38− { tag = fromPrimExpr $ fromColumn tag
39− , just = pure a
40− }
29+optional :: Query a -> Query (MaybeTable a)
30+optional =
31+ mapOpaleye $
32+ Opaleye.optionalInternal $
33+ MaybeTable . fromExpr . fromPrimExpr . fromColumn
4134
4235
4336-- | Filter out 'MaybeTable's, returning only the tables that are not-null.
@@ -45,24 +38,23 @@ optional = mapOpaleye $ Opaleye.optionalInternal $ \tag a -> MaybeTable
4538-- This operation can be used to "undo" the effect of 'optional', which
4639-- operationally is like turning a @LEFT JOIN@ back into a full @JOIN@. You
4740-- can think of this as analogous to 'Data.Maybe.catMaybes'.
48−catMaybeTable :: MaybeTable Expr a -> Query a
41+catMaybeTable :: MaybeTable a -> Query a
4942catMaybeTable ma@(MaybeTable _ a) = do
5043 where_ $ isJustTable ma
51− pure (extract a)
44+ pure a
5245
5346
5447-- | Extend an optional query with another query. This is useful if you want
5548-- to step through multiple @LEFT JOINs@.
5649--
5750-- Note that @traverseMaybeTable@ takes a @a -> Query b@ function, which means
58−-- you also have the ability to "expand" one row into multiple rows. If the
51+-- you also have the ability to "expand" one row into multiple rows. If the
5952-- @a -> Query b@ function returns no rows, then the resulting query will also
6053-- have no rows. However, regardless of the given @a -> Query b@ function, if
6154-- the input is @nothingTable@, you will always get exactly one @nothingTable@
6255-- back.
63−traverseMaybeTable :: (a -> Query b) -> MaybeTable Expr a -> Query (MaybeTable Expr b)
56+traverseMaybeTable :: (a -> Query b) -> MaybeTable a -> Query (MaybeTable b)
6457traverseMaybeTable query ma@(MaybeTable input _) = do
65− optional (query =<< catMaybeTable ma) >>= \case
66− MaybeTable output b -> do
67− where_ $ output ==. input
68− pure $ MaybeTable input b
58+ MaybeTable output b <- optional (query =<< catMaybeTable ma)
59+ where_ $ expr output ==. expr input
60+ pure $ MaybeTable 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
85
@@ -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+59−6
@@ -1,21 +1,74 @@
11{-# language FlexibleContexts #-}
2−{-# language MonoLocalBinds #-}
2+{-# language TypeFamilies #-}
3+{-# language ViewPatterns #-}
34
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, Col( 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( Name ), Selects, Col( N ) )
31+import Rel8.Schema.HTable ( htabulateA, hfield )
32+import Rel8.Table ( Table, toColumns )
33+import Rel8.Table.Name ( namesFromLabels )
34+import Rel8.Table.Opaleye ( castTable )
1735
1836
19−-- | Convert a 'Query' to a 'String' containing a @SELECT@ statement.
37+-- | Convert a query to a 'String' containing the query as a @SELECT@
38+-- statement.
2039showQuery :: Table Expr a => Query a -> String
21−showQuery = show . ppSelect
40+showQuery = fold . sqlForQuery
41+
42+
43+sqlForQuery :: Table Expr a
44+ => Query a -> Maybe String
45+sqlForQuery = sqlForQueryWithNames namesFromLabels . fmap toColumns
46+
47+
48+sqlForQueryWithNames :: Selects names exprs
49+ => names -> Query exprs -> Maybe String
50+sqlForQueryWithNames names query =
51+ show . Opaleye.ppSql . selectFrom names exprs <$> optimize primQuery
52+ where
53+ (exprs, primQuery, _) =
54+ Opaleye.runSimpleQueryArrStart (toOpaleye query) ()
55+
56+
57+optimize :: Opaleye.PrimQuery' a -> Maybe (Opaleye.PrimQuery' Void)
58+optimize = Opaleye.removeEmpty . Opaleye.optimize
59+
60+
61+selectFrom :: Selects names exprs
62+ => names -> exprs -> Opaleye.PrimQuery' Void -> Opaleye.Select
63+selectFrom (toColumns -> names) (toColumns . castTable -> exprs) query =
64+ Opaleye.SelectFrom $ Opaleye.newSelect
65+ { Opaleye.attrs = Opaleye.SelectAttrs attributes
66+ , Opaleye.tables = Opaleye.oneTable select
67+ }
68+ where
69+ select = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator query
70+ attributes = getConst $ htabulateA $ \field -> case hfield names field of
71+ N (Name name) -> case hfield exprs field of
72+ E (toPrimExpr -> expr) -> Const (pure (makeAttr name expr))
73+ makeAttr label expr =
74+ (Opaleye.sqlExpr expr, Just (Opaleye.SqlColumn label))
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+36−36
@@ -1,5 +1,4 @@
11{-# language FlexibleContexts #-}
2−{-# language GADTs #-}
32
43module Rel8.Query.These
54 ( alignBy
@@ -15,9 +14,6 @@ where
1514-- base
1615import Prelude
1716
18−-- comonad
19−import Control.Comonad ( extract )
20−
2117-- opaleye
2218import qualified Opaleye.Internal.PackMap as Opaleye
2319import qualified Opaleye.Internal.PrimQuery as Opaleye
@@ -36,6 +32,7 @@ import Rel8.Query.Maybe ( optional )
3632import Rel8.Query.Opaleye ( zipOpaleyeWith )
3733import Rel8.Table.Either ( EitherTable( EitherTable ) )
3834import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
35+import Rel8.Table.Tag ( Tag(..), fromExpr )
3936import Rel8.Table.These
4037 ( TheseTable( TheseTable, here, there )
4138 , hasHereTable, hasThereTable
@@ -47,89 +44,92 @@ import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) )
4744-- | Corresponds to a @FULL OUTER JOIN@ between two queries.
4845alignBy :: ()
4946 => (a -> b -> Expr Bool)
50− -> Query a -> Query b -> Query (TheseTable Expr a b)
51−alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.stateQueryArr $ \_ t -> case t of
52− tag -> (tab, join', tag''')
47+ -> Query a -> Query b -> Query (TheseTable a b)
48+alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.QueryArr $ \i -> case i of
49+ (_, tag) -> (tab, join', tag''')
5350 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
51+ (ma, left', tag') = Opaleye.runSimpleQueryArr (pure <$> left) ((), tag)
52+ (mb, right', tag'') = Opaleye.runSimpleQueryArr (pure <$> right) ((), tag')
53+ MaybeTable Tag {expr = hasHere} a = ma
54+ MaybeTable Tag {expr = hasThere} b = mb
5855 (hasHere', lbindings) = Opaleye.run $ do
5956 traversePrimExpr (Opaleye.extractAttr "hasHere" tag'') hasHere
6057 (hasThere', rbindings) = Opaleye.run $ do
6158 traversePrimExpr (Opaleye.extractAttr "hasThere" tag'') hasThere
6259 tag''' = Opaleye.next tag''
63− join = Opaleye.Join Opaleye.FullJoin on left'' right''
60+ join lateral = Opaleye.Join Opaleye.FullJoin on left'' right''
6461 where
65− 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
62+ on = toPrimExpr $ condition a b
63+ left'' = (lateral, Opaleye.Rebind True lbindings left')
64+ right'' = (lateral, Opaleye.Rebind True rbindings right')
65+ ma' = MaybeTable (fromExpr hasHere') a
66+ mb' = MaybeTable (fromExpr hasThere') b
7067 tab = TheseTable {here = ma', there = mb'}
71− join' = Opaleye.aProduct join
68+ join' lateral input = Opaleye.times lateral input (join lateral)
7269
7370
74−keepHereTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)
71+-- | Filter 'TheseTable's, keeping only 'thisTable's and 'thoseTable's.
72+keepHereTable :: TheseTable a b -> Query (a, MaybeTable b)
7573keepHereTable = loseThatTable
7674
7775
78−loseHereTable :: TheseTable Expr a b -> Query b
76+-- | Filter 'TheseTable's, keeping on
77+loseHereTable :: TheseTable a b -> Query b
7978loseHereTable = keepThatTable
8079
8180
82−keepThereTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)
81+keepThereTable :: TheseTable a b -> Query (MaybeTable a, b)
8382keepThereTable = loseThisTable
8483
8584
86−loseThereTable :: TheseTable Expr a b -> Query a
85+loseThereTable :: TheseTable a b -> Query a
8786loseThereTable = keepThisTable
8887
8988
90−keepThisTable :: TheseTable Expr a b -> Query a
89+keepThisTable :: TheseTable a b -> Query a
9190keepThisTable t@(TheseTable (MaybeTable _ a) _) = do
9291 where_ $ isThisTable t
93− pure (extract a)
92+ pure a
9493
9594
96−loseThisTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)
95+loseThisTable :: TheseTable a b -> Query (MaybeTable a, b)
9796loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do
9897 where_ $ not_ $ isThisTable t
99− pure (ma, extract b)
98+ pure (ma, b)
10099
101100
102−keepThatTable :: TheseTable Expr a b -> Query b
101+keepThatTable :: TheseTable a b -> Query b
103102keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do
104103 where_ $ isThatTable t
105− pure (extract b)
104+ pure b
106105
107106
108−loseThatTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)
107+loseThatTable :: TheseTable a b -> Query (a, MaybeTable b)
109108loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do
110109 where_ $ not_ $ isThatTable t
111− pure (extract a, mb)
110+ pure (a, mb)
112111
113112
114−keepThoseTable :: TheseTable Expr a b -> Query (a, b)
113+keepThoseTable :: TheseTable a b -> Query (a, b)
115114keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
116115 where_ $ isThoseTable t
117− pure (extract a, extract b)
116+ pure (a, b)
118117
119118
120−loseThoseTable :: TheseTable Expr a b -> Query (EitherTable Expr a b)
119+loseThoseTable :: TheseTable a b -> Query (EitherTable a b)
121120loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
122121 where_ $ not_ $ isThoseTable t
123− pure $ EitherTable tag a b
122+ pure $ EitherTable result a b
124123 where
125124 tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)
125+ result = (mempty `asTypeOf` result) {expr = tag}
126126
127127
128128bitraverseTheseTable :: ()
129129 => (a -> Query c)
130130 -> (b -> Query d)
131− -> TheseTable Expr a b
132− -> Query (TheseTable Expr c d)
131+ -> TheseTable a b
132+ -> Query (TheseTable c d)
133133bitraverseTheseTable f g t = do
134134 mc <- optional (f . fst =<< keepHereTable t)
135135 md <- optional (g . snd =<< keepThereTable t)
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.hsnew file+20
@@ -0,0 +1,20 @@
1+{-# language DataKinds #-}
2+{-# language StandaloneKindSignatures #-}
3+{-# language TypeFamilies #-}
4+
5+module Rel8.Schema.Context
6+ ( Interpretation( Col )
7+ )
8+where
9+
10+-- base
11+import Data.Kind ( Constraint )
12+import Prelude ()
13+
14+-- rel8
15+import Rel8.Schema.Kind ( Context, HContext )
16+
17+
18+type Interpretation :: Context -> Constraint
19+class Interpretation context where
20+ data Col context :: HContext
src/Rel8/Schema/Context/Nullify.hs+148−105
@@ -1,144 +1,187 @@
11{-# language DataKinds #-}
2−{-# language EmptyCase #-}
32{-# language FlexibleContexts #-}
4−{-# language GADTs #-}
5−{-# language LambdaCase #-}
3+{-# language FlexibleInstances #-}
4+{-# language InstanceSigs #-}
5+{-# language MultiParamTypeClasses #-}
66{-# language NamedFieldPuns #-}
7+{-# language ScopedTypeVariables #-}
78{-# language StandaloneKindSignatures #-}
9+{-# language TypeFamilies #-}
810
911module Rel8.Schema.Context.Nullify
10− ( Nullifiability(..), NonNullifiability(..), nullifiableOrNot, absurd
11− , Nullifiable, nullifiability
12− , guarder, nullifier, unnullifier
13− , sguard, snullify
12+ ( Nullifiable( ConstrainTag, encodeTag, decodeTag, nullifier, unnullifier )
13+ , HNullifiable( HConstrainTag, hencodeTag, hdecodeTag, hnullifier, hunnullifier )
14+ , runTag, unnull
1415 )
1516where
1617
1718-- base
18−import Data.Bool ( bool )
19−import Data.Functor.Identity ( Identity( Identity ) )
2019import Data.Kind ( Constraint, Type )
20+import GHC.TypeLits ( KnownSymbol )
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( Aggregate ), Col( A )
29+ , mapInputs
30+ , unsafeMakeAggregate
31+ )
32+import Rel8.Expr ( Expr, Col( E ) )
2933import Rel8.Expr.Bool ( boolExpr )
3034import Rel8.Expr.Null ( nullify, unsafeUnnullify )
31−import Rel8.Expr.Opaleye ( fromPrimExpr )
32−import Rel8.Kind.Context ( SContext(..) )
33−import Rel8.Schema.Field ( Field )
35+import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
36+import Rel8.Schema.Context ( Interpretation )
3437import qualified Rel8.Schema.Kind as K
35−import Rel8.Schema.Name ( Name( Name ) )
36−import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )
37−import Rel8.Schema.Result ( Result )
38−import Rel8.Schema.Spec ( Spec(..) )
39−
40−
41−type Nullifiability :: K.Context -> Type
42−data Nullifiability context where
43− NAggregate :: Nullifiability Aggregate
44− NExpr :: Nullifiability Expr
45− NName :: Nullifiability Name
38+import Rel8.Schema.Name ( Name( Name ), Col( N ) )
39+import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql )
40+import Rel8.Schema.Dict ( Dict( Dict ) )
41+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
42+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
43+import qualified Rel8.Schema.Spec.ConstrainDBType as ConstrainDBType
44+import Rel8.Table.Tag ( Tag(..), Taggable, fromAggregate, fromExpr, fromName )
4645
4746
4847type Nullifiable :: K.Context -> Constraint
49−class Nullifiable context where
50− nullifiability :: Nullifiability context
48+class Interpretation context => Nullifiable context where
49+ type ConstrainTag context :: Type -> Constraint
50+ type ConstrainTag _context = DefaultConstrainTag
51+
52+ encodeTag ::
53+ ( Sql (ConstrainTag context) a
54+ , Taggable a
55+ )
56+ => Tag label a
57+ -> Col context ('Spec a)
58+
59+ decodeTag ::
60+ ( Sql (ConstrainTag context) a
61+ , KnownSymbol label
62+ , Taggable a
63+ )
64+ => Col context ('Spec a)
65+ -> Tag label a
66+
67+ nullifier :: ()
68+ => Tag label a
69+ -> (Expr a -> Expr Bool)
70+ -> SSpec ('Spec x)
71+ -> Col context ('Spec x)
72+ -> Col context ('Spec (Nullify x))
73+
74+ unnullifier :: ()
75+ => SSpec ('Spec x)
76+ -> Col context ('Spec (Nullify x))
77+ -> Col context ('Spec x)
5178
5279
5380instance Nullifiable Aggregate where
54− nullifiability = NAggregate
81+ encodeTag Tag {aggregator, expr} =
82+ A $ unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr
83+
84+ decodeTag (A aggregate) = fromAggregate aggregate
85+
86+ nullifier Tag {expr} test SSpec {nullity} (A (Aggregate a)) =
87+ A $
88+ mapInputs (toPrimExpr . runTag nullity condition . fromPrimExpr) $
89+ Aggregate $
90+ runTag nullity condition <$> a
91+ where
92+ condition = test expr
93+
94+ unnullifier SSpec {nullity} (A (Aggregate a)) =
95+ A (Aggregate (unnull nullity <$> a))
96+
97+ {-# INLINABLE encodeTag #-}
98+ {-# INLINABLE decodeTag #-}
99+ {-# INLINABLE nullifier #-}
100+ {-# INLINABLE unnullifier #-}
55101
56102
57103instance Nullifiable Expr where
58− nullifiability = NExpr
104+ encodeTag Tag {expr} = E expr
105+ decodeTag (E a) = fromExpr a
106+ nullifier Tag {expr} test SSpec {nullity} (E a) =
107+ E $ runTag nullity (test expr) a
108+ unnullifier SSpec {nullity} (E a) = E $ unnull nullity a
109+
110+ {-# INLINABLE encodeTag #-}
111+ {-# INLINABLE decodeTag #-}
112+ {-# INLINABLE nullifier #-}
113+ {-# INLINABLE unnullifier #-}
59114
60115
61116instance Nullifiable Name where
62− nullifiability = NName
63−
64−
65−type NonNullifiability :: K.Context -> Type
66−data NonNullifiability context where
67− NField :: NonNullifiability (Field table)
68− NResult :: NonNullifiability Result
69−
70−
71−nullifiableOrNot :: ()
72− => SContext context
73− -> Either (NonNullifiability context) (Nullifiability context)
74−nullifiableOrNot = \case
75− SAggregate -> Right NAggregate
76− SExpr -> Right NExpr
77− SField -> Left NField
78− SName -> Right NName
79− SResult -> Left NResult
80−
81−
82−absurd :: Nullifiability context -> NonNullifiability context -> a
83−absurd = \case
84− NAggregate -> \case
85− NExpr -> \case
86− NName -> \case
87−
88−
89−guarder :: ()
90− => SContext context
91− -> context tag
92− -> (tag -> Bool)
93− -> (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))
103−
104−
105−nullifier :: ()
106− => 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−
116−
117−unnullifier :: ()
118− => 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
127−
128−
129−sguard :: Expr Bool -> Expr (Maybe a) -> Expr (Maybe a)
130−sguard condition a = boolExpr null a condition
117+ encodeTag Tag {name} = N name
118+ decodeTag (N name) = fromName name
119+ nullifier _ _ _ (N (Name name)) = N (Name name)
120+ unnullifier _ (N (Name name)) = N (Name name)
121+
122+ {-# INLINABLE encodeTag #-}
123+ {-# INLINABLE decodeTag #-}
124+ {-# INLINABLE nullifier #-}
125+ {-# INLINABLE unnullifier #-}
126+
127+
128+runTag :: Nullity a -> Expr Bool -> Expr a -> Expr (Nullify a)
129+runTag nullity tag a = case nullity of
130+ Null -> boolExpr null a tag
131+ NotNull -> boolExpr null (nullify a) tag
131132 where
132133 null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit
133134
134135
135−snullify :: Nullity a -> Expr a -> Expr (Nullify a)
136−snullify nullity a = case nullity of
136+unnull :: Nullity a -> Expr (Nullify a) -> Expr a
137+unnull nullity a = case nullity of
137138 Null -> a
138− NotNull -> nullify a
139+ NotNull -> unsafeUnnullify a
139140
140141
141−sunnullify :: Nullity a -> Expr (Nullify a) -> Expr a
142−sunnullify nullity a = case nullity of
143− Null -> a
144− NotNull -> unsafeUnnullify a
142+type HNullifiable :: K.HContext -> Constraint
143+class HNullifiable context where
144+ type HConstrainTag context :: Type -> Constraint
145+ type HConstrainTag _context = DefaultConstrainTag
146+
147+ hencodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)
148+ => Tag label a
149+ -> context ('Spec a)
150+
151+ hdecodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)
152+ => context ('Spec a)
153+ -> Tag label a
154+
155+ hnullifier :: ()
156+ => Tag label a
157+ -> (Expr a -> Expr Bool)
158+ -> SSpec ('Spec x)
159+ -> context ('Spec x)
160+ -> context ('Spec (Nullify x))
161+
162+ hunnullifier :: ()
163+ => SSpec ('Spec x)
164+ -> context ('Spec (Nullify x))
165+ -> context ('Spec x)
166+
167+
168+instance Nullifiable context => HNullifiable (Col context) where
169+ type HConstrainTag (Col context) = ConstrainTag context
170+ hencodeTag = encodeTag
171+ hdecodeTag = decodeTag
172+ hnullifier = nullifier
173+ hunnullifier = unnullifier
174+
175+
176+instance HNullifiable (Dict (ConstrainDBType constraint)) where
177+ type HConstrainTag (Dict (ConstrainDBType constraint)) = constraint
178+
179+ hencodeTag _ = Dict
180+ hdecodeTag = mempty
181+ hnullifier _ _ = ConstrainDBType.nullifier
182+ hunnullifier = ConstrainDBType.unnullifier
183+
184+
185+type DefaultConstrainTag :: Type -> Constraint
186+class DefaultConstrainTag a
187+instance DefaultConstrainTag a
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+24−51
@@ -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,43 +114,22 @@ 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
159−type GHTable :: K.Context -> (Type -> Type) -> Constraint
132+type GHTable :: K.HContext -> (Type -> Type) -> Constraint
160133class HTable (GHColumns rep) => GHTable context rep | rep -> context where
161134 type GHColumns rep :: K.HTable
162135 toGHColumns :: rep x -> GHColumns rep context
@@ -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 #-}
66
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−16
@@ -1,5 +1,4 @@
11{-# language DataKinds #-}
2−{-# language RankNTypes #-}
32{-# language RecordWildCards #-}
43{-# language ScopedTypeVariables #-}
54{-# language StandaloneKindSignatures #-}
@@ -8,7 +7,6 @@
87
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,8 +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, ..}
49− {-# INLINABLE hspecs #-}
43+ SSpec {..} -> SSpec {labels = symbolVal (Proxy @label) : labels, ..}
5044
5145
5246hlabel :: forall label t context. t context -> HLabel label t context
@@ -62,9 +56,3 @@ hrelabel = hlabel . hunlabel
6256hunlabel :: forall label t context. HLabel label t context -> t context
6357hunlabel (HLabel a) = a
6458{-# 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+29−44
@@ -19,34 +19,25 @@
1919module Rel8.Schema.HTable.Nullify
2020 ( HNullify( HNullify )
2121 , Nullify
22− , hguard
23− , hnulls
24− , hnullify
25− , hunnullify
26− , hproject
22+ , hnulls, hnullify, hunnullify
2723 )
2824where
2925
3026-- base
31−import Data.Kind ( Type )
32−import GHC.Generics ( Generic )
3327import Prelude hiding ( null )
3428
3529-- rel8
36−import Rel8.FCF ( Eval, Exp )
3730import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )
38−import Rel8.Schema.HTable.MapTable
39− ( HMapTable, HMapTableField( HMapTableField )
40− , MapSpec, mapInfo
41− )
42−import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )
4331import qualified Rel8.Schema.Kind as K
4432import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
4533import qualified Rel8.Schema.Null as Type ( Nullify )
46−import Rel8.Schema.Spec ( Spec(..) )
34+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
4735
4836-- semigroupoids
4937import Data.Functor.Apply ( Apply )
38+import Rel8.Schema.HTable.MapTable
39+import Rel8.FCF
40+import GHC.Generics (Generic)
5041
5142
5243type HNullify :: K.HTable -> K.HTable
@@ -55,63 +46,57 @@ newtype HNullify table context = HNullify (HMapTable Nullify table context)
5546 deriving anyclass HTable
5647
5748
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
49+
50+-- | Transform a 'Spec' by allowing it to be @null@.
51+data Nullify :: Spec -> Exp Spec
52+
53+
54+type instance Eval (Nullify ('Spec a)) =
55+ 'Spec (Type.Nullify a)
6156
6257
6358instance MapSpec Nullify where
6459 mapInfo = \case
65− Spec {nullity, ..} -> Spec
60+ SSpec {nullity, ..} -> SSpec
6661 { nullity = case nullity of
6762 Null -> Null
6863 NotNull -> Null
6964 , ..
70− }
71−
72−
73−hguard :: HTable t
74− => (forall a. context (Maybe a) -> context (Maybe a))
75− -> HNullify t context -> HNullify t context
76−hguard guarder (HNullify as) = HNullify $ htabulate $ \(HMapTableField field) ->
77− case hfield hspecs field of
78− Spec {nullity} -> case hfield as (HMapTableField field) of
79− a -> case nullity of
80− Null -> guarder a
81− NotNull -> guarder a
65+ }
8266
8367
8468hnulls :: HTable t
85− => (forall a. Spec a -> context (Type.Nullify a))
69+ => (forall a. ()
70+ => SSpec ('Spec a)
71+ -> context ('Spec (Type.Nullify a)))
8672 -> HNullify t context
87−hnulls null = HNullify $ htabulate $ \(HMapTableField field) ->
88− case hfield hspecs field of
89− spec@Spec {} -> null spec
73+hnulls null = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
74+ spec@SSpec {} -> null spec
9075{-# INLINABLE hnulls #-}
9176
9277
9378hnullify :: HTable t
94− => (forall a. Spec a -> context a -> context (Type.Nullify a))
79+ => (forall a. ()
80+ => SSpec ('Spec a)
81+ -> context ('Spec a)
82+ -> context ('Spec (Type.Nullify a)))
9583 -> t context
9684 -> HNullify t context
9785hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->
9886 case hfield hspecs field of
99− spec@Spec {} -> nullifier spec (hfield a field)
87+ spec@SSpec {} -> nullifier spec (hfield a field)
10088{-# INLINABLE hnullify #-}
10189
10290
10391hunnullify :: (HTable t, Apply m)
104− => (forall a. Spec a -> context (Type.Nullify a) -> m (context a))
92+ => (forall a. ()
93+ => SSpec ('Spec a)
94+ -> context ('Spec (Type.Nullify a))
95+ -> m (context ('Spec a)))
10596 -> HNullify t context
10697 -> m (t context)
10798hunnullify unnullifier (HNullify as) =
10899 htabulateA $ \field -> case hfield hspecs field of
109− spec@Spec {} -> case hfield as (HMapTableField field) of
100+ spec@SSpec {} -> case hfield as (HMapTableField field) of
110101 a -> unnullifier spec a
111102{-# 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+41−39
@@ -9,6 +9,8 @@
99{-# language GADTs #-}
1010{-# language LambdaCase #-}
1111{-# language MultiParamTypeClasses #-}
12+{-# language NamedFieldPuns #-}
13+{-# language QuantifiedConstraints #-}
1214{-# language RankNTypes #-}
1315{-# language RecordWildCards #-}
1416{-# language ScopedTypeVariables #-}
@@ -21,39 +23,33 @@ module Rel8.Schema.HTable.Vectorize
2123 ( HVectorize
2224 , hvectorize, hunvectorize
2325 , happend, hempty
24− , hproject
25− , hcolumn
2626 )
2727where
2828
2929-- base
30−import Data.Kind ( Constraint, Type )
30+import Data.Kind ( Type )
3131import Data.List.NonEmpty ( NonEmpty )
32−import GHC.Generics (Generic)
3332import Prelude
3433
3534-- rel8
36−import Rel8.FCF ( Eval, Exp )
3735import Rel8.Schema.Dict ( Dict( Dict ) )
3836import 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 )
37+import Rel8.Schema.HTable
38+ ( HTable
39+ , hfield, htabulate, htabulateA, hspecs
4540 )
46−import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )
4741import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )
48−import Rel8.Schema.Spec ( Spec(..) )
42+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
4943import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
5044import Rel8.Type.Information ( TypeInformation )
5145
5246-- semialign
5347import Data.Zip ( Unzip, Zip, Zippy(..) )
48+import Rel8.FCF
49+import Rel8.Schema.HTable.MapTable
50+import GHC.Generics (Generic)
5451
5552
56−type Vector :: (Type -> Type) -> Constraint
5753class Vector list where
5854 listNotNull :: proxy a -> Dict NotNull (list a)
5955 vectorTypeInformation :: ()
@@ -78,16 +74,16 @@ newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) t
7874 deriving anyclass HTable
7975
8076
81−data Vectorize :: (Type -> Type) -> Type -> Exp Type
77+data Vectorize :: (Type -> Type) -> Spec -> Exp Spec
8278
8379
84−type instance Eval (Vectorize list a) = list a
80+type instance Eval (Vectorize list ('Spec a)) = 'Spec (list a)
8581
8682
8783instance Vector list => MapSpec (Vectorize list) where
8884 mapInfo = \case
89− Spec {..} -> case listNotNull @list nullity of
90− Dict -> Spec
85+ SSpec {..} -> case listNotNull @list nullity of
86+ Dict -> SSpec
9187 { nullity = NotNull
9288 , info = vectorTypeInformation nullity info
9389 , ..
@@ -95,49 +91,55 @@ instance Vector list => MapSpec (Vectorize list) where
9591
9692
9793hvectorize :: (HTable t, Unzip f, Vector list)
98− => (forall a. Spec a -> f (context a) -> context' (list a))
94+ => (forall a. ()
95+ => SSpec ('Spec a)
96+ -> f (context ('Spec a))
97+ -> context' ('Spec (list a)))
9998 -> f (t context)
10099 -> HVectorize list t context'
101100hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->
102101 case hfield hspecs field of
103− spec -> vectorizer spec (fmap (`hfield` field) as)
102+ spec@SSpec {} -> vectorizer spec (fmap (`hfield` field) as)
104103{-# INLINABLE hvectorize #-}
105104
106105
107106hunvectorize :: (HTable t, Zip f, Vector list)
108− => (forall a. Spec a -> context (list a) -> f (context' a))
107+ => (forall a. ()
108+ => SSpec ('Spec a)
109+ -> context ('Spec (list a))
110+ -> f (context' ('Spec a)))
109111 -> HVectorize list t context
110112 -> f (t context')
111113hunvectorize unvectorizer (HVectorize table) =
112114 getZippy $ htabulateA $ \field -> case hfield hspecs field of
113− spec -> case hfield table (HMapTableField field) of
115+ spec@SSpec{} -> case hfield table (HMapTableField field) of
114116 a -> Zippy (unvectorizer spec a)
115117{-# INLINABLE hunvectorize #-}
116118
117119
118−happend :: (HTable t, Vector list)
119− => (forall a. Spec a -> context (list a) -> context (list a) -> context (list a))
120+happend :: (HTable t, Vector list) =>
121+ ( forall a. ()
122+ => Nullity a
123+ -> TypeInformation (Unnullify a)
124+ -> context ('Spec (list a))
125+ -> context ('Spec (list a))
126+ -> context ('Spec (list a))
127+ )
120128 -> HVectorize list t context
121129 -> HVectorize list t context
122130 -> HVectorize list t context
123131happend append (HVectorize as) (HVectorize bs) = HVectorize $
124132 htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of
125133 (a, b) -> case hfield hspecs j of
126− spec -> append spec a b
134+ SSpec {nullity, info} -> append nullity info a b
127135
128136
129−hempty :: HTable t
130− => (forall a. Spec a -> context [a])
137+hempty :: HTable t =>
138+ ( forall a. ()
139+ => Nullity a
140+ -> TypeInformation (Unnullify a)
141+ -> context ('Spec [a])
142+ )
131143 -> 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
144+hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
145+ SSpec {nullity, info} -> empty nullity info
src/Rel8/Schema/Kind.hs+15−6
@@ -1,9 +1,8 @@
11{-# language StandaloneKindSignatures #-}
22
33module Rel8.Schema.Kind
4− ( Rel8able
5− , Context
6− , HTable
4+ ( Context, Rel8able
5+ , HContext, HTable
76 )
87where
98
@@ -11,13 +10,23 @@ where
1110import Data.Kind ( Type )
1211import Prelude ()
1312
13+-- rel8
14+import Rel8.Schema.Spec ( Spec )
1415
15−type Context :: Type
16−type Context = Type -> Type
16+
17+type HContext :: Type
18+type HContext = Spec -> Type
1719
1820
1921type HTable :: Type
20−type HTable = Context -> Type
22+type HTable = HContext -> Type
23+
24+
25+data X
26+
27+
28+type Context :: Type
29+type Context = X -> Type
2130
2231
2332type Rel8able :: Type
src/Rel8/Schema/Name.hs+50−34
@@ -3,44 +3,40 @@
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+{-# language UndecidableSuperClasses #-}
1214
1315module Rel8.Schema.Name
1416 ( Name(..)
17+ , Col( N, unN )
1518 , Selects
16− , ppColumn
1719 )
1820where
1921
2022-- base
21−import Data.Functor.Identity ( Identity( Identity ) )
23+import Data.Functor.Identity ( Identity )
2224import Data.Kind ( Constraint, Type )
23−import Data.String ( IsString )
25+import Data.String ( IsString, fromString )
2426import Prelude
2527
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−
3328-- rel8
3429import Rel8.Expr ( Expr )
35−import qualified Rel8.Schema.Kind as K
36−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
30+import Rel8.Schema.Context ( Interpretation, Col )
31+import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )
3732import Rel8.Schema.Null ( Sql )
33+import Rel8.Schema.Reify ( notReify )
34+import Rel8.Schema.Result ( Result )
35+import Rel8.Schema.Spec ( Spec( Spec ) )
3836import Rel8.Table
39− ( Table, Columns, Context, fromColumns, toColumns
40− , FromExprs, fromResult, toResult
41− , Transpose
37+ ( Table, Columns, Context, fromColumns, toColumns, reify, unreify
4238 )
43−import Rel8.Table.Transpose ( Transposes )
39+import Rel8.Table.Recontextualize ( Recontextualize )
4440import Rel8.Type ( DBType )
4541
4642
@@ -48,30 +44,50 @@ import Rel8.Type ( DBType )
4844-- schema definition. You can construct names by using the @OverloadedStrings@
4945-- extension and writing string literals. This is typically done when providing
5046-- a 'TableSchema' value.
51−type Name :: K.Context
52−newtype Name a = Name String
53− deriving stock Show
54− deriving newtype IsString
47+type Name :: k -> Type
48+data Name a where
49+ Name :: k ~ Type => !String -> Name (a :: k)
50+
51+
52+deriving stock instance Show (Name a)
53+
54+
55+instance k ~ Type => IsString (Name (a :: k)) where
56+ fromString = Name
5557
5658
5759instance Sql DBType a => Table Name (Name a) where
58− type Columns (Name a) = HIdentity a
60+ type Columns (Name a) = HType a
5961 type Context (Name a) = Name
60− type FromExprs (Name a) = a
61− type Transpose to (Name a) = to a
6262
63− toColumns a = HIdentity a
64− fromColumns (HIdentity a) = a
65− toResult a = HIdentity (Identity a)
66− fromResult (HIdentity (Identity a)) = a
63+ toColumns a = HType (N a)
64+ fromColumns (HType (N a)) = a
65+ reify = notReify
66+ unreify = notReify
67+
68+
69+instance Sql DBType a => Recontextualize Expr Name (Expr a) (Name a)
70+
71+
72+instance Sql DBType a => Recontextualize Result Name (Identity a) (Name a)
73+
74+
75+instance Sql DBType a => Recontextualize Name Expr (Name a) (Expr a)
76+
77+
78+instance Sql DBType a => Recontextualize Name Result (Name a) (Identity a)
79+
80+
81+instance Sql DBType a => Recontextualize Name Name (Name a) (Name a)
82+
83+
84+instance Interpretation Name where
85+ data Col Name _spec where
86+ N :: {unN :: !(Name a)} -> Col Name ('Spec a)
6787
6888
6989-- | @Selects a b@ means that @a@ is a schema (i.e., a 'Table' of 'Name's) for
7090-- the 'Expr' columns in @b@.
7191type Selects :: Type -> Type -> Constraint
72−class Transposes Name Expr names exprs => Selects names exprs
73−instance Transposes Name Expr names exprs => Selects names exprs
74−
75−
76−ppColumn :: String -> Doc
77−ppColumn = Opaleye.ppSqlExpr . Opaleye.ColumnSqlExpr . Opaleye.SqlColumn
92+class Recontextualize Name Expr names exprs => Selects names exprs
93+instance Recontextualize Name Expr names exprs => Selects names exprs
src/Rel8/Schema/Reify.hsnew file+68
@@ -0,0 +1,68 @@
1+{-# language AllowAmbiguousTypes #-}
2+{-# language EmptyCase #-}
3+{-# language DataKinds #-}
4+{-# language FlexibleInstances #-}
5+{-# language ScopedTypeVariables #-}
6+{-# language StandaloneKindSignatures #-}
7+{-# language TypeApplications #-}
8+{-# language TypeFamilies #-}
9+{-# language TypeOperators #-}
10+{-# language UndecidableInstances #-}
11+
12+module Rel8.Schema.Reify
13+ ( Reify, Col( Reify ), hreify, hunreify
14+ , UnwrapReify
15+ , NotReify, notReify
16+ )
17+where
18+
19+-- base
20+import Data.Kind ( Constraint )
21+import Data.Type.Equality ( (:~:)( Refl ) )
22+import Prelude
23+
24+-- rel8
25+import Rel8.Schema.Context ( Interpretation, Col )
26+import Rel8.Schema.HTable ( HTable, hmap )
27+import Rel8.Schema.Kind ( Context )
28+
29+
30+type Reify :: Context -> Context
31+data Reify context a
32+
33+
34+instance Interpretation (Reify context) where
35+ newtype Col (Reify context) spec = Reify (Col context spec)
36+
37+
38+hreify :: HTable t => t (Col context) -> t (Col (Reify context))
39+hreify = hmap Reify
40+
41+
42+hunreify :: HTable t => t (Col (Reify context)) -> t (Col context)
43+hunreify = hmap (\(Reify a) -> a)
44+
45+
46+type UnwrapReify :: Context -> Context
47+type family UnwrapReify context where
48+ UnwrapReify (Reify context) = context
49+
50+
51+type IsReify :: Context -> Bool
52+type family IsReify context where
53+ IsReify (Reify _) = 'True
54+ IsReify _ = 'False
55+
56+
57+type NotReify :: Context -> Constraint
58+class IsReify context ~ 'False => NotReify context
59+instance IsReify context ~ 'False => NotReify context
60+
61+
62+notReify :: forall context ctx a. NotReify context => context :~: Reify ctx -> a
63+notReify refl = case lemma @context of
64+ Refl -> case refl of
65+
66+
67+lemma :: NotReify context => IsReify context :~: 'False
68+lemma = Refl
src/Rel8/Schema/Result.hs+33−16
@@ -5,20 +5,20 @@
55{-# language TypeFamilies #-}
66
77module Rel8.Schema.Result
8− ( Result
8+ ( Col( R, unR ), Result
99 , null, nullifier, unnullifier
1010 , vectorizer, unvectorizer
1111 )
1212where
1313
1414-- base
15−import Data.Functor.Identity ( Identity( Identity), runIdentity )
1615import Prelude hiding ( null )
1716
1817-- rel8
18+import Rel8.Schema.Context ( Interpretation( Col ) )
1919import Rel8.Schema.Kind ( Context )
2020import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )
21−import Rel8.Schema.Spec ( Spec(..) )
21+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
2222
2323
2424-- | The @Result@ context is the context used for decoded query results.
@@ -26,29 +26,46 @@ import Rel8.Schema.Spec ( Spec(..) )
2626-- When a query is executed against a PostgreSQL database, Rel8 parses the
2727-- returned rows, decoding each row into the @Result@ context.
2828type Result :: Context
29−type Result = Identity
29+data Result a
3030
3131
32−null :: Result (Maybe a)
33−null = Identity Nothing
32+instance Interpretation Result where
33+ data Col Result _spec where
34+ R :: {unR :: !a} -> Col Result ('Spec a)
3435
3536
36−nullifier :: Spec a -> Result a -> Result (Nullify a)
37−nullifier Spec {nullity} (Identity a) = Identity $ case nullity of
37+null :: Col Result ('Spec (Maybe a))
38+null = R Nothing
39+
40+
41+nullifier :: ()
42+ => SSpec ('Spec a)
43+ -> Col Result ('Spec a)
44+ -> Col Result ('Spec (Nullify a))
45+nullifier SSpec {nullity} (R a) = R $ case nullity of
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+ -> Col Result ('Spec (Nullify a))
53+ -> Maybe (Col 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 (Col Result ('Spec a))
63+ -> Col 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+ -> Col Result ('Spec (f a))
70+ -> f (Col 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 #-}
46
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/ConstrainDBType.hsnew file+89
@@ -0,0 +1,89 @@
1+{-# language ConstraintKinds #-}
2+{-# language DataKinds #-}
3+{-# language FlexibleInstances #-}
4+{-# language MultiParamTypeClasses #-}
5+{-# language NamedFieldPuns #-}
6+{-# language QuantifiedConstraints #-}
7+{-# language StandaloneKindSignatures #-}
8+{-# language TypeFamilies #-}
9+{-# language UndecidableInstances #-}
10+
11+module Rel8.Schema.Spec.ConstrainDBType
12+ ( ConstrainDBType
13+ , dbTypeNullity, dbTypeDict
14+ , nullifier, unnullifier
15+ )
16+where
17+
18+-- base
19+import Data.Kind ( Constraint, Type )
20+import Prelude
21+
22+-- rel8
23+import Rel8.Schema.Dict ( Dict( Dict ) )
24+import Rel8.Schema.Null
25+ ( Nullify, Unnullify
26+ , Nullity( Null, NotNull )
27+ , Sql, nullable
28+ )
29+import Rel8.Schema.Spec ( Spec( Spec ), SSpec( SSpec, nullity ) )
30+
31+
32+type ConstrainDBType :: (Type -> Constraint) -> Spec -> Constraint
33+class
34+ ( forall c a. ()
35+ => (spec ~ 'Spec a)
36+ => (forall x. (constraint x => c x)) => Sql c a
37+ )
38+ => ConstrainDBType constraint spec
39+instance
40+ ( spec ~ 'Spec a
41+ , Sql constraint a
42+ )
43+ => ConstrainDBType constraint spec
44+
45+
46+dbTypeNullity :: Dict (ConstrainDBType c) ('Spec a) -> Nullity a
47+dbTypeNullity = step2 . step1
48+ where
49+ step1 :: Dict (ConstrainDBType c) ('Spec a) -> Dict (Sql c) a
50+ step1 Dict = Dict
51+
52+ step2 :: Dict (Sql c) a -> Nullity a
53+ step2 Dict = nullable
54+
55+
56+dbTypeDict :: Dict (ConstrainDBType c) ('Spec a) -> Dict c (Unnullify a)
57+dbTypeDict = step2 . step1
58+ where
59+ step1 :: Dict (ConstrainDBType c) ('Spec a) -> Dict (Sql c) a
60+ step1 Dict = Dict
61+
62+ step2 :: Dict (Sql c) a -> Dict c (Unnullify a)
63+ step2 Dict = Dict
64+
65+
66+fromNullityDict :: Nullity a -> Dict c (Unnullify a) -> Dict (ConstrainDBType c) ('Spec a)
67+fromNullityDict Null Dict = Dict
68+fromNullityDict NotNull Dict = Dict
69+
70+
71+nullifier :: ()
72+ => SSpec ('Spec a)
73+ -> Dict (ConstrainDBType c) ('Spec a)
74+ -> Dict (ConstrainDBType c) ('Spec (Nullify a))
75+nullifier SSpec {} dict = case dbTypeDict dict of
76+ Dict -> case dbTypeNullity dict of
77+ Null -> Dict
78+ NotNull -> Dict
79+
80+
81+unnullifier :: ()
82+ => SSpec ('Spec a)
83+ -> Dict (ConstrainDBType c) ('Spec (Nullify a))
84+ -> Dict (ConstrainDBType c) ('Spec a)
85+unnullifier SSpec {nullity} dict = case dbTypeDict dict of
86+ Dict -> case nullity of
87+ Null -> Dict
88+ NotNull -> case dbTypeNullity dict of
89+ Null -> fromNullityDict nullity Dict
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 #-}
63
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 #-}
87
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 ( fromColumns, toColumns )
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 $ toColumns <$> from
73+ where' = toColumn . toPrimExpr . deleteWhere . fromColumns
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 $ toColumns <$> from
87+ where' = toColumn . toPrimExpr . deleteWhere . fromColumns
88+ project' = castTable . toColumns . project . fromColumns
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 #-}
87
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 ( fromColumns, toColumns )
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 $ toColumns <$> into
88+ rows' = toColumns <$> 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 $ toColumns <$> into
107+ rows' = toColumns <$> x :| xs
108+ project' = castTable . toColumns . project . fromColumns
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 #-}
93
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 #-}
84
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 #-}
76
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 ( fromColumns, toColumns )
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 $ toColumns <$> target
74+ set' = toColumns . set . fromColumns
75+ where' = toColumn . toPrimExpr . updateWhere . fromColumns
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 $ toColumns <$> target
94+ set' = toColumns . set . fromColumns
95+ where' = toColumn . toPrimExpr . updateWhere . fromColumns
96+ project' = castTable . toColumns . project . fromColumns
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 @@
33
44module Rel8.Statement.View
55 ( createView
6− , createOrReplaceView
76 )
87where
98
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+245−88
@@ -1,47 +1,75 @@
11{-# language AllowAmbiguousTypes #-}
22{-# language DataKinds #-}
33{-# language DefaultSignatures #-}
4+{-# language DisambiguateRecordFields #-}
45{-# language FlexibleContexts #-}
56{-# language FlexibleInstances #-}
67{-# language FunctionalDependencies #-}
8+{-# language LambdaCase #-}
9+{-# language NamedFieldPuns #-}
710{-# language ScopedTypeVariables #-}
811{-# language StandaloneKindSignatures #-}
912{-# language TypeApplications #-}
1013{-# language TypeFamilies #-}
14+{-# language TypeOperators #-}
1115{-# language UndecidableInstances #-}
1216
1317module Rel8.Table
14− ( Table
15− ( Columns, Context, fromColumns, toColumns
16− , FromExprs, fromResult, toResult
17− , Transpose
18− )
18+ ( Table (Columns, Context, Unreify, toColumns, fromColumns, reify, unreify)
1919 , Congruent
20− , TTable, TColumns, TContext, TFromExprs, TTranspose
21− , TSerialize
20+ , TTable, TColumns, TContext, TUnreify
2221 )
2322where
2423
2524-- base
25+import Data.Functor ( ($>) )
2626import Data.Functor.Identity ( Identity( Identity ) )
2727import Data.Kind ( Constraint, Type )
28+import Data.List.NonEmpty ( NonEmpty )
29+import Data.Proxy ( Proxy( Proxy ) )
30+import Data.Type.Equality ( (:~:)( Refl ) )
2831import GHC.Generics ( Generic, Rep, from, to )
2932import Prelude hiding ( null )
3033
3134-- rel8
3235import Rel8.FCF ( Eval, Exp )
33−import Rel8.Generic.Map ( Map )
34−import Rel8.Generic.Table.Record
35− ( GTable, GColumns, GContext, gfromColumns, gtoColumns
36− , GSerialize, gfromResult, gtoResult
36+import Rel8.Kind.Algebra ( KnownAlgebra )
37+import Rel8.Generic.Map ( GMap, GMappable, gmap, gunmap )
38+import Rel8.Generic.Table
39+ ( GGTable, GGColumns, GGContext, ggfromColumns, ggtoColumns
40+ , GAlgebra
3741 )
3842import Rel8.Generic.Record ( Record(..) )
43+import Rel8.Generic.Reify ( ARep )
3944import Rel8.Schema.HTable ( HTable )
40−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
45+import Rel8.Schema.HTable.Either ( HEitherTable(..) )
46+import Rel8.Schema.HTable.Identity ( HIdentity(..), HType )
47+import Rel8.Schema.HTable.Label ( hlabel, hrelabel, hunlabel )
48+import Rel8.Schema.HTable.List ( HListTable )
49+import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
50+import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
51+import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify )
52+import Rel8.Schema.HTable.These ( HTheseTable(..) )
53+import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )
4154import qualified Rel8.Schema.Kind as K
4255import Rel8.Schema.Null ( Sql )
43−import Rel8.Schema.Result ( Result )
56+import Rel8.Schema.Reify
57+ ( Reify, Col( Reify ), hreify, hunreify
58+ , UnwrapReify
59+ , notReify
60+ )
61+import Rel8.Schema.Result
62+ ( Col( R ), Result
63+ , null, nullifier, unnullifier
64+ , vectorizer, unvectorizer
65+ )
66+import Rel8.Schema.Spec ( KnownSpec )
4467import Rel8.Type ( DBType )
68+import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )
69+
70+-- these
71+import Data.These ( These( This, That, These ) )
72+import Data.These.Combinators ( justHere, justThere )
4573
4674
4775-- | @Table@s are one of the foundational elements of Rel8, and describe data
@@ -56,102 +84,90 @@ import Rel8.Type ( DBType )
5684-- yourself, as anything that's an instance of 'Rel8.Rel8able' is always a
5785-- 'Table'.
5886type Table :: K.Context -> Type -> Constraint
59−class
60− ( HTable (Columns a)
61− , context ~ Context a
62− , a ~ Transpose context a
63− )
64− => Table context a | a -> context
65− where
87+class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where
6688 -- | The 'HTable' functor that describes the schema of this table.
6789 type Columns a :: K.HTable
6890
6991 -- | The common context that all columns use as an interpretation.
7092 type Context a :: K.Context
7193
72− -- | The @FromExprs@ type family maps a type in the @Expr@ context to the
73− -- corresponding Haskell type.
74− type FromExprs a :: Type
75−
76− type Transpose (context' :: K.Context) a :: Type
94+ type Unreify a :: Type
7795
96+ toColumns :: a -> Columns a (Col context)
97+ fromColumns :: Columns a (Col context) -> a
7898
79− toColumns :: a -> Columns a context
80− fromColumns :: Columns a context -> a
99+ reify :: context :~: Reify ctx -> Unreify a -> a
100+ unreify :: context :~: Reify ctx -> a -> Unreify a
81101
82− fromResult :: Columns a Result -> FromExprs a
83− toResult :: FromExprs a -> Columns a Result
84−
85− type Columns a = GColumns TColumns (Rep (Record a))
86− type Context a = GContext TContext (Rep (Record a))
87− type FromExprs a = Map TFromExprs a
88− type Transpose context a = Map (TTranspose context) a
102+ type Columns a = Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))
103+ type Context a = Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))
104+ type Unreify a = DefaultUnreify a
89105
90106 default toColumns ::
91107 ( Generic (Record a)
92− , GTable (TTable context) TColumns (Rep (Record a))
93− , Columns a ~ GColumns TColumns (Rep (Record a))
108+ , KnownAlgebra (GAlgebra (Rep (Record a)))
109+ , Eval (GGTable (GAlgebra (Rep (Record a))) (TTable context) TColumns (Col context) (Rep (Record a)))
110+ , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))
111+ , Context a ~ Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))
94112 )
95− => a -> Columns a context
113+ => a -> Columns a (Col context)
96114 toColumns =
97− gtoColumns @(TTable context) @TColumns toColumns .
115+ ggtoColumns
116+ @(GAlgebra (Rep (Record a)))
117+ @(TTable context)
118+ @TColumns
119+ id
120+ id
121+ toColumns .
98122 from .
99123 Record
100124
101125 default fromColumns ::
102126 ( Generic (Record a)
103− , GTable (TTable context) TColumns (Rep (Record a))
104− , Columns a ~ GColumns TColumns (Rep (Record a))
127+ , KnownAlgebra (GAlgebra (Rep (Record a)))
128+ , Eval (GGTable (GAlgebra (Rep (Record a))) (TTable context) TColumns (Col context) (Rep (Record a)))
129+ , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))
130+ , Context a ~ Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))
105131 )
106− => Columns a context -> a
132+ => Columns a (Col context) -> a
107133 fromColumns =
108134 unrecord .
109135 to .
110− gfromColumns @(TTable context) @TColumns fromColumns
136+ ggfromColumns
137+ @(GAlgebra (Rep (Record a)))
138+ @(TTable context)
139+ @TColumns
140+ id
141+ id
142+ fromColumns
111143
112− default toResult ::
113− ( Generic (Record (FromExprs a))
114− , GSerialize TSerialize TColumns (Rep (Record a)) (Rep (Record (FromExprs a)))
115− , Columns a ~ GColumns TColumns (Rep (Record a))
144+ default reify ::
145+ ( Generic (Record a)
146+ , Generic (Record (Unreify a))
147+ , GMappable (TTable context) (Rep (Record a))
148+ , Rep (Record (Unreify a)) ~ GMap TUnreify (Rep (Record a))
116149 )
117− => FromExprs a -> Columns a Result
118− toResult =
119− gtoResult
120− @TSerialize
121− @TColumns
122− @(Rep (Record a))
123− @(Rep (Record (FromExprs a)))
124− (\(_ :: proxy x) -> toResult @(Context x) @x) .
150+ => context :~: Reify ctx -> Unreify a -> a
151+ reify Refl =
152+ unrecord .
153+ to .
154+ gunmap @(TTable context) (Proxy @TUnreify) (reify Refl) .
125155 from .
126156 Record
127157
128− default fromResult ::
129− ( Generic (Record (FromExprs a))
130− , GSerialize TSerialize TColumns (Rep (Record a)) (Rep (Record (FromExprs a)))
131− , Columns a ~ GColumns TColumns (Rep (Record a))
158+ default unreify ::
159+ ( Generic (Record a)
160+ , Generic (Record (Unreify a))
161+ , GMappable (TTable context) (Rep (Record a))
162+ , Rep (Record (Unreify a)) ~ GMap TUnreify (Rep (Record a))
132163 )
133− => Columns a Result -> FromExprs a
134− fromResult =
164+ => context :~: Reify ctx -> a -> Unreify a
165+ unreify Refl =
135166 unrecord .
136167 to .
137− gfromResult
138− @TSerialize
139− @TColumns
140− @(Rep (Record a))
141− @(Rep (Record (FromExprs a)))
142− (\(_ :: proxy x) -> fromResult @(Context x) @x)
143−
144−
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
168+ gmap @(TTable context) (Proxy @TUnreify) (unreify Refl) .
169+ from .
170+ Record
155171
156172
157173data TTable :: K.Context -> Type -> Exp Constraint
@@ -166,22 +182,163 @@ data TContext :: Type -> Exp K.Context
166182type instance Eval (TContext a) = Context a
167183
168184
169−data TFromExprs :: Type -> Exp Type
170−type instance Eval (TFromExprs a) = FromExprs a
185+data TUnreify :: Type -> Exp Type
186+type instance Eval (TUnreify a) = Unreify a
171187
172188
173−data TTranspose :: K.Context -> Type -> Exp Type
174−type instance Eval (TTranspose context a) = Transpose context a
189+type DefaultUnreify :: Type -> Type
190+type family DefaultUnreify a where
191+ DefaultUnreify (t a b c d e f g) =
192+ t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e) (Unreify f) (Unreify g)
193+ DefaultUnreify (t a b c d e f) =
194+ t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e) (Unreify f)
195+ DefaultUnreify (t a b c d e) =
196+ t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e)
197+ DefaultUnreify (t a b c d) =
198+ t (Unreify a) (Unreify b) (Unreify c) (Unreify d)
199+ DefaultUnreify (t a b c) = t (Unreify a) (Unreify b) (Unreify c)
200+ DefaultUnreify (t a b) = t (Unreify a) (Unreify b)
201+ DefaultUnreify (t a) = t (Unreify a)
202+ DefaultUnreify a = ARep (GMap TUnreify (Rep a))
175203
176204
177−data TSerialize :: Type -> Type -> Exp Constraint
178−type instance Eval (TSerialize expr a) =
179− ( Table (Context expr) expr
180− , a ~ FromExprs expr
181− )
205+-- | Any 'HTable' is also a 'Table'.
206+instance HTable t => Table context (t (Col context)) where
207+ type Columns (t (Col context)) = t
208+ type Context (t (Col context)) = context
209+ type Unreify (t (Col context)) = t (Col (UnwrapReify context))
210+
211+ toColumns = id
212+ fromColumns = id
213+
214+ reify Refl = hreify
215+ unreify Refl = hunreify
182216
183217
184−instance (Table context a, Table context b) => Table context (a, b)
218+-- | Any context is trivially a table.
219+instance KnownSpec spec => Table context (Col context spec) where
220+ type Columns (Col context spec) = HIdentity spec
221+ type Context (Col context spec) = context
222+ type Unreify (Col context spec) = Col (UnwrapReify context) spec
223+
224+ toColumns = HIdentity
225+ fromColumns = unHIdentity
226+
227+ reify Refl = Reify
228+ unreify Refl (Reify a) = a
229+
230+
231+instance Sql DBType a => Table Result (Identity a) where
232+ type Columns (Identity a) = HType a
233+ type Context (Identity a) = Result
234+
235+ toColumns (Identity a) = HType (R a)
236+ fromColumns (HType (R a)) = Identity a
237+
238+ reify = notReify
239+ unreify = notReify
240+
241+
242+instance (Table Result a, Table Result b) => Table Result (Either a b) where
243+ type Columns (Either a b) = HEitherTable (Columns a) (Columns b)
244+ type Context (Either a b) = Result
245+
246+ toColumns = \case
247+ Left table -> HEitherTable
248+ { htag = hlabel (HType (R IsLeft))
249+ , hleft = hlabel (hnullify nullifier (toColumns table))
250+ , hright = hlabel (hnulls (const null))
251+ }
252+ Right table -> HEitherTable
253+ { htag = hlabel (HType (R IsRight))
254+ , hleft = hlabel (hnulls (const null))
255+ , hright = hlabel (hnullify nullifier (toColumns table))
256+ }
257+
258+ fromColumns HEitherTable {htag, hleft, hright} = case hunlabel htag of
259+ HType (R tag) -> case tag of
260+ IsLeft -> maybe err (Left . fromColumns) $ hunnullify unnullifier (hunlabel hleft)
261+ IsRight -> maybe err (Right . fromColumns) $ hunnullify unnullifier (hunlabel hright)
262+ where
263+ err = error "Either.fromColumns: mismatch between tag and data"
264+
265+
266+instance Table Result a => Table Result [a] where
267+ type Columns [a] = HListTable (Columns a)
268+ type Context [a] = Result
269+
270+ toColumns = hvectorize vectorizer . fmap toColumns
271+ fromColumns = fmap fromColumns . hunvectorize unvectorizer
272+
273+
274+instance Table Result a => Table Result (Maybe a) where
275+ type Columns (Maybe a) = HMaybeTable (Columns a)
276+ type Context (Maybe a) = Result
277+
278+ toColumns = \case
279+ Nothing -> HMaybeTable
280+ { htag = hlabel (HIdentity (R Nothing))
281+ , hjust = hlabel (hnulls (const null))
282+ }
283+ Just table -> HMaybeTable
284+ { htag = hlabel (HIdentity (R (Just IsJust)))
285+ , hjust = hlabel (hnullify nullifier (toColumns table))
286+ }
287+
288+ fromColumns HMaybeTable {htag, hjust} = case hunlabel htag of
289+ HType (R tag) -> tag $>
290+ case hunnullify unnullifier (hunlabel hjust) of
291+ Nothing -> error "Maybe.fromColumns: mismatch between tag and data"
292+ Just just -> fromColumns just
293+
294+
295+instance Table Result a => Table Result (NonEmpty a) where
296+ type Columns (NonEmpty a) = HNonEmptyTable (Columns a)
297+ type Context (NonEmpty a) = Result
298+
299+ toColumns = hvectorize vectorizer . fmap toColumns
300+ fromColumns = fmap fromColumns . hunvectorize unvectorizer
301+
302+
303+instance (Table Result a, Table Result b) => Table Result (These a b) where
304+ type Columns (These a b) = HTheseTable (Columns a) (Columns b)
305+ type Context (These a b) = Result
306+
307+ toColumns tables = HTheseTable
308+ { hhereTag = hrelabel hhereTag
309+ , hhere = hrelabel (toColumns hhere)
310+ , hthereTag = hrelabel hthereTag
311+ , hthere = hrelabel (toColumns hthere)
312+ }
313+ where
314+ HMaybeTable
315+ { htag = hhereTag
316+ , hjust = hhere
317+ } = toColumns (justHere tables)
318+ HMaybeTable
319+ { htag = hthereTag
320+ , hjust = hthere
321+ } = toColumns (justThere tables)
322+
323+ fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} =
324+ case (fromColumns mhere, fromColumns mthere) of
325+ (Just a, Nothing) -> This (fromColumns a)
326+ (Nothing, Just b) -> That (fromColumns b)
327+ (Just a, Just b) -> These (fromColumns a) (fromColumns b)
328+ _ -> error "These.fromColumns: mismatch between tags and data"
329+ where
330+ mhere = HMaybeTable
331+ { htag = hrelabel hhereTag
332+ , hjust = hrelabel hhere
333+ }
334+ mthere = HMaybeTable
335+ { htag = hrelabel hthereTag
336+ , hjust = hrelabel hthere
337+ }
338+
339+
340+instance (Table context a, Table context b)
341+ => Table context (a, b)
185342
186343
187344instance
src/Rel8/Table/ADT.hs+65−33
@@ -7,13 +7,13 @@
77{-# language ScopedTypeVariables #-}
88{-# language StandaloneKindSignatures #-}
99{-# language TypeApplications #-}
10−{-# language TypeFamilyDependencies #-}
10+{-# language TypeFamilies #-}
1111{-# language UndecidableInstances #-}
1212{-# language UndecidableSuperClasses #-}
1313
1414module Rel8.Table.ADT
1515 ( ADT( ADT )
16− , ADTable
16+ , ADTable, fromADT, toADT
1717 , BuildableADT
1818 , BuildADT, buildADT
1919 , ConstructableADT
@@ -27,7 +27,9 @@ where
2727
2828-- base
2929import Data.Kind ( Constraint, Type )
30−import GHC.Generics ( Generic, from, to )
30+import Data.Proxy ( Proxy( Proxy ) )
31+import Data.Type.Equality ( (:~:)( Refl ) )
32+import GHC.Generics ( Generic, Rep, from, to )
3133import GHC.TypeLits ( Symbol )
3234import Prelude
3335
@@ -44,65 +46,95 @@ import Rel8.Generic.Construction
4446 , GGName, ggname
4547 , GGAggregate, ggaggregate
4648 )
47−import Rel8.Generic.Record ( Record( Record ), unrecord )
49+import Rel8.Generic.Map ( GMappable, GMap, gmap, gunmap )
50+import Rel8.Generic.Record ( GRecordable, GRecord, grecord, gunrecord )
4851import Rel8.Generic.Rel8able
4952 ( Rel8able
5053 , GRep, GColumns, gfromColumns, gtoColumns
51− , GFromExprs, gfromResult, gtoResult
52− , TSerialize, deserialize, serialize
54+ , greify, gunreify
5355 )
5456import qualified Rel8.Generic.Table.ADT as G
5557import qualified Rel8.Kind.Algebra as K
58+import Rel8.Schema.Context ( Col )
5659import Rel8.Schema.HTable ( HTable )
5760import qualified Rel8.Schema.Kind as K
5861import Rel8.Schema.Name ( Name )
62+import Rel8.Schema.Reify ( Col( Reify ), Reify, hreify, hunreify )
5963import Rel8.Schema.Result ( Result )
60−import Rel8.Table ( Table, TColumns )
64+import Rel8.Table
65+ ( Table
66+ , fromColumns, toColumns, reify, unreify
67+ , TTable, TColumns, TUnreify
68+ )
6169
6270
6371type ADT :: K.Rel8able -> K.Rel8able
64−newtype ADT t context = ADT (GColumnsADT t context)
72+newtype ADT t context = ADT (GColumnsADT t (Col context))
6573
6674
6775instance ADTable t => Rel8able (ADT t) where
6876 type GColumns (ADT t) = GColumnsADT t
69− type GFromExprs (ADT t) = t Result
7077
71− gfromColumns _ = ADT
72− gtoColumns _ (ADT a) = a
78+ gfromColumns = ADT
79+ gtoColumns (ADT a) = a
80+
81+ greify (ADT a) = ADT (hreify a)
82+ gunreify (ADT a) = ADT (hunreify a)
7383
74− gfromResult =
75− unrecord .
76− to .
77− G.gfromResultADT
78− @TSerialize
79− @TColumns
80− @(Eval (ADTRep t Expr))
81− @(Eval (ADTRep t Result))
82− (\(_ :: proxy x) -> deserialize @_ @x)
8384
84− gtoResult =
85− G.gtoResultADT
86− @TSerialize
85+instance (ADTable t, context ~ Result) => Generic (ADT t context) where
86+ type Rep (ADT t context) = Rep (t context)
87+
88+ from =
89+ gmap @(TTable (Reify Result)) (Proxy @TUnreify) (unreify Refl) .
90+ gunrecord @(Rep (t (Reify Result))) .
91+ G.gfromColumnsADT
92+ @(TTable (Reify Result))
93+ @TColumns
94+ (\(Reify a) -> a)
95+ Reify
96+ fromColumns .
97+ hreify .
98+ (\(ADT a) -> a)
99+
100+ to =
101+ ADT .
102+ hunreify .
103+ G.gtoColumnsADT
104+ @(TTable (Reify Result))
87105 @TColumns
88− @(Eval (ADTRep t Expr))
89− @(Eval (ADTRep t Result))
90− (\(_ :: proxy x) -> serialize @_ @x) .
91− from .
92− Record
106+ (\(Reify a) -> a)
107+ Reify
108+ toColumns .
109+ grecord @(Rep (t (Reify Result))) .
110+ gunmap @(TTable (Reify Result)) (Proxy @TUnreify) (reify Refl)
111+
112+
113+fromADT :: ADTable t => ADT t Result -> t Result
114+fromADT = to . from
115+
116+
117+toADT :: ADTable t => t Result -> ADT t Result
118+toADT = to . from
93119
94120
95121type ADTable :: K.Rel8able -> Constraint
96122class
97− ( Generic (Record (t Result))
123+ ( Generic (t Result)
98124 , HTable (GColumnsADT t)
99− , G.GSerializeADT TSerialize TColumns (Eval (ADTRep t Expr)) (Eval (ADTRep t Result))
125+ , G.GTableADT (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRecord (Rep (t (Reify Result))))
126+ , GRecordable (Rep (t (Reify Result)))
127+ , GMappable (TTable (Reify Result)) (Rep (t (Reify Result)))
128+ , GMap TUnreify (Rep (t (Reify Result))) ~ Rep (t Result)
100129 )
101130 => ADTable t
102131instance
103− ( Generic (Record (t Result))
132+ ( Generic (t Result)
104133 , HTable (GColumnsADT t)
105− , G.GSerializeADT TSerialize TColumns (Eval (ADTRep t Expr)) (Eval (ADTRep t Result))
134+ , G.GTableADT (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRecord (Rep (t (Reify Result))))
135+ , GRecordable (Rep (t (Reify Result)))
136+ , GMappable (TTable (Reify Result)) (Rep (t (Reify Result)))
137+ , GMap TUnreify (Rep (t (Reify Result))) ~ Rep (t Result)
106138 )
107139 => ADTable t
108140
@@ -170,4 +202,4 @@ type instance Eval (ADTRep t context) = GRep t context
170202
171203
172204type GColumnsADT :: K.Rel8able -> K.HTable
173−type GColumnsADT t = G.GColumnsADT TColumns (GRep t Expr)
205+type GColumnsADT t = G.GColumnsADT TColumns (GRep t (Reify Result))
src/Rel8/Table/Aggregate.hs+13−24
@@ -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, Aggregates, Col( A ) )
20+import Rel8.Expr ( Expr, Col( E ) )
2121import Rel8.Expr.Aggregate
2222 ( groupByExpr
2323 , slistAggExpr
@@ -26,8 +26,8 @@ import Rel8.Expr.Aggregate
2626import Rel8.Schema.Dict ( Dict( Dict ) )
2727import Rel8.Schema.HTable ( HTable, hfield, htabulate )
2828import Rel8.Schema.HTable.Vectorize ( hvectorize )
29−import Rel8.Schema.Null ( Sql )
30−import Rel8.Schema.Spec ( Spec( Spec, info ) )
29+import Rel8.Schema.Spec ( SSpec( SSpec, info ) )
30+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
3131import Rel8.Table ( toColumns, fromColumns )
3232import Rel8.Table.Eq ( EqTable, eqTable )
3333import Rel8.Table.List ( ListTable )
@@ -37,28 +37,17 @@ import Rel8.Type.Eq ( DBEq )
3737
3838-- | Group equal tables together. This works by aggregating each column in the
3939-- 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−-- @
5240groupBy :: forall exprs aggregates. (EqTable exprs, Aggregates aggregates exprs)
5341 => exprs -> aggregates
5442groupBy = fromColumns . hgroupBy (eqTable @exprs) . toColumns
5543
5644
57−hgroupBy :: HTable t => t (Dict (Sql DBEq)) -> t Expr -> t Aggregate
58−hgroupBy eqs exprs = htabulate $ \field ->
45+hgroupBy :: HTable t
46+ => t (Dict (ConstrainDBType DBEq)) -> t (Col Expr) -> t (Col Aggregate)
47+hgroupBy eqs exprs = fromColumns $ htabulate $ \field ->
5948 case hfield eqs field of
6049 Dict -> case hfield exprs field of
61− expr -> groupByExpr expr
50+ E expr -> A $ groupByExpr expr
6251
6352
6453-- | Aggregate rows into a single row containing an array of all aggregated
@@ -71,22 +60,22 @@ hgroupBy eqs exprs = htabulate $ \field ->
7160-- items:
7261--
7362-- @
74−-- ordersWithItems :: Query (Order Expr, ListTable Expr (Item Expr))
63+-- ordersWithItems :: Query (Order Expr, ListTable (Item Expr))
7564-- ordersWithItems = do
7665-- order <- each orderSchema
7766-- items <- aggregate $ listAgg <$> itemsFromOrder order
7867-- return (order, items)
7968-- @
80−listAgg :: Aggregates aggregates exprs => exprs -> ListTable Aggregate aggregates
69+listAgg :: Aggregates aggregates exprs => exprs -> ListTable aggregates
8170listAgg (toColumns -> exprs) = fromColumns $
8271 hvectorize
83− (\Spec {info} (Identity a) -> slistAggExpr info a)
72+ (\SSpec {info} (Identity (E a)) -> A $ slistAggExpr info a)
8473 (pure exprs)
8574
8675
8776-- | Like 'listAgg', but the result is guaranteed to be a non-empty list.
88−nonEmptyAgg :: Aggregates aggregates exprs => exprs -> NonEmptyTable Aggregate aggregates
77+nonEmptyAgg :: Aggregates aggregates exprs => exprs -> NonEmptyTable aggregates
8978nonEmptyAgg (toColumns -> exprs) = fromColumns $
9079 hvectorize
91− (\Spec {info} (Identity a) -> snonEmptyAggExpr info a)
80+ (\SSpec {info} (Identity (E a)) -> A $ snonEmptyAggExpr info a)
9281 (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, Col( 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/Cols.hsdeleted−50
@@ -1,50 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language FlexibleInstances #-}
3−{-# language MultiParamTypeClasses #-}
4−{-# language StandaloneKindSignatures #-}
5−{-# language TypeFamilies #-}
6−{-# language UndecidableInstances #-}
7−
8−module Rel8.Table.Cols
9− ( Cols( Cols )
10− , fromCols
11− , toCols
12− )
13−where
14−
15−-- base
16−import Data.Kind ( Type )
17−import Prelude
18−
19−-- rel8
20−import qualified Rel8.Schema.Kind as K
21−import Rel8.Schema.HTable ( HTable )
22−import Rel8.Schema.Result ( Result )
23−import Rel8.Table ( Table(..) )
24−
25−
26−type Cols :: K.Context -> K.HTable -> Type
27−newtype Cols context columns = Cols (columns context)
28−
29−
30−instance (HTable columns, context ~ context') =>
31− Table context' (Cols context columns)
32− where
33− type Columns (Cols context columns) = columns
34− type Context (Cols context columns) = context
35− type FromExprs (Cols context columns) = Cols Result columns
36− type Transpose to (Cols context columns) = Cols to columns
37−
38− toColumns (Cols a) = a
39− fromColumns = Cols
40−
41− toResult (Cols a) = a
42− fromResult = Cols
43−
44−
45−fromCols :: Table context a => Cols context (Columns a) -> a
46−fromCols (Cols a) = fromColumns a
47−
48−
49−toCols :: Table context a => a -> Cols context (Columns a)
50−toCols = Cols . toColumns
src/Rel8/Table/Either.hs+125−126
@@ -18,44 +18,42 @@ module Rel8.Table.Either
1818 ( EitherTable(..)
1919 , eitherTable, leftTable, rightTable
2020 , isLeftTable, isRightTable
21− , aggregateEitherTable
2221 , nameEitherTable
2322 )
2423where
2524
2625-- base
26+import Control.Applicative ( liftA2 )
2727import Data.Bifunctor ( Bifunctor, bimap )
28−import Data.Functor.Identity ( Identity( Identity ) )
28+import Data.Functor.Identity ( runIdentity )
2929import Data.Kind ( Type )
3030import Prelude hiding ( undefined )
3131
32−-- comonad
33−import Control.Comonad ( extract )
34−
3532-- rel8
36−import Rel8.Aggregate ( Aggregate )
3733import Rel8.Expr ( Expr )
38−import Rel8.Expr.Aggregate ( groupByExpr )
3934import Rel8.Expr.Serialize ( litExpr )
40−import Rel8.Kind.Context ( Reifiable )
41−import Rel8.Schema.Context.Nullify ( Nullifiable )
42−import Rel8.Schema.Dict ( Dict( Dict ) )
35+import Rel8.Schema.Context.Nullify
36+ ( Nullifiable, ConstrainTag
37+ , HNullifiable, HConstrainTag
38+ , hencodeTag, hdecodeTag
39+ , hnullifier, hunnullifier
40+ )
41+import Rel8.Schema.HTable ( HTable )
4342import Rel8.Schema.HTable.Either ( HEitherTable(..) )
4443import Rel8.Schema.HTable.Identity ( HIdentity(..) )
4544import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
46−import qualified Rel8.Schema.Kind as K
45+import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
4746import Rel8.Schema.Name ( Name )
4847import Rel8.Table
4948 ( Table, Columns, Context, fromColumns, toColumns
50− , FromExprs, fromResult, toResult
51− , Transpose
49+ , reify, unreify
5250 )
5351import Rel8.Table.Bool ( bool )
5452import Rel8.Table.Eq ( EqTable, eqTable )
55−import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )
5653import Rel8.Table.Ord ( OrdTable, ordTable )
57−import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )
58−import Rel8.Table.Serialize ( ToExprs )
54+import Rel8.Table.Recontextualize ( Recontextualize )
55+import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
56+import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )
5957import Rel8.Table.Undefined ( undefined )
6058import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
6159
@@ -70,162 +68,119 @@ import Data.Functor.Bind ( Bind, (>>-) )
7068--
7169-- An @EitherTable@ is operationally the same as Haskell's 'Either' type, but
7270-- adapted to work with Rel8.
73−type EitherTable :: K.Context -> Type -> Type -> Type
74−data EitherTable context a b = EitherTable
75− { tag :: context EitherTag
76− , left :: Nullify context a
77− , right :: Nullify context b
71+type EitherTable :: Type -> Type -> Type
72+data EitherTable a b = EitherTable
73+ { tag :: Tag "isRight" EitherTag
74+ , left :: a
75+ , right :: b
7876 }
7977 deriving stock Functor
8078
8179
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−
87−instance Nullifiable context => Bifunctor (EitherTable context) where
88− bimap f g (EitherTable tag a b) = EitherTable tag (fmap f a) (fmap g b)
80+instance Bifunctor EitherTable where
81+ bimap f g (EitherTable tag a b) = EitherTable tag (f a) (g b)
8982
9083
91−instance Projectable (EitherTable context a) where
92− project f (EitherTable tag a b) = EitherTable tag a (project f b)
93−
94−
95−instance (context ~ Expr, Table Expr a) => Apply (EitherTable context a) where
84+instance Table Expr a => Apply (EitherTable a) where
9685 EitherTable tag l1 f <.> EitherTable tag' l2 a =
97− EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f <.> a)
86+ EitherTable (tag <> tag') (bool l1 l2 (isLeft (expr tag))) (f a)
9887
9988
100−instance (context ~ Expr, Table Expr a) => Applicative (EitherTable context a) where
89+instance Table Expr a => Applicative (EitherTable a) where
10190 pure = rightTable
10291 (<*>) = (<.>)
10392
10493
105−instance (context ~ Expr, Table Expr a) => Bind (EitherTable context a) where
106− EitherTable tag l1 a >>- f = case f (extract a) of
94+instance Table Expr a => Bind (EitherTable a) where
95+ EitherTable tag l1 a >>- f = case f a of
10796 EitherTable tag' l2 b ->
108− EitherTable (tag <> tag') (bool l1 l2 (isRight tag)) b
97+ EitherTable (tag <> tag') (bool l1 l2 (isRight (expr tag))) b
10998
11099
111−instance (context ~ Expr, Table Expr a) => Monad (EitherTable context a) where
100+instance Table Expr a => Monad (EitherTable a) where
112101 (>>=) = (>>-)
113102
114103
115−instance (context ~ Expr, Table Expr a, Table Expr b) =>
116− Semigroup (EitherTable context a b)
117− where
104+instance (Table Expr a, Table Expr b) => Semigroup (EitherTable a b) where
118105 a <> b = bool a b (isRightTable a)
119106
120107
121108instance
122109 ( Table context a, Table context b
123− , Reifiable context, context ~ context'
124− )
125− => Table context' (EitherTable context a b)
110+ , Nullifiable context, ConstrainTag context EitherTag
111+ ) =>
112+ Table context (EitherTable a b)
126113 where
127− type Columns (EitherTable context a b) = HEitherTable (Columns a) (Columns b)
128− type Context (EitherTable context a b) = Context a
129− type FromExprs (EitherTable context a b) = Either (FromExprs a) (FromExprs b)
130− type Transpose to (EitherTable context a b) =
131− EitherTable to (Transpose to a) (Transpose to b)
132−
133− toColumns EitherTable {tag, left, right} = HEitherTable
134− { htag = hlabel $ HIdentity tag
135− , hleft = hlabel $ guard tag (== IsLeft) isLeft $ toColumns left
136− , hright = hlabel $ guard tag (== IsRight) isRight $ toColumns right
137− }
138−
139− fromColumns HEitherTable {htag, hleft, hright} = EitherTable
140− { tag = unHIdentity $ hunlabel htag
141− , left = fromColumns $ hunlabel hleft
142− , right = fromColumns $ hunlabel hright
143− }
144−
145− toResult = \case
146− Left table -> HEitherTable
147− { htag = hlabel (HIdentity (Identity IsLeft))
148− , hleft = hlabel (toResult @_ @(Nullify context a) (Just table))
149− , hright = hlabel (toResult @_ @(Nullify context b) Nothing)
150− }
151− Right table -> HEitherTable
152− { htag = hlabel (HIdentity (Identity IsRight))
153− , hleft = hlabel (toResult @_ @(Nullify context a) Nothing)
154− , hright = hlabel (toResult @_ @(Nullify context b) (Just table))
155− }
156−
157− fromResult HEitherTable {htag, hleft, hright} = case hunlabel htag of
158− HIdentity (Identity tag) -> case tag of
159− IsLeft -> maybe err Left $ fromResult @_ @(Nullify context a) (hunlabel hleft)
160− IsRight -> maybe err Right $ fromResult @_ @(Nullify context b) (hunlabel hright)
161− where
162− err = error "Either.fromColumns: mismatch between tag and data"
163−
164−
165−instance (EqTable a, EqTable b, context ~ Expr) =>
166− EqTable (EitherTable context a b)
167− where
168− eqTable = HEitherTable
169− { htag = hlabel (HIdentity Dict)
170− , hleft = hlabel (eqTable @(Nullify context a))
171− , hright = hlabel (eqTable @(Nullify context b))
172− }
114+ type Columns (EitherTable a b) = HEitherTable (Columns a) (Columns b)
115+ type Context (EitherTable a b) = Context a
173116
117+ toColumns = toColumns2 toColumns toColumns
118+ fromColumns = fromColumns2 fromColumns fromColumns
119+ reify = liftA2 bimap reify reify
120+ unreify = liftA2 bimap unreify unreify
121+
122+
123+instance
124+ ( Nullifiable from, ConstrainTag from EitherTag
125+ , Nullifiable to, ConstrainTag to EitherTag
126+ , Recontextualize from to a1 b1
127+ , Recontextualize from to a2 b2
128+ )
129+ => Recontextualize from to (EitherTable a1 a2) (EitherTable b1 b2)
130+
131+
132+instance (EqTable a, EqTable b) => EqTable (EitherTable a b) where
133+ eqTable = toColumns2 id id (rightTableWith (eqTable @a) (eqTable @b))
174134
175−instance (OrdTable a, OrdTable b, context ~ Expr) =>
176− OrdTable (EitherTable context a b)
177− where
178− ordTable = HEitherTable
179− { htag = hlabel (HIdentity Dict)
180− , hleft = hlabel (ordTable @(Nullify context a))
181− , hright = hlabel (ordTable @(Nullify context b))
182− }
183135
136+instance (OrdTable a, OrdTable b) => OrdTable (EitherTable a b) where
137+ ordTable = toColumns2 id id (rightTableWith (ordTable @a) (ordTable @b))
184138
185−instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable Expr exprs1 exprs2) =>
139+
140+type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
141+
142+
143+instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable exprs1 exprs2) =>
186144 ToExprs x (Either a b)
145+ where
146+ fromResult =
147+ bimap (fromResult @exprs1) (fromResult @exprs2) .
148+ fromColumns
149+ toResult =
150+ toColumns .
151+ bimap (toResult @exprs1) (toResult @exprs2)
187152
188153
189154-- | Test if an 'EitherTable' is a 'leftTable'.
190−isLeftTable :: EitherTable Expr a b -> Expr Bool
191−isLeftTable EitherTable {tag} = isLeft tag
155+isLeftTable :: EitherTable a b -> Expr Bool
156+isLeftTable = isLeft . expr . tag
192157
193158
194159-- | Test if an 'EitherTable' is a 'rightTable'.
195−isRightTable :: EitherTable Expr a b -> Expr Bool
196−isRightTable EitherTable {tag} = isRight tag
160+isRightTable :: EitherTable a b -> Expr Bool
161+isRightTable = isRight . expr . tag
197162
198163
199164-- | Pattern match/eliminate an 'EitherTable', by providing mappings from a
200165-- 'leftTable' and 'rightTable'.
201166eitherTable :: Table Expr c
202− => (a -> c) -> (b -> c) -> EitherTable Expr a b -> c
167+ => (a -> c) -> (b -> c) -> EitherTable a b -> c
203168eitherTable f g EitherTable {tag, left, right} =
204− bool (f (extract left)) (g (extract right)) (isRight tag)
169+ bool (f left) (g right) (isRight (expr tag))
205170
206171
207172-- | Construct a left 'EitherTable'. Like 'Left'.
208−leftTable :: Table Expr b => a -> EitherTable Expr a b
209−leftTable a = EitherTable (litExpr IsLeft) (pure a) undefined
173+leftTable :: Table Expr b => a -> EitherTable a b
174+leftTable a = EitherTable (fromExpr (litExpr IsLeft)) a undefined
210175
211176
212177-- | Construct a right 'EitherTable'. Like 'Right'.
213−rightTable :: Table Expr a => b -> EitherTable Expr a b
214−rightTable = EitherTable (litExpr IsRight) undefined . pure
215−
216−
217−-- | Lift a pair of aggregating functions to operate on an 'EitherTable'.
218−-- @leftTable@s and @rightTable@s are grouped separately.
219−aggregateEitherTable :: ()
220− => (exprs -> aggregates)
221− -> (exprs' -> aggregates')
222− -> EitherTable Expr exprs exprs'
223− -> EitherTable Aggregate aggregates aggregates'
224−aggregateEitherTable f g (EitherTable tag a b) = EitherTable
225− { tag = groupByExpr tag
226− , left = aggregateNullify f a
227− , right = aggregateNullify g b
228− }
178+rightTable :: Table Expr a => b -> EitherTable a b
179+rightTable = rightTableWith undefined
180+
181+
182+rightTableWith :: a -> b -> EitherTable a b
183+rightTableWith = EitherTable (fromExpr (litExpr IsRight))
229184
230185
231186-- | Construct a 'EitherTable' in the 'Name' context. This can be useful if you
@@ -239,5 +194,49 @@ nameEitherTable
239194 -- ^ Names of the columns in the @a@ table.
240195 -> b
241196 -- ^ Names of the columns in the @b@ table.
242− -> EitherTable Name a b
243−nameEitherTable tag left right = EitherTable tag (pure left) (pure right)
197+ -> EitherTable a b
198+nameEitherTable = EitherTable . fromName
199+
200+
201+toColumns2 ::
202+ ( HTable t
203+ , HTable u
204+ , HConstrainTag context EitherTag
205+ , HNullifiable context
206+ )
207+ => (a -> t context)
208+ -> (b -> u context)
209+ -> EitherTable a b
210+ -> HEitherTable t u context
211+toColumns2 f g EitherTable {tag, left, right} = HEitherTable
212+ { htag
213+ , hleft = hlabel $ hnullify (hnullifier tag isLeft) $ f left
214+ , hright = hlabel $ hnullify (hnullifier tag isRight) $ g right
215+ }
216+ where
217+ htag = hlabel $ HType $ hencodeTag tag
218+
219+
220+fromColumns2 ::
221+ ( HTable t
222+ , HTable u
223+ , HConstrainTag context EitherTag
224+ , HNullifiable context
225+ )
226+ => (t context -> a)
227+ -> (u context -> b)
228+ -> HEitherTable t u context
229+ -> EitherTable a b
230+fromColumns2 f g HEitherTable {htag, hleft, hright} = EitherTable
231+ { tag
232+ , left = f $ runIdentity $
233+ hunnullify (\a -> pure . hunnullifier a) $
234+ hunlabel
235+ hleft
236+ , right = g $ runIdentity $
237+ hunnullify (\a -> pure . hunnullifier a) $
238+ hunlabel
239+ hright
240+ }
241+ where
242+ tag = hdecodeTag $ unHIdentity $ hunlabel htag
src/Rel8/Table/Eq.hs+39−12
@@ -11,6 +11,7 @@
1111{-# language TypeFamilies #-}
1212{-# language TypeOperators #-}
1313{-# language UndecidableInstances #-}
14+{-# language UndecidableSuperClasses #-}
1415{-# language ViewPatterns #-}
1516
1617module Rel8.Table.Eq
@@ -27,16 +28,24 @@ import GHC.Generics ( Rep )
2728import Prelude
2829
2930-- rel8
30−import Rel8.Expr ( Expr )
31+import Rel8.Expr ( Expr, Col( E ) )
3132import Rel8.Expr.Bool ( (||.), (&&.) )
3233import Rel8.Expr.Eq ( (==.), (/=.) )
3334import Rel8.FCF ( Eval, Exp )
3435import Rel8.Generic.Record ( Record )
35−import Rel8.Generic.Table.Record ( GTable, GColumns, gtable )
36+import Rel8.Generic.Table
37+ ( GGTable, GGColumns, ggtable
38+ , GAlgebra
39+ )
40+import Rel8.Kind.Algebra ( KnownAlgebra )
3641import Rel8.Schema.Dict ( Dict( Dict ) )
37−import Rel8.Schema.HTable ( htabulateA, hfield )
38−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
42+import Rel8.Schema.HTable
43+ ( HTable, HConstrainTable
44+ , htabulateA, hfield, hdicts
45+ )
46+import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )
3947import Rel8.Schema.Null ( Sql )
48+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType, nullifier )
4049import Rel8.Table ( Table, Columns, toColumns, TColumns )
4150import Rel8.Type.Eq ( DBEq )
4251
@@ -46,14 +55,22 @@ import Rel8.Type.Eq ( DBEq )
4655-- means "all columns in a 'Table' have an instance of 'DBEq'".
4756type EqTable :: Type -> Constraint
4857class Table Expr a => EqTable a where
49− eqTable :: Columns a (Dict (Sql DBEq))
58+ eqTable :: Columns a (Dict (ConstrainDBType DBEq))
5059
5160 default eqTable ::
52− ( GTable TEqTable TColumns (Rep (Record a))
53− , Columns a ~ GColumns TColumns (Rep (Record a))
61+ ( KnownAlgebra (GAlgebra (Rep (Record a)))
62+ , Eval (GGTable (GAlgebra (Rep (Record a))) TEqTable TColumns (Dict (ConstrainDBType DBEq)) (Rep (Record a)))
63+ , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))
5464 )
55− => Columns a (Dict (Sql DBEq))
56− eqTable = gtable @TEqTable @TColumns @(Rep (Record a)) table
65+ => Columns a (Dict (ConstrainDBType DBEq))
66+ eqTable =
67+ ggtable
68+ @(GAlgebra (Rep (Record a)))
69+ @TEqTable
70+ @TColumns
71+ @(Rep (Record a))
72+ table
73+ nullifier
5774 where
5875 table (_ :: proxy x) = eqTable @x
5976
@@ -62,8 +79,18 @@ data TEqTable :: Type -> Exp Constraint
6279type instance Eval (TEqTable a) = EqTable a
6380
6481
82+instance
83+ ( HTable t
84+ , f ~ Col Expr
85+ , HConstrainTable t (ConstrainDBType DBEq)
86+ )
87+ => EqTable (t f)
88+ where
89+ eqTable = hdicts @(Columns (t f)) @(ConstrainDBType DBEq)
90+
91+
6592instance Sql DBEq a => EqTable (Expr a) where
66− eqTable = HIdentity Dict
93+ eqTable = HType Dict
6794
6895
6996instance (EqTable a, EqTable b) => EqTable (a, b)
@@ -97,7 +124,7 @@ instance
97124(toColumns -> as) ==: (toColumns -> bs) =
98125 foldl1' (&&.) $ getConst $ htabulateA $ \field ->
99126 case (hfield as field, hfield bs field) of
100− (a, b) -> case hfield (eqTable @a) field of
127+ (E a, E b) -> case hfield (eqTable @a) field of
101128 Dict -> Const (pure (a ==. b))
102129infix 4 ==:
103130
@@ -109,7 +136,7 @@ infix 4 ==:
109136(toColumns -> as) /=: (toColumns -> bs) =
110137 foldl1' (||.) $ getConst $ htabulateA $ \field ->
111138 case (hfield as field, hfield bs field) of
112− (a, b) -> case hfield (eqTable @a) field of
139+ (E a, E b) -> case hfield (eqTable @a) field of
113140 Dict -> Const (pure (a /=. b))
114141infix 4 /=:
115142
src/Rel8/Table/HKD.hs+105−65
@@ -13,7 +13,7 @@
1313
1414module Rel8.Table.HKD
1515 ( HKD( HKD )
16− , HKDable
16+ , HKDable, fromHKD, toHKD, HKDT(..)
1717 , BuildableHKD
1818 , BuildHKD, buildHKD
1919 , ConstructableHKD
@@ -27,6 +27,9 @@ where
2727
2828-- base
2929import Data.Kind ( Constraint, Type )
30+import Data.Proxy ( Proxy( Proxy ) )
31+import Data.Type.Equality ( (:~:)( Refl ) )
32+import Data.Void ( Void )
3033import GHC.Generics ( Generic, Rep, from, to )
3134import GHC.TypeLits ( Symbol )
3235import Prelude
@@ -46,118 +49,129 @@ import Rel8.Generic.Construction
4649 , GGName, ggname
4750 , GGAggregate, ggaggregate
4851 )
49−import Rel8.Generic.Map ( GMap )
50−import Rel8.Generic.Record
51− ( GRecord, GRecordable, grecord, gunrecord
52− , Record( Record ), unrecord
53− )
52+import Rel8.Generic.Map ( GMap, GMappable, gmap, gunmap )
53+import Rel8.Generic.Record ( GRecord, GRecordable, grecord, gunrecord )
5454import Rel8.Generic.Rel8able
5555 ( Rel8able
5656 , GColumns, gfromColumns, gtoColumns
57− , GFromExprs, gfromResult, gtoResult
57+ , greify, gunreify
58+ , TUnreifyContext
5859 )
5960import Rel8.Generic.Table
60− ( GGSerialize, GGColumns, GAlgebra, ggfromResult, ggtoResult
61+ ( GGTable, GGColumns, GGContext, ggfromColumns, ggtoColumns
62+ , GAlgebra
6163 )
62−import Rel8.Generic.Table.Record ( GTable, GContext )
63−import qualified Rel8.Generic.Table.Record as G
64+import Rel8.Schema.Context ( Col )
6465import qualified Rel8.Schema.Kind as K
6566import Rel8.Schema.HTable ( HTable )
6667import Rel8.Schema.Name ( Name )
68+import Rel8.Schema.Reify ( Col( Reify ), Reify, hreify, hunreify, notReify )
6769import Rel8.Schema.Result ( Result )
6870import Rel8.Table
69− ( Table, fromColumns, toColumns, fromResult, toResult
70− , TTable, TColumns, TContext
71− , TSerialize
71+ ( Table, Columns, Context, Unreify
72+ , fromColumns, toColumns, reify, unreify
73+ , TTable, TColumns, TUnreify
7274 )
75+import Rel8.Table.Serialize ( ToExprs, fromResult, toResult )
7376
7477
7578type GColumnsHKD :: Type -> K.HTable
7679type GColumnsHKD a =
77− Eval (GGColumns (GAlgebra (Rep a)) TColumns (GRecord (GMap (TColumn Expr) (Rep a))))
80+ Eval (GGColumns (GAlgebra (Rep a)) TColumns (GRecord (GMap (TColumn (Reify Result)) (Rep a))))
7881
7982
8083type HKD :: Type -> K.Rel8able
81−newtype HKD a f = HKD (GColumnsHKD a f)
84+newtype HKD a f = HKD (GColumnsHKD a (Col f))
8285
8386
8487instance HKDable a => Rel8able (HKD a) where
8588 type GColumns (HKD a) = GColumnsHKD a
86− type GFromExprs (HKD a) = a
8789
88− gfromColumns _ = HKD
89− gtoColumns _ (HKD a) = a
90+ gfromColumns = HKD
91+ gtoColumns (HKD a) = a
9092
91− gfromResult =
92− unrecord .
93− to .
94− ggfromResult
95− @(GAlgebra (Rep a))
96− @TSerialize
97− @TColumns
98− @(Eval (HKDRep a Expr))
99− @(Eval (HKDRep a Result))
100− (\(_ :: proxy x) -> fromResult @_ @x)
101−
102− gtoResult =
103− ggtoResult
104− @(GAlgebra (Rep a))
105− @TSerialize
106− @TColumns
107− @(Eval (HKDRep a Expr))
108− @(Eval (HKDRep a Result))
109− (\(_ :: proxy x) -> toResult @_ @x) .
110− from .
111− Record
93+ greify (HKD a) = HKD (hreify a)
94+ gunreify (HKD a) = HKD (hunreify a)
11295
11396
11497instance
115− ( GTable (TTable f) TColumns (GRecord (GMap (TColumn f) (Rep a)))
116− , G.GColumns TColumns (GRecord (GMap (TColumn f) (Rep a))) ~ GColumnsHKD a
117− , GContext TContext (GRecord (GMap (TColumn f) (Rep a))) ~ f
118− , GRecordable (GMap (TColumn f) (Rep a))
98+ ( KnownAlgebra (GAlgebra (Rep a))
99+ , HTable (GColumnsHKD a)
100+ , Eval (GGTable (GAlgebra (Rep a)) (TTable (Reify f)) TColumns (Col (Reify f)) (GRecord (GMap (TColumn (Reify f)) (Rep a))))
101+ , Eval (GGColumns (GAlgebra (Rep a)) TColumns (GRecord (GMap (TColumn (Reify f)) (Rep a)))) ~ GColumnsHKD a
102+ , Eval (GGContext (GAlgebra (Rep a)) TUnreifyContext (GRecord (GMap (TColumn (Reify f)) (Rep a)))) ~ f
103+ , GRecordable (GMap (TColumn (Reify f)) (Rep a))
104+ , GMappable (TTable (Reify f)) (GMap (TColumn (Reify f)) (Rep a))
105+ , GMap TUnreify (GMap (TColumn (Reify f)) (Rep a)) ~ GMap (TColumn f) (Rep a)
119106 )
120107 => Generic (HKD a f)
121108 where
122109 type Rep (HKD a f) = GMap (TColumn f) (Rep a)
123110
124111 from =
125− gunrecord @(GMap (TColumn f) (Rep a)) .
126− G.gfromColumns
127− @(TTable f)
112+ gmap @(TTable (Reify f)) (Proxy @TUnreify) (unreify Refl) .
113+ gunrecord @(GMap (TColumn (Reify f)) (Rep a)) .
114+ ggfromColumns
115+ @(GAlgebra (Rep a))
116+ @(TTable (Reify f))
128117 @TColumns
118+ (\(Reify a) -> a)
119+ Reify
129120 fromColumns .
121+ hreify .
130122 (\(HKD a) -> a)
131123
132124 to =
133125 HKD .
134− G.gtoColumns
135− @(TTable f)
126+ hunreify .
127+ ggtoColumns
128+ @(GAlgebra (Rep a))
129+ @(TTable (Reify f))
136130 @TColumns
131+ (\(Reify a) -> a)
132+ Reify
137133 toColumns .
138− grecord @(GMap (TColumn f) (Rep a))
134+ grecord @(GMap (TColumn (Reify f)) (Rep a)) .
135+ gunmap @(TTable (Reify f)) (Proxy @TUnreify) (reify Refl)
136+
137+
138+type HKDT :: Type -> Type
139+newtype HKDT a = HKDT
140+ { unHKDT :: a
141+ }
142+
143+
144+instance HKDable a => Table Result (HKDT a) where
145+ type Columns (HKDT a) = GColumnsHKD a
146+ type Context (HKDT a) = Result
147+ type Unreify (HKDT a) = Void
148+
149+ fromColumns = HKDT . fromHKD . HKD
150+ toColumns = (\(HKD a) -> a) . toHKD . (\(HKDT a) -> a)
151+ reify = notReify
152+ unreify = notReify
139153
140154
141−type HKDable :: Type -> Constraint
142−class
143− ( Generic (Record a)
144− , HTable (GColumns (HKD a))
145− , 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)
148− )
149− => HKDable a
150155instance
151− ( Generic (Record a)
152− , HTable (GColumns (HKD a))
153− , 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)
156+ ( Table Expr (HKD a Expr)
157+ , Columns (HKD a Expr) ~ GColumns (HKD a)
158+ , HKDable a
159+ , x ~ HKD a Expr
156160 )
157− => HKDable a
161+ => ToExprs x (HKDT a)
162+ where
163+ toResult = (\(HKD a) -> a) . toHKD . (\(HKDT a) -> a)
164+ fromResult = HKDT . fromHKD . HKD
165+
166+
167+fromHKD :: HKDable a => HKD a Result -> a
168+fromHKD = to . gunmap @Top (Proxy @(TColumn Result)) id . from
169+
170+
171+toHKD :: HKDable a => a -> HKD a Result
172+toHKD = to . gmap @Top (Proxy @(TColumn Result)) id . from
158173
159174
160−type Top_ :: Constraint
161175class Top_
162176instance Top_
163177
@@ -166,6 +180,32 @@ data Top :: Type -> Exp Constraint
166180type instance Eval (Top _) = Top_
167181
168182
183+class
184+ ( Generic a
185+ , HTable (GColumns (HKD a))
186+ , KnownAlgebra (GAlgebra (Rep a))
187+ , Eval (GGTable (GAlgebra (Rep a)) (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRecord (GMap (TColumn (Reify Result)) (Rep a))))
188+ , Eval (GGContext (GAlgebra (Rep a)) TUnreifyContext (GRecord (GMap (TColumn (Reify Result)) (Rep a)))) ~ Result
189+ , GRecordable (GMap (TColumn (Reify Result)) (Rep a))
190+ , GMappable Top (Rep a)
191+ , GMappable (TTable (Reify Result)) (GMap (TColumn (Reify Result)) (Rep a))
192+ , GMap TUnreify (GMap (TColumn (Reify Result)) (Rep a)) ~ GMap (TColumn Result) (Rep a)
193+ )
194+ => HKDable a
195+instance
196+ ( Generic a
197+ , HTable (GColumns (HKD a))
198+ , KnownAlgebra (GAlgebra (Rep a))
199+ , Eval (GGTable (GAlgebra (Rep a)) (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRecord (GMap (TColumn (Reify Result)) (Rep a))))
200+ , Eval (GGContext (GAlgebra (Rep a)) TUnreifyContext (GRecord (GMap (TColumn (Reify Result)) (Rep a)))) ~ Result
201+ , GRecordable (GMap (TColumn (Reify Result)) (Rep a))
202+ , GMappable Top (Rep a)
203+ , GMappable (TTable (Reify Result)) (GMap (TColumn (Reify Result)) (Rep a))
204+ , GMap TUnreify (GMap (TColumn (Reify Result)) (Rep a)) ~ GMap (TColumn Result) (Rep a)
205+ )
206+ => HKDable a
207+
208+
169209type BuildableHKD :: Type -> Symbol -> Constraint
170210class GGBuildable (GAlgebra (Rep a)) name (HKDRep a) => BuildableHKD a name
171211instance GGBuildable (GAlgebra (Rep a)) name (HKDRep a) => BuildableHKD a name
src/Rel8/Table/List.hs+55−65
@@ -1,4 +1,3 @@
1−{-# language DataKinds #-}
21{-# language FlexibleContexts #-}
32{-# language FlexibleInstances #-}
43{-# language MultiParamTypeClasses #-}
@@ -11,36 +10,30 @@
1110
1211module Rel8.Table.List
1312 ( ListTable(..)
14− , ($*)
15− , listTable
16− , nameListTable
13+ , listTable, nameListTable
1714 )
1815where
1916
2017-- base
2118import Data.Functor.Identity ( Identity( Identity ) )
2219import Data.Kind ( Type )
20+import Data.Type.Equality ( (:~:)( Refl ) )
2321import Prelude
2422
2523-- rel8
26−import Rel8.Expr ( Expr )
24+import Rel8.Expr ( Expr, Col( 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− )
35−import qualified Rel8.Schema.Kind as K
36−import Rel8.Schema.Name ( Name( Name ) )
28+import Rel8.Schema.HTable.Vectorize ( happend, hempty, hvectorize )
29+import Rel8.Schema.Name ( Col( N ), Name( Name ) )
3730import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
38−import Rel8.Schema.Result ( vectorizer, unvectorizer )
39−import Rel8.Schema.Spec ( Spec(..) )
31+import Rel8.Schema.Spec ( SSpec(..) )
32+import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullity )
33+import Rel8.Schema.Reify ( hreify, hunreify )
4034import Rel8.Table
4135 ( Table, Context, Columns, fromColumns, toColumns
42− , FromExprs, fromResult, toResult
43− , Transpose
36+ , reify, unreify
4437 )
4538import Rel8.Table.Alternative
4639 ( AltTable, (<|>:)
@@ -48,90 +41,87 @@ import Rel8.Table.Alternative
4841 )
4942import Rel8.Table.Eq ( EqTable, eqTable )
5043import Rel8.Table.Ord ( OrdTable, ordTable )
51−import Rel8.Table.Projection
52− ( Projectable, Projecting, Projection, project, apply
53− )
54−import Rel8.Table.Serialize ( ToExprs )
44+import Rel8.Table.Recontextualize ( Recontextualize )
45+import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
46+import Rel8.Table.Unreify ( Unreifies )
5547
5648
5749-- | A @ListTable@ value contains zero or more instances of @a@. You construct
5850-- @ListTable@s with 'Rel8.many' or 'Rel8.listAgg'.
59−type ListTable :: K.Context -> Type -> Type
60−newtype ListTable context a =
61− ListTable (HListTable (Columns a) (Context a))
62−
63−
64−instance Projectable (ListTable context) where
65− project f (ListTable a) = ListTable (hproject (apply f) a)
51+type ListTable :: Type -> Type
52+newtype ListTable a = ListTable (HListTable (Columns a) (Col (Context a)))
6653
6754
68−instance (Table context a, context ~ context') =>
69− Table context' (ListTable context a)
55+instance (Table context a, Unreifies context a) =>
56+ Table context (ListTable a)
7057 where
71− type Columns (ListTable context a) = HListTable (Columns a)
72− type Context (ListTable context a) = Context a
73− type FromExprs (ListTable context a) = [FromExprs a]
74− type Transpose to (ListTable context a) = ListTable to (Transpose to a)
58+ type Columns (ListTable a) = HListTable (Columns a)
59+ type Context (ListTable a) = Context a
7560
7661 fromColumns = ListTable
7762 toColumns (ListTable a) = a
78− fromResult = fmap (fromResult @_ @a) . hunvectorize unvectorizer
79− toResult = hvectorize vectorizer . fmap (toResult @_ @a)
63+
64+ reify Refl (ListTable a) = ListTable (hreify a)
65+ unreify Refl (ListTable a) = ListTable (hunreify a)
66+
67+
68+instance
69+ ( Unreifies from a, Unreifies to b
70+ , Recontextualize from to a b
71+ )
72+ => Recontextualize from to (ListTable a) (ListTable b)
8073
8174
82−instance (EqTable a, context ~ Expr) => EqTable (ListTable context a) where
75+instance EqTable a => EqTable (ListTable a) where
8376 eqTable =
8477 hvectorize
85− (\Spec {nullity} (Identity Dict) -> case nullity of
86− Null -> Dict
87− NotNull -> Dict)
78+ (\SSpec {} (Identity dict) -> case dbTypeDict dict of
79+ Dict -> case dbTypeNullity dict of
80+ Null -> Dict
81+ NotNull -> Dict)
8882 (Identity (eqTable @a))
8983
9084
91−instance (OrdTable a, context ~ Expr) => OrdTable (ListTable context a) where
85+instance OrdTable a => OrdTable (ListTable a) where
9286 ordTable =
9387 hvectorize
94− (\Spec {nullity} (Identity Dict) -> case nullity of
95− Null -> Dict
96− NotNull -> Dict)
88+ (\SSpec {} (Identity dict) -> case dbTypeDict dict of
89+ Dict -> case dbTypeNullity dict of
90+ Null -> Dict
91+ NotNull -> Dict)
9792 (Identity (ordTable @a))
9893
9994
100−instance (ToExprs exprs a, context ~ Expr) =>
101− ToExprs (ListTable context exprs) [a]
95+type instance FromExprs (ListTable a) = [FromExprs a]
10296
10397
104−instance context ~ Expr => AltTable (ListTable context) where
105− (<|>:) = (<>)
98+instance ToExprs exprs a => ToExprs (ListTable exprs) [a] where
99+ fromResult = fmap (fromResult @exprs) . fromColumns
100+ toResult = toColumns . fmap (toResult @exprs)
106101
107102
108−instance context ~ Expr => AlternativeTable (ListTable context) where
109− emptyTable = mempty
103+instance AltTable ListTable where
104+ (<|>:) = (<>)
110105
111106
112−instance (context ~ Expr, Table Expr a) => Semigroup (ListTable context a)
113− where
114− ListTable as <> ListTable bs = ListTable $ happend (const sappend) as bs
107+instance AlternativeTable ListTable where
108+ emptyTable = mempty
115109
116110
117−instance (context ~ Expr, Table Expr a) =>
118− Monoid (ListTable context a)
119− where
120− mempty = ListTable $ hempty $ \Spec {info} -> sempty info
111+instance Table Expr a => Semigroup (ListTable a) where
112+ ListTable as <> ListTable bs = ListTable $
113+ happend (\_ _ (E a) (E b) -> E (sappend a b)) as bs
121114
122115
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 $*
116+instance Table Expr a => Monoid (ListTable a) where
117+ mempty = ListTable $ hempty $ \_ -> E . sempty
128118
129119
130120-- | Construct a @ListTable@ from a list of expressions.
131−listTable :: Table Expr a => [a] -> ListTable Expr a
121+listTable :: Table Expr a => [a] -> ListTable a
132122listTable =
133123 ListTable .
134− hvectorize (\Spec {info} -> slistOf info) .
124+ hvectorize (\SSpec {info} -> E . slistOf info . fmap unE) .
135125 fmap toColumns
136126
137127
@@ -141,9 +131,9 @@ listTable =
141131nameListTable
142132 :: Table Name a
143133 => a -- ^ The names of the columns of elements of the list.
144− -> ListTable Name a
134+ -> ListTable a
145135nameListTable =
146136 ListTable .
147− hvectorize (\_ (Identity (Name a)) -> Name a) .
137+ hvectorize (\_ (Identity (N (Name a))) -> N (Name a)) .
148138 pure .
149139 toColumns
src/Rel8/Table/Maybe.hs+113−110
@@ -3,6 +3,7 @@
33{-# language DerivingStrategies #-}
44{-# language FlexibleContexts #-}
55{-# language FlexibleInstances #-}
6+{-# language LambdaCase #-}
67{-# language MultiParamTypeClasses #-}
78{-# language NamedFieldPuns #-}
89{-# language ScopedTypeVariables #-}
@@ -15,42 +16,36 @@ module Rel8.Table.Maybe
1516 ( MaybeTable(..)
1617 , maybeTable, nothingTable, justTable
1718 , isNothingTable, isJustTable
18− , fromMaybeTable
1919 , ($?)
20− , aggregateMaybeTable
2120 , nameMaybeTable
2221 )
2322where
2423
2524-- base
26−import Data.Functor ( ($>) )
27−import Data.Functor.Identity ( Identity( Identity ) )
25+import Data.Functor.Identity ( runIdentity )
2826import Data.Kind ( Type )
29−import Data.Maybe ( fromMaybe, isJust )
3027import Prelude hiding ( null, undefined )
3128
32−-- comonad
33−import Control.Comonad ( extract )
34−
3529-- rel8
36−import Rel8.Aggregate ( Aggregate )
3730import Rel8.Expr ( Expr )
38−import Rel8.Expr.Aggregate ( groupByExpr )
3931import Rel8.Expr.Bool ( boolExpr )
4032import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )
41−import Rel8.Kind.Context ( Reifiable )
42−import Rel8.Schema.Dict ( Dict( Dict ) )
43−import qualified Rel8.Schema.Kind as K
33+import Rel8.Schema.Context.Nullify
34+ ( Nullifiable, ConstrainTag
35+ , HNullifiable, HConstrainTag
36+ , hencodeTag, hdecodeTag
37+ , hnullifier, hunnullifier
38+ )
39+import Rel8.Schema.HTable ( HTable )
4440import Rel8.Schema.HTable.Identity ( HIdentity(..) )
4541import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
4642import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
43+import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
4744import Rel8.Schema.Name ( Name )
48−import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
49−import qualified Rel8.Schema.Null as N
45+import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql, nullable )
5046import Rel8.Table
5147 ( Table, Columns, Context, fromColumns, toColumns
52− , FromExprs, fromResult, toResult
53− , Transpose
48+ , reify, unreify
5449 )
5550import Rel8.Table.Alternative
5651 ( AltTable, (<|>:)
@@ -59,12 +54,12 @@ import Rel8.Table.Alternative
5954import Rel8.Table.Bool ( bool )
6055import Rel8.Table.Eq ( EqTable, eqTable )
6156import Rel8.Table.Ord ( OrdTable, ordTable )
62−import Rel8.Table.Projection ( Projectable, project )
63−import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )
64−import Rel8.Table.Serialize ( ToExprs )
57+import Rel8.Table.Recontextualize ( Recontextualize )
58+import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
59+import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )
6560import Rel8.Table.Undefined ( undefined )
6661import Rel8.Type ( DBType )
67−import Rel8.Type.Tag ( MaybeTag( IsJust ) )
62+import Rel8.Type.Tag ( MaybeTag )
6863
6964-- semigroupoids
7065import Data.Functor.Apply ( Apply, (<.>) )
@@ -79,160 +74,135 @@ import Data.Functor.Bind ( Bind, (>>-) )
7974-- entirely of nulls, you can't distinguish if you matched an all null row, or
8075-- if the match failed. For this reason @MaybeTable@ contains an extra field -
8176-- a "nullTag" - to track whether or not the outer join produced any rows.
82−type MaybeTable :: K.Context -> Type -> Type
83−data MaybeTable context a = MaybeTable
84− { tag :: context (Maybe MaybeTag)
85− , just :: Nullify context a
77+type MaybeTable :: Type -> Type
78+data MaybeTable a = MaybeTable
79+ { tag :: Tag "isJust" (Maybe MaybeTag)
80+ , just :: a
8681 }
8782 deriving stock Functor
8883
8984
90−instance Projectable (MaybeTable context) where
91− project f (MaybeTable tag a) = MaybeTable tag (project f a)
92−
93−
94−instance context ~ Expr => Apply (MaybeTable context) where
95− MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f <.> a)
85+instance Apply MaybeTable where
86+ MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f a)
9687
9788
9889-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:
9990-- 'Rel8.traverseMaybeTable'.
100−instance context ~ Expr => Applicative (MaybeTable context) where
91+instance Applicative MaybeTable where
10192 (<*>) = (<.>)
10293 pure = justTable
10394
10495
105−instance context ~ Expr => Bind (MaybeTable context) where
106− MaybeTable tag a >>- f = case f (extract a) of
96+instance Bind MaybeTable where
97+ MaybeTable tag a >>- f = case f a of
10798 MaybeTable tag' b -> MaybeTable (tag <> tag') b
10899
109100
110101-- | Has the same behavior as the @Monad@ instance for @Maybe@.
111−instance context ~ Expr => Monad (MaybeTable context) where
102+instance Monad MaybeTable where
112103 (>>=) = (>>-)
113104
114105
115−instance context ~ Expr => AltTable (MaybeTable context) where
116− ma <|>: mb = bool ma mb (isNothingTable ma)
106+instance AltTable MaybeTable where
107+ ma@(MaybeTable tag a) <|>: MaybeTable tag' b = MaybeTable
108+ { tag = (tag <> tag')
109+ { expr = boolExpr (expr tag) (expr tag') condition
110+ }
111+ , just = bool a b condition
112+ }
113+ where
114+ condition = isNothingTable ma
117115
118116
119−instance context ~ Expr => AlternativeTable (MaybeTable context) where
117+instance AlternativeTable MaybeTable where
120118 emptyTable = nothingTable
121119
122120
123−instance (context ~ Expr, Table Expr a, Semigroup a) =>
124− Semigroup (MaybeTable context a)
125− where
121+instance (Table Expr a, Semigroup a) => Semigroup (MaybeTable a) where
126122 ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma
127123
128124
129−instance (context ~ Expr, Table Expr a, Semigroup a) =>
130− Monoid (MaybeTable context a)
131− where
125+instance (Table Expr a, Semigroup a) => Monoid (MaybeTable a) where
132126 mempty = nothingTable
133127
134128
135−instance (Table context a, Reifiable context, context ~ context') =>
136− Table context' (MaybeTable context a)
129+instance
130+ ( Table context a
131+ , Nullifiable context
132+ , ConstrainTag context MaybeTag
133+ ) => Table context (MaybeTable a)
137134 where
138− type Columns (MaybeTable context a) = HMaybeTable (Columns a)
139− type Context (MaybeTable context a) = Context a
140− type FromExprs (MaybeTable context a) = Maybe (FromExprs a)
141− type Transpose to (MaybeTable context a) = MaybeTable to (Transpose to a)
142−
143− toColumns MaybeTable {tag, just} = HMaybeTable
144− { htag = hlabel $ HIdentity tag
145− , hjust = hlabel $ guard tag isJust isNonNull $ toColumns just
146− }
135+ type Columns (MaybeTable a) = HMaybeTable (Columns a)
136+ type Context (MaybeTable a) = Context a
147137
148− fromColumns HMaybeTable {htag, hjust} = MaybeTable
149− { tag = unHIdentity $ hunlabel htag
150− , just = fromColumns $ hunlabel hjust
151− }
138+ toColumns = toColumns1 toColumns
139+ fromColumns = fromColumns1 fromColumns
140+ reify = fmap fmap reify
141+ unreify = fmap fmap unreify
152142
153− toResult ma = HMaybeTable
154− { htag = hlabel (HIdentity (Identity (IsJust <$ ma)))
155− , hjust = hlabel (toResult @_ @(Nullify context a) ma)
156− }
157143
158− fromResult HMaybeTable {htag, hjust} = case hunlabel htag of
159− HIdentity (Identity tag) -> tag $>
160− fromMaybe err (fromResult @_ @(Nullify context a) (hunlabel hjust))
161− where
162− err = error "Maybe.fromColumns: mismatch between tag and data"
144+instance
145+ ( Nullifiable from, ConstrainTag from MaybeTag
146+ , Nullifiable to, ConstrainTag to MaybeTag
147+ , Recontextualize from to a b
148+ )
149+ => Recontextualize from to (MaybeTable a) (MaybeTable b)
163150
164151
165−instance (EqTable a, context ~ Expr) => EqTable (MaybeTable context a) where
166− eqTable = HMaybeTable
167− { htag = hlabel (HIdentity Dict)
168− , hjust = hlabel (eqTable @(Nullify context a))
169− }
152+instance EqTable a => EqTable (MaybeTable a) where
153+ eqTable = toColumns1 id (justTable (eqTable @a))
170154
171155
172−instance (OrdTable a, context ~ Expr) => OrdTable (MaybeTable context a) where
173− ordTable = HMaybeTable
174− { htag = hlabel (HIdentity Dict)
175− , hjust = hlabel (ordTable @(Nullify context a))
176− }
156+instance OrdTable a => OrdTable (MaybeTable a) where
157+ ordTable = toColumns1 id (justTable (ordTable @a))
177158
178159
179−instance (ToExprs exprs a, context ~ Expr) =>
180− ToExprs (MaybeTable context exprs) (Maybe a)
160+type instance FromExprs (MaybeTable a) = Maybe (FromExprs a)
161+
162+
163+instance ToExprs exprs a => ToExprs (MaybeTable exprs) (Maybe a) where
164+ fromResult = fmap (fromResult @exprs) . fromColumns
165+ toResult = toColumns . fmap (toResult @exprs)
181166
182167
183168-- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.
184−isNothingTable :: MaybeTable Expr a -> Expr Bool
185−isNothingTable (MaybeTable tag _) = isNull tag
169+isNothingTable :: MaybeTable a -> Expr Bool
170+isNothingTable (MaybeTable tag _) = isNull (expr tag)
186171
187172
188173-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.
189−isJustTable :: MaybeTable Expr a -> Expr Bool
190−isJustTable (MaybeTable tag _) = isNonNull tag
174+isJustTable :: MaybeTable a -> Expr Bool
175+isJustTable (MaybeTable tag _) = isNonNull (expr tag)
191176
192177
193178-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.
194−maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable Expr a -> b
195−maybeTable b f ma@(MaybeTable _ a) = bool (f (extract a)) b (isNothingTable ma)
179+maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable a -> b
180+maybeTable b f ma@(MaybeTable _ a) = bool (f a) b (isNothingTable ma)
196181{-# INLINABLE maybeTable #-}
197182
198183
199184-- | The null table. Like 'Nothing'.
200−nothingTable :: Table Expr a => MaybeTable Expr a
201−nothingTable = MaybeTable null (pure undefined)
185+nothingTable :: Table Expr a => MaybeTable a
186+nothingTable = MaybeTable (fromExpr null) undefined
202187
203188
204189-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use
205190-- 'pure'.
206−justTable :: 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
191+justTable :: a -> MaybeTable a
192+justTable = MaybeTable (fromExpr mempty)
213193
214194
215195-- | Project a single expression out of a 'MaybeTable'. You can think of this
216196-- operator like the '$' operator, but it also has the ability to return
217197-- @null@.
218198($?) :: forall a b. Sql DBType b
219− => (a -> Expr b) -> MaybeTable Expr a -> Expr (N.Nullify b)
199+ => (a -> Expr b) -> MaybeTable a -> Expr (Nullify b)
220200f $? ma@(MaybeTable _ a) = case nullable @b of
221− Null -> boolExpr (f (extract a)) null (isNothingTable ma)
222− NotNull -> boolExpr (nullify (f (extract a))) null (isNothingTable ma)
201+ Null -> boolExpr (f a) null (isNothingTable ma)
202+ NotNull -> boolExpr (nullify (f a)) null (isNothingTable ma)
223203infixl 4 $?
224204
225205
226−-- | Lift an aggregating function to operate on a 'MaybeTable'.
227−-- @nothingTable@s and @justTable@s are grouped separately.
228−aggregateMaybeTable :: ()
229− => (exprs -> aggregates)
230− -> MaybeTable Expr exprs
231− -> MaybeTable Aggregate aggregates
232−aggregateMaybeTable f (MaybeTable tag a) =
233− MaybeTable (groupByExpr tag) (aggregateNullify f a)
234−
235−
236206-- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you
237207-- have a 'MaybeTable' that you are storing in a table and need to construct a
238208-- 'TableSchema'.
@@ -242,5 +212,38 @@ nameMaybeTable
242212 -- 'nothingTable'.
243213 -> a
244214 -- ^ Names of the columns in @a@.
245− -> MaybeTable Name a
246−nameMaybeTable tag = MaybeTable tag . pure
215+ -> MaybeTable a
216+nameMaybeTable = MaybeTable . fromName
217+
218+
219+toColumns1 ::
220+ ( HTable t
221+ , HConstrainTag context MaybeTag
222+ , HNullifiable context
223+ )
224+ => (a -> t context)
225+ -> MaybeTable a
226+ -> HMaybeTable t context
227+toColumns1 f MaybeTable {tag, just} = HMaybeTable
228+ { htag
229+ , hjust = hlabel $ hnullify (hnullifier tag isNonNull) $ f just
230+ }
231+ where
232+ htag = hlabel (HType (hencodeTag tag))
233+
234+
235+fromColumns1 ::
236+ ( HTable t
237+ , HConstrainTag context MaybeTag
238+ , HNullifiable context
239+ )
240+ => (t context -> a)
241+ -> HMaybeTable t context
242+ -> MaybeTable a
243+fromColumns1 f HMaybeTable {htag, hjust} = MaybeTable
244+ { tag
245+ , just = f $ runIdentity $
246+ hunnullify (\a -> pure . hunnullifier a) (hunlabel hjust)
247+ }
248+ where
249+ tag = hdecodeTag (unHIdentity (hunlabel htag))
src/Rel8/Table/Name.hs+20−11
@@ -1,17 +1,14 @@
1−{-# language DataKinds #-}
21{-# language FlexibleContexts #-}
3−{-# language FlexibleInstances #-}
4−{-# language MultiParamTypeClasses #-}
52{-# language NamedFieldPuns #-}
63{-# language ScopedTypeVariables #-}
74{-# language TypeApplications #-}
85{-# language TypeFamilies #-}
9−{-# language UndecidableInstances #-}
106{-# language ViewPatterns #-}
117
128module Rel8.Table.Name
139 ( namesFromLabels
1410 , namesFromLabelsWith
11+ , showExprs
1512 , showLabels
1613 , showNames
1714 )
@@ -24,11 +21,16 @@ import Data.List.NonEmpty ( NonEmpty, intersperse, nonEmpty )
2421import Data.Maybe ( fromMaybe )
2522import Prelude
2623
24+-- opaleye
25+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
26+
2727-- rel8
28+import Rel8.Expr ( Expr, Col( E ) )
29+import Rel8.Expr.Opaleye ( toPrimExpr )
2830import Rel8.Schema.HTable ( htabulate, htabulateA, hfield, hspecs )
29−import Rel8.Schema.Name ( Name( Name ) )
30−import Rel8.Schema.Spec ( Spec(..) )
31−import Rel8.Table ( Table(..) )
31+import Rel8.Schema.Name ( Name( Name ), Col( N ) )
32+import Rel8.Schema.Spec ( SSpec(..) )
33+import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
3234
3335
3436-- | Construct a table in the 'Name' context containing the names of all
@@ -60,19 +62,26 @@ namesFromLabelsWith :: Table Name a
6062 => (NonEmpty String -> String) -> a
6163namesFromLabelsWith f = fromColumns $ htabulate $ \field ->
6264 case hfield hspecs field of
63− Spec {labels} -> Name (f (renderLabels labels))
65+ SSpec {labels} -> N (Name (f (renderLabels labels)))
66+
67+
68+showExprs :: Table Expr a => a -> [(String, Opaleye.PrimExpr)]
69+showExprs as = case (namesFromLabels, toColumns as) of
70+ (names, exprs) -> getConst $ htabulateA $ \field ->
71+ case (hfield names field, hfield exprs field) of
72+ (N (Name name), E expr) -> Const [(name, toPrimExpr expr)]
6473
6574
6675showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]
6776showLabels _ = getConst $
6877 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
69− Spec {labels} -> Const (pure (renderLabels labels))
78+ SSpec {labels} -> Const [renderLabels labels]
7079
7180
72−showNames :: forall a. Table Name a => a -> NonEmpty String
81+showNames :: forall a. Table Name a => a -> [String]
7382showNames (toColumns -> names) = getConst $
7483 htabulateA @(Columns a) $ \field -> case hfield names field of
75− Name name -> Const (pure name)
84+ N (Name name) -> Const [name]
7685
7786
7887renderLabels :: [String] -> NonEmpty String
src/Rel8/Table/NonEmpty.hs+54−66
@@ -1,4 +1,3 @@
1−{-# language DataKinds #-}
21{-# language FlexibleContexts #-}
32{-# language FlexibleInstances #-}
43{-# language MultiParamTypeClasses #-}
@@ -11,9 +10,7 @@
1110
1211module Rel8.Table.NonEmpty
1312 ( NonEmptyTable(..)
14− , ($+)
15− , nonEmptyTable
16− , nameNonEmptyTable
13+ , nonEmptyTable, nameNonEmptyTable
1714 )
1815where
1916
@@ -21,111 +18,102 @@ where
2118import Data.Functor.Identity ( Identity( Identity ) )
2219import Data.Kind ( Type )
2320import Data.List.NonEmpty ( NonEmpty )
24−import Prelude hiding ( id )
21+import Data.Type.Equality ( (:~:)( Refl ) )
22+import Prelude
2523
2624-- rel8
27−import Rel8.Expr ( Expr )
25+import Rel8.Expr ( Expr, Col( 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− )
36−import qualified Rel8.Schema.Kind as K
37−import Rel8.Schema.Name ( Name( Name ) )
29+import Rel8.Schema.HTable.Vectorize ( happend, hvectorize )
30+import Rel8.Schema.Name ( Col( N ), Name( Name ) )
3831import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
39−import Rel8.Schema.Result ( vectorizer, unvectorizer )
40−import Rel8.Schema.Spec ( Spec(..) )
32+import Rel8.Schema.Reify ( hreify, hunreify )
33+import Rel8.Schema.Spec ( SSpec(..) )
34+import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullity )
4135import Rel8.Table
4236 ( Table, Context, Columns, fromColumns, toColumns
43− , FromExprs, fromResult, toResult
44− , Transpose
37+ , reify, unreify
4538 )
4639import Rel8.Table.Alternative ( AltTable, (<|>:) )
4740import Rel8.Table.Eq ( EqTable, eqTable )
4841import Rel8.Table.Ord ( OrdTable, ordTable )
49−import Rel8.Table.Projection
50− ( Projectable, Projecting, Projection, project, apply
51− )
52−import Rel8.Table.Serialize ( ToExprs )
42+import Rel8.Table.Recontextualize ( Recontextualize )
43+import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
44+import Rel8.Table.Unreify ( Unreifies )
5345
5446
5547-- | A @NonEmptyTable@ value contains one or more instances of @a@. You
5648-- construct @NonEmptyTable@s with 'Rel8.some' or 'nonEmptyAgg'.
57−type NonEmptyTable :: K.Context -> Type -> Type
58−newtype NonEmptyTable context a =
59− NonEmptyTable (HNonEmptyTable (Columns a) (Context a))
60−
61−
62−instance Projectable (NonEmptyTable context) where
63− project f (NonEmptyTable a) = NonEmptyTable (hproject (apply f) a)
49+type NonEmptyTable :: Type -> Type
50+newtype NonEmptyTable a =
51+ NonEmptyTable (HNonEmptyTable (Columns a) (Col (Context a)))
6452
6553
66−instance (Table context a, context ~ context') =>
67− Table context' (NonEmptyTable context a)
54+instance (Table context a, Unreifies context a) =>
55+ Table context (NonEmptyTable a)
6856 where
69− type Columns (NonEmptyTable context a) = HNonEmptyTable (Columns a)
70− type Context (NonEmptyTable context a) = Context a
71− type FromExprs (NonEmptyTable context a) = NonEmpty (FromExprs a)
72− type Transpose to (NonEmptyTable context a) =
73− NonEmptyTable to (Transpose to a)
57+ type Columns (NonEmptyTable a) = HNonEmptyTable (Columns a)
58+ type Context (NonEmptyTable a) = Context a
7459
7560 fromColumns = NonEmptyTable
7661 toColumns (NonEmptyTable a) = a
77− fromResult = fmap (fromResult @_ @a) . hunvectorize unvectorizer
78− toResult = hvectorize vectorizer . fmap (toResult @_ @a)
7962
63+ reify Refl (NonEmptyTable a) = NonEmptyTable (hreify a)
64+ unreify Refl (NonEmptyTable a) = NonEmptyTable (hunreify a)
8065
81−instance (EqTable a, context ~ Expr) =>
82− EqTable (NonEmptyTable context a)
83− where
66+
67+instance
68+ ( Unreifies from a, Unreifies to b
69+ , Recontextualize from to a b
70+ )
71+ => Recontextualize from to (NonEmptyTable a) (NonEmptyTable b)
72+
73+
74+instance EqTable a => EqTable (NonEmptyTable a) where
8475 eqTable =
8576 hvectorize
86− (\Spec {nullity} (Identity Dict) -> case nullity of
87− Null -> Dict
88− NotNull -> Dict)
77+ (\SSpec {} (Identity dict) -> case dbTypeDict dict of
78+ Dict -> case dbTypeNullity dict of
79+ Null -> Dict
80+ NotNull -> Dict)
8981 (Identity (eqTable @a))
9082
9183
92−instance (OrdTable a, context ~ Expr) =>
93− OrdTable (NonEmptyTable context a)
94− where
84+instance OrdTable a => OrdTable (NonEmptyTable a) where
9585 ordTable =
9686 hvectorize
97− (\Spec {nullity} (Identity Dict) -> case nullity of
98− Null -> Dict
99− NotNull -> Dict)
87+ (\SSpec {} (Identity dict) -> case dbTypeDict dict of
88+ Dict -> case dbTypeNullity dict of
89+ Null -> Dict
90+ NotNull -> Dict)
10091 (Identity (ordTable @a))
10192
10293
103−instance (ToExprs exprs a, context ~ Expr) =>
104− ToExprs (NonEmptyTable context exprs) (NonEmpty a)
94+type instance FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)
10595
10696
107−instance context ~ Expr => AltTable (NonEmptyTable context) where
108− (<|>:) = (<>)
97+instance ToExprs exprs a => ToExprs (NonEmptyTable exprs) (NonEmpty a)
98+ where
99+ fromResult = fmap (fromResult @exprs) . fromColumns
100+ toResult = toColumns . fmap (toResult @exprs)
109101
110102
111−instance (Table Expr a, context ~ Expr) => Semigroup (NonEmptyTable context a)
112− where
113− NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $
114− happend (const sappend1) as bs
103+instance AltTable NonEmptyTable where
104+ (<|>:) = (<>)
115105
116106
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 $+
107+instance Table Expr a => Semigroup (NonEmptyTable a) where
108+ NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $
109+ happend (\_ _ (E a) (E b) -> E (sappend1 a b)) as bs
122110
123111
124112-- | Construct a @NonEmptyTable@ from a non-empty list of expressions.
125−nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable Expr a
113+nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable a
126114nonEmptyTable =
127115 NonEmptyTable .
128− hvectorize (\Spec {info} -> snonEmptyOf info) .
116+ hvectorize (\SSpec {info} -> E . snonEmptyOf info . fmap unE) .
129117 fmap toColumns
130118
131119
@@ -135,9 +123,9 @@ nonEmptyTable =
135123nameNonEmptyTable
136124 :: Table Name a
137125 => a -- ^ The names of the columns of elements of the list.
138− -> NonEmptyTable Name a
126+ -> NonEmptyTable a
139127nameNonEmptyTable =
140128 NonEmptyTable .
141− hvectorize (\_ (Identity (Name a)) -> Name a) .
129+ hvectorize (\_ (Identity (N (Name a))) -> N (Name a)) .
142130 pure .
143131 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.hsdeleted−211
@@ -1,211 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
3−{-# language FlexibleInstances #-}
4−{-# language LambdaCase #-}
5−{-# language MultiParamTypeClasses #-}
6−{-# language NamedFieldPuns #-}
7−{-# language ScopedTypeVariables #-}
8−{-# language StandaloneKindSignatures #-}
9−{-# language TypeApplications #-}
10−{-# language TypeFamilies #-}
11−{-# language UndecidableInstances #-}
12−
13−module Rel8.Table.Nullify
14− ( Nullify
15− , aggregateNullify
16− , guard
17− , isNull
18− )
19−where
20−
21−-- base
22−import Control.Applicative ( liftA2 )
23−import Data.Functor.Const ( Const( Const ), getConst )
24−import Data.Functor.Identity ( runIdentity )
25−import Data.Kind ( Type )
26−import Prelude
27−
28−-- comonad
29−import Control.Comonad ( Comonad, duplicate, extract, ComonadApply, (<@>) )
30−
31−-- rel8
32−import Rel8.Aggregate ( Aggregate )
33−import Rel8.Expr ( Expr )
34−import Rel8.Expr.Bool ( (||.), false )
35−import qualified Rel8.Expr.Null as Expr
36−import Rel8.Kind.Context ( Reifiable, contextSing )
37−import Rel8.Schema.Context.Nullify
38− ( Nullifiability( NAggregate, NExpr )
39− , NonNullifiability
40− , Nullifiable, nullifiability
41− , nullifiableOrNot, absurd
42− , guarder
43− , nullifier
44− , unnullifier
45− )
46−import Rel8.Schema.Dict ( Dict( Dict ) )
47−import Rel8.Schema.HTable ( HTable )
48−import Rel8.Schema.HTable.Nullify
49− ( HNullify, hnulls, hnullify, hunnullify
50− , hguard
51− , hproject
52− )
53−import qualified Rel8.Schema.Kind as K
54−import Rel8.Schema.Null ( Nullity( NotNull, Null ) )
55−import qualified Rel8.Schema.Result as R
56−import Rel8.Table
57− ( Table, Columns, Context, toColumns, fromColumns
58− , FromExprs, fromResult, toResult
59− , Transpose
60− )
61−import Rel8.Schema.Spec ( Spec( Spec, nullity ) )
62−import Rel8.Table.Eq ( EqTable, eqTable )
63−import Rel8.Table.Ord ( OrdTable, ordTable )
64−import Rel8.Table.Projection ( Projectable, apply, project )
65−
66−-- semigroupoids
67−import Data.Functor.Apply ( Apply, (<.>), liftF2 )
68−import Data.Functor.Bind ( Bind, (>>-) )
69−import Data.Functor.Extend ( Extend, duplicated )
70−
71−
72−type Nullify :: K.Context -> Type -> Type
73−data Nullify context a
74− = Table (Nullifiability context) a
75− | Fields (NonNullifiability context) (HNullify (Columns a) (Context a))
76−
77−
78−instance Projectable (Nullify context) where
79− project f = \case
80− Table nullifiable a -> Table nullifiable (fromColumns (apply f (toColumns a)))
81− Fields nonNullifiable a -> Fields nonNullifiable (hproject (apply f) a)
82−
83−
84−instance Nullifiable context => Functor (Nullify context) where
85− fmap f = \case
86− Table nullifiable a -> Table nullifiable (f a)
87− Fields notNullifiable _ -> absurd nullifiability notNullifiable
88−
89−
90−instance Nullifiable context => Foldable (Nullify context) where
91− foldMap f = \case
92− Table _ a -> f a
93− Fields notNullifiable _ -> absurd nullifiability notNullifiable
94−
95−
96−instance Nullifiable context => Traversable (Nullify context) where
97− traverse f = \case
98− Table nullifiable a -> Table nullifiable <$> f a
99− Fields notNullifiable _ -> absurd nullifiability notNullifiable
100−
101−
102−instance Nullifiable context => Apply (Nullify context) where
103− liftF2 f = \case
104− Table nullifiable a -> \case
105− Table _ b -> Table nullifiable (f a b)
106− Fields notNullifiable _ -> absurd nullifiable notNullifiable
107− Fields notNullifiable _ -> absurd nullifiability notNullifiable
108−
109−
110−instance Nullifiable context => Applicative (Nullify context) where
111− pure = Table nullifiability
112− liftA2 = liftF2
113−
114−
115−instance Nullifiable context => Bind (Nullify context) where
116− Table _ a >>- f = f a
117− Fields notNullifiable _ >>- _ = absurd nullifiability notNullifiable
118−
119−
120−instance Nullifiable context => Monad (Nullify context) where
121− (>>=) = (>>-)
122−
123−
124−instance Nullifiable context => Extend (Nullify context) where
125− duplicated = \case
126− Table nullifiable a -> Table nullifiable (Table nullifiable a)
127− Fields notNullifiable _ -> absurd nullifiability notNullifiable
128−
129−
130−instance Nullifiable context => Comonad (Nullify context) where
131− extract = \case
132− Table _ a -> a
133− Fields notNullifiable _ -> absurd nullifiability notNullifiable
134− duplicate = duplicated
135−
136−
137−instance Nullifiable context => ComonadApply (Nullify context) where
138− (<@>) = (<.>)
139−
140−
141−instance (Table context a, Reifiable context, context ~ context') =>
142− Table context' (Nullify context a)
143− where
144− type Columns (Nullify context a) = HNullify (Columns a)
145− type Context (Nullify context a) = Context a
146− type FromExprs (Nullify context a) = Maybe (FromExprs a)
147− type Transpose to (Nullify context a) = Nullify to (Transpose to a)
148−
149− fromColumns = case nullifiableOrNot contextSing of
150− Left notNullifiable -> Fields notNullifiable
151− Right nullifiable ->
152− Table nullifiable .
153− fromColumns .
154− runIdentity .
155− hunnullify (\spec -> pure . unnullifier nullifiable spec)
156−
157− toColumns = \case
158− Table nullifiable a -> hnullify (nullifier nullifiable) (toColumns a)
159− Fields _ a -> a
160−
161− fromResult = fmap (fromResult @_ @a) . hunnullify R.unnullifier
162−
163− toResult =
164− maybe (hnulls (const R.null)) (hnullify R.nullifier) .
165− fmap (toResult @_ @a)
166−
167−
168−instance (EqTable a, context ~ Expr) => EqTable (Nullify context a) where
169− eqTable = hnullify (\_ Dict -> Dict) (eqTable @a)
170−
171−
172−instance (OrdTable a, context ~ Expr) => OrdTable (Nullify context a) where
173− ordTable = hnullify (\_ Dict -> Dict) (ordTable @a)
174−
175−
176−aggregateNullify :: ()
177− => (exprs -> aggregates)
178− -> Nullify Expr exprs
179− -> Nullify Aggregate aggregates
180−aggregateNullify f = \case
181− Table _ a -> Table NAggregate (f a)
182− Fields notNullifiable _ -> absurd NExpr notNullifiable
183−
184−
185−guard :: (Reifiable context, HTable t)
186− => context tag
187− -> (tag -> Bool)
188− -> (Expr tag -> Expr Bool)
189− -> HNullify t context
190− -> HNullify t context
191−guard tag isNonNull isNonNullExpr =
192− hguard (guarder contextSing tag isNonNull isNonNullExpr)
193−
194−
195−isNull :: forall a. Table Expr a => Nullify Expr a -> Expr Bool
196−isNull =
197− maybe false getAny .
198− getConst .
199− hunnullify (\Spec {nullity} a -> Const $ case nullity of
200− NotNull -> Just $ Any $ Expr.isNull a
201− Null -> Nothing) .
202− toColumns
203−
204−
205−newtype Any = Any
206− { getAny :: Expr Bool
207− }
208−
209−
210−instance Semigroup Any where
211− Any a <> Any b = Any (a ||. b)
src/Rel8/Table/Opaleye.hs+64−78
@@ -1,150 +1,136 @@
11{-# language BlockArguments #-}
2−{-# language DataKinds #-}
32{-# language DisambiguateRecordFields #-}
43{-# language FlexibleContexts #-}
4+{-# language LambdaCase #-}
55{-# language NamedFieldPuns #-}
6−{-# language RankNTypes #-}
76{-# language TypeFamilies #-}
87{-# language ViewPatterns #-}
98
10−{-# options_ghc -Wno-deprecations #-}
11−
129module Rel8.Table.Opaleye
1310 ( aggregator
14− , attributes
1511 , binaryspec
1612 , distinctspec
17− , exprs
18− , exprsWithNames
1913 , table
2014 , tableFields
2115 , unpackspec
2216 , valuesspec
23− , view
2417 , castTable
2518 )
2619where
2720
2821-- base
29−import Data.Functor.Const ( Const( Const ), getConst )
30−import Data.List.NonEmpty ( NonEmpty )
31−import Prelude
22+import Prelude hiding ( undefined )
3223
3324-- opaleye
34−import qualified Opaleye.Adaptors as Opaleye
35−import qualified Opaleye.Field as Opaleye ( Field_ )
3625import qualified Opaleye.Internal.Aggregate as Opaleye
26+import qualified Opaleye.Internal.Binary as Opaleye
27+import qualified Opaleye.Internal.Distinct as Opaleye
3728import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
29+import qualified Opaleye.Internal.PackMap as Opaleye
30+import qualified Opaleye.Internal.Unpackspec as Opaleye
3831import qualified Opaleye.Internal.Values as Opaleye
39−import qualified Opaleye.Table as Opaleye
32+import qualified Opaleye.Internal.Table as Opaleye
4033
4134-- profunctors
4235import Data.Profunctor ( dimap, lmap )
4336
4437-- rel8
45−import Rel8.Aggregate ( Aggregate( Aggregate ), Aggregates )
46−import Rel8.Expr ( Expr )
38+import Rel8.Aggregate ( Col( A ), Aggregate( Aggregate ), Aggregates )
39+import Rel8.Expr ( Expr, Col(..) )
4740import Rel8.Expr.Opaleye
4841 ( fromPrimExpr, toPrimExpr
49− , scastExpr, traverseFieldP
42+ , traversePrimExpr
43+ , fromColumn, toColumn
44+ , scastExpr
5045 )
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 )
46+import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs, htabulate )
47+import Rel8.Schema.Name ( Col( N ), Name( Name ), Selects )
48+import Rel8.Schema.Spec ( SSpec(..) )
49+import Rel8.Schema.Table ( TableSchema(..) )
5650import Rel8.Table ( Table, fromColumns, toColumns )
57−import Rel8.Type.Information ( typeName )
51+import Rel8.Table.Undefined ( undefined )
5852
5953-- semigroupoids
6054import Data.Functor.Apply ( WrappedApplicative(..) )
61−import Data.Profunctor.Product ( ProductProfunctor )
6255
6356
6457aggregator :: 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))
58+aggregator = Opaleye.Aggregator $ Opaleye.PackMap $ \f aggregates ->
59+ fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->
60+ WrapApplicative $ case hfield (toColumns aggregates) field of
61+ A (Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner))) ->
62+ E <$> inner f ()
8363
8464
8565binaryspec :: Table Expr a => Opaleye.Binaryspec a a
86−binaryspec = fromOpaleyespec Opaleye.binaryspecField
66+binaryspec = Opaleye.Binaryspec $ Opaleye.PackMap $ \f (as, bs) ->
67+ fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->
68+ WrapApplicative $
69+ case (hfield (toColumns as) field, hfield (toColumns bs) field) of
70+ (E a, E b) -> E . fromPrimExpr <$> f (toPrimExpr a, toPrimExpr b)
8771
8872
8973distinctspec :: 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))
74+distinctspec =
75+ Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap $ \f ->
76+ fmap fromColumns .
77+ unwrapApplicative .
78+ htraverse
79+ (\(E a) ->
80+ WrapApplicative $ E . fromPrimExpr <$> f (Nothing, toPrimExpr a)) .
81+ toColumns
10482
10583
106−table :: Selects names exprs => TableSchema names -> Opaleye.Table exprs exprs
84+table ::Selects names exprs => TableSchema names -> Opaleye.Table exprs exprs
10785table (TableSchema name schema columns) =
10886 case schema of
109− Nothing -> Opaleye.table name (tableFields columns)
110− Just schemaName -> Opaleye.tableWithSchema schemaName name (tableFields columns)
87+ Nothing -> Opaleye.Table name (tableFields columns)
88+ Just schemaName -> Opaleye.TableWithSchema schemaName name (tableFields columns)
11189
11290
113−tableFields :: Selects names exprs
91+tableFields ::Selects names exprs
11492 => names -> Opaleye.TableFields exprs exprs
11593tableFields (toColumns -> names) = dimap toColumns fromColumns $
11694 unwrapApplicative $ htabulateA $ \field -> WrapApplicative $
11795 case hfield names field of
11896 name -> lmap (`hfield` field) (go name)
11997 where
120− go :: Name a -> Opaleye.TableFields (Expr a) (Expr a)
121− go (Name name) =
122− traverseFieldP $
123− Opaleye.requiredTableField name
98+ go :: Col Name spec -> Opaleye.TableFields (Col Expr spec) (Col Expr spec)
99+ go (N (Name name)) =
100+ lmap (\(E a) -> toColumn $ toPrimExpr a) $
101+ E . fromPrimExpr . fromColumn <$>
102+ Opaleye.requiredTableField name
124103
125104
126105unpackspec :: Table Expr a => Opaleye.Unpackspec a a
127−unpackspec = fromOpaleyespec Opaleye.unpackspecField
106+unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->
107+ fmap fromColumns .
108+ unwrapApplicative .
109+ htraverse (\(E a) -> WrapApplicative $ E <$> traversePrimExpr f a) .
110+ toColumns
128111{-# INLINABLE unpackspec #-}
129112
130113
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
114+valuesspec :: Table Expr a => Opaleye.ValuesspecSafe a a
115+valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec
135116
136117
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
118+toPackMap :: Table Expr a
119+ => a -> Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () a
120+toPackMap as = Opaleye.PackMap $ \f () ->
121+ fmap fromColumns $
122+ unwrapApplicative .
123+ htraverse (\(E a) -> WrapApplicative $ E <$> traversePrimExpr f a) $
124+ toColumns as
141125
142126
143127-- | Transform a table by adding 'CAST' to all columns. This is most useful for
144128-- finalising a SELECT or RETURNING statement, guaranteed that the output
145129-- matches what is encoded in each columns TypeInformation.
146130castTable :: 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
131+castTable (toColumns -> as) = fromColumns $ htabulate \i ->
132+ case hfield hspecs i of
133+ SSpec{info} ->
134+ case hfield as i of
135+ E expr ->
136+ E (scastExpr info expr)
src/Rel8/Table/Ord.hs+45−16
@@ -10,6 +10,7 @@
1010{-# language TypeFamilies #-}
1111{-# language TypeOperators #-}
1212{-# language UndecidableInstances #-}
13+{-# language UndecidableSuperClasses #-}
1314{-# language ViewPatterns #-}
1415
1516module Rel8.Table.Ord
@@ -24,20 +25,29 @@ import GHC.Generics ( Rep )
2425import Prelude hiding ( seq )
2526
2627-- rel8
27−import Rel8.Expr ( Expr )
28+import Rel8.Expr ( Expr, Col( E ) )
2829import Rel8.Expr.Bool ( (||.), (&&.), false, true )
2930import Rel8.Expr.Eq ( (==.) )
3031import Rel8.Expr.Ord ( (<.), (>.) )
3132import Rel8.FCF ( Eval, Exp )
3233import Rel8.Generic.Record ( Record )
33−import Rel8.Generic.Table.Record ( GTable, GColumns, gtable )
34+import Rel8.Generic.Table
35+ ( GGTable, GGColumns, ggtable
36+ , GAlgebra
37+ )
38+import Rel8.Kind.Algebra ( KnownAlgebra )
3439import Rel8.Schema.Dict ( Dict( Dict ) )
35−import Rel8.Schema.HTable ( htabulateA, hfield )
36−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
40+import Rel8.Schema.HTable
41+ ( HTable, HConstrainTable
42+ , htabulateA, hfield, hdicts
43+ )
44+import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )
3745import Rel8.Schema.Null (Sql)
46+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType, nullifier )
3847import Rel8.Table ( Columns, toColumns, TColumns )
3948import Rel8.Table.Bool ( bool )
4049import Rel8.Table.Eq ( EqTable )
50+import Rel8.Type.Eq ( DBEq )
4151import Rel8.Type.Ord ( DBOrd )
4252
4353
@@ -46,14 +56,22 @@ import Rel8.Type.Ord ( DBOrd )
4656-- columns in a 'Table' have an instance of 'DBOrd'".
4757type OrdTable :: Type -> Constraint
4858class EqTable a => OrdTable a where
49− ordTable :: Columns a (Dict (Sql DBOrd))
59+ ordTable :: Columns a (Dict (ConstrainDBType DBOrd))
5060
5161 default ordTable ::
52− ( GTable TOrdTable TColumns (Rep (Record a))
53− , Columns a ~ GColumns TColumns (Rep (Record a))
62+ ( KnownAlgebra (GAlgebra (Rep (Record a)))
63+ , Eval (GGTable (GAlgebra (Rep (Record a))) TOrdTable TColumns (Dict (ConstrainDBType DBOrd)) (Rep (Record a)))
64+ , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))
5465 )
55− => Columns a (Dict (Sql DBOrd))
56− ordTable = gtable @TOrdTable @TColumns @(Rep (Record a)) table
66+ => Columns a (Dict (ConstrainDBType DBOrd))
67+ ordTable =
68+ ggtable
69+ @(GAlgebra (Rep (Record a)))
70+ @TOrdTable
71+ @TColumns
72+ @(Rep (Record a))
73+ table
74+ nullifier
5775 where
5876 table (_ :: proxy x) = ordTable @x
5977
@@ -62,8 +80,19 @@ data TOrdTable :: Type -> Exp Constraint
6280type instance Eval (TOrdTable a) = OrdTable a
6381
6482
83+instance
84+ ( HTable t
85+ , f ~ Col Expr
86+ , HConstrainTable t (ConstrainDBType DBEq)
87+ , HConstrainTable t (ConstrainDBType DBOrd)
88+ )
89+ => OrdTable (t f)
90+ where
91+ ordTable = hdicts @(Columns (t f)) @(ConstrainDBType DBOrd)
92+
93+
6594instance Sql DBOrd a => OrdTable (Expr a) where
66− ordTable = HIdentity Dict
95+ ordTable = HType Dict
6796
6897
6998instance (OrdTable a, OrdTable b) => OrdTable (a, b)
@@ -98,7 +127,7 @@ instance
98127(toColumns -> as) <: (toColumns -> bs) =
99128 foldr @[] go false $ getConst $ htabulateA $ \field ->
100129 case (hfield as field, hfield bs field) of
101− (a, b) -> case hfield (ordTable @a) field of
130+ (E a, E b) -> case hfield (ordTable @a) field of
102131 Dict -> Const [(a <. b, a ==. b)]
103132 where
104133 go (lt, eq) a = lt ||. (eq &&. a)
@@ -111,7 +140,7 @@ infix 4 <:
111140(toColumns -> as) <=: (toColumns -> bs) =
112141 foldr @[] go true $ getConst $ htabulateA $ \field ->
113142 case (hfield as field, hfield bs field) of
114− (a, b) -> case hfield (ordTable @a) field of
143+ (E a, E b) -> case hfield (ordTable @a) field of
115144 Dict -> Const [(a <. b, a ==. b)]
116145 where
117146 go (lt, eq) a = lt ||. (eq &&. a)
@@ -124,7 +153,7 @@ infix 4 <=:
124153(toColumns -> as) >: (toColumns -> bs) =
125154 foldr @[] go false $ getConst $ htabulateA $ \field ->
126155 case (hfield as field, hfield bs field) of
127− (a, b) -> case hfield (ordTable @a) field of
156+ (E a, E b) -> case hfield (ordTable @a) field of
128157 Dict -> Const [(a >. b, a ==. b)]
129158 where
130159 go (gt, eq) a = gt ||. (eq &&. a)
@@ -137,7 +166,7 @@ infix 4 >:
137166(toColumns -> as) >=: (toColumns -> bs) =
138167 foldr @[] go true $ getConst $ htabulateA $ \field ->
139168 case (hfield as field, hfield bs field) of
140− (a, b) -> case hfield (ordTable @a) field of
169+ (E a, E b) -> case hfield (ordTable @a) field of
141170 Dict -> Const [(a >. b, a ==. b)]
142171 where
143172 go (gt, eq) a = gt ||. (eq &&. a)
@@ -146,9 +175,9 @@ infix 4 >=:
146175
147176-- | Given two 'Table's, return the table that sorts before the other.
148177least :: OrdTable a => a -> a -> a
149−least a b = bool b a (a <: b)
178+least a b = bool a b (a <: b)
150179
151180
152181-- | Given two 'Table's, return the table that sorts after the other.
153182greatest :: OrdTable a => a -> a -> a
154−greatest a b = bool b a (a >: b)
183+greatest a b = bool a b (a >: b)
src/Rel8/Table/Order.hs+16−13
@@ -1,5 +1,4 @@
11{-# language DataKinds #-}
2−{-# language NamedFieldPuns #-}
32{-# language ScopedTypeVariables #-}
43{-# language TypeApplications #-}
54{-# language TypeFamilies #-}
@@ -16,14 +15,16 @@ import Data.Functor.Contravariant ( (>$<), contramap )
1615import Prelude
1716
1817-- rel8
18+import Rel8.Expr ( unE )
1919import Rel8.Expr.Order ( asc, desc, nullsFirst, nullsLast )
2020import Rel8.Order ( Order )
2121import Rel8.Schema.Dict ( Dict( Dict ) )
2222import Rel8.Schema.HTable (htabulateA, hfield, hspecs)
2323import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
24−import Rel8.Schema.Spec ( Spec( Spec, nullity ) )
24+import Rel8.Schema.Spec ( SSpec( SSpec ) )
25+import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullity )
2526import Rel8.Table ( Columns, toColumns )
26−import Rel8.Table.Ord ( OrdTable, ordTable )
27+import Rel8.Table.Ord
2728
2829
2930-- | Construct an 'Order' for a 'Table' by sorting all columns into ascending
@@ -31,11 +32,12 @@ 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) >$<
36− case nullity of
37− Null -> nullsFirst asc
38− NotNull -> asc
35+ SSpec {} -> case hfield (ordTable @a) field of
36+ dict@Dict -> case dbTypeDict dict of
37+ Dict -> Const $ unE . (`hfield` field) >$<
38+ case dbTypeNullity dict of
39+ Null -> nullsFirst asc
40+ NotNull -> asc
3941
4042
4143-- | Construct an 'Order' for a 'Table' by sorting all columns into descending
@@ -43,8 +45,9 @@ ascTable = contramap toColumns $ getConst $
4345descTable :: forall a. OrdTable a => Order a
4446descTable = contramap toColumns $ getConst $
4547 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
46− Spec {nullity} -> case hfield (ordTable @a) field of
47− Dict -> Const $ (`hfield` field) >$<
48− case nullity of
49− Null -> nullsLast desc
50− NotNull -> desc
48+ SSpec {} -> case hfield (ordTable @a) field of
49+ dict@Dict -> case dbTypeDict dict of
50+ Dict -> Const $ unE . (`hfield` field) >$<
51+ case dbTypeNullity dict of
52+ Null -> nullsLast desc
53+ 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/Recontextualize.hsnew file+107
@@ -0,0 +1,107 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleInstances #-}
3+{-# language FunctionalDependencies #-}
4+{-# language StandaloneKindSignatures #-}
5+{-# language TypeFamilies #-}
6+{-# language UndecidableInstances #-}
7+{-# language UndecidableSuperClasses #-}
8+
9+module Rel8.Table.Recontextualize
10+ ( Recontextualize
11+ )
12+where
13+
14+-- base
15+import Data.Functor.Identity ( Identity )
16+import Data.Kind ( Constraint, Type )
17+import Prelude ()
18+
19+-- rel8
20+import Rel8.Schema.Context ( Col )
21+import Rel8.Schema.HTable ( HTable )
22+import qualified Rel8.Schema.Kind as K
23+import Rel8.Schema.Null ( Sql )
24+import Rel8.Schema.Result ( Result )
25+import Rel8.Table ( Table, Congruent )
26+import Rel8.Type ( DBType )
27+
28+
29+-- | @Recontextualize from to a b@ is evidence that the types @a@ and @b@ are
30+-- related, and that @b@ is the same type as @a@, but after changing the
31+-- context from the initial context @from@, to the new context @to@.
32+type Recontextualize :: K.Context -> K.Context -> Type -> Type -> Constraint
33+class
34+ ( Table from a
35+ , Table to b
36+ , Congruent a b
37+ , Recontextualize from from a a
38+ , Recontextualize to to b b
39+ , Recontextualize to from b a
40+ ) => Recontextualize from to a b
41+ | a -> from
42+ , b -> to
43+ , a to -> b
44+ , b from -> a
45+
46+
47+instance Sql DBType a => Recontextualize Result Result (Identity a) (Identity a)
48+
49+
50+instance HTable t => Recontextualize from to (t (Col from)) (t (Col to))
51+
52+
53+instance
54+ ( Recontextualize from to a1 b1
55+ , Recontextualize from to a2 b2
56+ )
57+ => Recontextualize from to (a1, a2) (b1, b2)
58+
59+
60+instance
61+ ( Recontextualize from to a1 b1
62+ , Recontextualize from to a2 b2
63+ , Recontextualize from to a3 b3
64+ )
65+ => Recontextualize from to (a1, a2, a3) (b1, b2, b3)
66+
67+
68+instance
69+ ( Recontextualize from to a1 b1
70+ , Recontextualize from to a2 b2
71+ , Recontextualize from to a3 b3
72+ , Recontextualize from to a4 b4
73+ )
74+ => Recontextualize from to (a1, a2, a3, a4) (b1, b2, b3, b4)
75+
76+
77+instance
78+ ( Recontextualize from to a1 b1
79+ , Recontextualize from to a2 b2
80+ , Recontextualize from to a3 b3
81+ , Recontextualize from to a4 b4
82+ , Recontextualize from to a5 b5
83+ )
84+ => Recontextualize from to (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5)
85+
86+
87+instance
88+ ( Recontextualize from to a1 b1
89+ , Recontextualize from to a2 b2
90+ , Recontextualize from to a3 b3
91+ , Recontextualize from to a4 b4
92+ , Recontextualize from to a5 b5
93+ , Recontextualize from to a6 b6
94+ )
95+ => Recontextualize from to (a1, a2, a3, a4, a5, a6) (b1, b2, b3, b4, b5, b6)
96+
97+
98+instance
99+ ( Recontextualize from to a1 b1
100+ , Recontextualize from to a2 b2
101+ , Recontextualize from to a3 b3
102+ , Recontextualize from to a4 b4
103+ , Recontextualize from to a5 b5
104+ , Recontextualize from to a6 b6
105+ , Recontextualize from to a7 b7
106+ )
107+ => Recontextualize from to (a1, a2, a3, a4, a5, a6, a7) (b1, b2, b3, b4, b5, b6, b7)
src/Rel8/Table/Rel8able.hs+82−29
@@ -1,6 +1,6 @@
11{-# language DataKinds #-}
22{-# language FlexibleInstances #-}
3−{-# language MultiParamTypeClasses #-}
3+{-# language FunctionalDependencies #-}
44{-# language ScopedTypeVariables #-}
55{-# language StandaloneKindSignatures #-}
66{-# language TypeApplications #-}
@@ -15,78 +15,131 @@ module Rel8.Table.Rel8able
1515where
1616
1717-- base
18−import Prelude ()
18+import Data.Kind ( Constraint, Type )
19+import Data.Type.Equality ( (:~:)( Refl ) )
20+import Prelude
1921
2022-- rel8
2123import Rel8.Expr ( Expr )
2224import qualified Rel8.Kind.Algebra as K
23−import Rel8.Kind.Context ( Reifiable, contextSing )
25+import Rel8.Kind.Context
26+ ( SContext( SReify )
27+ , Reifiable, contextSing
28+ , sReifiable
29+ )
2430import Rel8.Generic.Rel8able
2531 ( Rel8able, Algebra
2632 , GColumns, gfromColumns, gtoColumns
27− , GFromExprs, gfromResult, gtoResult
33+ , greify, gunreify
2834 )
35+import Rel8.Schema.Context ( Col )
36+import Rel8.Schema.Dict ( Dict( Dict ) )
2937import qualified Rel8.Schema.Kind as K
3038import Rel8.Schema.HTable ( HConstrainTable, hdicts )
31−import Rel8.Schema.Null ( Sql )
39+import Rel8.Schema.Reify ( hreify, hunreify, UnwrapReify )
3240import Rel8.Schema.Result ( Result )
3341import Rel8.Table
34− ( Table, Columns, Context, fromColumns, toColumns
35− , FromExprs, fromResult, toResult
36− , Transpose
42+ ( Table, Columns, Context, Congruent, fromColumns, toColumns
43+ , Unreify, reify, unreify
3744 )
38−import Rel8.Table.ADT ( ADT )
45+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
46+import Rel8.Table.ADT ( ADT( ADT ), ADTable, fromADT, toADT )
3947import Rel8.Table.Eq ( EqTable, eqTable )
48+import Rel8.Table.HKD ( HKD )
4049import Rel8.Table.Ord ( OrdTable, ordTable )
41−import Rel8.Table.Serialize ( ToExprs )
50+import Rel8.Table.Recontextualize ( Recontextualize )
51+import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
4252import Rel8.Type.Eq ( DBEq )
4353import Rel8.Type.Ord ( DBOrd )
4454
4555
46−instance (Rel8able t, Reifiable context, context ~ context') =>
47− Table context' (t context)
56+instance (Rel8able t, Reifiable context) =>
57+ Table context (t context)
4858 where
4959 type Columns (t context) = GColumns t
5060 type Context (t context) = context
51− type FromExprs (t context) = GFromExprs t
52− type Transpose to (t context) = t to
61+ type Unreify (t context) = t (UnwrapReify context)
62+
63+ fromColumns = gunreify . gfromColumns . hreify
64+ toColumns = hunreify . gtoColumns . greify
65+
66+ reify Refl = case contextSing @context of
67+ SReify context -> case sReifiable context of
68+ Dict -> greify
69+
70+ unreify Refl = case contextSing @context of
71+ SReify context -> case sReifiable context of
72+ Dict -> gunreify
73+
5374
54− fromColumns = gfromColumns contextSing
55− toColumns = gtoColumns contextSing
56− fromResult = gfromResult @t
57− toResult = gtoResult @t
75+instance
76+ ( Rel8able t
77+ , Reifiable from
78+ , Reifiable to
79+ , Congruent (t from) (t to)
80+ )
81+ => Recontextualize from to (t from) (t to)
5882
5983
6084instance
6185 ( context ~ Expr
6286 , Rel8able t
63− , HConstrainTable (Columns (t context)) (Sql DBEq)
87+ , HConstrainTable (Columns (t context)) (ConstrainDBType DBEq)
6488 )
6589 => EqTable (t context)
6690 where
67− eqTable = hdicts @(Columns (t context)) @(Sql DBEq)
91+ eqTable = hdicts @(Columns (t context)) @(ConstrainDBType DBEq)
6892
6993
7094instance
7195 ( context ~ Expr
7296 , Rel8able t
73− , HConstrainTable (Columns (t context)) (Sql DBEq)
74− , HConstrainTable (Columns (t context)) (Sql DBOrd)
97+ , HConstrainTable (Columns (t context)) (ConstrainDBType DBEq)
98+ , HConstrainTable (Columns (t context)) (ConstrainDBType DBOrd)
7599 )
76100 => OrdTable (t context)
77101 where
78− ordTable = hdicts @(Columns (t context)) @(Sql DBOrd)
102+ ordTable = hdicts @(Columns (t context)) @(ConstrainDBType DBOrd)
103+
104+
105+type instance FromExprs (t Expr) = FromExprs' t
79106
80107
81108instance
82− ( Rel8able t', t' ~ Choose (Algebra t) t
83− , x ~ t' Expr
109+ ( x ~ t' Expr
84110 , result ~ Result
111+ , ToExprs' (Algebra t) t' t
85112 )
86113 => ToExprs x (t result)
114+ where
115+ fromResult = fromResult' @(Algebra t) @t'
116+ toResult = toResult' @(Algebra t) @t'
87117
88118
89−type Choose :: K.Algebra -> K.Rel8able -> K.Rel8able
90−type family Choose algebra t where
91− Choose 'K.Sum t = ADT t
92− Choose 'K.Product t = t
119+type FromExprs' :: K.Rel8able -> Type
120+type family FromExprs' t where
121+ FromExprs' (ADT t) = t Result
122+ FromExprs' (HKD a) = a
123+ FromExprs' t = t Result
124+
125+
126+type ToExprs' :: K.Algebra -> K.Rel8able -> K.Rel8able -> Constraint
127+class (algebra ~ Algebra t, Rel8able t') =>
128+ ToExprs' algebra t' t | algebra t -> t'
129+ where
130+ fromResult' :: GColumns t' (Col Result) -> t Result
131+ toResult' :: t Result -> GColumns t' (Col Result)
132+
133+
134+instance (Algebra t ~ 'K.Product, Rel8able t, t ~ t') =>
135+ ToExprs' 'K.Product t' t
136+ where
137+ fromResult' = fromColumns
138+ toResult' = toColumns
139+
140+
141+instance (Algebra t ~ 'K.Sum, ADTable t, t' ~ ADT t) =>
142+ ToExprs' 'K.Sum t' t
143+ where
144+ fromResult' = fromADT . ADT
145+ toResult' = (\(ADT a) -> a) . toADT
src/Rel8/Table/Serialize.hs+122−22
@@ -1,4 +1,7 @@
11{-# language AllowAmbiguousTypes #-}
2+{-# language DataKinds #-}
3+{-# language DefaultSignatures #-}
4+{-# language DisambiguateRecordFields #-}
25{-# language FlexibleContexts #-}
36{-# language FlexibleInstances #-}
47{-# language FunctionalDependencies #-}
@@ -7,31 +10,41 @@
710{-# language StandaloneKindSignatures #-}
811{-# language TypeApplications #-}
912{-# language TypeFamilies #-}
13+{-# language TypeOperators #-}
1014{-# language UndecidableInstances #-}
1115
1216module Rel8.Table.Serialize
13− ( Serializable, lit, litHTable, parse
14− , ToExprs
17+ ( Serializable, lit, parse
18+ , ToExprs(..), FromExprs
19+ , TToExprs
1520 )
1621where
1722
1823-- base
19−import Data.Functor.Identity ( Identity( Identity ) )
2024import Data.Kind ( Constraint, Type )
2125import Data.List.NonEmpty ( NonEmpty )
26+import GHC.Generics ( Generic, Rep, from, to )
2227import Prelude
2328
2429-- hasql
2530import qualified Hasql.Decoders as Hasql
2631
2732-- rel8
28−import Rel8.Expr ( Expr )
33+import Rel8.Expr ( Expr, Col( E ) )
2934import Rel8.Expr.Serialize ( slitExpr, sparseValue )
35+import Rel8.FCF ( Eval, Exp )
36+import Rel8.Generic.Record ( Record(..) )
37+import Rel8.Generic.Table
38+ ( GGToExprs, GGColumns, ggfromResult, ggtoResult
39+ , GAlgebra
40+ )
41+import Rel8.Kind.Algebra ( KnownAlgebra )
3042import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )
43+import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )
3144import Rel8.Schema.Null ( NotNull, Sql )
32−import Rel8.Schema.Result ( Result )
33−import Rel8.Schema.Spec ( Spec(..) )
34−import Rel8.Table ( Table, fromColumns, FromExprs, fromResult, toResult )
45+import Rel8.Schema.Result ( Col( R ), Result )
46+import Rel8.Schema.Spec ( SSpec(..), KnownSpec )
47+import Rel8.Table ( Table, Columns, fromColumns, toColumns, TColumns )
3548import Rel8.Type ( DBType )
3649
3750-- semigroupoids
@@ -40,21 +53,71 @@ import Data.Functor.Apply ( WrappedApplicative(..) )
4053
4154-- | @ToExprs exprs a@ is evidence that the types @exprs@ and @a@ describe
4255-- essentially the same type, but @exprs@ is in the 'Expr' context, and @a@ is
43−-- a normal Haskell type.
56+-- in the 'Result' context.
4457type ToExprs :: Type -> Type -> Constraint
45−class Table Expr exprs => ToExprs exprs a
46−
47−
48−instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a
49−
50−
51−instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a]
58+class Table Expr exprs => ToExprs exprs a where
59+ fromResult :: Columns exprs (Col Result) -> a
60+ toResult :: a -> Columns exprs (Col Result)
61+
62+ default fromResult ::
63+ ( Generic (Record a)
64+ , KnownAlgebra (GAlgebra (Rep (Record exprs)))
65+ , Eval (GGToExprs (GAlgebra (Rep (Record exprs))) TToExprs TColumns (Rep (Record exprs)) (Rep (Record a)))
66+ , Columns exprs ~ Eval (GGColumns (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs)))
67+ )
68+ => Columns exprs (Col Result) -> a
69+ fromResult =
70+ unrecord .
71+ to .
72+ ggfromResult
73+ @(GAlgebra (Rep (Record exprs)))
74+ @TToExprs
75+ @TColumns
76+ @(Rep (Record exprs))
77+ (\(_ :: proxy expr) -> fromResult @expr)
78+
79+ default toResult ::
80+ ( Generic (Record a)
81+ , KnownAlgebra (GAlgebra (Rep (Record exprs)))
82+ , Eval (GGToExprs (GAlgebra (Rep (Record exprs))) TToExprs TColumns (Rep (Record exprs)) (Rep (Record a)))
83+ , Columns exprs ~ Eval (GGColumns (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs)))
84+ )
85+ => a -> Columns exprs (Col Result)
86+ toResult =
87+ ggtoResult
88+ @(GAlgebra (Rep (Record exprs)))
89+ @TToExprs
90+ @TColumns
91+ @(Rep (Record exprs))
92+ (\(_ :: proxy expr) -> toResult @expr) .
93+ from .
94+ Record
95+
96+
97+data TToExprs :: Type -> Type -> Exp Constraint
98+type instance Eval (TToExprs exprs a) = ToExprs exprs a
99+
100+
101+instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a where
102+ fromResult (HType (R a)) = a
103+ toResult = HType . R
104+
105+
106+instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a] where
107+ fromResult (HType (R a)) = a
108+ toResult = HType . R
52109
53110
54111instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a)
112+ where
113+ fromResult (HType (R a)) = a
114+ toResult = HType . R
55115
56116
57117instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a)
118+ where
119+ fromResult (HType (R a)) = a
120+ toResult = HType . R
58121
59122
60123instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>
@@ -116,6 +179,43 @@ instance
116179 => ToExprs x (a, b, c, d, e, f, g)
117180
118181
182+instance (HTable t, result ~ Col Result, x ~ t (Col Expr)) =>
183+ ToExprs x (t result)
184+ where
185+ fromResult = id
186+ toResult = id
187+
188+
189+instance (KnownSpec spec, x ~ Col Expr spec) =>
190+ ToExprs x (Col Result spec)
191+ where
192+ fromResult = fromColumns
193+ toResult = toColumns
194+
195+
196+-- | The @FromExprs@ type function maps a type in the @Expr@ context to the
197+-- corresponding type in the @Result@ context.
198+type FromExprs :: Type -> Type
199+type family FromExprs a
200+type instance FromExprs (Expr a) = a
201+type instance FromExprs (Col Expr spec) = Col Result spec
202+type instance FromExprs (a, b) = (FromExprs a, FromExprs b)
203+type instance FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)
204+type instance FromExprs (a, b, c, d) =
205+ (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
206+type instance FromExprs (a, b, c, d, e) =
207+ (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
208+type instance FromExprs (a, b, c, d, e, f) =
209+ ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e
210+ , FromExprs f
211+ )
212+type instance FromExprs (a, b, c, d, e, f, g) =
213+ ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e
214+ , FromExprs f, FromExprs g
215+ )
216+type instance FromExprs (t (Col Expr)) = t (Col Result)
217+
218+
119219-- | @Serializable@ witnesses the one-to-one correspondence between the type
120220-- @sql@, which contains SQL expressions, and the type @haskell@, which
121221-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
@@ -128,21 +228,21 @@ instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a
128228-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is
129229-- capable of lifting single @Expr@s to full tables.
130230lit :: forall exprs a. Serializable exprs a => a -> exprs
131−lit = fromColumns . litHTable . toResult @_ @exprs
231+lit = fromColumns . litHTable . toResult @exprs
132232
133233
134234parse :: forall exprs a. Serializable exprs a => Hasql.Row a
135−parse = fromResult @_ @exprs <$> parseHTable
235+parse = fromResult @exprs <$> parseHTable
136236
137237
138−litHTable :: HTable t => t Result -> t Expr
238+litHTable :: HTable t => t (Col Result) -> t (Col Expr)
139239litHTable as = htabulate $ \field ->
140240 case hfield hspecs field of
141− Spec {nullity, info} -> case hfield as field of
142− Identity value -> slitExpr nullity info value
241+ SSpec {nullity, info} -> case hfield as field of
242+ R value -> E (slitExpr nullity info value)
143243
144244
145−parseHTable :: HTable t => Hasql.Row (t Result)
245+parseHTable :: HTable t => Hasql.Row (t (Col Result))
146246parseHTable = unwrapApplicative $ htabulateA $ \field ->
147247 WrapApplicative $ case hfield hspecs field of
148− Spec {nullity, info} -> Identity <$> sparseValue nullity info
248+ SSpec {nullity, info} -> R <$> sparseValue nullity info
src/Rel8/Table/Tag.hsnew file+97
@@ -0,0 +1,97 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleInstances #-}
3+{-# language GADTs #-}
4+{-# language InstanceSigs #-}
5+{-# language NamedFieldPuns #-}
6+{-# language ScopedTypeVariables #-}
7+{-# language StandaloneKindSignatures #-}
8+{-# language TypeApplications #-}
9+{-# language UndecidableInstances #-}
10+
11+module Rel8.Table.Tag
12+ ( Tag(..), Taggable
13+ , fromAggregate
14+ , fromExpr
15+ , fromName
16+ )
17+where
18+
19+-- base
20+import Control.Applicative ( (<|>), empty )
21+import Data.Kind ( Constraint, Type )
22+import Data.Foldable ( fold )
23+import Data.Monoid ( getFirst )
24+import Data.Proxy ( Proxy( Proxy ) )
25+import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
26+import Prelude
27+
28+-- rel8
29+import Rel8.Aggregate ( Aggregate, Aggregator, foldInputs )
30+import Rel8.Expr ( Expr )
31+import Rel8.Expr.Opaleye ( fromPrimExpr )
32+import Rel8.Schema.Name ( Name( Name ) )
33+import Rel8.Schema.Null ( Sql )
34+import Rel8.Type.Monoid ( DBMonoid )
35+
36+
37+type Tag :: Symbol -> Type -> Type
38+data Tag label a = Tag
39+ { expr :: Expr a
40+ , aggregator :: Maybe Aggregator
41+ , name :: Name a
42+ }
43+
44+
45+type Taggable :: Type -> Constraint
46+class Taggable a where
47+ tappend :: KnownSymbol label => Tag label a -> Tag label a -> Tag label a
48+ tempty :: KnownSymbol label => Tag label a
49+
50+
51+instance Sql DBMonoid a => Taggable a where
52+ tappend :: forall label. KnownSymbol label
53+ => Tag label a -> Tag label a -> Tag label a
54+ tappend a b = Tag
55+ { expr = expr a <> expr b
56+ , aggregator = aggregator a <|> aggregator b
57+ , name = case (name a, symbolVal (Proxy @label)) of
58+ (Name x, y)
59+ | x == y -> name b
60+ | otherwise -> name a
61+ }
62+ {-# INLINABLE tappend #-}
63+
64+ tempty :: forall label. KnownSymbol label => Tag label a
65+ tempty = Tag
66+ { expr = mempty
67+ , aggregator = empty
68+ , name = Name (symbolVal (Proxy @label))
69+ }
70+ {-# INLINABLE tempty #-}
71+
72+
73+instance (KnownSymbol label, Taggable a) => Semigroup (Tag label a) where
74+ (<>) = tappend
75+
76+
77+instance (KnownSymbol label, Taggable a) => Monoid (Tag label a) where
78+ mempty = tempty
79+
80+
81+fromAggregate :: forall a label. (KnownSymbol label, Taggable a)
82+ => Aggregate a -> Tag label a
83+fromAggregate = fold . getFirst . foldInputs go
84+ where
85+ go aggregator primExpr = pure $ (tempty @a @label)
86+ { expr = fromPrimExpr primExpr
87+ , aggregator
88+ }
89+
90+
91+fromExpr :: forall label a. (KnownSymbol label, Taggable a)
92+ => Expr a -> Tag label a
93+fromExpr expr = (tempty @a @label) {expr}
94+
95+
96+fromName :: forall a label. Taggable a => Name a -> Tag label a
97+fromName name = (tempty @a @"") {name}
src/Rel8/Table/These.hs+142−164
@@ -5,6 +5,7 @@
55{-# language FlexibleInstances #-}
66{-# language MultiParamTypeClasses #-}
77{-# language NamedFieldPuns #-}
8+{-# language RecordWildCards #-}
89{-# language ScopedTypeVariables #-}
910{-# language StandaloneKindSignatures #-}
1011{-# language TupleSections #-}
@@ -20,49 +21,48 @@ module Rel8.Table.These
2021 , isThisTable, isThatTable, isThoseTable
2122 , hasHereTable, hasThereTable
2223 , justHereTable, justThereTable
23− , alignMaybeTable
24− , aggregateTheseTable
2524 , nameTheseTable
2625 )
2726where
2827
2928-- base
29+import Control.Applicative ( liftA2 )
3030import Data.Bifunctor ( Bifunctor, bimap )
31+import Data.Functor.Identity ( runIdentity )
3132import Data.Kind ( Type )
32−import Data.Maybe ( isJust )
33−import Prelude hiding ( null, undefined )
33+import Prelude hiding ( undefined )
3434
3535-- rel8
36−import Rel8.Aggregate ( Aggregate )
3736import Rel8.Expr ( Expr )
38−import Rel8.Expr.Bool ( (&&.), (||.), boolExpr, not_ )
39−import Rel8.Expr.Null ( null, isNonNull )
40−import Rel8.Kind.Context ( Reifiable )
41−import Rel8.Schema.Context.Nullify ( Nullifiable )
42−import Rel8.Schema.Dict ( Dict( Dict ) )
43−import Rel8.Schema.HTable.Label ( hlabel, hrelabel, hunlabel )
37+import Rel8.Expr.Bool ( (&&.), not_ )
38+import Rel8.Expr.Null ( isNonNull )
39+import Rel8.Schema.Context.Nullify
40+ ( Nullifiable, ConstrainTag
41+ , HNullifiable, HConstrainTag
42+ , hencodeTag, hdecodeTag
43+ , hnullifier, hunnullifier
44+ )
45+import Rel8.Schema.HTable ( HTable )
46+import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
4447import Rel8.Schema.HTable.Identity ( HIdentity(..) )
45−import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
48+import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
4649import Rel8.Schema.HTable.These ( HTheseTable(..) )
47−import qualified Rel8.Schema.Kind as K
4850import Rel8.Schema.Name ( Name )
4951import Rel8.Table
5052 ( Table, Columns, Context, fromColumns, toColumns
51− , FromExprs, fromResult, toResult
52− , Transpose
53+ , reify, unreify
5354 )
5455import Rel8.Table.Eq ( EqTable, eqTable )
5556import Rel8.Table.Maybe
5657 ( MaybeTable(..)
5758 , maybeTable, justTable, nothingTable
5859 , isJustTable
59− , aggregateMaybeTable
6060 , nameMaybeTable
6161 )
62−import Rel8.Table.Nullify ( Nullify, guard )
6362import Rel8.Table.Ord ( OrdTable, ordTable )
64−import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )
65−import Rel8.Table.Serialize ( ToExprs )
63+import Rel8.Table.Recontextualize ( Recontextualize )
64+import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
65+import Rel8.Table.Tag ( Tag(..) )
6666import Rel8.Table.Undefined ( undefined )
6767import Rel8.Type.Tag ( MaybeTag )
6868
@@ -71,8 +71,7 @@ import Data.Functor.Apply ( Apply, (<.>) )
7171import Data.Functor.Bind ( Bind, (>>-) )
7272
7373-- these
74−import Data.These ( These( This, That, These ) )
75−import Data.These.Combinators ( justHere, justThere )
74+import Data.These ( These )
7675
7776
7877-- | @TheseTable a b@ is a Rel8 table that contains either the table @a@, the
@@ -82,45 +81,32 @@ import Data.These.Combinators ( justHere, justThere )
8281--
8382-- @TheseTable@ is operationally the same as Haskell's 'These' type, but
8483-- adapted to work with Rel8.
85−type TheseTable :: K.Context -> Type -> Type -> Type
86−data TheseTable context a b = TheseTable
87− { here :: MaybeTable context a
88− , there :: MaybeTable context b
84+type TheseTable :: Type -> Type -> Type
85+data TheseTable a b = TheseTable
86+ { here :: MaybeTable a
87+ , there :: MaybeTable b
8988 }
9089 deriving stock Functor
9190
9291
93−instance Biprojectable (TheseTable context) where
94− biproject f g (TheseTable a b) = TheseTable (project f a) (project g b)
95−
96−
97−instance Nullifiable context => Bifunctor (TheseTable context) where
92+instance Bifunctor TheseTable where
9893 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
9994
10095
101−instance Projectable (TheseTable context a) where
102− project f (TheseTable a b) = TheseTable a (project f b)
103−
104−
105−instance (context ~ Expr, Table Expr a, Semigroup a) =>
106− Apply (TheseTable context a)
107− where
96+instance (Table Expr a, Semigroup a) => Apply (TheseTable a) where
10897 fs <.> as = TheseTable
10998 { here = here fs <> here as
11099 , there = there fs <.> there as
111100 }
112101
113102
114−instance (context ~ Expr, Table Expr a, Semigroup a) =>
115− Applicative (TheseTable context a)
103+instance (Table Expr a, Semigroup a) => Applicative (TheseTable a)
116104 where
117105 pure = thatTable
118106 (<*>) = (<.>)
119107
120108
121−instance (context ~ Expr, Table Expr a, Semigroup a) =>
122− Bind (TheseTable context a)
123− where
109+instance (Table Expr a, Semigroup a) => Bind (TheseTable a) where
124110 TheseTable here1 ma >>- f = case ma >>- f' of
125111 mtb -> TheseTable
126112 { here = maybeTable here1 ((here1 <>) . fst) mtb
@@ -131,14 +117,12 @@ instance (context ~ Expr, Table Expr a, Semigroup a) =>
131117 TheseTable here2 mb -> (here2,) <$> mb
132118
133119
134−instance (context ~ Expr, Table Expr a, Semigroup a) =>
135− Monad (TheseTable context a)
136− where
120+instance (Table Expr a, Semigroup a) => Monad (TheseTable a) where
137121 (>>=) = (>>-)
138122
139123
140−instance (context ~ Expr, Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
141− Semigroup (TheseTable context a b)
124+instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
125+ Semigroup (TheseTable a b)
142126 where
143127 a <> b = TheseTable
144128 { here = here a <> here b
@@ -148,175 +132,124 @@ instance (context ~ Expr, Table Expr a, Table Expr b, Semigroup a, Semigroup b)
148132
149133instance
150134 ( Table context a, Table context b
151− , Reifiable context, context ~ context'
152− )
153− => Table context' (TheseTable context a b)
135+ , Nullifiable context, ConstrainTag context MaybeTag
136+ ) => Table context (TheseTable a b)
154137 where
155− type Columns (TheseTable context a b) = HTheseTable (Columns a) (Columns b)
156− type Context (TheseTable context a b) = Context a
157− type FromExprs (TheseTable context a b) =
158− These (FromExprs a) (FromExprs b)
159− type Transpose to (TheseTable context a b) =
160− TheseTable to (Transpose to a) (Transpose to b)
161−
162− toColumns TheseTable {here, there} = HTheseTable
163− { hhereTag = hlabel $ HIdentity $ tag here
164− , hhere =
165− hlabel $ guard (tag here) isJust isNonNull $ toColumns $ just here
166− , hthereTag = hlabel $ HIdentity $ tag there
167− , hthere =
168− hlabel $ guard (tag there) isJust isNonNull $ toColumns $ just there
169− }
138+ type Columns (TheseTable a b) = HTheseTable (Columns a) (Columns b)
139+ type Context (TheseTable a b) = Context a
170140
171− fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable
172− { here = MaybeTable
173− { tag = unHIdentity $ hunlabel hhereTag
174− , just = fromColumns $ hunlabel hhere
175− }
176− , there = MaybeTable
177− { tag = unHIdentity $ hunlabel hthereTag
178− , just = fromColumns $ hunlabel hthere
179− }
180− }
141+ toColumns = toColumns2 toColumns toColumns
142+ fromColumns = fromColumns2 fromColumns fromColumns
143+ reify = liftA2 bimap reify reify
144+ unreify = liftA2 bimap unreify unreify
181145
182− toResult tables = HTheseTable
183− { hhereTag = hrelabel hhereTag
184− , hhere = hrelabel hhere
185− , hthereTag = hrelabel hthereTag
186− , hthere = hrelabel hthere
187− }
188− where
189− HMaybeTable
190− { htag = hhereTag
191− , hjust = hhere
192− } = toResult @_ @(MaybeTable context a) (justHere tables)
193− HMaybeTable
194− { htag = hthereTag
195− , hjust = hthere
196− } = toResult @_ @(MaybeTable context b) (justThere tables)
197−
198− fromResult HTheseTable {hhereTag, hhere, hthereTag, hthere} =
199− case (here, there) of
200− (Just a, Nothing) -> This a
201− (Nothing, Just b) -> That b
202− (Just a, Just b) -> These a b
203− _ -> error "These.fromColumns: mismatch between tags and data"
204− where
205− here = fromResult @_ @(MaybeTable context a) mhere
206− there = fromResult @_ @(MaybeTable context b) mthere
207− mhere = HMaybeTable
208− { htag = hrelabel hhereTag
209− , hjust = hrelabel hhere
210− }
211− mthere = HMaybeTable
212− { htag = hrelabel hthereTag
213− , hjust = hrelabel hthere
214− }
215−
216−
217−instance (EqTable a, EqTable b, context ~ Expr) =>
218− EqTable (TheseTable context a b)
219− where
220− eqTable = HTheseTable
221− { hhereTag = hlabel (HIdentity Dict)
222− , hhere = hlabel (eqTable @(Nullify context a))
223− , hthereTag = hlabel (HIdentity Dict)
224− , hthere = hlabel (eqTable @(Nullify context b))
225− }
226146
147+instance
148+ ( Nullifiable from, ConstrainTag from MaybeTag
149+ , Nullifiable to, ConstrainTag to MaybeTag
150+ , Recontextualize from to a1 b1
151+ , Recontextualize from to a2 b2
152+ ) =>
153+ Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2)
154+
155+
156+instance (EqTable a, EqTable b) => EqTable (TheseTable a b) where
157+ eqTable = toColumns2 id id (thoseTable (eqTable @a) (eqTable @b))
227158
228−instance (OrdTable a, OrdTable b, context ~ Expr) =>
229− OrdTable (TheseTable context a b)
230− where
231− ordTable = HTheseTable
232− { hhereTag = hlabel (HIdentity Dict)
233− , hhere = hlabel (ordTable @(Nullify context a))
234− , hthereTag = hlabel (HIdentity Dict)
235− , hthere = hlabel (ordTable @(Nullify context b))
236− }
237159
160+instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where
161+ ordTable = toColumns2 id id (thoseTable (ordTable @a) (ordTable @b))
238162
239−instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable Expr exprs1 exprs2) =>
163+
164+type instance FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
165+
166+
167+instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable exprs1 exprs2) =>
240168 ToExprs x (These a b)
169+ where
170+ fromResult =
171+ bimap (fromResult @exprs1) (fromResult @exprs2) .
172+ fromColumns
173+ toResult =
174+ toColumns .
175+ bimap (toResult @exprs1) (toResult @exprs2)
176+
177+
178+toHereTag :: Tag "isJust" a -> Tag "hasHere" a
179+toHereTag Tag {..} = Tag {..}
180+
181+
182+toThereTag :: Tag "isJust" a -> Tag "hasThere" a
183+toThereTag Tag {..} = Tag {..}
241184
242185
243186-- | Test if a 'TheseTable' was constructed with 'thisTable'.
244187--
245188-- Corresponds to 'Data.These.Combinators.isThis'.
246−isThisTable :: TheseTable Expr a b -> Expr Bool
189+isThisTable :: TheseTable a b -> Expr Bool
247190isThisTable a = hasHereTable a &&. not_ (hasThereTable a)
248191
249192
250193-- | Test if a 'TheseTable' was constructed with 'thatTable'.
251194--
252195-- Corresponds to 'Data.These.Combinators.isThat'.
253−isThatTable :: TheseTable Expr a b -> Expr Bool
196+isThatTable :: TheseTable a b -> Expr Bool
254197isThatTable a = not_ (hasHereTable a) &&. hasThereTable a
255198
256199
257200-- | Test if a 'TheseTable' was constructed with 'thoseTable'.
258201--
259202-- Corresponds to 'Data.These.Combinators.isThese'.
260−isThoseTable :: TheseTable Expr a b -> Expr Bool
203+isThoseTable :: TheseTable a b -> Expr Bool
261204isThoseTable a = hasHereTable a &&. hasThereTable a
262205
263206
264207-- | Test if the @a@ side of @TheseTable a b@ is present.
265208--
266209-- Corresponds to 'Data.These.Combinators.hasHere'.
267−hasHereTable :: TheseTable Expr a b -> Expr Bool
210+hasHereTable :: TheseTable a b -> Expr Bool
268211hasHereTable TheseTable {here} = isJustTable here
269212
270213
271214-- | Test if the @b@ table of @TheseTable a b@ is present.
272215--
273216-- Corresponds to 'Data.These.Combinators.hasThere'.
274−hasThereTable :: TheseTable Expr a b -> Expr Bool
217+hasThereTable :: TheseTable a b -> Expr Bool
275218hasThereTable TheseTable {there} = isJustTable there
276219
277220
278221-- | Attempt to project out the @a@ table of a @TheseTable a b@.
279222--
280223-- Corresponds to 'Data.These.Combinators.justHere'.
281−justHereTable :: TheseTable context a b -> MaybeTable context a
224+justHereTable :: TheseTable a b -> MaybeTable a
282225justHereTable = here
283226
284227
285228-- | Attempt to project out the @b@ table of a @TheseTable a b@.
286229--
287230-- Corresponds to 'Data.These.Combinators.justThere'.
288−justThereTable :: TheseTable context a b -> MaybeTable context b
231+justThereTable :: TheseTable a b -> MaybeTable b
289232justThereTable = there
290233
291234
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−
302235-- | Construct a @TheseTable@. Corresponds to 'This'.
303−thisTable :: Table Expr b => a -> TheseTable Expr a b
236+thisTable :: Table Expr b => a -> TheseTable a b
304237thisTable a = TheseTable (justTable a) nothingTable
305238
306239
307240-- | Construct a @TheseTable@. Corresponds to 'That'.
308−thatTable :: Table Expr a => b -> TheseTable Expr a b
241+thatTable :: Table Expr a => b -> TheseTable a b
309242thatTable b = TheseTable nothingTable (justTable b)
310243
311244
312245-- | Construct a @TheseTable@. Corresponds to 'These'.
313−thoseTable :: a -> b -> TheseTable Expr a b
246+thoseTable :: a -> b -> TheseTable a b
314247thoseTable a b = TheseTable (justTable a) (justTable b)
315248
316249
317250-- | Pattern match on a 'TheseTable'. Corresponds to 'these'.
318251theseTable :: Table Expr c
319− => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable Expr a b -> c
252+ => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable a b -> c
320253theseTable f g h TheseTable {here, there} =
321254 maybeTable
322255 (maybeTable undefined f here)
@@ -324,19 +257,6 @@ theseTable f g h TheseTable {here, there} =
324257 there
325258
326259
327−-- | Lift a pair of aggregating functions to operate on an 'TheseTable'.
328−-- @thisTable@s, @thatTable@s and @thoseTable@s are grouped separately.
329−aggregateTheseTable :: ()
330− => (exprs -> aggregates)
331− -> (exprs' -> aggregates')
332− -> TheseTable Expr exprs exprs'
333− -> TheseTable Aggregate aggregates aggregates'
334−aggregateTheseTable f g (TheseTable here there) = TheseTable
335− { here = aggregateMaybeTable f here
336− , there = aggregateMaybeTable g there
337− }
338−
339−
340260-- | Construct a 'TheseTable' in the 'Name' context. This can be useful if you
341261-- have a 'TheseTable' that you are storing in a table and need to construct a
342262-- 'TableSchema'.
@@ -349,9 +269,67 @@ nameTheseTable :: ()
349269 -- ^ Names of the columns in the @a@ table.
350270 -> b
351271 -- ^ Names of the columns in the @b@ table.
352− -> TheseTable Name a b
272+ -> TheseTable a b
353273nameTheseTable here there a b =
354274 TheseTable
355275 { here = nameMaybeTable here a
356276 , there = nameMaybeTable there b
357277 }
278+
279+
280+toColumns2 ::
281+ ( HTable t
282+ , HTable u
283+ , HConstrainTag context MaybeTag
284+ , HNullifiable context
285+ )
286+ => (a -> t context)
287+ -> (b -> u context)
288+ -> TheseTable a b
289+ -> HTheseTable t u context
290+toColumns2 f g TheseTable {here, there} = HTheseTable
291+ { hhereTag = hlabel $ HType $ hencodeTag (toHereTag (tag here))
292+ , hhere =
293+ hlabel $ hnullify (hnullifier (tag here) isNonNull) $ f (just here)
294+ , hthereTag = hlabel $ HType $ hencodeTag (toThereTag (tag there))
295+ , hthere =
296+ hlabel $ hnullify (hnullifier (tag there) isNonNull) $ g (just there)
297+ }
298+
299+
300+fromColumns2 ::
301+ ( HTable t
302+ , HTable u
303+ , HConstrainTag context MaybeTag
304+ , HNullifiable context
305+ )
306+ => (t context -> a)
307+ -> (u context -> b)
308+ -> HTheseTable t u context
309+ -> TheseTable a b
310+fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable
311+ { here =
312+ let
313+ tag = hdecodeTag $ unHIdentity $ hunlabel hhereTag
314+ in
315+ MaybeTable
316+ { tag
317+ , just = f $
318+ runIdentity $
319+ hunnullify (\a -> pure . hunnullifier a) $
320+ hunlabel
321+ hhere
322+ }
323+ , there =
324+ let
325+ tag = hdecodeTag $ unHIdentity $ hunlabel hthereTag
326+ in
327+ MaybeTable
328+ { tag
329+ , just = g $
330+ runIdentity $
331+ hunnullify (\a -> pure . hunnullifier a) $
332+ hunlabel
333+ hthere
334+ }
335+ }
src/Rel8/Table/Transpose.hsdeleted−46
@@ -1,46 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language FlexibleInstances #-}
3−{-# language FunctionalDependencies #-}
4−{-# language StandaloneKindSignatures #-}
5−{-# language TypeFamilies #-}
6−{-# language UndecidableInstances #-}
7−
8−module Rel8.Table.Transpose
9− ( Transposes
10− )
11−where
12−
13−-- base
14−import Data.Kind ( Constraint, Type )
15−import Prelude ()
16−
17−-- rel8
18−import qualified Rel8.Schema.Kind as K
19−import Rel8.Table ( Table, Transpose, Congruent )
20−
21−
22−-- | @'Transposes' from to a b@ means that @a@ and @b@ are 'Table's, in the
23−-- @from@ and @to@ contexts respectively, which share the same underlying
24−-- structure. In other words, @b@ is a version of @a@ transposed from the
25−-- @from@ context to the @to@ context (and vice versa).
26−type Transposes :: K.Context -> K.Context -> Type -> Type -> Constraint
27−class
28− ( Table from a
29− , Table to b
30− , Congruent a b
31− , b ~ Transpose to a
32− , a ~ Transpose from b
33− )
34− => Transposes from to a b
35− | a -> from
36− , b -> to
37− , a to -> b
38− , b from -> a
39−instance
40− ( Table from a
41− , Table to b
42− , Congruent a b
43− , b ~ Transpose to a
44− , a ~ Transpose from b
45− )
46− => Transposes from to a b
src/Rel8/Table/Undefined.hs+5−5
@@ -11,16 +11,16 @@ where
1111import Prelude hiding ( undefined )
1212
1313-- rel8
14−import Rel8.Expr ( Expr )
14+import Rel8.Expr ( Expr, Col( 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/Unreify.hsnew file+102
@@ -0,0 +1,102 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language FlexibleInstances #-}
4+{-# language GADTs #-}
5+{-# language LambdaCase #-}
6+{-# language MultiParamTypeClasses #-}
7+{-# language QuantifiedConstraints #-}
8+{-# language RankNTypes #-}
9+{-# language StandaloneKindSignatures #-}
10+{-# language TypeFamilies #-}
11+{-# language UndecidableInstances #-}
12+
13+-- | This module implements some machinery for implementing methods of the
14+-- 'Table' class for a particular special (but important) class of polymorphic
15+-- @Table@ types.
16+--
17+-- This special case is characterised by a @newtype@ wrapper around a bare
18+-- 'HTable' which is constructed by applying a type family to the polymorphic
19+-- type variable.
20+--
21+-- Examples of this class of @Table@ include @ListTable@ and @NonEmptyTable@.
22+--
23+-- The tricky part about implementing @Table@ for these types is 'reify' and
24+-- 'unreify'. There is no guarantee in general that @'Unreify' a@ is itself
25+-- a @Table@, let alone a @Table@ with the same 'Columns' as @a@
26+-- (e.g., @Unreify (AColumn Result Bool) = Bool@, and @Bool@ is not a
27+-- @Table@)
28+
29+module Rel8.Table.Unreify
30+ ( Unreifiable, Unreifiability(..), unreifiability
31+ , Unreifies
32+ )
33+where
34+
35+-- base
36+import Data.Kind ( Constraint, Type )
37+import Prelude ()
38+
39+-- rel8
40+import Rel8.Aggregate ( Aggregate )
41+import Rel8.Expr ( Expr )
42+import Rel8.Kind.Context ( SContext(..), Reifiable, sReifiable )
43+import Rel8.Schema.Dict ( Dict( Dict ) )
44+import qualified Rel8.Schema.Kind as K
45+import Rel8.Schema.Name ( Name )
46+import Rel8.Schema.Reify ( Reify )
47+import Rel8.Schema.Result ( Result )
48+import Rel8.Table ( Table, Context, Congruent, Unreify )
49+
50+
51+type Unreifies :: K.Context -> Type -> Constraint
52+type family Unreifies context a where
53+ Unreifies (Reify context) a = Unreifier context a
54+ Unreifies _ _ = ()
55+
56+
57+type Unreifiable :: Type -> Constraint
58+class
59+ ( Context a ~ Reify Aggregate => Unreifier Aggregate a
60+ , Context a ~ Reify Expr => Unreifier Expr a
61+ , Context a ~ Reify Name => Unreifier Name a
62+ , (forall ctx. (Context a ~ Reify (Reify ctx), Reifiable ctx) => Unreifier (Reify ctx) a)
63+ )
64+ => Unreifiable a
65+instance
66+ ( Context a ~ Reify Aggregate => Unreifier Aggregate a
67+ , Context a ~ Reify Expr => Unreifier Expr a
68+ , Context a ~ Reify Name => Unreifier Name a
69+ , (forall ctx. (Context a ~ Reify (Reify ctx), Reifiable ctx) => Unreifier (Reify ctx) a)
70+ )
71+ => Unreifiable a
72+
73+
74+type Unreifier :: K.Context -> Type -> Constraint
75+class
76+ ( Table context (Unreify a)
77+ , Congruent a (Unreify a)
78+ )
79+ => Unreifier context a
80+instance
81+ ( Table context (Unreify a)
82+ , Congruent a (Unreify a)
83+ )
84+ => Unreifier context a
85+
86+
87+type Unreifiability :: K.Context -> Type -> Type
88+data Unreifiability context a where
89+ UResult :: Unreifiability Result a
90+ Unreifiability :: Unreifier context a
91+ => SContext context -> Unreifiability context a
92+
93+
94+unreifiability :: (Context a ~ Reify context, Unreifiable a)
95+ => SContext context -> Unreifiability context a
96+unreifiability = \case
97+ SAggregate -> Unreifiability SAggregate
98+ SExpr -> Unreifiability SExpr
99+ SName -> Unreifiability SName
100+ SResult -> UResult
101+ SReify context -> case sReifiable context of
102+ Dict -> Unreifiability (SReify context)
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+19−20
@@ -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,19 +30,19 @@ 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 ( Col( E ), Expr )
3534import Rel8.Expr.Opaleye ( castExpr, fromPrimExpr, toPrimExpr )
36−import Rel8.Schema.HTable ( HTable, hfield, hspecs, htabulate, htabulateA )
37−import Rel8.Schema.Name ( Name( Name ) )
35+import Rel8.Schema.HTable ( hfield, hspecs, htabulate, htabulateA )
36+import Rel8.Schema.Name ( Col( N ), Name( Name ) )
3837import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
39−import Rel8.Schema.Result ( Result )
40−import Rel8.Schema.Spec ( Spec( Spec, nullity, info ) )
41−import Rel8.Table ( fromColumns, toColumns, fromResult, toResult )
38+import Rel8.Schema.Result ( Col( R ), Result )
39+import Rel8.Schema.Spec ( SSpec( SSpec, nullity, info ) )
40+import Rel8.Table ( Table, fromColumns, toColumns )
4241import Rel8.Table.Eq ( EqTable )
43−import Rel8.Table.HKD ( HKD, HKDable )
42+import Rel8.Table.HKD ( HKD, HKDable, fromHKD, toHKD )
4443import Rel8.Table.Ord ( OrdTable )
4544import Rel8.Table.Rel8able ()
46−import Rel8.Table.Serialize ( litHTable )
45+import Rel8.Table.Serialize ( lit )
4746import Rel8.Type ( DBType, typeInformation )
4847import Rel8.Type.Eq ( DBEq )
4948import Rel8.Type.Information ( TypeInformation(..) )
@@ -68,8 +67,8 @@ newtype Composite a = Composite
6867
6968instance DBComposite a => DBType (Composite a) where
7069 typeInformation = TypeInformation
71− { decode = Hasql.composite (Composite . fromResult @_ @(HKD a Expr) <$> decoder)
72− , encode = encoder . litHTable . toResult @_ @(HKD a Expr) . unComposite
70+ { decode = Hasql.composite (Composite . fromHKD <$> decoder)
71+ , encode = encoder . lit . toColumns . toHKD . unComposite
7372 , typeName = compositeTypeName @a
7473 }
7574
@@ -104,7 +103,7 @@ class (DBType a, HKDable a) => DBComposite a where
104103-- single column expression, by combining them into a PostgreSQL composite
105104-- type.
106105compose :: DBComposite a => HKD a Expr -> Expr a
107−compose = castExpr . fromPrimExpr . encoder . toColumns
106+compose = castExpr . fromPrimExpr . encoder
108107
109108
110109-- | Expand a composite type into a 'HKD'.
@@ -113,23 +112,23 @@ 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
121120
122−decoder :: HTable t => Hasql.Composite (t Result)
123−decoder = unwrapApplicative $ htabulateA \field ->
121+decoder :: Table Result a => Hasql.Composite a
122+decoder = fmap fromColumns $ 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
129128
130129
131−encoder :: HTable t => t Expr -> Opaleye.PrimExpr
132−encoder a = Opaleye.FunExpr "ROW" exprs
130+encoder :: Table Expr a => a -> Opaleye.PrimExpr
131+encoder (toColumns -> 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
42
53-- aeson
@@ -8,7 +6,6 @@ import Data.Aeson.Types ( parseEither )
86
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
42
53-- aeson
@@ -7,7 +5,6 @@ import Data.Aeson ( FromJSON, ToJSON, parseJSON, toJSON )
75import Data.Aeson.Types ( parseEither )
86
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 #-}
54
65module Rel8.Type.ReadShow ( ReadShow(..) ) where
76
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−2
@@ -21,7 +21,7 @@ import Prelude
2121import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
2222
2323-- rel8
24−import Rel8.Expr ( Expr )
24+import {-# SOURCE #-} Rel8.Expr ( Expr )
2525import Rel8.Expr.Eq ( (==.) )
2626import Rel8.Expr.Opaleye ( zipPrimExprsWith )
2727import Rel8.Expr.Serialize ( litExpr )
@@ -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+-}