git.iko.soy/rel8
on 11e75b5 help sign in
6c038ec
swap
0 ahead, 247 behind
175 files changed+6213−9690
since splitsnapshots
unifiedsplit
.github/workflows/build.yaml+3−4 Changelog.md−159 LICENSE+1−1 README.md−4 cabal.project+5 cabal.project.haskell-nix+6 default.nix+5−5 docs/concepts/dbtype.rst+30−54 docs/concepts/expr.rst+2−2 docs/concepts/insert.rst−181 docs/concepts/queries.rst+11−130 docs/cookbook.rst+8−10 docs/index.rst+1−2 docs/tutorial.rst+47−64 nix/sources.json+9−9 nix/sources.nix+20−66 rel8.cabal+37−77 shell.nix+2−2 src/Rel8.hs+38−383 src/Rel8/Aggregate.hs+119−46 src/Rel8/Aggregate/Legacy.hs+93 src/Rel8/Column.hs−31 src/Rel8/Column/ADT.hs−23 src/Rel8/Column/Either.hs−26 src/Rel8/Column/Lift.hs−23 src/Rel8/Column/List.hs−25 src/Rel8/Column/Maybe.hs−26 src/Rel8/Column/NonEmpty.hs−27 src/Rel8/Column/Null.hs−26 src/Rel8/Column/These.hs−29 src/Rel8/Expr.hs+49−48 src/Rel8/Expr.hs-boot+4−5 src/Rel8/Expr/Aggregate.hs+84−57 src/Rel8/Expr/Array.hs+6−6 src/Rel8/Expr/Bool.hs+2−4 src/Rel8/Expr/Default.hs−35 src/Rel8/Expr/Eq.hs+17−15 src/Rel8/Expr/Function.hs+2−2 src/Rel8/Expr/Null.hs+17−18 src/Rel8/Expr/Num.hs+11−44 src/Rel8/Expr/Opaleye.hs+8−20 src/Rel8/Expr/Ord.hs+31−28 src/Rel8/Expr/Sequence.hs−22 src/Rel8/Expr/Serialize.hs+15−11 src/Rel8/Expr/Text.hs+4−24 src/Rel8/Expr/Time.hs+2−2 src/Rel8/Expr/Window.hs−121 src/Rel8/FCF.hs+1−9 src/Rel8/Generic/Construction.hs−352 src/Rel8/Generic/Construction/ADT.hs−478 src/Rel8/Generic/Construction/Record.hs−168 src/Rel8/Generic/Map.hs−49 src/Rel8/Generic/Record.hs−155 src/Rel8/Generic/Rel8able.hs−281 src/Rel8/Generic/Table.hs−103 src/Rel8/Generic/Table/ADT.hs−221 src/Rel8/Generic/Table/Record.hs−181 src/Rel8/Kind/Algebra.hs−38 src/Rel8/Kind/Context.hs−56 src/Rel8/Kind/Labels.hs+61 src/Rel8/Kind/Necessity.hs+38 src/Rel8/Opaque.hs+15 src/Rel8/Order.hs+2−2 src/Rel8/Query.hs+8−181 src/Rel8/Query.hs-boot+1−3 src/Rel8/Query/Aggregate.hs+2−22 src/Rel8/Query/Distinct.hs+9−4 src/Rel8/Query/Each.hs+3−4 src/Rel8/Query/Either.hs+17−27 src/Rel8/Query/Evaluate.hs−49 src/Rel8/Query/Exists.hs+17−15 src/Rel8/Query/Indexed.hs−21 src/Rel8/Query/List.hs+14−93 src/Rel8/Query/Maybe.hs+45−26 src/Rel8/Query/Null.hs+3−18 src/Rel8/Query/Opaleye.hs+5−41 src/Rel8/Query/Rebind.hs−27 src/Rel8/Query/SQL.hs+58−6 src/Rel8/Query/Set.hs+6−6 src/Rel8/Query/These.hs+45−52 src/Rel8/Query/Window.hs−26 src/Rel8/Schema/Column.hs+142 src/Rel8/Schema/Context.hs+28 src/Rel8/Schema/Context/Identity.hs+199 src/Rel8/Schema/Context/Label.hs+60 src/Rel8/Schema/Context/Nullify.hs+166−105 src/Rel8/Schema/Field.hs+21−37 src/Rel8/Schema/Generic.hs+1049 src/Rel8/Schema/Generic/Test.hs+79 src/Rel8/Schema/HTable.hs+36−68 src/Rel8/Schema/HTable/Either.hs+17−5 src/Rel8/Schema/HTable/Identity.hs+17−16 src/Rel8/Schema/HTable/Label.hs+51−36 src/Rel8/Schema/HTable/MapTable.hs+14−28 src/Rel8/Schema/HTable/Maybe.hs+17−5 src/Rel8/Schema/HTable/Nullify.hs+46−55 src/Rel8/Schema/HTable/Pair.hs+20 src/Rel8/Schema/HTable/Product.hs−17 src/Rel8/Schema/HTable/Quartet.hs+29 src/Rel8/Schema/HTable/Quintet.hs+30 src/Rel8/Schema/HTable/These.hs+6−5 src/Rel8/Schema/HTable/Trio.hs+28 src/Rel8/Schema/HTable/Type.hs+61 src/Rel8/Schema/HTable/Vectorize.hs+67−45 src/Rel8/Schema/Insert.hs+164 src/Rel8/Schema/Kind.hs+14−8 src/Rel8/Schema/Name.hs+43−32 src/Rel8/Schema/Null.hs−110 src/Rel8/Schema/Nullability.hs+22 src/Rel8/Schema/Nullability/Internal.hs+142 src/Rel8/Schema/Result.hs−54 src/Rel8/Schema/Spec.hs+60−18 src/Rel8/Schema/Spec/ConstrainDBType.hs+70 src/Rel8/Schema/Spec/ConstrainType.hs+31 src/Rel8/Schema/Structure.hs+54 src/Rel8/Schema/Table.hs−20 src/Rel8/Statement/Delete.hs+48−35 src/Rel8/Statement/Insert.hs+60−60 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−121 src/Rel8/Statement/Set.hs−33 src/Rel8/Statement/Update.hs+60−38 src/Rel8/Statement/Using.hs−36 src/Rel8/Statement/View.hs+28−44 src/Rel8/Statement/Where.hs−31 src/Rel8/Table.hs+144−144 src/Rel8/Table/ADT.hs−173 src/Rel8/Table/Aggregate.hs+17−40 src/Rel8/Table/Bool.hs+6−12 src/Rel8/Table/Cols.hs−50 src/Rel8/Table/Either.hs+116−154 src/Rel8/Table/Eq.hs+69−38 src/Rel8/Table/HKD.hs−228 src/Rel8/Table/Insert.hs+51 src/Rel8/Table/Lifted.hs+82 src/Rel8/Table/List.hs+36−84 src/Rel8/Table/Maybe.hs+110−124 src/Rel8/Table/Name.hs+22−37 src/Rel8/Table/NonEmpty.hs+34−85 src/Rel8/Table/Null.hs−147 src/Rel8/Table/Nullify.hs−211 src/Rel8/Table/Opaleye.hs+68−92 src/Rel8/Table/Ord.hs+73−45 src/Rel8/Table/Order.hs+18−14 src/Rel8/Table/Projection.hs−73 src/Rel8/Table/Recontextualize.hs+133 src/Rel8/Table/Rel8able.hs−92 src/Rel8/Table/Serialize.hs+270−69 src/Rel8/Table/Tag.hs+104 src/Rel8/Table/These.hs+133−211 src/Rel8/Table/Transpose.hs−46 src/Rel8/Table/Undefined.hs+6−6 src/Rel8/Table/Window.hs−43 src/Rel8/Tabulate.hs+228−530 src/Rel8/Type.hs+21−16 src/Rel8/Type/Array.hs+31−52 src/Rel8/Type/Array1D.hs+136 src/Rel8/Type/Composite.hs−135 src/Rel8/Type/Enum.hs−139 src/Rel8/Type/Eq.hs+7−2 src/Rel8/Type/JSONBEncoded.hs−4 src/Rel8/Type/JSONEncoded.hs−4 src/Rel8/Type/Monoid.hs+9−2 src/Rel8/Type/Num.hs+13−9 src/Rel8/Type/Ord.hs+17−2 src/Rel8/Type/ReadShow.hs+3−14 src/Rel8/Type/Semigroup.hs+9−5 src/Rel8/Type/String.hs+5 src/Rel8/Type/Sum.hs+5 src/Rel8/Type/Tag.hs−13 src/Rel8/Window.hs−97 tests/Main.hs+174−338 tests/Rel8/Generic/Rel8able/Test.hs−188
.github/workflows/build.yaml+3−4
@@ -9,18 +9,17 @@ 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 }}'
2323
2424 - run: nix-build -A hsPkgs.rel8.components.library
2525 - run: nix-build -A hsPkgs.rel8.checks.tests
26− - run: nix-build shell.nix
Changelog.mddeleted−159
@@ -1,159 +0,0 @@
1−# 1.4.0.0 (2002-08-17)
2−
3−## Breaking changes
4−
5−* The behavior of `greatest`/`least` has been corrected, and was previously flipped. ([#183](https://github.com/circuithub/rel8/pull/183))
6−
7−## New features
8−
9−* `NullTable`/`HNull` have been added. This is an alternative to `MaybeTable` that doesn't use a tag columns. It's less flexible (no `Functor` or `Applicative` instance) and is meaningless when used with a table that has no non-nullable columns (so nesting `NullTable` is redundant). But in situations where the underlying `Table` does have non-nullable columns, it can losslessly converted to and from `MaybeTable`. It is useful for embedding into a base table when you don't want to store the extra tag column in your schema. ([#173](https://github.com/circuithub/rel8/pull/173))
10−* Add `fromMaybeTable`. ([#179](https://github.com/circuithub/rel8/pull/179))
11−* Add `alignMaybeTable`. ([#196](https://github.com/circuithub/rel8/pull/196))
12−
13−## Improvements
14−
15−* Optimize implementation of `AltTable` for `Tabulation` ([#178](https://github.com/circuithub/rel8/pull/178))
16−
17−## Other
18−
19−* Documentation improvements for `HADT`. ([#177](https://github.com/circuithub/rel8/pull/177))
20−* Document example usage of `groupBy`. ([#184](https://github.com/circuithub/rel8/pull/184))
21−* Build with and require Opaleye >= 0.9.3.3. ([#190](https://github.com/circuithub/rel8/pull/190))
22−* Build with `hasql` 1.6. ([#195](https://github.com/circuithub/rel8/pull/195))
23−
24−# 1.3.1.0 (2022-01-20)
25−
26−## Other
27−
28−* Rel8 now requires Opaleye >= 0.9.1. ([#165](https://github.com/circuithub/rel8/pull/165))
29−
30−# 1.3.0.0 (2022-01-31)
31−
32−## Breaking changes
33−
34−* `div` and `mod` have been changed to match Haskell semantics. If you need the PostgreSQL `div()` and `mod()` functions, use `quot` and `rem`. While this is not an API change, we feel this is a breaking change in semantics and have bumped the major version number. ([#155](https://github.com/circuithub/rel8/pull/155))
35−
36−## New features
37−
38−* `divMod` and `quotRem` functions have been added, matching Haskell's `Prelude` functions. ([#155](https://github.com/circuithub/rel8/pull/155))
39−* `avg` and `mode` aggregation functions to find the mean value of an expression, or the most common row in a query, respectively. ([#152](https://github.com/circuithub/rel8/pull/152))
40−* The full `EqTable` and `OrdTable` classes have been exported, allowing for instances to be manually created. ([#157](https://github.com/circuithub/rel8/pull/157))
41−* Added `like` and `ilike` (for the `LIKE` and `ILIKE` operators). ([#146](https://github.com/circuithub/rel8/pull/146))
42−
43−## Other
44−
45−* Rel8 now requires Opaleye 0.9. ([#158](https://github.com/circuithub/rel8/pull/158))
46−* Rel8's test suite supports Hedgehog 1.1. ([#160](https://github.com/circuithub/rel8/pull/160))
47−* The documentation for binary operations has been corrected. ([#162](https://github.com/circuithub/rel8/pull/162))
48−
49−# 1.2.2.0 (2021-11-21)
50−
51−## Other
52−
53−* Support GHC 9.2 ([#145](https://github.com/circuithub/rel8/pull/145))
54−* Correct the documentation for `except` ([#147](https://github.com/circuithub/rel8/pull/147))
55−* Support `hasql` 1.5 ([#149](https://github.com/circuithub/rel8/pull/149))
56−
57−# 1.2.1.0 (2021-11-21)
58−
59−## New features
60−
61−* `castTable` has been added, which casts all columns selected from in `Query` according to the types of columns. This can occasionally be useful when using `many`/`some` on older PostgreSQL versions. ([#137](https://github.com/circuithub/rel8/pull/137))
62−
63−* Added `<:`, `<=:`, `>:`, `>=:`, `greatest` and `least`, which sort all columns in a table lexicographically. These operators are like the `<.` operators which operate on `Expr`s, but the `<:` operate on entire tables. ([#139](https://github.com/circuithub/rel8/pull/139))
64−
65−## Other
66−
67−* Support opaleye-0.8 ([#142](https://github.com/circuithub/rel8/pull/142))
68−
69−# 1.2.0.0 (2021-10-22)
70−
71−## New features
72−
73−* New `$*` and `$+` operators for projecting out of `ListTable` and `NonEmptyTable` respectively (analogous to the existing `$?` for `MaybeTable`). ([#125](https://github.com/circuithub/rel8/pull/125))
74−
75−## Bug fixes
76−
77−* Fix `UPSERT` support (and add tests), which was broken due to a typo inside Rel8 that made it impossible to construct `Projection`s which are needed by `UPSERT`. ([#134](https://github.com/circuithub/rel8/pull/134))
78−
79−* Remove `DBMin` and `DBMax` instances for `Bool`, which are invalid as far as Postgres is concerned. `and` and `or` can be used to achieve the same thing. ([#126](https://github.com/circuithub/rel8/pull/126))
80−
81−* Fix `aggregateMaybeTable`, `aggregateEitherTable` and `aggregateTheseTable`, which generated invalid SQL previously. ([#127](https://github.com/circuithub/rel8/pull/127))
82−
83−## Breaking changes
84−
85−* `rebind` now takes an additional argument for the "name" of the binding. ([#128](https://github.com/circuithub/rel8/pull/128))
86−
87−# 1.1.0.0 (2021-07-16)
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−
122−* Rename `whereExists` and `whereNotExists` to `present` and `absent` respectively. ([#57](https://github.com/circuithub/rel8/pull/57))
123−
124−* Simplify `evaluate` to run directly inside the `Query` monad, rendering the `Evaluate` monad unnecessary. ([#56](https://github.com/circuithub/rel8/pull/56))
125−
126−* 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))
127−
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−
138−## Bug fixes
139−
140−* 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))
141−
142−* 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))
143−
144−* Rel8 now compiles with GHC 9. ([#97](https://github.com/circuithub/rel8/pull/97))
145−
146−## Other changes
147−
148−* `exists` is now implemented in terms of the SQL `EXISTS` keyword. ([#69](https://github.com/circuithub/rel8/pull/69))
149−
150−* `alignBy` no longer requires `Table`s. ([#67](https://github.com/circuithub/rel8/pull/67))
151−
152−
153−# 1.0.0.1 (2021-06-21)
154−
155−This release contains various fixes for documentation.
156−
157−# 1.0.0.0 (2021-06-18)
158−
159−* Initial release.
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright 2021 Oliver Charles
1+Copyright 2020 Oliver Charles
22
33All rights reserved.
44
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/galenhuntington/data-serializer
9+ tag: 070d681f97b705f47716e13b646512140524f940
10+ --sha256: 198g99ksglnc7c45sjm2xyay1m6hfj4afkp3sksdss5w5abp543f
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/dbtype.rst+30−54
@@ -11,19 +11,18 @@ though most of these primitive ``DBType``\s should already be available.
1111Combining ``newtype`` and ``DBType``
1212------------------------------------
1313
14−You can define new instances of ``DBType`` by using Haskell "generalized
15−newtype deriving" strategy. This is useful when you have a common database
16−type, but need to interpret this type differently in different contexts. A very
17−common example here is with auto-incrementing ``id`` counters. In PostgreSQL,
18−it's common for a table to have a primary key that uses the ``serial`` type,
19−which means the key is an ``int8`` with a default value for ``INSERT``. In
20−Rel8, we could use ``Int64`` (as ``Int64`` is the ``DBType`` instance for
21−``int8``), but we can be even clearer if we make a ``newtype`` for each *type*
22−of id.
23−
24−If our database has users and orders, these tables might both have ids, but
25−they are clearly not meant to be treated as a common type. Instead, we can make
26−these types clearly different by writing::
14+You can define new instances of ``DBType`` by using Haskell "generalized newtype
15+deriving" strategy. This is useful when you have a common database type, but
16+need to interpret this type differently in different contexts. A very common
17+example here is with auto-incrementing ``id`` counters. In PostgreSQL, it's
18+common for a table to have a primary key that uses the ``serial`` type, which
19+means the key is an ``int8`` with a default value for ``INSERT``. In Rel8, we
20+could use ``Int64`` (as ``Int64`` is the ``DBType`` instance for ``int8``), but
21+we can be even clearer if we make a ``newtype`` for each *type* of id.
22+
23+If our database has users and orders, these tables might both have ids, but they
24+are clearly not meant to be treated as a common type. Instead, we can make these
25+types clearly different by writing::
2726
2827 newtype UserId = UserId { getUserId :: Int64 }
2928 deriving newtype DBType
@@ -58,8 +57,8 @@ In our PostgreSQL we have a few choices, but for now we'll assume that they are
5857stored as ``text`` values.
5958
6059In order to use this type in Rel8 queries, we need to write an instance of
61−``DBType`` for ``OrderStatus``. One approach is to use
62−``parseTypeInformation``, which allows you to refine an existing ``DBType``::
60+``DBType`` for ``OrderStatus``. One approach is to use ``parseTypeInformation``,
61+which allows you to refine an existing ``DBType``::
6362
6463 instance DBType OrderStatus where
6564 typeInformation = parseTypeInformation parser printer typeInformation
@@ -101,9 +100,9 @@ There usage is very similar to ``ReadShow`` - simply derive ``DBType via
101100JSONEncoded``, and Rel8 will use ``ToJSON`` and ``FromJSON`` instances (from
102101``aeson``) to serialize the given type.
103102
104−For example, a project might use event sourcing with a table of events. Each
105−row in this table is an event, but this event is stored as a JSON object. We
106−can use this type with Rel8 by writing::
103+For example, a project might use event sourcing with a table of events. Each row
104+in this table is an event, but this event is stored as a JSON object. We can use
105+this type with Rel8 by writing::
107106
108107 data Event = UserCreated UserCreatedData | OrderCreated OrderCreatedData
109108 deriving stock Generic
@@ -119,57 +118,34 @@ The ``DBType`` subtypes
119118``DBEq``
120119^^^^^^^^
121120
122−The ``DBEq`` type class represents the subclass of database types that support
123−equality. By supporting equality, we mean that a type supports the ``=``
124−operator, and also has a suitable notion of equality for operations like
125−``GROUP BY`` and ``DISTINCT``. On the one hand, this class is like Haskell's
126−``Eq`` type class. The main difference is that this class has no methods.
121+.. todo::
122+
123+ Document this
127124
128125``DBOrd``
129126^^^^^^^^^
130127
131−The ``DBOrd`` type class represents the subclass of database types that support
132−the normal comparison operators - ``<``, ``<=``, ``>=`` and ``>``.
133−
134−``DBMax`` and ``DBMin``
135−^^^^^^^^^^^^^^^^^^^^^^^
128+.. todo::
136129
137−The type classes indicate that a database type supports the ``min()`` and
138−``max()`` aggregation functions.
130+ Write this
139131
140132``DBSemigroup`` and ``DBMonoid``
141133^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
142134
143−These type classes exist to give Rel8's API a similar feel to Haskell
144−programming. Many database types have a sensible monoid structure, with the
145−presence of a ``mempty``-like expression, and an associative operation to
146−combine ``Expr``\s.
135+.. todo::
136+
137+ Write this
147138
148139``DBNum``, ``DBIntegral`` and ``DBFractional``
149140^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
150141
151−These type classes are used to present a familiar numeric type hierarchy for
152−Haskell programmers.
142+.. todo::
153143
154−``DBNum``
155− This class indicates that a type supports the ``+``, ``-``, and ``*``
156− operators, along with the ``abs()``, ``negate()`` and ``sign()`` functions.
157− Database types that are instances of ``DBNum`` allow ``Num (Expr a)`` to be
158− used (allowing you to combine expressions with Haskell's normal ``+``
159− function).
160−
161−``DBIntegral``
162− If a type is an instance of ``DBIntegral``, it means that the type stores
163− integral (whole) numbers. The ``Rel8.Expr.Num`` module provides familiar
164− ``Expr`` functions like ``fromIntegral`` to convert between types.
165−
166−``DBFractional``
167− If a type is an instance of ``DBFraction``, it means that the type supports
168− the ``/`` operator, and literals can be created via Haskell's ``Rational``
169− type class. This type class provides the ``Fracitonal (Expr a)`` instance.
144+ Write this
170145
171146``DBString``
172147^^^^^^^^^^^^
173148
174−This type class indicates that a database type supports the ``string_agg()``
175−aggregation function.
149+.. todo::
150+
151+ Write this
docs/concepts/expr.rst+2−2
@@ -58,7 +58,7 @@ Through the API reference documentation for Rel8, you might encounter the
5858``Sql`` type class. For example, if we look at the type of ``litExpr``, we
5959have::
6060
61− litExpr :: Sql DBType a => a -> Expr a
61+ litExpr :: Sql DBType a => a -> Expr a
6262
6363Here ``Sql DBType a`` means that ``a`` can either be literally a type that has
6464an instance of ``DBType`` (like ``UserId`` or ``Bool``), *or* that same type
@@ -69,6 +69,6 @@ Some functions work regardless of whether or not a value is null, and in these
6969cases you'll see ``Sql DBType a``. ``Sql`` can be used with any ``DBType``
7070subtype. For example, the type of ``div`` is::
7171
72− div :: Sql DBIntegral a => Expr a -> Expr a -> Expr a
72+ div :: Sql DBIntegral a => Expr a -> Expr a -> Expr a
7373
7474Which means ``div`` works on any ``DBIntegral a``, including ``Maybe a``.
docs/concepts/insert.rstdeleted−181
@@ -1,181 +0,0 @@
1−``INSERT``, ``UPDATE`` and ``DELETE``
2−=====================================
3−
4−While the majority of Rel8 is about building and executing ``SELECT``
5−statement, Rel8 also has support for ``INSERT``, ``UPDATE`` and ``DELETE``.
6−These statements are all executed using the ``insert``, ``update`` and
7−``delete`` functions, all of which take a record of parameters.
8−
9−.. note::
10−
11− This part of Rel8's API uses the ``DuplicateRecordFields`` language
12− extension. In code that needs to use this API, you should also enable this
13− language extension, or you may get errors about ambiguous field names.
14−
15−``DELETE``
16−----------
17−
18−To perform a ``DELETE`` statement, construct a ``Delete`` value and execute it
19−using ``delete``. ``Delete`` takes:
20−
21−``from``
22− The ``TableSchema`` for the table to delete rows from.
23−
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−
30−``deleteWhere``
31− 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.
34−
35−``returning``
36− What to return - see :ref:`returning`.
37−
38−``UPDATE``
39−----------
40−
41−To perform a ``UPDATE`` statement, construct a ``Update`` value and execute it
42−using ``update``. ``Update`` takes:
43−
44−``target``
45− The ``TableSchema`` for the table to update rows in.
46−
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 ()``.
52−
53−``set``
54− A row to row transformation function, indicating how to update selected rows.
55− This function takes rows of the same shape as ``target`` but in the ``Expr``
56− context. One way to write this function is to use record update syntax::
57−
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.
64−
65−``returning``
66− What to return - see :ref:`returning`.
67−
68−``INSERT``
69−----------
70−
71−To perform a ``INSERT`` statement, construct a ``Insert`` value and execute it
72−using ``insert``. ``Insert`` takes:
73−
74−``into``
75− The ``TableSchema`` for the table to insert rows into.
76−
77−``rows``
78− The rows to insert. These are the same as ``into``, but in the ``Expr``
79− context. You can construct rows from their individual fields::
80−
81− rows = values [ MyTable { myTableA = lit "A", myTableB = lit 42 }
82−
83− or you can use ``lit`` on a table value in the ``Result`` context::
84−
85− rows = values [ lit MyTable { myTableA = "A", myTableB = 42 }
86−
87−``onConflict``
88− What should happen if an insert clashes with rows that already exist. This
89− corresponds to PostgreSQL's ``ON CONFLICT`` clause. You can specify:
90−
91− ``Abort``
92− PostgreSQL should abort the ``INSERT`` with an exception
93−
94− ``DoNothing``
95− PostgreSQL should not insert the duplicate rows.
96−
97− ``DoUpdate``
98− PostgreSQL should instead try to update any existing rows that conflict
99− with rows proposed for insertion.
100−
101−``returning``
102− What to return - see :ref:`returning`.
103−
104−.. _returning:
105−
106−``RETURNING``
107−-------------
108−
109−PostgreSQL has the ability to return extra information after a ``DELETE``,
110−``INSERT`` or ``UPDATE`` statement by attaching a ``RETURNING`` clause. A common
111−use of this clause is to return any automatically generated sequence values for
112−primary key columns. Rel8 supports ``RETURNING`` clauses by filling in the
113−``returning`` field and specifying a ``Projection``. A ``Projection`` is a row
114−to row transformation, allowing you to project out a subset of fields.
115−
116−For example, if we are inserting orders, we might want the order ids returned::
117−
118− insert Insert
119− { into = orderSchema
120− , rows = values [ order ]
121− , onConflict = Abort
122− , returning = Projection orderId
123− }
124−
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−
134−Default values
135−--------------
136−
137−It is fairly common to define tables with default values. While Rel8 does not
138−have specific functionality for ``DEFAULT``, there are a few options:
139−
140−``unsafeDefault``
141−~~~~~~~~~~~~~~~~~~~~~~~~~~~
142−
143−Rel8 does not have any special support for ``DEFAULT``. If you need to use
144−default column values in inserts, you can use ``unsafeDefault`` to
145−construct the ``DEFAULT`` expression::
146−
147− insert Insert
148− { into = orderSchema
149− , rows = values [ Order { orderId = unsafeDefault, ... } ]
150− , onConflict = Abort
151− , returning = Projection orderId
152− }
153−
154−.. warning::
155− As the name suggests, this is an unsafe operation. In particular, Rel8 is not
156− able to prove that this column does have a default value, so it may be
157− possible to introduce a runtime error. Furthermore, ``DEFAULT`` is fairly
158− special in SQL, and cannot be combined like other expressions. For example,
159− the innocuous expression::
160−
161− unsafeDefault + 1
162−
163− will lead to a runtime crash.
164−
165−Reimplement default values in Rel8
166−~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
167−
168−If you only need to access default values in Rel8, another option is to specify
169−them in Rel8, rather than in your database schema.
170−
171−.. hint::
172− A common default value for primary keys is to use `nextval` to obtain the
173− next value from a sequence. This can be done in Rel8 by using the ``nextval``
174− function::
175−
176− insert Insert
177− { into = orderSchema
178− , rows = values [ Order { orderId = nextval "order_id_seq", ... } ]
179− , onConflict = Abort
180− , returning = Projection orderId
181− }
docs/concepts/queries.rst+11−130
@@ -88,7 +88,7 @@ notation allows you to write these queries in a simpler form, where we don't
8888have to introduce functions. Expanding on the latter query, we could write::
8989
9090 do user <- getAllUsers
91− order <- getOrdersForUser user
91+ order <- getOrdersForUser (user)
9292 return (user, order)
9393
9494Now we have a query that, for each ``User``, fetches all orders for that user.
@@ -108,156 +108,37 @@ with a ``TableSchema``.
108108Limit and offset
109109----------------
110110
111−The SQL ``LIMIT`` and ``OFFSET`` keywords are available in Rel8 as ``limit``
112−and ``offset``. Note that, like SQL, the order of these operations matters.
113−Usually, the correct thing to do is to first apply an offset with ``offset``,
114−and then use ``limit`` to limit the number of rows returned::
115−
116− limit n . offset m . orderBy anOrdering
111+.. todo::
117112
118−These operations are similar to Haskell's ``take`` and ``drop`` operations.
113+ Write this
119114
120115Filtering queries
121116-----------------
122117
123−Rel8 offers a few different ways to filter the rows selected by a query.
124−Perhaps the most familiar operation is to apply a ``WHERE`` clause to a query.
125−In Rel8, this is done using ``where_``, which takes any ``Expr Bool``, and
126−returns rows where that ``Expr`` is true. For example, to select all public
127−blog posts, we could write::
128−
129− blogPost <- each blogPostSchema
130− where_ $ blogPostIsPublic blogPost
131−
132−An alternative way to write ``WHERE`` clauses is to use ``filter``. This
133−operator is similar to the ``guard`` function in ``Control.Monad``, but also
134−returns the tested row. This allows us to easily chain a filtering operation on
135−a query. The above query could thus be written as::
136−
137− blogPost <- filter blogPostIsPublic =<< each blogPostSchema
138−
139−``where_`` and ``filter`` allow you to filter rows based on an expression, but
140−sometimes we want to filter based on another query. For this, Rel8 offers
141−``present`` and ``absent``. For example, if all blog posts have a
142−list of tags, we could use ``present`` to find all blog posts that have been
143−tagged as "Haskell"::
144−
145− blogPost <- each blogPostSchema
146− present do
147− filter (("Haskell" ==.) . tagName) =<< tagFromBlogPost blogPost
148−
149−Notice that this example uses ``present`` with a query that itself uses
150−``filter``. For each blog post, ``present`` causes that row to be selected
151−only if the associated query finds a tag for that blog post with the ``tagName``
152−"Haskell".
153−
154−Like ``filter`` there is also a chaining variant of ``present`` - ``with``.
155−We could rewrite the above query using ``with`` as::
118+.. todo::
156119
157− haskellBlogPost <-
158− each blogPostSchema >>=
159− with (filter (("Haskell" ==.) . tagName) <=< tagFromBlogPost)
120+ Write this
160121
161122Inner joins
162123-----------
163124
164−Inner joins are SQL queries of the form ``SELECT .. FROM x JOIN y ON ..``. Rel8
165−doesn't offer a special function for these queries, as the same query can be
166−expressed by selecting from two tables (this is called taking the *cartesian
167−product* of two queries) and then filtering the result.
168−
169−If we wanted to join each blog post with the author of the blog post, we would
170−write the SQL::
171−
172− SELECT * FROM blog_post JOIN author ON author.id = blog_post.id
173−
174−The alternative way to write this query with ``WHERE`` is::
175−
176− SELECT * FROM blog_post, author WHERE author.id = blog_post.id
177−
178−and this query can be written in Rel8 as::
179−
180− blogPost <- each blogPostSchema
181− author <- each authorSchema
182− where_ $ blogPostAuthorId blogPost ==. authorId author
183−
184−.. hint::
185−
186− A good pattern to adopt is to abstract out these joins as functions. A
187− suggested way to write the above would be to extract out an "author for blog
188− post" function::
189−
190− blogPost <- each blogPostSchema
191− author <- authorForBlogPost blogPost
192−
193− where::
194−
195− authorForBlogPost :: BlogPost Expr -> Query (Author Expr)
196− authorForBlogPost blogPost =
197− filter ((blogPostAuthorId blogPost ==.) . authorId) =<<
198− each authorSchema
125+.. todo::
199126
200− While this is a little more code over all, in our experience this style
201− dramatically increases the readability of queries using joins.
127+ Write this
202128
203129Left (outer) joins with ``optional``
204130------------------------------------
205131
206−A left join is like an inner join, but allows for the possibility of the join to
207−"fail". You use left joins when you want to join optional information against a
208−row.
209−
210−In Rel8, a ``LEFT JOIN`` is introduced by converting an inner join with
211−``optional``. While this approach might seem a little foreign at first, it has a
212−strong similarity with the ``Control.Applicative.optional`` function, and allows
213−you to reuse previous code.
214−
215−To see an example of this, let's assume that we want to get the latest comment
216−for each blog post. Not all blog posts are popular though, so some blog posts
217−might have no comment at all. To write this in Rel8, we could write::
218−
219− blogPost <- each blogPostSchema
220−
221− latestComment <-
222− optional $ limit 1 $
223− orderBy (commentCreatedAt >$< desc) $
224− commentsForBlogPost blogPost
225−
226−``optional`` will transform a ``Query a`` into a ``Query (MaybeTable a)``.
227−``MaybeTable`` is similar to the normal ``Maybe`` data type in Haskell, and
228−represents the choice between a ``justTable x`` and a ``nothingTable`` (like
229−``Just x`` and ``Nothing``, respectively). When you execute a query containing
230−``MaybeTable x`` with ``select``, Rel8 will return ``Maybe x``. ``MaybeTable``
231−comes with a library of routines, similar to the functions that can be used to
232−operate on ``Maybe``. For more details, see the API documentation.
233−
234−.. hint::
132+.. todo::
235133
236− ``optional`` converts an inner join into a ``LEFT JOIN``, but you can also go
237− the other way - and turn a ``LEFT JOIN`` back into an inner join! To do this,
238− you can use ``catMaybeTable``, which will select only the rows when the left
239− join was successful.
134+ Write this
240135
241136Ordering results
242137----------------
243138
244−Rel8 supports ordering the results returned by a ``Query``, using SQL's ``ORDER
245−BY`` syntax. To specify an ordering, you use ``orderBy`` and supply an
246−appropriate ``Order`` value.
247−
248−An ``Order`` is built by combining the order of individual columns, each of
249−which can be either ascending or descending. To order a single column, you
250−combine ``asc`` or ``desc`` with ``Order``\s *contravariant* interface. For
251−example, if we have a table with a ``orderId`` column, we can order a ``Query
252−(Order Expr)`` by ``orderId`` with::
253−
254− orderBy (orderId >$< asc)
255−
256−To order by multiple columns, combine the individual orders with ``Order``\s
257−``Monoid`` instance. We could extend the above example to order by the order
258−date first (with the most recent orders first) with::
139+.. todo::
259140
260− orderBy (mconcat [orderDate >$< desc, orderId >$< asc])
141+ Write this
261142
262143Aggregating queries
263144-------------------
docs/cookbook.rst+8−10
@@ -72,7 +72,7 @@ can be written as::
7272 each myTableSchema
7373
7474Note that we use ``>$<`` (from ``Data.Functor.Contravariant``) to select table
75−columns, and we can use ``mconcat`` to combine orderings.
75+columns, and we can use `mconcat` to combine orderings.
7676
7777If all columns of a table have an ordering, you can also use ``ascTable`` and
7878``descTable``. For example::
@@ -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)
docs/index.rst+1−2
@@ -30,7 +30,6 @@ The main objectives of Rel8 are:
3030 concepts/expr
3131 concepts/tables
3232 concepts/queries
33− concepts/insert
3433
3534.. toctree::
3635 :caption: Tips and tricks
@@ -50,4 +49,4 @@ More Resources
5049
5150* If you think you've found a bug, confusing behavior, or have a feature
5251 request, please raise an issue at `Rel8's issue tracker
53− <https://github.com/circuithub/rel8>`_.
52+ <https://github.com/circuithub/rel8>`_.
docs/tutorial.rst+47−64
@@ -5,25 +5,24 @@ Getting Started
55
66In this section, we'll take a look at using Rel8 to work with a small database
77for Haskell packages. We'll take a look at idiomatic usage of Rel8, mapping
8−tables to Haskell, and then look at writing some simple queries.
8+tables to Haskell, and then look at writing some simple queries.
99
1010Before we get started, we'll be using the following language extensions and
1111imports throughout this guide::
1212
13− {-# language BlockArguments #-}
14− {-# language DeriveAnyClass #-}
15− {-# language DeriveGeneric #-}
16− {-# language DerivingStrategies #-}
17− {-# language DerivingVia #-}
18− {-# language DuplicateRecordFields #-}
19− {-# language GeneralizedNewtypeDeriving #-}
20− {-# language OverloadedStrings #-}
21− {-# language StandaloneDeriving #-}
22− {-# language TypeApplications #-}
23− {-# language TypeFamilies #-}
13+ {-# language -XBlockArguments #-}
14+ {-# language -XDeriveAnyClass #-}
15+ {-# language -XDeriveGeneric #-}
16+ {-# language -XDerivingStrategies #-}
17+ {-# language -XDerivingVia #-}
18+ {-# language -XDuplicateRecordFields #-}
19+ {-# language -XGeneralizedNewtypeDeriving #-}
20+ {-# language -XOverloadedStrings #-}
21+ {-# language -XStandaloneDeriving #-}
22+ {-# language -XTypeApplications #-}
23+ {-# language -XTypeFamilies #-}
2424
2525 import Prelude
26− import Rel8
2726
2827The Example Schema
2928------------------
@@ -71,7 +70,7 @@ Following these steps for ``author``, we have::
7170 { authorId :: Column f Int64
7271 , name :: Column f Text
7372 , url :: Column f (Maybe Text)
74− }
73+ }
7574 deriving stock (Generic)
7675 deriving anyclass (Rel8able)
7776
@@ -82,7 +81,7 @@ in our project, it would be too easy to accidentally mix them up and create
8281nonsensical joins. As Haskell programmers, we often solve this problem by
8382creating ``newtype`` wrappers, and we can also use this technique with Rel8::
8483
85− newtype AuthorId = AuthorId { toInt64 :: Int64 }
84+ newtype AuthorId = AuthorId { toInt64 :: Int64 }
8685 deriving newtype (DBEq, DBType, Eq, Show)
8786
8887Now we can write our final schema mapping. First, the ``author`` table::
@@ -91,7 +90,7 @@ Now we can write our final schema mapping. First, the ``author`` table::
9190 { authorId :: Column f AuthorId
9291 , authorName :: Column f Text
9392 , authorUrl :: Column f (Maybe Text)
94− }
93+ }
9594 deriving stock (Generic)
9695 deriving anyclass (Rel8able)
9796
@@ -100,16 +99,16 @@ And similarly, the ``project`` table::
10099 data Project f = Project
101100 { projectAuthorId :: Column f AuthorId
102101 , projectName :: Column f Text
103− }
102+ }
104103 deriving stock (Generic)
105− deriving anyclass (Rel8able)
104+ deriving anyclass (Rel8able
106105
107106To show query results in this documentation, we'll also need ``Show`` instances:
108107Unfortunately these definitions look a bit scary, but they are essentially just
109108``deriving (Show)``::
110109
111− deriving stock instance f ~ Result => Show (Author f)
112− deriving stock instance f ~ Result => Show (Project f)
110+ deriving stock instance f ~ Identity => Show (Author f)
111+ deriving stock instance f ~ Identity => Show (Project f)
113112
114113These data types describe the structural mapping of the tables, but we also
115114need to specify a ``TableSchema`` for each table. A ``TableSchema`` contains
@@ -126,9 +125,9 @@ associated with the ``Author`` type::
126125
127126 authorSchema :: TableSchema (Author Name)
128127 authorSchema = TableSchema
129− { name = "author"
130− , schema = Nothing
131− , columns = Author
128+ { tableName = "author"
129+ , tableSchema = Nothing
130+ , tableColumns = Author
132131 { authorId = "author_id"
133132 , authorName = "name"
134133 , authorUrl = "url"
@@ -139,27 +138,14 @@ And likewise for ``project`` and ``Project``::
139138
140139 projectSchema :: TableSchema (Project Name)
141140 projectSchema = TableSchema
142− { name = "project"
143− , schema = Nothing
144− , columns = Project
141+ { tableName = "project"
142+ , tableSchema = Nothing
143+ , tableColumns = Project
145144 { projectAuthorId = "author_id"
146145 , projectName = "name"
147146 }
148147 }
149148
150−There is also some generics machinery available if you want to grab the field
151−information from your ``Rel8able`` type::
152−
153− projectSchema :: TableSchema (Project Name)
154− projectSchema = TableSchema
155− { name = "project"
156− , schema = Nothing
157− , columns = namesFromLabels @(Project Name)
158− }
159−
160−This will create a ``TableSchema`` for ``Project`` where every column name
161−corresponds exactly to the name of the field. If you need more flexibility, you
162−can use ``namesFromLabelsWith``, which takes a transformation function.
163149
164150.. note::
165151
@@ -183,7 +169,7 @@ database heavy applications.
183169
184170In Rel8, ``SELECT`` statements are built using the ``Query`` monad. You can
185171think of this monad like the ordinary ``[]`` (List) monad - but this isn't
186−required knowledge.
172+required knowledge.
187173
188174To start, we'll look at one of the simplest queries possible - a basic ``SELECT
189175* FROM`` statement. To select all rows from a table, we use ``each``, and
@@ -204,28 +190,25 @@ Recall we defined ``projectAuthorId`` as ``Column f AuthorId``. Now we have
204190We'll see more about ``Expr`` soon, but you can think of ``Expr a`` as "SQL
205191expressions of type ``a``\".
206192
207−To execute this ``Query``, we pass it to ``select``. This function takes both a
208−database connection (which can be obtained using hasql's ``acquire`` function),
209−and the ``Query`` to run::
193+To execute this ``Query``, we pass it to ``select``::
210194
211− >>> Right conn <- acquire "user=postgres"
212− >>> :t select conn (each projectSchema)
213− select conn (each projectSchema) :: MonadIO m => m [Project Result]
195+ >>> :t select c (each projectSchema)
196+ select c (each projectSchema) :: MonadIO m => m [Project Identity]
214197
215−When we ``select`` things containing ``Expr``\s, Rel8 builds a new response
216−table with the ``Result`` interpretation. This means you'll get back plain
198+When we ``select`` things containing ``Expr``s, Rel8 builds a new response
199+table with the ``Identity`` interpretation. This means you'll get back plain
217200Haskell values. Studying ``projectAuthorId`` again, we have::
218201
219− >>> let aProjectResult = undefined :: Project Result
220− >>> :t projectAuthorId aProjectResult
221− projectAuthorId aProjectResult :: AuthorId
202+ >>> let aProjectIdentity = undefined :: Project Identity
203+ >>> :t projectAuthorId aProjectIdentity
204+ projectAuthorId aProjectIdentity :: AuthorId
222205
223−Here ``Column Result AuthorId`` reduces to just ``AuthorId``, with no
206+Here ``Column Identity AuthorId`` reduces to just ``AuthorId``, with no
224207wrappping type at all.
225208
226209Putting this all together, we can run our first query::
227210
228− >>> select conn (each projectSchema) >>= mapM_ print
211+ >>> select c (each projectSchema) >>= mapM_ print
229212 Project {projectAuthorId = 1, projectName = "rel8"}
230213 Project {projectAuthorId = 2, projectName = "aeson"}
231214 Project {projectAuthorId = 2, projectName = "text"}
@@ -235,7 +218,7 @@ sometimes we're only interested in a subset of the columns of a table. To
235218restrict the returned columns, we can specify a projection by using ``Query``\s
236219``Functor`` instance::
237220
238− >>> select conn $ projectName <$> each projectSchema
221+ >>> select c $ projectName <$> each projectSchema
239222 ["rel8","aeson","text"]
240223
241224Joins
@@ -251,7 +234,7 @@ We can do this by simply calling ``each`` twice, and then returning a tuple of
251234their results::
252235
253236 >>> :{
254− mapM_ print =<< select conn do
237+ mapM_ print =<< select c do
255238 author <- each authorSchema
256239 project <- each projectSchema
257240 return (projectName project, authorName author)
@@ -270,7 +253,7 @@ This isn't quite right, though, as we have ended up pairing up the wrong
270253projects and authors. To fix this, we can use ``where_`` to restrict the
271254returned rows. We could write::
272255
273− select conn $ do
256+ select c $ do
274257 author <- each authorSchema
275258 project <- each projectSchema
276259 where_ $ projectAuthorId project ==. authorId author
@@ -287,7 +270,7 @@ for the particular joins in your database. In our case, this would be::
287270Our final query is then::
288271
289272 >>> :{
290− mapM_ print =<< select conn do
273+ mapM_ print =<< select c do
291274 author <- each authorSchema
292275 project <- projectsForAuthor author
293276 return (projectName project, authorName author)
@@ -306,7 +289,7 @@ transformer to allow for the possibility of the join to fail.
306289In our test database, we can see that there's another author who we haven't
307290seen yet::
308291
309− >>> select conn $ authorName <$> each authorSchema
292+ >>> select c $ authorName <$> each authorSchema
310293 ["Ollie","Bryan O'Sullivan","Emily Pillmore"]
311294
312295Emily wasn't returned in our earlier query because - in our database - she
@@ -314,7 +297,7 @@ doesn't have any registered projects. We can account for this partiality in our
314297original query by wrapping the ``projectsForAuthor`` call with ``optional``::
315298
316299 >>> :{
317− mapM_ print =<< select conn do
300+ mapM_ print =<< select c do
318301 author <- each authorSchema
319302 mproject <- optional $ projectsForAuthor author
320303 return (authorName author, projectName <$> mproject)
@@ -359,9 +342,9 @@ focus on the /type/ of that query::
359342 return (author, project)
360343 where
361344
362− >>> :t select conn authorsAndProjects
363− select conn authorsAndProjects
364− :: MonadIO m => m [(Author Result, Project Result)]
345+ >>> :t select c authorsAndProjects
346+ select c authorsAndProjects
347+ :: MonadIO m => m [(Author Identity, Project Identity)]
365348
366349
367350Our query gives us a single list of pairs of authors and projects. However,
@@ -369,7 +352,7 @@ with our domain knowledge of the schema, this isn't a great type - what we'd
369352rather have is a list of pairs of authors and /lists/ of projects. That is,
370353what we'd like is::
371354
372− [(Author Result, [Project Result])]
355+ [(Author Identity, [Project Identity])]
373356
374357This would be a much better type! Rel8 can produce a query with this type by
375358simply wrapping the call to ``projectsForAuthor`` with either ``some`` or
@@ -377,7 +360,7 @@ simply wrapping the call to ``projectsForAuthor`` with either ``some`` or
377360author to have no projects::
378361
379362 >>> :{
380− mapM_ print =<< select conn do
363+ mapM_ print =<< select c do
381364 author <- each authorSchema
382365 projectNames <- many $ projectName <$> projectsForAuthor author
383366 return (authorName author, projectNames)
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": "486de5bfd4e7a93d999dc09969cb1278b9a43f30",
9+ "sha256": "12mal6p6z946z1w0knv04dkhpjmyqlaccmkf7skv23bf8iqg6gaz",
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/486de5bfd4e7a93d999dc09969cb1278b9a43f30.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": "af958e8057f345ee1aca714c1247ef3ba1c15f5e",
21+ "sha256": "1qjavxabbrsh73yck5dcq8jggvh3r2jkbr6b5nlz5d9yrqm9255n",
2222 "type": "tarball",
23− "url": "https://github.com/nmattia/niv/archive/acdb1726783637852c01e0ad639ac9cbec28d8c8.tar.gz",
23+ "url": "https://github.com/nmattia/niv/archive/af958e8057f345ee1aca714c1247ef3ba1c15f5e.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": "da7f4c4842520167f65c20ad75ecdbd14e27ae91",
33+ "sha256": "0vdq6lkc1sqj85x8r8idpck3igjns8ix57fqf1r5pm4k0qhy7p2m",
3434 "type": "tarball",
35− "url": "https://github.com/nixos/nixpkgs/archive/1c1f5649bb9c1b0d98637c8c365228f57126f361.tar.gz",
35+ "url": "https://github.com/nixos/nixpkgs/archive/da7f4c4842520167f65c20ad75ecdbd14e27ae91.tar.gz",
3636 "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
3737 }
3838}
nix/sources.nix+20−66
@@ -6,53 +6,25 @@ let
66 # The fetchers. fetch_<type> fetches specs of type <type>.
77 #
88
9− fetch_file = pkgs: name: spec:
10− let
11− name' = sanitizeName name + "-src";
12− in
13− if spec.builtin or true then
14− builtins_fetchurl { inherit (spec) url sha256; name = name'; }
15− else
16− pkgs.fetchurl { inherit (spec) url sha256; name = name'; };
9+ fetch_file = pkgs: spec:
10+ if spec.builtin or true then
11+ builtins_fetchurl { inherit (spec) url sha256; }
12+ else
13+ pkgs.fetchurl { inherit (spec) url sha256; };
1714
1815 fetch_tarball = pkgs: name: spec:
1916 let
20− name' = sanitizeName name + "-src";
17+ ok = str: ! builtins.isNull (builtins.match "[a-zA-Z0-9+-._?=]" str);
18+ # sanitize the name, though nix will still fail if name starts with period
19+ name' = stringAsChars (x: if ! ok x then "-" else x) "${name}-src";
2120 in
2221 if spec.builtin or true then
2322 builtins_fetchTarball { name = name'; inherit (spec) url sha256; }
2423 else
2524 pkgs.fetchzip { name = name'; inherit (spec) url sha256; };
2625
27− fetch_git = name: spec:
28− let
29− ref =
30− if spec ? ref then spec.ref else
31− if spec ? branch then "refs/heads/${spec.branch}" else
32− if spec ? tag then "refs/tags/${spec.tag}" else
33− abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!";
34− submodules = if spec ? submodules then spec.submodules else false;
35− submoduleArg =
36− let
37− nixSupportsSubmodules = builtins.compareVersions builtins.nixVersion "2.4" >= 0;
38− emptyArgWithWarning =
39− if submodules == true
40− then
41− builtins.trace
42− (
43− "The niv input \"${name}\" uses submodules "
44− + "but your nix's (${builtins.nixVersion}) builtins.fetchGit "
45− + "does not support them"
46− )
47− {}
48− else {};
49− in
50− if nixSupportsSubmodules
51− then { inherit submodules; }
52− else emptyArgWithWarning;
53− in
54− builtins.fetchGit
55− ({ url = spec.repo; inherit (spec) rev; inherit ref; } // submoduleArg);
26+ fetch_git = spec:
27+ builtins.fetchGit { url = spec.repo; inherit (spec) rev ref; };
5628
5729 fetch_local = spec: spec.path;
5830
@@ -68,21 +40,11 @@ let
6840 # Various helpers
6941 #
7042
71− # https://github.com/NixOS/nixpkgs/pull/83241/files#diff-c6f540a4f3bfa4b0e8b6bafd4cd54e8bR695
72− sanitizeName = name:
73− (
74− concatMapStrings (s: if builtins.isList s then "-" else s)
75− (
76− builtins.split "[^[:alnum:]+._?=-]+"
77− ((x: builtins.elemAt (builtins.match "\\.*(.*)" x) 0) name)
78− )
79− );
80−
8143 # The set of packages used when specs are fetched using non-builtins.
82− mkPkgs = sources: system:
44+ mkPkgs = sources:
8345 let
8446 sourcesNixpkgs =
85− import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; };
47+ import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) {};
8648 hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath;
8749 hasThisAsNixpkgsPath = <nixpkgs> == ./.;
8850 in
@@ -102,9 +64,9 @@ let
10264
10365 if ! builtins.hasAttr "type" spec then
10466 abort "ERROR: niv spec ${name} does not have a 'type' attribute"
105− else if spec.type == "file" then fetch_file pkgs name spec
67+ else if spec.type == "file" then fetch_file pkgs spec
10668 else if spec.type == "tarball" then fetch_tarball pkgs name spec
107− else if spec.type == "git" then fetch_git name spec
69+ else if spec.type == "git" then fetch_git spec
10870 else if spec.type == "local" then fetch_local spec
10971 else if spec.type == "builtin-tarball" then fetch_builtin-tarball name
11072 else if spec.type == "builtin-url" then fetch_builtin-url name
@@ -118,10 +80,7 @@ let
11880 saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name;
11981 ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}";
12082 in
121− if ersatz == "" then drv else
122− # this turns the string into an actual Nix path (for both absolute and
123− # relative paths)
124− if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}";
83+ if ersatz == "" then drv else ersatz;
12584
12685 # Ports of functions for older nix versions
12786
@@ -139,29 +98,25 @@ let
13998
14099 # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269
141100 stringAsChars = f: s: concatStrings (map f (stringToCharacters s));
142− concatMapStrings = f: list: concatStrings (map f list);
143101 concatStrings = builtins.concatStringsSep "";
144102
145− # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331
146− optionalAttrs = cond: as: if cond then as else {};
147−
148103 # fetchTarball version that is compatible between all the versions of Nix
149− builtins_fetchTarball = { url, name ? null, sha256 }@attrs:
104+ builtins_fetchTarball = { url, name, sha256 }@attrs:
150105 let
151106 inherit (builtins) lessThan nixVersion fetchTarball;
152107 in
153108 if lessThan nixVersion "1.12" then
154− fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; }))
109+ fetchTarball { inherit name url; }
155110 else
156111 fetchTarball attrs;
157112
158113 # fetchurl version that is compatible between all the versions of Nix
159− builtins_fetchurl = { url, name ? null, sha256 }@attrs:
114+ builtins_fetchurl = { url, sha256 }@attrs:
160115 let
161116 inherit (builtins) lessThan nixVersion fetchurl;
162117 in
163118 if lessThan nixVersion "1.12" then
164− fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; }))
119+ fetchurl { inherit url; }
165120 else
166121 fetchurl attrs;
167122
@@ -180,8 +135,7 @@ let
180135 mkConfig =
181136 { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null
182137 , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile)
183− , system ? builtins.currentSystem
184− , pkgs ? mkPkgs sources system
138+ , pkgs ? mkPkgs sources
185139 }: rec {
186140 # The sources, i.e. the attribute set of spec name to spec
187141 inherit sources;
rel8.cabal+37−77
@@ -1,36 +1,24 @@
11cabal-version: 2.0
22name: rel8
3−version: 1.4.0.0
3+version: 0.1.0.0
44synopsis: Hey! Hey! Can u rel8?
55license: BSD3
66license-file: LICENSE
77author: Oliver Charles
88maintainer: ollie@ocharles.org.uk
9−homepage: https://github.com/circuithub/rel8
10−bug-reports: https://github.com/circuithub/rel8/issues
119build-type: Simple
12−extra-doc-files:
13− README.md
14− Changelog.md
15−
16−source-repository head
17− type: git
18− location: https://github.com/circuithub/rel8
1910
2011library
2112 build-depends:
2213 aeson
23− , base ^>= 4.14 || ^>=4.15 || ^>=4.16
24− , bifunctors
14+ , base ^>= 4.14 || ^>=4.15
2515 , bytestring
2616 , case-insensitive
27− , comonad
17+ , casing
2818 , contravariant
29− , hasql ^>= 1.4.5.1 || ^>= 1.5.0.0 || ^>= 1.6.0.0
30− , opaleye ^>= 0.9.6.1
31− , pretty
19+ , hasql ^>= 1.4.5.1
20+ , opaleye ^>= 0.7.1.0
3221 , profunctors
33− , product-profunctors
3422 , scientific
3523 , semialign
3624 , semigroupoids
@@ -41,12 +29,10 @@ library
4129 default-language:
4230 Haskell2010
4331 ghc-options:
44− -Werror=missing-methods -Werror=incomplete-patterns -Werror=missing-fields
4532 -Weverything -Wno-unsafe -Wno-safe -Wno-missing-safe-haskell-mode
4633 -Wno-missing-import-lists -Wno-prepositive-qualified-module
4734 -Wno-monomorphism-restriction
48− -Wno-missing-local-signatures
49− -Wno-missing-kind-signatures
35+ -Wno-missing-local-signatures
5036 hs-source-dirs:
5137 src
5238 exposed-modules:
@@ -56,48 +42,28 @@ library
5642 Rel8.Expr.Time
5743 Rel8.Tabulate
5844
45+ -- deprecated
46+ Rel8.Aggregate.Legacy
47+
5948 other-modules:
6049 Rel8.Aggregate
6150
62− Rel8.Column
63− Rel8.Column.ADT
64− Rel8.Column.Either
65− Rel8.Column.Lift
66− Rel8.Column.List
67− Rel8.Column.Maybe
68− Rel8.Column.NonEmpty
69− Rel8.Column.Null
70− Rel8.Column.These
71−
7251 Rel8.Expr
7352 Rel8.Expr.Aggregate
7453 Rel8.Expr.Array
7554 Rel8.Expr.Bool
76− Rel8.Expr.Default
7755 Rel8.Expr.Eq
7856 Rel8.Expr.Function
7957 Rel8.Expr.Null
8058 Rel8.Expr.Opaleye
8159 Rel8.Expr.Ord
8260 Rel8.Expr.Order
83− Rel8.Expr.Sequence
8461 Rel8.Expr.Serialize
85− Rel8.Expr.Window
8662
8763 Rel8.FCF
8864
89− Rel8.Kind.Algebra
90− Rel8.Kind.Context
91−
92− Rel8.Generic.Construction
93− Rel8.Generic.Construction.ADT
94− Rel8.Generic.Construction.Record
95− Rel8.Generic.Map
96− Rel8.Generic.Record
97− Rel8.Generic.Rel8able
98− Rel8.Generic.Table
99− Rel8.Generic.Table.ADT
100− Rel8.Generic.Table.Record
65+ Rel8.Kind.Labels
66+ Rel8.Kind.Necessity
10167
10268 Rel8.Order
10369
@@ -106,26 +72,28 @@ library
10672 Rel8.Query.Distinct
10773 Rel8.Query.Each
10874 Rel8.Query.Either
109− Rel8.Query.Evaluate
11075 Rel8.Query.Exists
11176 Rel8.Query.Filter
112− Rel8.Query.Indexed
11377 Rel8.Query.Limit
11478 Rel8.Query.List
11579 Rel8.Query.Maybe
11680 Rel8.Query.Null
11781 Rel8.Query.Opaleye
11882 Rel8.Query.Order
119− Rel8.Query.Rebind
12083 Rel8.Query.Set
12184 Rel8.Query.SQL
12285 Rel8.Query.These
12386 Rel8.Query.Values
124− Rel8.Query.Window
12587
88+ Rel8.Schema.Column
89+ Rel8.Schema.Context
90+ Rel8.Schema.Context.Identity
91+ Rel8.Schema.Context.Label
12692 Rel8.Schema.Context.Nullify
12793 Rel8.Schema.Dict
12894 Rel8.Schema.Field
95+ Rel8.Schema.Generic
96+ Rel8.Schema.Generic.Test
12997 Rel8.Schema.HTable
13098 Rel8.Schema.HTable.Either
13199 Rel8.Schema.HTable.Identity
@@ -135,59 +103,55 @@ library
135103 Rel8.Schema.HTable.Maybe
136104 Rel8.Schema.HTable.NonEmpty
137105 Rel8.Schema.HTable.Nullify
138− Rel8.Schema.HTable.Product
106+ Rel8.Schema.HTable.Pair
107+ Rel8.Schema.HTable.Quartet
108+ Rel8.Schema.HTable.Quintet
139109 Rel8.Schema.HTable.These
110+ Rel8.Schema.HTable.Trio
111+ Rel8.Schema.HTable.Type
140112 Rel8.Schema.HTable.Vectorize
113+ Rel8.Schema.Insert
141114 Rel8.Schema.Kind
142115 Rel8.Schema.Name
143− Rel8.Schema.Null
144− Rel8.Schema.Result
116+ Rel8.Schema.Nullability
117+ Rel8.Schema.Nullability.Internal
145118 Rel8.Schema.Spec
119+ Rel8.Schema.Spec.ConstrainDBType
120+ Rel8.Schema.Spec.ConstrainType
146121 Rel8.Schema.Table
147122
148123 Rel8.Statement.Delete
149124 Rel8.Statement.Insert
150− Rel8.Statement.OnConflict
151125 Rel8.Statement.Returning
152126 Rel8.Statement.Select
153− Rel8.Statement.Set
154− Rel8.Statement.SQL
155127 Rel8.Statement.Update
156− Rel8.Statement.Using
157128 Rel8.Statement.View
158− Rel8.Statement.Where
159129
160130 Rel8.Table
161− Rel8.Table.ADT
162131 Rel8.Table.Aggregate
163132 Rel8.Table.Alternative
164133 Rel8.Table.Bool
165− Rel8.Table.Cols
166134 Rel8.Table.Either
167135 Rel8.Table.Eq
168− Rel8.Table.HKD
136+ Rel8.Table.Insert
137+ Rel8.Table.Lifted
169138 Rel8.Table.List
170139 Rel8.Table.Maybe
171140 Rel8.Table.Name
172141 Rel8.Table.NonEmpty
173− Rel8.Table.Null
174− Rel8.Table.Nullify
175142 Rel8.Table.Opaleye
176143 Rel8.Table.Ord
177144 Rel8.Table.Order
178− Rel8.Table.Projection
179− Rel8.Table.Rel8able
145+ Rel8.Table.Recontextualize
180146 Rel8.Table.Serialize
147+ Rel8.Table.Tag
181148 Rel8.Table.These
182− Rel8.Table.Transpose
183149 Rel8.Table.Undefined
184− Rel8.Table.Window
185150
186151 Rel8.Type
187152 Rel8.Type.Array
188− Rel8.Type.Composite
153+ Rel8.Type.Array1D
189154 Rel8.Type.Eq
190− Rel8.Type.Enum
191155 Rel8.Type.Information
192156 Rel8.Type.JSONEncoded
193157 Rel8.Type.JSONBEncoded
@@ -200,8 +164,8 @@ library
200164 Rel8.Type.Sum
201165 Rel8.Type.Tag
202166
203− Rel8.Window
204−
167+ Rel8.Opaque
168+ Rel8.Schema.Structure
205169
206170test-suite tests
207171 type: exitcode-stdio-1.0
@@ -211,9 +175,9 @@ test-suite tests
211175 , case-insensitive
212176 , containers
213177 , hasql
214− , hasql-transaction
215− , hedgehog ^>= 1.0 || ^>= 1.1
216− , mmorph
178+ , hedgehog ^>=1.0.2
179+ , lifted-base ^>=0.2.3.12
180+ , monad-control ^>=1.0.2.3
217181 , rel8
218182 , scientific
219183 , tasty
@@ -221,12 +185,8 @@ test-suite tests
221185 , text
222186 , time
223187 , tmp-postgres ^>=1.34.1.0
224− , transformers
225188 , uuid
226189
227− other-modules:
228− Rel8.Generic.Rel8able.Test
229−
230190 main-is: Main.hs
231191 hs-source-dirs: tests
232192 default-language: Haskell2010
shell.nix+2−2
@@ -1,10 +1,10 @@
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 {
7− withHoogle = false;
7+ withHoogle = true;
88 tools = { cabal = "latest"; };
99 exactDeps = false;
1010 buildInputs = [ pkgs.postgresql pkgs.pythonPackages.sphinx ];
src/Rel8.hs+38−383
@@ -13,10 +13,6 @@ module Rel8
1313 -- **** @ReadShow@
1414 , ReadShow(..)
1515
16− -- **** Generic
17− , Composite(..), DBComposite(..), compose, decompose
18− , Enum(..), DBEnum(..), Enumable
19−
2016 -- *** @TypeInformation@
2117 , TypeInformation(..)
2218 , mapTypeInformation
@@ -28,42 +24,32 @@ module Rel8
2824 , DBNum
2925 , DBIntegral
3026 , DBFractional
31− , DBFloating
3227
3328 -- * Tables and higher-kinded tables
34− , Rel8able, KRel8able
35− , Column
36− , HADT
37− , HEither
29+ , Rel8able
30+ , Column, Field, Necessity( Required, Optional )
31+ , Default, Label
3832 , HMaybe
3933 , HList
4034 , HNonEmpty
41− , HNull
4235 , HThese
43− , Lift
4436
45− , Table(..)
46− , HTable
47− , Transposes
37+ , Table
4838 , AltTable((<|>:))
49− , AlternativeTable( emptyTable )
50− , EqTable(..), (==:), (/=:)
51− , OrdTable(..), (<:), (<=:), (>:), (>=:), ascTable, descTable, greatest, least
39+ , EqTable, (==:), (/=:)
40+ , OrdTable, ascTable, descTable
5241 , lit
5342 , bool
5443 , case_
55− , castTable
5644
5745 -- ** @MaybeTable@
5846 , MaybeTable
5947 , maybeTable, ($?), nothingTable, justTable
6048 , isNothingTable, isJustTable
61− , fromMaybeTable
6249 , optional
6350 , catMaybeTable
51+ , bindMaybeTable
6452 , traverseMaybeTable
65− , aggregateMaybeTable
66− , nameMaybeTable
6753
6854 -- ** @EitherTable@
6955 , EitherTable
@@ -71,9 +57,8 @@ module Rel8
7157 , isLeftTable, isRightTable
7258 , keepLeftTable
7359 , keepRightTable
60+ , bindEitherTable
7461 , bitraverseEitherTable
75− , aggregateEitherTable
76− , nameEitherTable
7762
7863 -- ** @TheseTable@
7964 , TheseTable
@@ -81,73 +66,22 @@ module Rel8
8166 , isThisTable, isThatTable, isThoseTable
8267 , hasHereTable, hasThereTable
8368 , justHereTable, justThereTable
84− , alignMaybeTable
8569 , alignBy
8670 , keepHereTable, loseHereTable
8771 , keepThereTable, loseThereTable
8872 , keepThisTable, loseThisTable
8973 , keepThatTable, loseThatTable
9074 , keepThoseTable, loseThoseTable
75+ , bindTheseTable
9176 , bitraverseTheseTable
92− , aggregateTheseTable
93− , nameTheseTable
9477
9578 -- ** @ListTable@
9679 , ListTable
97− , listTable, ($*)
98− , nameListTable
9980 , many
100− , manyExpr
101− , catListTable
102− , catList
10381
10482 -- ** @NonEmptyTable@
10583 , NonEmptyTable
106− , nonEmptyTable, ($+)
107− , nameNonEmptyTable
10884 , some
109− , someExpr
110− , catNonEmptyTable
111− , catNonEmpty
112−
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
127− , ADT, ADTable
128−
129− -- *** Deconstruction of ADTs
130− -- $deconstruction
131− , DeconstructADT, deconstructADT
132−
133− -- *** Construction of ADTs
134− -- $construction
135− , BuildADT, buildADT
136− , ConstructADT, constructADT
137−
138− -- *** Other ADT operations
139− , AggregateADT, aggregateADT
140−
141− -- *** Miscellaneous notes
142− -- $misc-notes
143−
144− -- ** @HKD@
145− , HKD, HKDable
146− , BuildHKD, buildHKD
147− , ConstructHKD, constructHKD
148− , DeconstructHKD, deconstructHKD
149− , NameHKD, nameHKD
150− , AggregateHKD, aggregateHKD
15185
15286 -- ** Table schemas
15387 , TableSchema(..)
@@ -160,20 +94,16 @@ module Rel8
16094 , Sql
16195 , litExpr
16296 , unsafeCastExpr
163− , unsafeLiteral
16497
16598 -- ** @null@
166− , NotNull
167− , Nullable
168− , Homonullable
16999 , null
170100 , nullify
171101 , nullable
172102 , isNull
173103 , isNonNull
174− , mapNull
175− , liftOpNull
176− , catNull
104+ , mapNullable
105+ , liftOpNullable
106+ , catNullable
177107 , coalesce
178108
179109 -- ** Boolean operations
@@ -184,7 +114,6 @@ module Rel8
184114 , (==.), (/=.), (==?), (/=?)
185115 , in_
186116 , boolExpr, caseExpr
187− , like, ilike
188117
189118 -- ** Ordering
190119 , DBOrd
@@ -202,13 +131,6 @@ module Rel8
202131 , Query
203132 , showQuery
204133
205− -- ** Projection
206− , Projection
207− , Projectable( project )
208− , Biprojectable( biproject )
209− , Projecting
210− , Field
211−
212134 -- ** Selecting rows
213135 , Selects
214136 , each
@@ -217,8 +139,8 @@ module Rel8
217139 -- ** Filtering
218140 , filter
219141 , where_
220− , present
221− , absent
142+ , whereExists
143+ , whereNotExists
222144 , distinct
223145 , distinctOn
224146 , distinctOnBy
@@ -248,16 +170,14 @@ module Rel8
248170
249171 -- ** Aggregation
250172 , Aggregate
251− , Aggregates
252173 , aggregate
253174 , countRows
254− , groupBy
255175 , listAgg, listAggExpr
256− , mode
257176 , nonEmptyAgg, nonEmptyAggExpr
177+ , groupBy
258178 , DBMax, max
259179 , DBMin, min
260− , DBSum, sum, sumWhere, avg
180+ , DBSum, sum, sumWhere
261181 , DBString, stringAgg
262182 , count
263183 , countStar
@@ -274,71 +194,43 @@ module Rel8
274194 , nullsFirst
275195 , nullsLast
276196
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−
303197 -- * IO
304198 , Serializable
305− , ToExprs
306− , Result
307199
308200 -- * Running statements
309− -- $running
310−
311201 -- ** @SELECT@
312202 , select
313203
314204 -- ** @INSERT@
315205 , Insert(..)
316206 , OnConflict(..)
317− , Upsert(..)
318207 , insert
319− , unsafeDefault
320− , showInsert
208+ , toInsert
209+ , toInsertDefaults
321210
322211 -- ** @DELETE@
323212 , Delete(..)
324213 , delete
325− , showDelete
326214
327215 -- ** @UPDATE@
328− , Update(..)
329216 , update
330− , showUpdate
217+ , Update(..)
331218
332219 -- ** @.. RETURNING@
333220 , Returning(..)
334221
335222 -- ** @CREATE VIEW@
336223 , createView
337− , createOrReplaceView
338224
339− -- ** Sequences
340− , nextval
341− , evaluate
225+ -- * TODO
226+ -- TODO
227+ -- These need organizing, but are reachable from Rel8's documentation so we
228+ -- do need to export and document them.
229+ , HasNullability
230+ , NotNull
231+ , HTable
232+ , Labelable
233+ , Context
342234 ) where
343235
344236-- base
@@ -346,91 +238,65 @@ import Prelude ()
346238
347239-- rel8
348240import Rel8.Aggregate
349−import Rel8.Column
350−import Rel8.Column.ADT
351−import Rel8.Column.Either
352−import Rel8.Column.Lift
353−import Rel8.Column.List
354−import Rel8.Column.Maybe
355−import Rel8.Column.NonEmpty
356−import Rel8.Column.Null
357−import Rel8.Column.These
358241import Rel8.Expr
359242import Rel8.Expr.Aggregate
360243import Rel8.Expr.Bool
361−import Rel8.Expr.Default
362244import Rel8.Expr.Eq
363245import Rel8.Expr.Function
364246import Rel8.Expr.Null
365−import Rel8.Expr.Opaleye (unsafeCastExpr, unsafeLiteral)
247+import Rel8.Expr.Opaleye (unsafeCastExpr)
366248import Rel8.Expr.Ord
367249import Rel8.Expr.Order
368250import Rel8.Expr.Serialize
369−import Rel8.Expr.Sequence
370−import Rel8.Expr.Text ( like, ilike )
371−import Rel8.Expr.Window hiding ( cumulative )
372−import Rel8.Generic.Rel8able ( KRel8able, Rel8able )
251+import Rel8.Kind.Necessity
373252import Rel8.Order
374253import Rel8.Query
375254import Rel8.Query.Aggregate
376255import Rel8.Query.Distinct
377256import Rel8.Query.Each
378257import Rel8.Query.Either
379−import Rel8.Query.Evaluate
380258import Rel8.Query.Exists
381259import Rel8.Query.Filter
382−import Rel8.Query.Indexed
383260import Rel8.Query.Limit
384261import Rel8.Query.List
385262import Rel8.Query.Maybe
386263import Rel8.Query.Null
387264import Rel8.Query.Order
388−import Rel8.Query.Rebind
389265import Rel8.Query.SQL (showQuery)
390266import Rel8.Query.Set
391267import Rel8.Query.These
392268import Rel8.Query.Values
393−import Rel8.Query.Window
394−import Rel8.Schema.Field
269+import Rel8.Schema.Column
270+import Rel8.Schema.Context.Label
271+import Rel8.Schema.Field (Field)
272+import Rel8.Schema.Generic
395273import Rel8.Schema.HTable
396274import Rel8.Schema.Name
397−import Rel8.Schema.Null hiding ( nullable )
398−import Rel8.Schema.Result ( Result )
275+import Rel8.Schema.Nullability
399276import Rel8.Schema.Table
400277import Rel8.Statement.Delete
401278import Rel8.Statement.Insert
402−import Rel8.Statement.OnConflict
403279import Rel8.Statement.Returning
404280import Rel8.Statement.Select
405−import Rel8.Statement.SQL
406281import Rel8.Statement.Update
407282import Rel8.Statement.View
408283import Rel8.Table
409−import Rel8.Table.ADT
410284import Rel8.Table.Aggregate
411285import Rel8.Table.Alternative
412286import Rel8.Table.Bool
413287import Rel8.Table.Either
414288import Rel8.Table.Eq
415−import Rel8.Table.HKD
289+import Rel8.Table.Insert
416290import Rel8.Table.List
417291import Rel8.Table.Maybe
418292import Rel8.Table.Name
419293import Rel8.Table.NonEmpty
420−import Rel8.Table.Null
421−import Rel8.Table.Opaleye ( castTable )
422294import Rel8.Table.Ord
423295import Rel8.Table.Order
424−import Rel8.Table.Projection
425−import Rel8.Table.Rel8able ()
426296import Rel8.Table.Serialize
427297import Rel8.Table.These
428−import Rel8.Table.Transpose
429−import Rel8.Table.Window
430298import Rel8.Type
431−import Rel8.Type.Composite
432299import Rel8.Type.Eq
433−import Rel8.Type.Enum
434300import Rel8.Type.Information
435301import Rel8.Type.JSONBEncoded
436302import Rel8.Type.JSONEncoded
@@ -441,216 +307,5 @@ import Rel8.Type.ReadShow
441307import Rel8.Type.Semigroup
442308import Rel8.Type.String
443309import Rel8.Type.Sum
444−import Rel8.Window
445−
446−
447−-- $running
448−-- To run queries and otherwise interact with a PostgreSQL database, Rel8
449−-- provides 'select', 'insert', 'update' and 'delete' functions. Note that
450−-- 'insert', 'update' and 'delete' will generally need the
451−-- `DuplicateRecordFields` language extension enabled.
452−
453−-- $adts
454−-- Algebraic data types can be modelled between Haskell and SQL.
455−--
456−-- * Your SQL table needs a certain text field that tags which Haskell constructor is in use.
457−-- * You have to use a few combinators to specify the sum type's individual constructors.
458−-- * If you want to do case analysis at the @Expr@ (SQL) level, you can use 'maybe'/'either'-like eliminators.
459−--
460−-- The documentation in this section will assume a set of database types like this:
461−--
462−-- @
463−-- data Thing f = ThingEmployer (Employer f) | ThingPotato (Potato f) | Nullary
464−-- deriving stock Generic
465−--
466−-- data Employer f = Employer { employerId :: f Int32, employerName :: f Text}
467−-- deriving stock Generic
468−-- deriving anyclass Rel8able
469−--
470−-- data Potato f = Potato { size :: f Int32, grower :: f Text }
471−-- deriving stock Generic
472−-- deriving anyclass Rel8able
473−-- @
474−
475−-- $naming
476−--
477−-- First, in your 'TableSchema', name your type like this:
478−--
479−-- @
480−-- thingSchema :: TableSchema (ADT Thing Name)
481−-- thingSchema =
482−-- TableSchema
483−-- { schema = Nothing,
484−-- name = \"thing\",
485−-- columns =
486−-- nameADT @Thing
487−-- \"tag\"
488−-- Employer
489−-- { employerName = \"name\",
490−-- employerId = \"id\"
491−-- }
492−-- Potato {size = \"size\", grower = \"Mary\"}
493−-- }
494−-- @
495−--
496−-- Note that @nameADT \@Thing "tag"@ is variadic: it accepts one
497−-- argument per constructor, except the nullary ones (Nullary) because
498−-- there's nothing to do for them.
499−
500−-- $deconstruction
501−--
502−-- To deconstruct sum types at the SQL level, use 'deconstructADT',
503−-- which is also variadic, and has one argument for each
504−-- constructor. Similar to 'maybe'.
505−--
506−-- @
507−-- query :: Query (ADT Thing Expr)
508−-- query = do
509−-- thingExpr <- each thingSchema
510−-- where_ $
511−-- deconstructADT @Thing
512−-- (\employer -> employerName employer ==. lit \"Mary\")
513−-- (\potato -> grower potato ==. lit \"Mary\")
514−-- (lit False) -- Nullary case
515−-- thingExpr
516−-- pure thingExpr
517−-- @
518−--
519−-- SQL output:
520−--
521−-- @
522−-- SELECT
523−-- CAST("tag0_1" AS text) as "tag",
524−-- CAST("id1_1" AS int4) as "ThingEmployer/_1/employerId",
525−-- CAST("name2_1" AS text) as "ThingEmployer/_1/employerName",
526−-- CAST("size3_1" AS int4) as "ThingPotato/_1/size",
527−-- CAST("Mary4_1" AS text) as "ThingPotato/_1/grower"
528−-- FROM (SELECT
529−-- *
530−-- FROM (SELECT
531−-- "tag" as "tag0_1",
532−-- "id" as "id1_1",
533−-- "name" as "name2_1",
534−-- "size" as "size3_1",
535−-- "Mary" as "Mary4_1"
536−-- FROM "thing" as "T1") as "T1"
537−-- WHERE (CASE WHEN ("tag0_1") = (CAST(E'ThingPotato' AS text)) THEN ("Mary4_1") = (CAST(E'Mary' AS text))
538−-- WHEN ("tag0_1") = (CAST(E'Nullary' AS text)) THEN CAST(FALSE AS bool) ELSE ("name2_1") = (CAST(E'Mary' AS text)) END)) as "T1"
539−-- @
540−
541−-- $construction
542−--
543−-- To construct an ADT, you can use 'buildADT' or 'constructADT'. Consider the following type:
544−--
545−-- @
546−-- data Task f = Pending | Complete (CompletedTask f)
547−-- @
548−--
549−-- 'buildADT' is for constructing values of 'Task' in the 'Expr'
550−-- context. 'buildADT' needs two type-level arguments before its type
551−-- makes any sense. The first argument is the type of the "ADT", which
552−-- in our case is 'Task'. The second is the name of the constructor we
553−-- want to use. So that means we have the following possible
554−-- instantiations of 'buildADT' for 'Task':
555−--
556−-- @
557−-- > :t buildADT @Task @\"Pending\"
558−-- buildADT @Task @\"Pending\" :: ADT Task Expr
559−-- > :t buildADT @Task @\"Complete\"
560−-- buildADT @Task @\"Complete\" :: CompletedTask Expr -> ADT Task Expr
561−-- @
562−--
563−-- Note that as the "Pending" constructor has no fields, @buildADT
564−-- \@Task \@"Pending"@ is equivalent to @lit Pending@. But @buildADT
565−-- \@Task \@"Complete"@ is not the same as @lit . Complete@:
566−--
567−-- @
568−-- > :t lit . Complete
569−-- lit . Complete :: CompletedTask Result -> ADT Task Expr
570−-- @
571−--
572−--
573−-- Note that the former takes a @CompletedTask Expr@ while the latter
574−-- takes a @CompletedTask Result@. The former is more powerful because
575−-- you can construct @Task@s using dynamic values coming a database
576−-- query.
577−--
578−-- To show what this can look like in SQL, consider:
579−--
580−-- @
581−-- > :{
582−-- showQuery $ values
583−-- [ buildADT @Task @\"Pending\"
584−-- , buildADT @Task @\"Complete\" CompletedTask {date = Rel8.Expr.Time.now}
585−-- ]
586−-- :}
587−-- @
588−--
589−-- This produces the following SQL:
590−--
591−-- @
592−-- SELECT
593−-- CAST(\"values0_1\" AS text) as \"tag\",
594−-- CAST(\"values1_1\" AS timestamptz) as \"Complete/_1/date\"
595−-- FROM (SELECT
596−-- *
597−-- FROM (SELECT \"column1\" as \"values0_1\",
598−-- \"column2\" as \"values1_1\"
599−-- FROM
600−-- (VALUES
601−-- (CAST(E'Pending' AS text),CAST(NULL AS timestamptz)),
602−-- (CAST(E'Complete' AS text),CAST(now() AS timestamptz))) as \"V\") as \"T1\") as \"T1\"
603−-- @
604−--
605−-- This is what you get if you run it in @psql@:
606−--
607−--
608−-- @
609−-- tag | Complete/_1/date
610−-- ----------+-------------------------------
611−-- Pending |
612−-- Complete | 2022-05-19 21:28:23.969065+00
613−-- (2 rows)
614−-- @
615−--
616−-- "constructADT" is less convenient but more general alternative to
617−-- "buildADT". It requires only one type-level argument for its type
618−-- to make sense:
619−--
620−-- @
621−-- > :t constructADT @Task
622−-- constructADT @Task
623−-- :: (forall r. r -> (CompletedTask Expr -> r) -> r) -> ADT Task Expr
624−-- @
625−--
626−-- This might still seem a bit opaque, but basically it gives you a
627−-- Church-encoded constructor for arbitrary algebraic data types. You
628−-- might use it as follows:
629−--
630−-- @
631−-- let
632−-- pending :: ADT Task Expr
633−-- pending = constructADT @Task $ \pending _complete -> pending
634−--
635−-- complete :: ADT Task Expr
636−-- complete = constructADT @Task $ \_pending complete -> complete CompletedTask {date = Rel8.Expr.Time.now}
637−-- @
638−--
639−-- These values are otherwise identical to the ones we saw above with
640−-- @buildADT@, it's just a different style of constructing them.
641−--
642−
643−-- $misc-notes
644−--
645−-- 1. Note that the order of the arguments for all of these functions
646−-- is determined by the order of the constructors in the data
647−-- definition. If it were @data Task = Complete (CompletedTask f) |
648−-- Pending@ then the order of all the invocations of @constructADT@
649−-- and @deconstructADT@ would need to change.
650−--
651−-- 2. Maybe this is obvious, but just to spell it out: once you're in
652−-- the @Result@ context, you can of course construct @Task@ values
653−-- normally and use standard Haskell pattern-matching. @constructADT@
654−-- and @deconstructADT@ are specifically only needed in the @Expr@
655−-- context, and they allow you to do the equivalent of pattern
656−-- matching in PostgreSQL.
310+
311+
src/Rel8/Aggregate.hs+119−46
@@ -1,83 +1,156 @@
11{-# language DataKinds #-}
2+{-# language DerivingVia #-}
23{-# language FlexibleContexts #-}
34{-# language FlexibleInstances #-}
5+{-# language GADTs #-}
6+{-# language GeneralizedNewtypeDeriving #-}
47{-# language MultiParamTypeClasses #-}
5−{-# language RankNTypes #-}
8+{-# language NamedFieldPuns #-}
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( Aggregation )
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
32−import Rel8.Expr ( Expr )
33−import Rel8.Schema.HTable.Identity ( HIdentity(..) )
34−import qualified Rel8.Schema.Kind as K
35−import Rel8.Schema.Null ( Sql )
36−import Rel8.Table
37− ( Table, Columns, Context, fromColumns, toColumns
38− , FromExprs, fromResult, toResult
39− , Transpose
40− )
41−import Rel8.Table.Transpose ( Transposes )
34+import Rel8.Expr ( Expr, Col(..) )
35+import Rel8.Opaque ( Opaque )
36+import Rel8.Schema.Context ( Interpretation(..) )
37+import Rel8.Schema.Context.Label ( Labelable(..) )
38+import Rel8.Schema.HTable ( hfield, htabulate, htabulateA, hspecs )
39+import Rel8.Schema.Name ( Name )
40+import Rel8.Schema.Nullability ( Sql )
41+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
42+import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
43+import Rel8.Table.Recontextualize ( Recontextualize )
4244import Rel8.Type ( DBType )
4345
46+-- semigroupoids
47+import Data.Functor.Apply ( Apply, WrappedApplicative(..) )
48+
49+
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 :: Type -> Type
56+newtype Aggregate a = Aggregate (Opaleye.Aggregator () a)
57+ deriving newtype Functor
58+ deriving Apply via (WrappedApplicative (Opaleye.Aggregator ()))
4459
45−-- | 'Aggregate' is a special context used by 'Rel8.aggregate'.
46−type Aggregate :: K.Context
47−newtype Aggregate a = Aggregate (Opaleye.Aggregator () (Expr a))
4860
61+instance Interpretation Aggregate where
62+ data Col Aggregate _spec where
63+ Aggregation :: ()
64+ => Aggregate (Expr a)
65+ -> Col Aggregate ('Spec labels necessity a)
4966
50−instance Sql DBType a => Table Aggregate (Aggregate a) where
51− type Columns (Aggregate a) = HIdentity a
67+
68+instance Table Expr a => Table Aggregate (Aggregate a) where
69+ type Columns (Aggregate a) = Columns a
5270 type Context (Aggregate a) = Aggregate
53− type FromExprs (Aggregate a) = a
54− type Transpose to (Aggregate a) = to a
5571
56− toColumns = HIdentity
57− fromColumns (HIdentity a) = a
58− toResult = HIdentity . Identity
59− fromResult (HIdentity (Identity a)) = a
72+ toColumns a = htabulate $ \field -> case hfield hspecs field of
73+ SSpec {} -> Aggregation $ unDB . (`hfield` field) . toColumns <$> a
74+ fromColumns as = fmap fromColumns $ htabulateA $ \field ->
75+ case hfield as field of
76+ Aggregation a -> DB <$> a
77+
78+
79+instance Sql DBType a =>
80+ Recontextualize Aggregate Aggregate (Aggregate (Expr a)) (Aggregate (Expr a))
81+
82+
83+instance Sql DBType a =>
84+ Recontextualize Aggregate Expr (Aggregate (Expr a)) (Expr a)
85+
86+
87+instance Sql DBType a =>
88+ Recontextualize Aggregate Identity (Aggregate (Expr a)) (Identity a)
89+
90+
91+instance Sql DBType a =>
92+ Recontextualize Aggregate Name (Aggregate (Expr a)) (Name a)
6093
6194
62−-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate's
63−-- for the 'Expr' columns in @b@.
95+instance Sql DBType a =>
96+ Recontextualize Expr Aggregate (Expr a) (Aggregate (Expr a))
97+
98+
99+instance Sql DBType a =>
100+ Recontextualize Identity Aggregate (Identity a) (Aggregate (Expr a))
101+
102+
103+instance Sql DBType a =>
104+ Recontextualize Name Aggregate (Name a) (Aggregate (Expr a))
105+
106+
107+instance Labelable Aggregate where
108+ labeler (Aggregation aggregate) = Aggregation aggregate
109+ unlabeler (Aggregation aggregate) = Aggregation aggregate
110+
111+
112+-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate' 'Expr's
113+-- for the columns in @b@.
64114type Aggregates :: Type -> Type -> Constraint
65−class Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs
66−instance Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs
115+class Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs
116+instance Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs
117+instance {-# OVERLAPPING #-} Aggregates (Opaque Aggregate Opaque) (Opaque Expr Opaque)
118+
119+
120+foldInputs :: Monoid b
121+ => (Maybe Aggregator -> Opaleye.PrimExpr -> b) -> Aggregate a -> b
122+foldInputs f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =
123+ getConst $ flip agg () $ \(aggregator, a) ->
124+ Const $ f (detuplize <$> aggregator) a
125+ where
126+ detuplize (operation, ordering, distinction) =
127+ Aggregator {operation, ordering, distinction}
128+
129+
130+mapInputs :: ()
131+ => (Opaleye.PrimExpr -> Opaleye.PrimExpr) -> Aggregate a -> Aggregate a
132+mapInputs transform (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =
133+ Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ agg . \f input ->
134+ f (fmap transform input)
67135
68136
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)
137+type Aggregator :: Type
138+data Aggregator = Aggregator
139+ { operation :: Opaleye.AggrOp
140+ , ordering :: [Opaleye.OrderExpr]
141+ , distinction :: Opaleye.AggrDistinct
142+ }
72143
73144
74−unsafeMakeAggregate :: forall (input :: Type) (output :: Type) n n' a a'. ()
75− => (Expr input -> Opaleye.PrimExpr)
76− -> (Opaleye.PrimExpr -> Expr output)
77− -> Opaleye.Aggregator (Opaleye.Field_ n a) (Opaleye.Field_ n' a')
78− -> Expr input
145+unsafeMakeAggregate :: ()
146+ => (input -> Opaleye.PrimExpr)
147+ -> (Opaleye.PrimExpr -> output)
148+ -> Maybe Aggregator
149+ -> input
79150 -> Aggregate output
80151unsafeMakeAggregate input output aggregator expr =
81− Aggregate $ dimap in_ out aggregator
82− where out = output . Opaleye.unColumn
83− in_ = Opaleye.Column . input . const expr
152+ Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ \f _ ->
153+ output <$> f (tuplize <$> aggregator, input expr)
154+ where
155+ tuplize Aggregator {operation, ordering, distinction} =
156+ (operation, ordering, distinction)
src/Rel8/Aggregate/Legacy.hsnew file+93
@@ -0,0 +1,93 @@
1+{-# language FlexibleContexts #-}
2+{-# language NamedFieldPuns #-}
3+{-# language ScopedTypeVariables #-}
4+{-# language TypeApplications #-}
5+{-# language TypeFamilies #-}
6+{-# language ViewPatterns #-}
7+
8+module Rel8.Aggregate.Legacy
9+ ( Aggregates
10+ , aggregate
11+ , aggregateTabulation
12+ , groupBy
13+ , listAgg
14+ , nonEmptyAgg
15+ )
16+where
17+
18+-- base
19+import Data.Functor.Identity ( Identity( Identity ) )
20+import Prelude
21+
22+-- opaleye
23+import qualified Opaleye.Aggregate as Opaleye
24+
25+-- rel8
26+import Rel8.Aggregate ( Aggregates, Col(..) )
27+import Rel8.Expr ( Col(..) )
28+import Rel8.Expr.Aggregate ( groupByExpr, listAggExpr, nonEmptyAggExpr )
29+import Rel8.Query ( Query )
30+import Rel8.Query.Opaleye ( mapOpaleye )
31+import Rel8.Schema.Dict ( Dict( Dict ) )
32+import Rel8.Schema.HTable ( htabulate, hfield )
33+import Rel8.Schema.HTable.Vectorize ( hvectorize )
34+import Rel8.Table ( toColumns, fromColumns )
35+import Rel8.Table.Eq ( EqTable, eqTable )
36+import Rel8.Table.List ( ListTable )
37+import Rel8.Table.NonEmpty ( NonEmptyTable )
38+import Rel8.Table.Opaleye ( aggregator )
39+import Rel8.Tabulate ( Tabulation )
40+import qualified Rel8.Tabulate
41+
42+
43+-- | Apply an aggregation to all rows returned by a 'Query'.
44+aggregate :: Aggregates aggregates exprs => Query aggregates -> Query exprs
45+aggregate = mapOpaleye (Opaleye.aggregate aggregator) . fmap (fromColumns . toColumns)
46+
47+
48+aggregateTabulation
49+ :: (EqTable k, Aggregates aggregates exprs)
50+ => (t -> aggregates) -> Tabulation k t -> Tabulation k exprs
51+aggregateTabulation f =
52+ Rel8.Tabulate.aggregateTabulation . fmap (fromColumns . toColumns . f)
53+
54+
55+-- | Group equal tables together. This works by aggregating each column in the
56+-- given table with 'groupByExpr'.
57+groupBy :: forall exprs aggregates. (EqTable exprs, Aggregates aggregates exprs)
58+ => exprs -> aggregates
59+groupBy (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
60+ case hfield (eqTable @exprs) field of
61+ Dict -> case hfield exprs field of
62+ DB expr -> Aggregation $ groupByExpr expr
63+
64+
65+-- | Aggregate rows into a single row containing an array of all aggregated
66+-- rows. This can be used to associate multiple rows with a single row, without
67+-- changing the over cardinality of the query. This allows you to essentially
68+-- return a tree-like structure from queries.
69+--
70+-- For example, if we have a table of orders and each orders contains multiple
71+-- items, we could aggregate the table of orders, pairing each order with its
72+-- items:
73+--
74+-- @
75+-- ordersWithItems :: Query (Order Expr, ListTable (Item Expr))
76+-- ordersWithItems = do
77+-- order <- each orderSchema
78+-- items <- aggregate $ listAgg <$> itemsFromOrder order
79+-- return (order, items)
80+-- @
81+listAgg :: Aggregates aggregates exprs => exprs -> ListTable aggregates
82+listAgg (toColumns -> exprs) = fromColumns $
83+ hvectorize
84+ (\_ (Identity (DB a)) -> Aggregation $ listAggExpr a)
85+ (pure exprs)
86+
87+
88+-- | Like 'listAgg', but the result is guaranteed to be a non-empty list.
89+nonEmptyAgg :: Aggregates aggregates exprs => exprs -> NonEmptyTable aggregates
90+nonEmptyAgg (toColumns -> exprs) = fromColumns $
91+ hvectorize
92+ (\_ (Identity (DB a)) -> Aggregation $ nonEmptyAggExpr a)
93+ (pure exprs)
src/Rel8/Column.hsdeleted−31
@@ -1,31 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language StandaloneKindSignatures #-}
3−{-# language TypeFamilies #-}
4−
5−module Rel8.Column
6− ( Column
7− , TColumn
8− )
9−where
10−
11−-- base
12−import Data.Kind ( Type )
13−import Prelude ()
14−
15−-- rel8
16−import Rel8.FCF ( Eval, Exp )
17−import qualified Rel8.Schema.Kind as K
18−import Rel8.Schema.Result ( Result )
19−
20−
21−-- | This type family is used to specify columns in 'Rel8able's. In @Column f
22−-- a@, @f@ is the context of the column (which should be left polymorphic in
23−-- 'Rel8able' definitions), and @a@ is the type of the column.
24−type Column :: K.Context -> Type -> Type
25−type family Column context a where
26− Column Result a = a
27− Column context a = context a
28−
29−
30−data TColumn :: K.Context -> Type -> Exp Type
31−type instance Eval (TColumn f a) = Column f a
src/Rel8/Column/ADT.hsdeleted−23
@@ -1,23 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language StandaloneKindSignatures #-}
3−{-# language TypeFamilies #-}
4−
5−module Rel8.Column.ADT
6− ( HADT
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.ADT ( ADT )
18−
19−
20−type HADT :: K.Context -> K.Rel8able -> Type
21−type family HADT context t where
22− HADT Result t = t Result
23− HADT context t = ADT t context
src/Rel8/Column/Either.hsdeleted−26
@@ -1,26 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language StandaloneKindSignatures #-}
3−{-# language TypeFamilyDependencies #-}
4−
5−module Rel8.Column.Either
6− ( HEither
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.Either ( EitherTable )
18−
19−
20−-- | Nest an 'Either' value within a 'Rel8able'. @HEither f a b@ will produce a
21−-- 'EitherTable' @a b@ in the 'Expr' context, and a 'Either' @a b@ in the
22−-- 'Result' context.
23−type HEither :: K.Context -> Type -> Type -> Type
24−type family HEither context = either | either -> context where
25− HEither Result = Either
26− HEither context = EitherTable context
src/Rel8/Column/Lift.hsdeleted−23
@@ -1,23 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language StandaloneKindSignatures #-}
3−{-# language TypeFamilies #-}
4−
5−module Rel8.Column.Lift
6− ( Lift
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.HKD ( HKD )
18−
19−
20−type Lift :: K.Context -> Type -> Type
21−type family Lift context a where
22− Lift Result a = a
23− Lift context a = HKD a context
src/Rel8/Column/List.hsdeleted−25
@@ -1,25 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language StandaloneKindSignatures #-}
3−{-# language TypeFamilyDependencies #-}
4−
5−module Rel8.Column.List
6− ( HList
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.List ( ListTable )
18−
19−
20−-- | Nest a list within a 'Rel8able'. @HList f a@ will produce a 'ListTable'
21−-- @a@ in the 'Expr' context, and a @[a]@ in the 'Result' context.
22−type HList :: K.Context -> Type -> Type
23−type family HList context = list | list -> context where
24− HList Result = []
25− HList context = ListTable context
src/Rel8/Column/Maybe.hsdeleted−26
@@ -1,26 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language StandaloneKindSignatures #-}
3−{-# language TypeFamilyDependencies #-}
4−
5−module Rel8.Column.Maybe
6− ( HMaybe
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.Maybe ( MaybeTable )
18−
19−
20−-- | Nest a 'Maybe' value within a 'Rel8able'. @HMaybe f a@ will produce a
21−-- 'MaybeTable' @a@ in the 'Expr' context, and a 'Maybe' @a@ in the 'Result'
22−-- context.
23−type HMaybe :: K.Context -> Type -> Type
24−type family HMaybe context = maybe | maybe -> context where
25− HMaybe Result = Maybe
26− HMaybe context = MaybeTable context
src/Rel8/Column/NonEmpty.hsdeleted−27
@@ -1,27 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language StandaloneKindSignatures #-}
3−{-# language TypeFamilyDependencies #-}
4−
5−module Rel8.Column.NonEmpty
6− ( HNonEmpty
7− )
8−where
9−
10−-- base
11−import Data.Kind ( Type )
12−import Data.List.NonEmpty ( NonEmpty )
13−import Prelude ()
14−
15−-- rel8
16−import qualified Rel8.Schema.Kind as K
17−import Rel8.Schema.Result ( Result )
18−import Rel8.Table.NonEmpty ( NonEmptyTable )
19−
20−
21−-- | Nest a 'NonEmpty' list within a 'Rel8able'. @HNonEmpty f a@ will produce a
22−-- 'NonEmptyTable' @a@ in the 'Expr' context, and a 'NonEmpty' @a@ in the
23−-- 'Result' context.
24−type HNonEmpty :: K.Context -> Type -> Type
25−type family HNonEmpty context = nonEmpty | nonEmpty -> context where
26− HNonEmpty Result = NonEmpty
27− HNonEmpty context = NonEmptyTable context
src/Rel8/Column/Null.hsdeleted−26
@@ -1,26 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language StandaloneKindSignatures #-}
3−{-# language TypeFamilyDependencies #-}
4−
5−module Rel8.Column.Null
6− ( HNull
7− )
8−where
9−
10−-- base
11−import Data.Kind ( Type )
12−import Prelude
13−
14−-- rel8
15−import qualified Rel8.Schema.Kind as K
16−import Rel8.Schema.Result ( Result )
17−import Rel8.Table.Null ( NullTable )
18−
19−
20−-- | Nest a 'Null' value within a 'Rel8able'. @HNull f a@ will produce a
21−-- 'NullTable' @a@ in the 'Expr' context, and a @'Maybe' a@ in the 'Result'
22−-- context.
23−type HNull :: K.Context -> Type -> Type
24−type family HNull context = maybe | maybe -> context where
25− HNull Result = Maybe
26− HNull context = NullTable context
src/Rel8/Column/These.hsdeleted−29
@@ -1,29 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language StandaloneKindSignatures #-}
3−{-# language TypeFamilyDependencies #-}
4−
5−module Rel8.Column.These
6− ( HThese
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.These ( TheseTable )
18−
19−-- these
20−import Data.These ( These )
21−
22−
23−-- | Nest an 'These' value within a 'Rel8able'. @HThese f a b@ will produce a
24−-- 'TheseTable' @a b@ in the 'Expr' context, and a 'These' @a b@ in the
25−-- 'Result' context.
26−type HThese :: K.Context -> Type -> Type -> Type
27−type family HThese context = these | these -> context where
28− HThese Result = These
29− HThese context = TheseTable context
src/Rel8/Expr.hs+49−48
@@ -1,21 +1,26 @@
11{-# language DataKinds #-}
22{-# language DerivingStrategies #-}
3−{-# language FlexibleContexts #-}
43{-# language FlexibleInstances #-}
4+{-# language GADTs #-}
55{-# language MultiParamTypeClasses #-}
6+{-# language NamedFieldPuns #-}
7+{-# language RoleAnnotations #-}
68{-# language ScopedTypeVariables #-}
79{-# language StandaloneKindSignatures #-}
810{-# language TypeApplications #-}
911{-# language TypeFamilies #-}
1012{-# language UndecidableInstances #-}
13+{-# language UndecidableSuperClasses #-}
1114
1215module Rel8.Expr
1316 ( Expr(..)
17+ , Col( DB, unDB )
1418 )
1519where
1620
1721-- base
18−import Data.Functor.Identity ( Identity( Identity ) )
22+import Data.Functor.Identity ( Identity )
23+import Data.Kind ( Type )
1924import Data.String ( IsString, fromString )
2025import Prelude hiding ( null )
2126
@@ -23,8 +28,7 @@ import Prelude hiding ( null )
2328import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
2429
2530-- rel8
26−import Rel8.Expr.Function ( function, nullaryFunction )
27−import Rel8.Expr.Null ( liftOpNull, nullify )
31+import Rel8.Expr.Null ( liftOpNullable, nullify )
2832import Rel8.Expr.Opaleye
2933 ( castExpr
3034 , fromPrimExpr
@@ -32,44 +36,47 @@ import Rel8.Expr.Opaleye
3236 , zipPrimExprsWith
3337 )
3438import Rel8.Expr.Serialize ( litExpr )
35−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
36−import qualified Rel8.Schema.Kind as K
37−import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
38−import Rel8.Table
39− ( Table, Columns, Context, fromColumns, toColumns
40− , FromExprs, fromResult, toResult
41− , Transpose
39+import Rel8.Schema.Context ( Interpretation, Col )
40+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
41+import Rel8.Schema.HTable.Type ( HType( HType ) )
42+import Rel8.Schema.Nullability
43+ ( Nullability( Nullable, NonNullable )
44+ , Sql, nullabilization
4245 )
46+import Rel8.Schema.Spec ( Spec( Spec ) )
47+import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
48+import Rel8.Table.Recontextualize ( Recontextualize )
4349import Rel8.Type ( DBType )
4450import Rel8.Type.Monoid ( DBMonoid, memptyExpr )
45−import Rel8.Type.Num ( DBFloating, DBFractional, DBNum )
51+import Rel8.Type.Num ( DBFractional, DBNum )
4652import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )
4753
4854
4955-- | Typed SQL expressions.
50−type Expr :: K.Context
56+type role Expr representational
57+type Expr :: Type -> Type
5158newtype Expr a = Expr Opaleye.PrimExpr
5259 deriving stock Show
5360
5461
5562instance Sql DBSemigroup a => Semigroup (Expr a) where
56− (<>) = case nullable @a of
57− Null -> liftOpNull (<>.)
58− NotNull -> (<>.)
63+ (<>) = case nullabilization @a of
64+ Nullable -> liftOpNullable (<>.)
65+ NonNullable -> (<>.)
5966 {-# INLINABLE (<>) #-}
6067
6168
6269instance Sql DBMonoid a => Monoid (Expr a) where
63− mempty = case nullable @a of
64− Null -> nullify memptyExpr
65− NotNull -> memptyExpr
70+ mempty = case nullabilization @a of
71+ Nullable -> nullify memptyExpr
72+ NonNullable -> memptyExpr
6673 {-# INLINABLE mempty #-}
6774
6875
6976instance (Sql IsString a, Sql DBType a) => IsString (Expr a) where
70− fromString = litExpr . case nullable @a of
71− Null -> Just . fromString
72− NotNull -> fromString
77+ fromString = litExpr . case nullabilization @a of
78+ Nullable -> Just . fromString
79+ NonNullable -> fromString
7380
7481
7582instance Sql DBNum a => Num (Expr a) where
@@ -92,34 +99,28 @@ instance Sql DBFractional a => Fractional (Expr a) where
9299 castExpr . Expr . Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac
93100
94101
95−instance Sql DBFloating a => Floating (Expr a) where
96− pi = nullaryFunction "PI"
97− exp = function "exp"
98− log = function "ln"
99− sqrt = function "sqrt"
100− (**) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:^))
101− logBase = function "log"
102− sin = function "sin"
103− cos = function "cos"
104− tan = function "tan"
105− asin = function "asin"
106− acos = function "acos"
107− atan = function "atan"
108− sinh = function "sinh"
109− cosh = function "cosh"
110− tanh = function "tanh"
111− asinh = function "asinh"
112− acosh = function "acosh"
113− atanh = function "atanh"
102+instance Interpretation Expr where
103+ data Col Expr _spec where
104+ DB :: {unDB :: Expr a} -> Col Expr ('Spec labels necessity a)
114105
115106
116107instance Sql DBType a => Table Expr (Expr a) where
117− type Columns (Expr a) = HIdentity a
108+ type Columns (Expr a) = HType a
118109 type Context (Expr a) = Expr
119− type FromExprs (Expr a) = a
120− type Transpose to (Expr a) = to a
121110
122− toColumns a = HIdentity a
123− fromColumns (HIdentity a) = a
124− toResult a = HIdentity (Identity a)
125− fromResult (HIdentity (Identity a)) = a
111+ toColumns a = HType (DB a)
112+ fromColumns (HType (DB a)) = a
113+
114+
115+instance Sql DBType a => Recontextualize Expr Expr (Expr a) (Expr a)
116+
117+
118+instance Sql DBType a => Recontextualize Expr Identity (Expr a) (Identity a)
119+
120+
121+instance Sql DBType a => Recontextualize Identity Expr (Identity a) (Expr a)
122+
123+
124+instance Labelable Expr where
125+ labeler (DB a) = DB a
126+ unlabeler (DB a) = DB a
src/Rel8/Expr.hs-boot+4−5
@@ -1,4 +1,4 @@
1−{-# language DataKinds #-}
1+{-# language RoleAnnotations #-}
22{-# language StandaloneKindSignatures #-}
33
44module Rel8.Expr
@@ -7,14 +7,13 @@ module Rel8.Expr
77where
88
99-- base
10+import Data.Kind ( Type )
1011import Prelude ()
1112
1213-- opaleye
1314import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
1415
15−-- rel8
16−import Rel8.Schema.Kind ( Context )
1716
18−
19−type Expr :: Context
17+type role Expr representational
18+type Expr :: Type -> Type
2019newtype Expr a = Expr Opaleye.PrimExpr
src/Rel8/Expr/Aggregate.hs+84−57
@@ -1,6 +1,7 @@
11{-# language DataKinds #-}
22{-# language FlexibleContexts #-}
33{-# language ScopedTypeVariables #-}
4+{-# language TypeApplications #-}
45{-# language TypeFamilies #-}
56
67{-# options_ghc -fno-warn-redundant-constraints #-}
@@ -10,11 +11,9 @@ module Rel8.Expr.Aggregate
1011 , and, or
1112 , min, max
1213 , sum, sumWhere
13− , avg
1414 , stringAgg
1515 , groupByExpr
1616 , listAggExpr, nonEmptyAggExpr
17− , slistAggExpr, snonEmptyAggExpr
1817 )
1918where
2019
@@ -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
@@ -40,11 +37,9 @@ import Rel8.Expr.Opaleye
4037 )
4138import Rel8.Expr.Null ( null )
4239import Rel8.Expr.Serialize ( litExpr )
43−import Rel8.Schema.Null ( Sql, Unnullify )
44−import Rel8.Type ( DBType, typeInformation )
45−import Rel8.Type.Array ( encodeArrayElement )
40+import Rel8.Schema.Nullability ( Sql )
41+import Rel8.Type.Array ( fromPrimArray )
4642import Rel8.Type.Eq ( DBEq )
47−import Rel8.Type.Information ( TypeInformation )
4843import Rel8.Type.Num ( DBNum )
4944import Rel8.Type.Ord ( DBMax, DBMin )
5045import Rel8.Type.String ( DBString )
@@ -52,99 +47,131 @@ import Rel8.Type.Sum ( DBSum )
5247
5348
5449-- | Count the occurances of a single column. Corresponds to @COUNT(a)@
55−count :: Expr a -> Aggregate Int64
56−count = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.count
50+count :: Expr a -> Aggregate (Expr Int64)
51+count = unsafeMakeAggregate toPrimExpr fromPrimExpr $
52+ Just Aggregator
53+ { operation = Opaleye.AggrCount
54+ , ordering = []
55+ , distinction = Opaleye.AggrAll
56+ }
57+
5758
5859-- | Count the number of distinct occurances of a single column. Corresponds to
5960-- @COUNT(DISTINCT a)@
60−countDistinct :: Sql DBEq a => Expr a -> Aggregate Int64
61+countDistinct :: Sql DBEq a => Expr a -> Aggregate (Expr Int64)
6162countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $
62− Opaleye.distinctAggregator Opaleye.count
63+ Just Aggregator
64+ { operation = Opaleye.AggrCount
65+ , ordering = []
66+ , distinction = Opaleye.AggrDistinct
67+ }
6368
6469
6570-- | Corresponds to @COUNT(*)@.
66−countStar :: Aggregate Int64
71+countStar :: Aggregate (Expr Int64)
6772countStar = count (litExpr True)
6873
6974
7075-- | A count of the number of times a given expression is @true@.
71−countWhere :: Expr Bool -> Aggregate Int64
76+countWhere :: Expr Bool -> Aggregate (Expr Int64)
7277countWhere condition = count (caseExpr [(condition, litExpr (Just True))] null)
7378
7479
7580-- | Corresponds to @bool_and@.
76−and :: Expr Bool -> Aggregate Bool
77−and = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolAnd
81+and :: Expr Bool -> Aggregate (Expr Bool)
82+and = unsafeMakeAggregate toPrimExpr fromPrimExpr $
83+ Just Aggregator
84+ { operation = Opaleye.AggrBoolAnd
85+ , ordering = []
86+ , distinction = Opaleye.AggrAll
87+ }
7888
7989
8090-- | Corresponds to @bool_or@.
81−or :: Expr Bool -> Aggregate Bool
82−or = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolOr
91+or :: Expr Bool -> Aggregate (Expr Bool)
92+or = unsafeMakeAggregate toPrimExpr fromPrimExpr $
93+ Just Aggregator
94+ { operation = Opaleye.AggrBoolOr
95+ , ordering = []
96+ , distinction = Opaleye.AggrAll
97+ }
8398
8499
85100-- | Produce an aggregation for @Expr a@ using the @max@ function.
86−max :: Sql DBMax a => Expr a -> Aggregate a
87−max = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMax
101+max :: Sql DBMax a => Expr a -> Aggregate (Expr a)
102+max = unsafeMakeAggregate toPrimExpr fromPrimExpr $
103+ Just Aggregator
104+ { operation = Opaleye.AggrMax
105+ , ordering = []
106+ , distinction = Opaleye.AggrAll
107+ }
88108
89109
90110-- | Produce an aggregation for @Expr a@ using the @max@ function.
91−min :: Sql DBMin a => Expr a -> Aggregate a
92−min = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMin
111+min :: Sql DBMin a => Expr a -> Aggregate (Expr a)
112+min = unsafeMakeAggregate toPrimExpr fromPrimExpr $
113+ Just Aggregator
114+ { operation = Opaleye.AggrMin
115+ , ordering = []
116+ , distinction = Opaleye.AggrAll
117+ }
93118
94119-- | Corresponds to @sum@. Note that in SQL, @sum@ is type changing - for
95120-- 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
121+-- this, and will add explicit cast back to the original input type. This can
97122-- lead to overflows, and if you anticipate very large sums, you should upcast
98123-- your input.
99−sum :: Sql DBSum a => Expr a -> Aggregate a
100−sum = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) Opaleye.unsafeSum
101−
124+sum :: Sql DBSum a => Expr a -> Aggregate (Expr a)
125+sum = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $
126+ Just Aggregator
127+ { operation = Opaleye.AggrSum
128+ , ordering = []
129+ , distinction = Opaleye.AggrAll
130+ }
102131
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
110132
111133-- | Take the sum of all expressions that satisfy a predicate.
112134sumWhere :: (Sql DBNum a, Sql DBSum a)
113− => Expr Bool -> Expr a -> Aggregate a
135+ => Expr Bool -> Expr a -> Aggregate (Expr a)
114136sumWhere condition a = sum (caseExpr [(condition, a)] 0)
115137
116138
117139-- | Corresponds to @string_agg()@.
118140stringAgg :: Sql DBString a
119− => Expr db -> Expr a -> Aggregate a
141+ => Expr db -> Expr a -> Aggregate (Expr a)
120142stringAgg delimiter =
121− unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) (Opaleye.stringAgg (Column (toPrimExpr delimiter)))
143+ unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $
144+ Just Aggregator
145+ { operation = Opaleye.AggrStringAggr (toPrimExpr delimiter)
146+ , ordering = []
147+ , distinction = Opaleye.AggrAll
148+ }
122149
123150
124151-- | Aggregate a value by grouping by it.
125−groupByExpr :: Sql DBEq a => Expr a -> Aggregate a
126−groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.groupBy
152+groupByExpr :: Sql DBEq a => Expr a -> Aggregate (Expr a)
153+groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Nothing
127154
128155
129156-- | Collect expressions values as a list.
130−listAggExpr :: Sql DBType a => Expr a -> Aggregate [a]
131−listAggExpr = slistAggExpr typeInformation
132−
133−
134−-- | Collect expressions values as a non-empty list.
135−nonEmptyAggExpr :: Sql DBType a => Expr a -> Aggregate (NonEmpty a)
136−nonEmptyAggExpr = snonEmptyAggExpr typeInformation
137−
138−
139−slistAggExpr :: ()
140− => TypeInformation (Unnullify a) -> Expr a -> Aggregate [a]
141−slistAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg
157+listAggExpr :: Expr a -> Aggregate (Expr [a])
158+listAggExpr = unsafeMakeAggregate toPrimExpr from $ Just
159+ Aggregator
160+ { operation = Opaleye.AggrArr
161+ , ordering = []
162+ , distinction = Opaleye.AggrAll
163+ }
142164 where
143− to = encodeArrayElement info . toPrimExpr
165+ from = fromPrimExpr . fromPrimArray
144166
145167
146−snonEmptyAggExpr :: ()
147− => TypeInformation (Unnullify a) -> Expr a -> Aggregate (NonEmpty a)
148−snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg
168+-- | Collect expressions values as a non-empty list.
169+nonEmptyAggExpr :: Expr a -> Aggregate (Expr (NonEmpty a))
170+nonEmptyAggExpr = unsafeMakeAggregate toPrimExpr from $ Just
171+ Aggregator
172+ { operation = Opaleye.AggrArr
173+ , ordering = []
174+ , distinction = Opaleye.AggrAll
175+ }
149176 where
150− to = encodeArrayElement info . toPrimExpr
177+ from = fromPrimExpr . fromPrimArray
src/Rel8/Expr/Array.hs+6−6
@@ -25,21 +25,21 @@ import Rel8.Expr.Opaleye
2525 , zipPrimExprsWith
2626 )
2727import Rel8.Type ( DBType, typeInformation )
28−import Rel8.Type.Array ( array )
28+import Rel8.Type.Array ( array, zipPrimArraysWith )
2929import Rel8.Type.Information ( TypeInformation(..) )
30−import Rel8.Schema.Null ( Unnullify, Sql )
30+import Rel8.Schema.Nullability ( Unnullify, Nullability, Sql )
3131
3232
3333sappend :: Expr [a] -> Expr [a] -> Expr [a]
34−sappend = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
34+sappend = zipPrimExprsWith (zipPrimArraysWith (Opaleye.BinExpr (Opaleye.:||)))
3535
3636
3737sappend1 :: Expr (NonEmpty a) -> Expr (NonEmpty a) -> Expr (NonEmpty a)
38−sappend1 = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
38+sappend1 = zipPrimExprsWith (zipPrimArraysWith (Opaleye.BinExpr (Opaleye.:||)))
3939
4040
41−sempty :: TypeInformation (Unnullify a) -> Expr [a]
42−sempty info = fromPrimExpr $ array info []
41+sempty :: Nullability a -> TypeInformation (Unnullify a) -> Expr [a]
42+sempty _ info = fromPrimExpr $ array info []
4343
4444
4545slistOf :: TypeInformation (Unnullify a) -> [Expr a] -> Expr [a]
src/Rel8/Expr/Bool.hs+2−4
@@ -1,5 +1,3 @@
1−{-# language GADTs #-}
2−
31module Rel8.Expr.Bool
42 ( false, true
53 , (&&.), (||.), not_
@@ -19,7 +17,7 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
1917
2018-- rel8
2119import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
22−import Rel8.Expr.Opaleye ( mapPrimExpr, toPrimExpr, zipPrimExprsWith )
20+import Rel8.Expr.Opaleye ( mapPrimExpr, zipPrimExprsWith )
2321import Rel8.Expr.Serialize ( litExpr )
2422
2523
@@ -77,7 +75,7 @@ caseExpr :: [(Expr Bool, Expr a)] -> Expr a -> Expr a
7775caseExpr branches (Expr fallback) =
7876 Expr $ Opaleye.CaseExpr (map go branches) fallback
7977 where
80− go (condition, value) = (toPrimExpr condition, toPrimExpr value)
78+ go (Expr condition, Expr value) = (condition, value)
8179
8280
8381-- | Convert a @Expr (Maybe Bool)@ to a @Expr Bool@ by treating @Nothing@ as
src/Rel8/Expr/Default.hsdeleted−35
@@ -1,35 +0,0 @@
1−module Rel8.Expr.Default
2− ( unsafeDefault
3− )
4−where
5−
6−-- base
7−import Prelude ()
8−
9−-- opaleye
10−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
11−
12−-- rel8
13−import Rel8.Expr ( Expr )
14−import Rel8.Expr.Opaleye ( fromPrimExpr )
15−
16−
17−-- | Corresponds to the SQL @DEFAULT@ expression.
18−--
19−-- This 'Expr' is unsafe for numerous reasons, and should be used with care:
20−--
21−-- 1. This 'Expr' only makes sense in an @INSERT@ or @UPDATE@ statement.
22−--
23−-- 2. Rel8 is not able to verify that a particular column actually has a
24−-- @DEFAULT@ value. Trying to use @unsafeDefault@ where there is no default
25−-- will cause a runtime crash
26−--
27−-- 3. @DEFAULT@ values can not be transformed. For example, the innocuous Rel8
28−-- code @unsafeDefault + 1@ will crash, despite type checking.
29−--
30−-- Given all these caveats, we suggest avoiding the use of default values where
31−-- possible, instead being explicit. A common scenario where default values are
32−-- used is with auto-incrementing identifier columns. In this case, we suggest
33−-- using 'Rel8.nextval' instead.
34−unsafeDefault :: Expr a
35−unsafeDefault = fromPrimExpr Opaleye.DefaultInsertExpr
src/Rel8/Expr/Eq.hs+17−15
@@ -1,5 +1,6 @@
11{-# language FlexibleContexts #-}
22{-# language GADTs #-}
3+{-# language LambdaCase #-}
34{-# language ScopedTypeVariables #-}
45{-# language TypeApplications #-}
56{-# language ViewPatterns #-}
@@ -24,9 +25,12 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
2425-- rel8
2526import Rel8.Expr ( Expr )
2627import Rel8.Expr.Bool ( (&&.), (||.), false, or_, coalesce )
27−import Rel8.Expr.Null ( isNull, unsafeLiftOpNull )
28+import Rel8.Expr.Null ( isNull, unsafeLiftOpNullable )
2829import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr, zipPrimExprsWith )
29−import Rel8.Schema.Null ( Nullity( NotNull, Null ), Sql, nullable )
30+import Rel8.Schema.Nullability
31+ ( Nullability( NonNullable, Nullable )
32+ , Sql, nullabilization
33+ )
3034import Rel8.Type.Eq ( DBEq )
3135
3236
@@ -45,11 +49,10 @@ ne = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:<>))
4549-- This operator matches Haskell's '==' operator. For an operator identical to
4650-- SQL @=@, see '==?'.
4751(==.) :: forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool
48−(==.) = case nullable @a of
49− Null -> \ma mb -> isNull ma &&. isNull mb ||. ma ==? mb
50− NotNull -> eq
52+(==.) = case nullabilization @a of
53+ Nullable -> \ma mb -> isNull ma &&. isNull mb ||. ma ==? mb
54+ NonNullable -> eq
5155infix 4 ==.
52−{-# INLINABLE (==.) #-}
5356
5457
5558-- | Test if two expressions are different (not equal).
@@ -59,11 +62,10 @@ infix 4 ==.
5962-- which would return @null@. This operator is closer to Haskell's '=='
6063-- operator. For an operator identical to SQL @=@, see '/=?'.
6164(/=.) :: forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool
62−(/=.) = case nullable @a of
63− Null -> \ma mb -> isNull ma `ne` isNull mb ||. ma /=? mb
64− NotNull -> ne
65+(/=.) = case nullabilization @a of
66+ Nullable -> \ma mb -> isNull ma `ne` isNull mb ||. ma /=? mb
67+ NonNullable -> ne
6568infix 4 /=.
66−{-# INLINABLE (/=.) #-}
6769
6870
6971-- | Test if two expressions are equal. This operator is usually the best
@@ -73,7 +75,7 @@ infix 4 /=.
7375-- This corresponds to the SQL @=@ operator, though it will always return a
7476-- 'Bool'.
7577(==?) :: DBEq a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
76−a ==? b = coalesce $ unsafeLiftOpNull eq a b
78+a ==? b = coalesce $ unsafeLiftOpNullable eq a b
7779infix 4 ==?
7880
7981
@@ -82,7 +84,7 @@ infix 4 ==?
8284-- This corresponds to the SQL @<>@ operator, though it will always return a
8385-- 'Bool'.
8486(/=?) :: DBEq a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
85−a /=? b = coalesce $ unsafeLiftOpNull ne a b
87+a /=? b = coalesce $ unsafeLiftOpNullable ne a b
8688infix 4 /=?
8789
8890
@@ -90,9 +92,9 @@ infix 4 /=?
9092-- '==.' and '||.'.
9193in_ :: forall a f. (Sql DBEq a, Foldable f)
9294 => Expr a -> f (Expr a) -> Expr Bool
93−in_ a (toList -> as) = case nullable @a of
94− Null -> or_ $ map (a ==.) as
95− NotNull -> case nonEmpty as of
95+in_ a (toList -> as) = case nullabilization @a of
96+ Nullable -> or_ $ map (a ==.) as
97+ NonNullable -> case nonEmpty as of
9698 Nothing -> false
9799 Just xs ->
98100 fromPrimExpr $
src/Rel8/Expr/Function.hs+2−2
@@ -20,12 +20,12 @@ import Prelude
2020import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
2121
2222-- rel8
23−import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
23+import Rel8.Expr ( Expr( Expr ) )
2424import Rel8.Expr.Opaleye
2525 ( castExpr
2626 , fromPrimExpr, toPrimExpr, zipPrimExprsWith
2727 )
28−import Rel8.Schema.Null ( Sql )
28+import Rel8.Schema.Nullability ( Sql )
2929import Rel8.Type ( DBType )
3030
3131
src/Rel8/Expr/Null.hs+17−18
@@ -5,11 +5,11 @@
55{-# options -fno-warn-redundant-constraints #-}
66
77module Rel8.Expr.Null
8− ( null, snull, nullableExpr, nullableOf
8+ ( null, snull, nullable, nullableOf
99 , isNull, isNonNull
1010 , nullify, unsafeUnnullify
11− , mapNull, liftOpNull
12− , unsafeMapNull, unsafeLiftOpNull
11+ , mapNullable, liftOpNullable
12+ , unsafeMapNullable, unsafeLiftOpNullable
1313 )
1414where
1515
@@ -23,7 +23,7 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
2323import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
2424import Rel8.Expr.Bool ( (||.), boolExpr )
2525import Rel8.Expr.Opaleye ( scastExpr, mapPrimExpr )
26−import Rel8.Schema.Null ( NotNull )
26+import Rel8.Schema.Nullability ( NotNull )
2727import Rel8.Type ( DBType, typeInformation )
2828import Rel8.Type.Information ( TypeInformation )
2929
@@ -40,8 +40,8 @@ unsafeUnnullify (Expr a) = Expr a
4040
4141
4242-- | Like 'maybe', but to eliminate @null@.
43−nullableExpr :: Expr b -> (Expr a -> Expr b) -> Expr (Maybe a) -> Expr b
44−nullableExpr b f ma = boolExpr (f (unsafeUnnullify ma)) b (isNull ma)
43+nullable :: Expr b -> (Expr a -> Expr b) -> Expr (Maybe a) -> Expr b
44+nullable b f ma = boolExpr (f (unsafeUnnullify ma)) b (isNull ma)
4545
4646
4747nullableOf :: DBType a => Maybe (Expr a) -> Expr (Maybe a)
@@ -59,26 +59,25 @@ isNonNull = mapPrimExpr (Opaleye.UnExpr Opaleye.OpIsNotNull)
5959
6060
6161-- | Lift an operation on non-@null@ values to an operation on possibly @null@
62−-- values. When given @null@, @mapNull f@ returns @null@.
62+-- values. When given @null@, @mapNullable f@ returns @null@.
6363--
6464-- This is like 'fmap' for 'Maybe'.
65−mapNull :: DBType b
65+mapNullable :: DBType b
6666 => (Expr a -> Expr b) -> Expr (Maybe a) -> Expr (Maybe b)
67−mapNull f ma = boolExpr (unsafeMapNull f ma) null (isNull ma)
67+mapNullable f ma = boolExpr (unsafeMapNullable f ma) null (isNull ma)
6868
6969
7070-- | Lift a binary operation on non-@null@ expressions to an equivalent binary
7171-- operator on possibly @null@ expressions. If either of the final arguments
72−-- are @null@, @liftOpNull@ returns @null@.
72+-- are @null@, @liftOpNullable@ returns @null@.
7373--
7474-- This is like 'liftA2' for 'Maybe'.
75−liftOpNull :: DBType c
75+liftOpNullable :: DBType c
7676 => (Expr a -> Expr b -> Expr c)
7777 -> Expr (Maybe a) -> Expr (Maybe b) -> Expr (Maybe c)
78−liftOpNull f ma mb =
79− boolExpr (unsafeLiftOpNull f ma mb) null
78+liftOpNullable f ma mb =
79+ boolExpr (unsafeLiftOpNullable f ma mb) null
8080 (isNull ma ||. isNull mb)
81−{-# INLINABLE liftOpNull #-}
8281
8382
8483snull :: TypeInformation a -> Expr (Maybe a)
@@ -90,13 +89,13 @@ null :: DBType a => Expr (Maybe a)
9089null = snull typeInformation
9190
9291
93−unsafeMapNull :: NotNull b
92+unsafeMapNullable :: NotNull b
9493 => (Expr a -> Expr b) -> Expr (Maybe a) -> Expr (Maybe b)
95−unsafeMapNull f ma = nullify (f (unsafeUnnullify ma))
94+unsafeMapNullable f ma = nullify (f (unsafeUnnullify ma))
9695
9796
98−unsafeLiftOpNull :: NotNull c
97+unsafeLiftOpNullable :: NotNull c
9998 => (Expr a -> Expr b -> Expr c)
10099 -> Expr (Maybe a) -> Expr (Maybe b) -> Expr (Maybe c)
101−unsafeLiftOpNull f ma mb =
100+unsafeLiftOpNullable f ma mb =
102101 nullify (f (unsafeUnnullify ma) (unsafeUnnullify mb))
src/Rel8/Expr/Num.hs+11−44
@@ -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 )
23−import Rel8.Schema.Null ( Homonullable, Sql )
24−import Rel8.Table.Bool ( bool )
18+import Rel8.Schema.Nullability ( Homonullable, Sql )
2519import Rel8.Type.Num ( DBFractional, DBIntegral, DBNum )
2620
2721
@@ -45,44 +39,17 @@ realToFrac (Expr a) = castExpr (Expr a)
4539-- Corresponds to the @ceiling()@ function.
4640ceiling :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)
4741 => Expr a -> Expr b
48−ceiling = function "ceiling"
42+ceiling = 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
@@ -91,7 +58,7 @@ quotRem n d = (quot n d, rem n d)
9158-- Corresponds to the @floor()@ function.
9259floor :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)
9360 => Expr a -> Expr b
94−floor = function "floor"
61+floor = function "FLOOR"
9562
9663
9764-- | Round a 'DBFractional' to a 'DBIntegral' by rounding to the nearest
@@ -100,11 +67,11 @@ floor = function "floor"
10067-- Corresponds to the @round()@ function.
10168round :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)
10269 => Expr a -> Expr b
103−round = function "round"
70+round = function "ROUND"
10471
10572
10673-- | Round a 'DBFractional' to a 'DBIntegral' by rounding to the nearest
10774-- integer towards zero.
10875truncate :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)
10976 => Expr a -> Expr b
110−truncate = function "trunc"
77+truncate = function "TRUNC"
src/Rel8/Expr/Opaleye.hs+8−20
@@ -1,6 +1,8 @@
11{-# language FlexibleContexts #-}
2+{-# language LambdaCase #-}
23{-# language NamedFieldPuns #-}
34{-# language ScopedTypeVariables #-}
5+{-# language TypeApplications #-}
46{-# language TypeFamilies #-}
57
68{-# options_ghc -fno-warn-redundant-constraints #-}
@@ -10,7 +12,7 @@ module Rel8.Expr.Opaleye
1012 , scastExpr, sunsafeCastExpr
1113 , unsafeLiteral
1214 , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith, traversePrimExpr
13− , toColumn, fromColumn, traverseFieldP
15+ , toColumn, fromColumn
1416 )
1517where
1618
@@ -23,13 +25,10 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
2325
2426-- rel8
2527import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
26−import Rel8.Schema.Null ( Unnullify, Sql )
28+import Rel8.Schema.Nullability ( Unnullify, Sql )
2729import Rel8.Type ( DBType, typeInformation )
2830import Rel8.Type.Information ( TypeInformation(..) )
2931
30−-- profunctors
31−import Data.Profunctor ( Profunctor, dimap )
32−
3332
3433castExpr :: Sql DBType a => Expr a -> Expr a
3534castExpr = scastExpr typeInformation
@@ -51,13 +50,8 @@ sunsafeCastExpr TypeInformation {typeName} =
5150 fromPrimExpr . Opaleye.CastExpr typeName . toPrimExpr
5251
5352
54−-- | Unsafely construct an expression from literal SQL.
55−--
56−-- This is an escape hatch, and can be used if Rel8 can not adequately express
57−-- the query you need. If you find yourself using this function, please let us
58−-- know, as it may indicate that something is missing from Rel8!
59−unsafeLiteral :: String -> Expr a
60−unsafeLiteral = Expr . Opaleye.ConstExpr . Opaleye.OtherLit
53+unsafeLiteral :: Sql DBType a => String -> Expr a
54+unsafeLiteral = castExpr . Expr . Opaleye.ConstExpr . Opaleye.OtherLit
6155
6256
6357fromPrimExpr :: Opaleye.PrimExpr -> Expr a
@@ -83,15 +77,9 @@ traversePrimExpr :: Functor f
8377traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr
8478
8579
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
80+toColumn :: Opaleye.PrimExpr -> Opaleye.Column b
9381toColumn = Opaleye.Column
9482
9583
96−fromColumn :: Opaleye.Field_ n b -> Opaleye.PrimExpr
84+fromColumn :: Opaleye.Column b -> Opaleye.PrimExpr
9785fromColumn (Opaleye.Column a) = a
src/Rel8/Expr/Ord.hs+31−28
@@ -1,5 +1,6 @@
11{-# language DataKinds #-}
22{-# language FlexibleContexts #-}
3+{-# language LambdaCase #-}
34{-# language GADTs #-}
45{-# language ScopedTypeVariables #-}
56{-# language TypeApplications #-}
@@ -22,9 +23,12 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
2223-- rel8
2324import Rel8.Expr ( Expr( Expr ) )
2425import Rel8.Expr.Bool ( (&&.), (||.), coalesce )
25−import Rel8.Expr.Null ( isNull, isNonNull, nullableExpr, unsafeLiftOpNull )
26−import Rel8.Expr.Opaleye ( toPrimExpr, zipPrimExprsWith )
27−import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
26+import Rel8.Expr.Null ( isNull, isNonNull, nullable, unsafeLiftOpNullable )
27+import Rel8.Expr.Opaleye ( zipPrimExprsWith )
28+import Rel8.Schema.Nullability
29+ ( Nullability( NonNullable, Nullable )
30+ , Sql, nullabilization
31+ )
2832import Rel8.Type.Ord ( DBOrd )
2933
3034
@@ -48,9 +52,9 @@ ge = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:>=))
4852-- as @null@ will sort below any other value. For a version of @<@ that exactly
4953-- matches SQL, see '(<?)'.
5054(<.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool
51−(<.) = case nullable @a of
52− Null -> \ma mb -> isNull ma &&. isNonNull mb ||. ma <? mb
53− NotNull -> lt
55+(<.) = case nullabilization @a of
56+ Nullable -> \ma mb -> isNull ma &&. isNonNull mb ||. ma <? mb
57+ NonNullable -> lt
5458infix 4 <.
5559
5660
@@ -58,9 +62,9 @@ infix 4 <.
5862-- as @null@ will sort below any other value. For a version of @<=@ that exactly
5963-- matches SQL, see '(<=?)'.
6064(<=.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool
61−(<=.) = case nullable @a of
62− Null -> \ma mb -> isNull ma ||. ma <=? mb
63− NotNull -> le
65+(<=.) = case nullabilization @a of
66+ Nullable -> \ma mb -> isNull ma ||. ma <=? mb
67+ NonNullable -> le
6468infix 4 <=.
6569
6670
@@ -68,9 +72,9 @@ infix 4 <=.
6872-- as @null@ will sort below any other value. For a version of @>@ that exactly
6973-- matches SQL, see '(>?)'.
7074(>.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool
71−(>.) = case nullable @a of
72− Null -> \ma mb -> isNonNull ma &&. isNull mb ||. ma >? mb
73− NotNull -> gt
75+(>.) = case nullabilization @a of
76+ Nullable -> \ma mb -> isNonNull ma &&. isNull mb ||. ma >? mb
77+ NonNullable -> gt
7478infix 4 >.
7579
7680
@@ -78,37 +82,37 @@ infix 4 >.
7882-- as @null@ will sort below any other value. For a version of @>=@ that
7983-- exactly matches SQL, see '(>=?)'.
8084(>=.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool
81−(>=.) = case nullable @a of
82− Null -> \ma mb -> isNull mb ||. ma >=? mb
83− NotNull -> ge
85+(>=.) = case nullabilization @a of
86+ Nullable -> \ma mb -> isNull mb ||. ma >=? mb
87+ NonNullable -> ge
8488infix 4 >=.
8589
8690
8791-- | Corresponds to the SQL @<@ operator. Returns @null@ if either arguments
8892-- are @null@.
8993(<?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
90−a <? b = coalesce $ unsafeLiftOpNull lt a b
94+a <? b = coalesce $ unsafeLiftOpNullable lt a b
9195infix 4 <?
9296
9397
9498-- | Corresponds to the SQL @<=@ operator. Returns @null@ if either arguments
9599-- are @null@.
96100(<=?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
97−a <=? b = coalesce $ unsafeLiftOpNull le a b
101+a <=? b = coalesce $ unsafeLiftOpNullable le a b
98102infix 4 <=?
99103
100104
101105-- | Corresponds to the SQL @>@ operator. Returns @null@ if either arguments
102106-- are @null@.
103107(>?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
104−a >? b = coalesce $ unsafeLiftOpNull gt a b
108+a >? b = coalesce $ unsafeLiftOpNullable gt a b
105109infix 4 >?
106110
107111
108112-- | Corresponds to the SQL @>=@ operator. Returns @null@ if either arguments
109113-- are @null@.
110114(>=?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
111−a >=? b = coalesce $ unsafeLiftOpNull ge a b
115+a >=? b = coalesce $ unsafeLiftOpNullable ge a b
112116infix 4 >=?
113117
114118
@@ -117,11 +121,11 @@ infix 4 >=?
117121--
118122-- Corresponds to the SQL @least()@ function.
119123leastExpr :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr a
120−leastExpr ma mb = case nullable @a of
121− Null -> nullableExpr ma (\a -> nullableExpr mb (least_ a) mb) ma
122− NotNull -> least_ ma mb
124+leastExpr ma mb = case nullabilization @a of
125+ Nullable -> nullable ma (\a -> nullable mb (least_ a) mb) ma
126+ NonNullable -> least_ ma mb
123127 where
124− least_ a b = Expr (Opaleye.FunExpr "LEAST" [toPrimExpr a, toPrimExpr b])
128+ least_ (Expr a) (Expr b) = Expr (Opaleye.FunExpr "LEAST" [a, b])
125129
126130
127131-- | Given two expressions, return the expression that sorts greater than the
@@ -129,9 +133,8 @@ leastExpr ma mb = case nullable @a of
129133--
130134-- Corresponds to the SQL @greatest()@ function.
131135greatestExpr :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr a
132−greatestExpr ma mb = case nullable @a of
133− Null -> nullableExpr mb (\a -> nullableExpr ma (greatest_ a) mb) ma
134− NotNull -> greatest_ ma mb
136+greatestExpr ma mb = case nullabilization @a of
137+ Nullable -> nullable mb (\a -> nullable ma (greatest_ a) mb) ma
138+ NonNullable -> greatest_ ma mb
135139 where
136− greatest_ a b =
137− Expr (Opaleye.FunExpr "GREATEST" [toPrimExpr a, toPrimExpr b])
140+ greatest_ (Expr a) (Expr b) = Expr (Opaleye.FunExpr "GREATEST" [a, b])
src/Rel8/Expr/Sequence.hsdeleted−22
@@ -1,22 +0,0 @@
1−module Rel8.Expr.Sequence
2− ( nextval
3− )
4−where
5−
6−-- base
7−import Data.Int ( Int64 )
8−import Prelude
9−
10−-- rel8
11−import Rel8.Expr ( Expr )
12−import Rel8.Expr.Function ( function )
13−import Rel8.Expr.Serialize ( litExpr )
14−import Rel8.Expr.Text ( quoteIdent )
15−
16−-- text
17−import Data.Text ( pack )
18−
19−
20−-- | See https://www.postgresql.org/docs/current/functions-sequence.html
21−nextval :: String -> Expr Int64
22−nextval = function "nextval" . quoteIdent . litExpr . pack
src/Rel8/Expr/Serialize.hs+15−11
@@ -21,7 +21,11 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
2121-- rel8
2222import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
2323import Rel8.Expr.Opaleye ( scastExpr )
24−import Rel8.Schema.Null ( Unnullify, Nullity( Null, NotNull ), Sql, nullable )
24+import Rel8.Schema.Nullability
25+ ( Unnullify
26+ , Nullability( Nullable, NonNullable )
27+ , Sql, nullabilization
28+ )
2529import Rel8.Type ( DBType, typeInformation )
2630import Rel8.Type.Information ( TypeInformation(..) )
2731
@@ -31,19 +35,19 @@ import Rel8.Type.Information ( TypeInformation(..) )
3135-- Note that you can usually use 'Rel8.lit', but @litExpr@ can solve problems
3236-- of inference in polymorphic code.
3337litExpr :: Sql DBType a => a -> Expr a
34−litExpr = slitExpr nullable typeInformation
38+litExpr = slitExpr nullabilization typeInformation
3539
3640
37−slitExpr :: Nullity a -> TypeInformation (Unnullify a) -> a -> Expr a
38−slitExpr nullity info@TypeInformation {encode} =
41+slitExpr :: Nullability a -> TypeInformation (Unnullify a) -> a -> Expr a
42+slitExpr nullability info@TypeInformation {encode} =
3943 scastExpr info . Expr . encoder
4044 where
41− encoder = case nullity of
42− Null -> maybe (Opaleye.ConstExpr Opaleye.NullLit) encode
43− NotNull -> encode
45+ encoder = case nullability of
46+ Nullable -> maybe (Opaleye.ConstExpr Opaleye.NullLit) encode
47+ NonNullable -> encode
4448
4549
46−sparseValue :: Nullity a -> TypeInformation (Unnullify a) -> Hasql.Row a
47−sparseValue nullity TypeInformation {decode} = case nullity of
48− Null -> Hasql.column $ Hasql.nullable decode
49− NotNull -> Hasql.column $ Hasql.nonNullable decode
50+sparseValue :: Nullability a -> TypeInformation (Unnullify a) -> Hasql.Row a
51+sparseValue nullability TypeInformation {decode} = case nullability of
52+ Nullable -> Hasql.column $ Hasql.nullable decode
53+ NonNullable -> Hasql.column $ Hasql.nonNullable decode
src/Rel8/Expr/Text.hs+4−24
@@ -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 )
@@ -35,6 +32,7 @@ import Data.ByteString ( ByteString )
3532-- rel8
3633import Rel8.Expr ( Expr )
3734import Rel8.Expr.Function ( binaryOperator, function, nullaryFunction )
35+import Rel8.Type.Array1D ( Array1D )
3836
3937-- text
4038import Data.Text (Text)
@@ -52,7 +50,7 @@ infixr 6 ++.
5250
5351
5452-- | Matches regular expression, case sensitive
55−--
53+--
5654-- Corresponds to the @~.@ operator.
5755(~.) :: Expr Text -> Expr Text -> Expr Bool
5856(~.) = binaryOperator "~."
@@ -220,7 +218,7 @@ regexpReplace a b c Nothing = function "regexp_replace" a b c
220218
221219-- | Corresponds to the @regexp_split_to_array@ function.
222220regexpSplitToArray :: ()
223− => Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr [Text]
221+ => Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr (Array1D Text)
224222regexpSplitToArray a b (Just c) = function "regexp_split_to_array" a b c
225223regexpSplitToArray a b Nothing = function "regexp_split_to_array" a b
226224
@@ -276,21 +274,3 @@ substr a b Nothing = function "substr" a b
276274-- | Corresponds to the @translate@ function.
277275translate :: Expr Text -> Expr Text -> Expr Text -> Expr Text
278276translate = 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/Time.hs+2−2
@@ -31,7 +31,7 @@ import Prelude
3131-- rel8
3232import Rel8.Expr ( Expr )
3333import Rel8.Expr.Function ( binaryOperator, nullaryFunction )
34−import Rel8.Expr.Opaleye ( castExpr, unsafeCastExpr, unsafeLiteral )
34+import Rel8.Expr.Opaleye ( unsafeCastExpr, unsafeLiteral )
3535
3636-- time
3737import Data.Time.Calendar ( Day )
@@ -164,4 +164,4 @@ years = (`scaleInterval` year)
164164
165165
166166singleton :: String -> Expr CalendarDiffTime
167−singleton unit = castExpr $ unsafeLiteral $ "'1 " ++ unit ++ "'"
167+singleton unit = unsafeLiteral $ "'1 " ++ unit ++ "'"
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+1−9
@@ -3,11 +3,7 @@
33{-# language StandaloneKindSignatures #-}
44{-# language TypeFamilies #-}
55
6−module Rel8.FCF
7− ( Exp, Eval
8− , Id
9− )
10−where
6+module Rel8.FCF ( Exp, Eval ) where
117
128-- base
139import Data.Kind ( Type )
@@ -20,7 +16,3 @@ type Exp e = e -> Type
2016
2117type Eval :: Exp e -> e
2218type family Eval a
23−
24−
25−data Id :: a -> Exp a
26−type instance Eval (Id a) = a
src/Rel8/Generic/Construction.hsdeleted−352
@@ -1,352 +0,0 @@
1−{-# language AllowAmbiguousTypes #-}
2−{-# language ConstraintKinds #-}
3−{-# language DataKinds #-}
4−{-# language FlexibleContexts #-}
5−{-# language NamedFieldPuns #-}
6−{-# language ScopedTypeVariables #-}
7−{-# language StandaloneKindSignatures #-}
8−{-# language TypeApplications #-}
9−{-# language TypeFamilies #-}
10−{-# language UndecidableInstances #-}
11−{-# language ViewPatterns #-}
12−
13−module Rel8.Generic.Construction
14− ( GGBuildable
15− , GGBuild, ggbuild
16− , GGConstructable
17− , GGConstruct, ggconstruct
18− , GGDeconstruct, ggdeconstruct
19− , GGName, ggname
20− , GGAggregate, ggaggregate
21− )
22−where
23−
24−-- base
25−import Data.Bifunctor ( first )
26−import Data.Kind ( Constraint, Type )
27−import Data.List.NonEmpty ( NonEmpty( (:|) ) )
28−import GHC.TypeLits ( Symbol )
29−import Prelude
30−
31−-- rel8
32−import Rel8.Aggregate ( Aggregate( Aggregate ) )
33−import Rel8.Expr ( Expr )
34−import Rel8.Expr.Aggregate ( groupByExpr )
35−import Rel8.Expr.Eq ( (==.) )
36−import Rel8.Expr.Null ( nullify, snull, unsafeUnnullify )
37−import Rel8.Expr.Serialize ( litExpr )
38−import Rel8.FCF ( Eval, Exp, Id )
39−import Rel8.Generic.Construction.ADT
40− ( GConstructorADT, GMakeableADT, gmakeADT
41− , GConstructableADT
42− , GBuildADT, gbuildADT, gunbuildADT
43− , GConstructADT, gconstructADT, gdeconstructADT
44− , RepresentableConstructors, GConstructors, gcindex, gctabulate
45− , RepresentableFields, gfindex, gftabulate
46− )
47−import Rel8.Generic.Construction.Record
48− ( GConstructor
49− , GConstructable, GConstruct, gconstruct, gdeconstruct
50− , Representable, gindex, gtabulate
51− )
52−import Rel8.Generic.Table ( GGColumns )
53−import Rel8.Kind.Algebra
54− ( SAlgebra( SProduct, SSum )
55− , KnownAlgebra, algebraSing
56− )
57−import qualified Rel8.Kind.Algebra as K
58−import Rel8.Schema.Context.Nullify ( sguard, snullify )
59−import Rel8.Schema.HTable ( HTable )
60−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
61−import qualified Rel8.Schema.Kind as K
62−import Rel8.Schema.Name ( Name( Name ) )
63−import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
64−import Rel8.Schema.Spec ( Spec( Spec, nullity, info ) )
65−import Rel8.Table
66− ( TTable, TColumns
67− , Table, fromColumns, toColumns
68− )
69−import Rel8.Table.Bool ( case_ )
70−import Rel8.Type.Tag ( Tag )
71−
72−
73−type GGBuildable :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Constraint
74−type GGBuildable algebra name rep =
75− ( 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))))
80− , GGBuildable' algebra name rep
81− )
82−
83−
84−type GGBuildable' :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Constraint
85−type family GGBuildable' algebra name rep where
86− 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))
90− )
91− GGBuildable' 'K.Sum name rep =
92− ( Representable Id (GConstructorADT name (Eval (rep Expr)))
93− , GMakeableADT (TTable Expr) TColumns Id Expr name (Eval (rep Expr))
94− )
95−
96−
97−type GGBuild :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Type -> Type
98−type family GGBuild algebra name rep r where
99− GGBuild 'K.Product _name rep r =
100− GConstruct Id (Eval (rep Expr)) r
101− GGBuild 'K.Sum name rep r =
102− GConstruct Id (GConstructorADT name (Eval (rep Expr))) r
103−
104−
105−ggbuild :: forall algebra name rep a. GGBuildable algebra name rep
106− => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a)
107− -> GGBuild algebra name rep a
108−ggbuild gfromColumns = case algebraSing @algebra of
109− SProduct ->
110− gtabulate @Id @(Eval (rep Expr)) @a $
111− gfromColumns .
112− gconstruct
113− @(TTable Expr)
114− @TColumns
115− @Id
116− @Expr
117− @(Eval (rep Expr))
118− (const toColumns)
119− SSum ->
120− gtabulate @Id @(GConstructorADT name (Eval (rep Expr))) @a $
121− gfromColumns .
122− gmakeADT
123− @(TTable Expr)
124− @TColumns
125− @Id
126− @Expr
127− @name
128− @(Eval (rep Expr))
129− (const toColumns)
130− (\Spec {info} -> snull info)
131− (\Spec {nullity} -> case nullity of
132− Null -> id
133− NotNull -> nullify)
134− (HIdentity . litExpr)
135−
136−
137−type GGConstructable :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint
138−type GGConstructable algebra rep =
139− ( 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))))
144− , GGConstructable' algebra rep
145− )
146−
147−
148−type GGConstructable' :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint
149−type family GGConstructable' algebra rep where
150− 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))
157− )
158− 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− )
168−
169−
170−type GGConstruct :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type
171−type 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
174−
175−
176−ggconstruct :: forall algebra rep a. GGConstructable algebra rep
177− => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a)
178− -> GGConstruct algebra rep a -> a
179−ggconstruct gfromColumns f = case algebraSing @algebra of
180− SProduct ->
181− f $
182− gtabulate @Id @(Eval (rep Expr)) @a $
183− gfromColumns .
184− gconstruct
185− @(TTable Expr)
186− @TColumns
187− @Id
188− @Expr
189− @(Eval (rep Expr))
190− (const toColumns)
191− SSum ->
192− gcindex @Id @(Eval (rep Expr)) @a f $
193− fmap gfromColumns $
194− gconstructADT
195− @(TTable Expr)
196− @TColumns
197− @Id
198− @Expr
199− @(Eval (rep Expr))
200− (const toColumns)
201− (\Spec {info} -> snull info)
202− (\Spec {nullity} -> case nullity of
203− Null -> id
204− NotNull -> nullify)
205− (HIdentity . litExpr)
206−
207−
208−type GGDeconstruct :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type -> Type
209−type family GGDeconstruct algebra rep a r where
210− GGDeconstruct 'K.Product rep a r =
211− GConstruct Id (Eval (rep Expr)) r -> a -> r
212− GGDeconstruct 'K.Sum rep a r =
213− GConstructADT Id (Eval (rep Expr)) r (a -> r)
214−
215−
216−ggdeconstruct :: forall algebra rep a r. (GGConstructable algebra rep, Table Expr r)
217− => (a -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)
218− -> GGDeconstruct algebra rep a r
219−ggdeconstruct gtoColumns = case algebraSing @algebra of
220− SProduct -> \build ->
221− gindex @Id @(Eval (rep Expr)) @r build .
222− gdeconstruct
223− @(TTable Expr)
224− @TColumns
225− @Id
226− @Expr
227− @(Eval (rep Expr))
228− (const fromColumns) .
229− gtoColumns
230− SSum ->
231− gctabulate @Id @(Eval (rep Expr)) @r @(a -> r) $ \constructors as ->
232− let
233− (HIdentity tag, cases) =
234− gdeconstructADT
235− @(TTable Expr)
236− @TColumns
237− @Id
238− @Expr
239− @(Eval (rep Expr))
240− (const fromColumns)
241− (\Spec {nullity} -> case nullity of
242− Null -> id
243− NotNull -> unsafeUnnullify)
244− constructors $
245− gtoColumns as
246− in
247− case cases of
248− ((_, r) :| (map (first ((tag ==.) . litExpr)) -> cases')) ->
249− case_ cases' r
250−
251−
252−type GGName :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type
253−type 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
256−
257−
258−ggname :: forall algebra rep a. GGConstructable algebra rep
259− => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Name -> a)
260− -> GGName algebra rep a
261−ggname gfromColumns = case algebraSing @algebra of
262− SProduct ->
263− gtabulate @Id @(Eval (rep Name)) @a $
264− gfromColumns .
265− gconstruct
266− @(TTable Name)
267− @TColumns
268− @Id
269− @Name
270− @(Eval (rep Name))
271− (const toColumns)
272− SSum -> \tag ->
273− gftabulate @Id @(Eval (rep Name)) @a $
274− gfromColumns .
275− gbuildADT
276− @(TTable Name)
277− @TColumns
278− @Id
279− @Name
280− @(Eval (rep Name))
281− (const toColumns)
282− (\_ _ (Name a) -> Name a)
283− (HIdentity tag)
284−
285−
286−type GGAggregate :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type
287−type family GGAggregate algebra rep r where
288− GGAggregate 'K.Product rep r =
289− GConstruct Id (Eval (rep Aggregate)) r ->
290− GConstruct Id (Eval (rep Expr)) r
291− GGAggregate 'K.Sum rep r =
292− GBuildADT Id (Eval (rep Aggregate)) r ->
293− GBuildADT Id (Eval (rep Expr)) r
294−
295−
296−ggaggregate :: 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)
299− -> GGAggregate algebra rep agg -> exprs -> agg
300−ggaggregate gfromColumns gtoColumns agg es = case algebraSing @algebra of
301− SProduct -> flip f exprs $
302− gfromColumns .
303− gconstruct
304− @(TTable Aggregate)
305− @TColumns
306− @Id
307− @Aggregate
308− @(Eval (rep Aggregate))
309− (const toColumns)
310− where
311− f =
312− gindex @Id @(Eval (rep Expr)) @agg .
313− agg .
314− gtabulate @Id @(Eval (rep Aggregate)) @agg
315− exprs =
316− gdeconstruct
317− @(TTable Expr)
318− @TColumns
319− @Id
320− @Expr
321− @(Eval (rep Expr))
322− (const fromColumns) $
323− gtoColumns es
324− SSum -> flip f exprs $
325− gfromColumns .
326− gbuildADT
327− @(TTable Aggregate)
328− @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))
336− where
337− f =
338− gfindex @Id @(Eval (rep Expr)) @agg .
339− agg .
340− gftabulate @Id @(Eval (rep Aggregate)) @agg
341− (HIdentity tag, exprs) =
342− gunbuildADT
343− @(TTable Expr)
344− @TColumns
345− @Id
346− @Expr
347− @(Eval (rep Expr))
348− (const fromColumns)
349− (\Spec {nullity} -> case nullity of
350− Null -> id
351− NotNull -> unsafeUnnullify) $
352− gtoColumns es
src/Rel8/Generic/Construction/ADT.hsdeleted−478
@@ -1,478 +0,0 @@
1−{-# language AllowAmbiguousTypes #-}
2−{-# language BlockArguments #-}
3−{-# language DataKinds #-}
4−{-# language FlexibleContexts #-}
5−{-# language FlexibleInstances #-}
6−{-# language MultiParamTypeClasses #-}
7−{-# language RankNTypes #-}
8−{-# language ScopedTypeVariables #-}
9−{-# language StandaloneKindSignatures #-}
10−{-# language TupleSections #-}
11−{-# language TypeApplications #-}
12−{-# language TypeFamilies #-}
13−{-# language TypeOperators #-}
14−{-# language UndecidableInstances #-}
15−
16−module Rel8.Generic.Construction.ADT
17− ( GConstructableADT
18− , GBuildADT, gbuildADT, gunbuildADT
19− , GConstructADT, gconstructADT, gdeconstructADT
20− , GFields, RepresentableFields, gftabulate, gfindex
21− , GConstructors, RepresentableConstructors, gctabulate, gcindex
22− , GConstructorADT, GMakeableADT, gmakeADT
23− )
24−where
25−
26−-- base
27−import Data.Bifunctor ( first )
28−import Data.Functor.Identity ( runIdentity )
29−import Data.Kind ( Constraint, Type )
30−import Data.List.NonEmpty ( NonEmpty )
31−import Data.Proxy ( Proxy( Proxy ) )
32−import GHC.Generics
33− ( (:+:), (:*:)( (:*:) ), M1, U1
34− , C, D
35− , Meta( MetaData, MetaCons )
36− )
37−import GHC.TypeLits
38− ( ErrorMessage( (:<>:), Text ), TypeError
39− , Symbol, KnownSymbol, symbolVal
40− )
41−import Prelude hiding ( null )
42−
43−-- rel8
44−import Rel8.FCF ( Exp )
45−import Rel8.Generic.Construction.Record
46− ( GConstruct, GConstructable, gconstruct, gdeconstruct
47− , GFields, Representable, gtabulate, gindex
48− , FromColumns, ToColumns
49− )
50−import Rel8.Generic.Table.ADT ( GColumnsADT, GColumnsADT' )
51−import Rel8.Generic.Table.Record ( GColumns )
52−import Rel8.Schema.HTable ( HTable )
53−import Rel8.Schema.HTable.Identity ( HIdentity )
54−import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
55−import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify )
56−import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
57−import Rel8.Schema.Null ( Nullify )
58−import Rel8.Schema.Spec ( Spec )
59−import qualified Rel8.Schema.Kind as K
60−import Rel8.Type.Tag ( Tag( Tag ) )
61−
62−-- text
63−import Data.Text ( pack )
64−
65−
66−type Null :: K.Context -> Type
67−type Null context = forall a. Spec a -> context (Nullify a)
68−
69−
70−type Nullifier :: K.Context -> Type
71−type Nullifier context = forall a. Spec a -> context a -> context (Nullify a)
72−
73−
74−type Unnullifier :: K.Context -> Type
75−type Unnullifier context = forall a. Spec a -> context (Nullify a) -> context a
76−
77−
78−type NoConstructor :: Symbol -> Symbol -> ErrorMessage
79−type NoConstructor datatype constructor =
80− ( 'Text "The type `" ':<>:
81− 'Text datatype ':<>:
82− 'Text "` has no constructor `" ':<>:
83− 'Text constructor ':<>:
84− 'Text "`."
85− )
86−
87−
88−type GConstructorADT :: Symbol -> (Type -> Type) -> Type -> Type
89−type family GConstructorADT name rep where
90− GConstructorADT name (M1 D ('MetaData datatype _ _ _) rep) =
91− GConstructorADT' name rep (TypeError (NoConstructor datatype name))
92−
93−
94−type GConstructorADT' :: Symbol -> (Type -> Type) -> (Type -> Type) -> Type -> Type
95−type family GConstructorADT' name rep fallback where
96− GConstructorADT' name (M1 D _ rep) fallback =
97− GConstructorADT' name rep fallback
98− GConstructorADT' name (a :+: b) fallback =
99− GConstructorADT' name a (GConstructorADT' name b fallback)
100− GConstructorADT' name (M1 C ('MetaCons name _ _) rep) _ = rep
101− GConstructorADT' _ _ fallback = fallback
102−
103−
104−type GConstructADT
105− :: (Type -> Exp Type)
106− -> (Type -> Type) -> Type -> Type -> Type
107−type family GConstructADT f rep r x where
108− GConstructADT f (M1 D _ rep) r x = GConstructADT f rep r x
109− GConstructADT f (a :+: b) r x = GConstructADT f a r (GConstructADT f b r x)
110− GConstructADT f (M1 C _ rep) r x = GConstruct f rep r -> x
111−
112−
113−type GConstructors :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type
114−type family GConstructors f rep where
115− GConstructors f (M1 D _ rep) = GConstructors f rep
116− GConstructors f (a :+: b) = GConstructors f a :*: GConstructors f b
117− GConstructors f (M1 C _ rep) = (->) (GFields f rep)
118−
119−
120−type RepresentableConstructors :: (Type -> Exp Type) -> (Type -> Type) -> Constraint
121−class RepresentableConstructors f rep where
122− gctabulate :: (GConstructors f rep r -> a) -> GConstructADT f rep r a
123− gcindex :: GConstructADT f rep r a -> GConstructors f rep r -> a
124−
125−
126−instance RepresentableConstructors f rep => RepresentableConstructors f (M1 D meta rep) where
127− gctabulate = gctabulate @f @rep
128− gcindex = gcindex @f @rep
129−
130−
131−instance (RepresentableConstructors f a, RepresentableConstructors f b) =>
132− RepresentableConstructors f (a :+: b)
133− where
134− gctabulate f =
135− gctabulate @f @a \a -> gctabulate @f @b \b -> f (a :*: b)
136− gcindex f (a :*: b) = gcindex @f @b (gcindex @f @a f a) b
137−
138−
139−instance Representable f rep => RepresentableConstructors f (M1 C meta rep) where
140− gctabulate f = f . gindex @f @rep
141− gcindex f = f . gtabulate @f @rep
142−
143−
144−type GBuildADT :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type
145−type family GBuildADT f rep r where
146− GBuildADT f (M1 D _ rep) r = GBuildADT f rep r
147− GBuildADT f (a :+: b) r = GBuildADT f a (GBuildADT f b r)
148− GBuildADT f (M1 C _ rep) r = GConstruct f rep r
149−
150−
151−type GFieldsADT :: (Type -> Exp Type) -> (Type -> Type) -> Type
152−type family GFieldsADT f rep where
153− GFieldsADT f (M1 D _ rep) = GFieldsADT f rep
154− GFieldsADT f (a :+: b) = (GFieldsADT f a, GFieldsADT f b)
155− GFieldsADT f (M1 C _ rep) = GFields f rep
156−
157−
158−type RepresentableFields :: (Type -> Exp Type) -> (Type -> Type) -> Constraint
159−class RepresentableFields f rep where
160− gftabulate :: (GFieldsADT f rep -> a) -> GBuildADT f rep a
161− gfindex :: GBuildADT f rep a -> GFieldsADT f rep -> a
162−
163−
164−instance RepresentableFields f rep => RepresentableFields f (M1 D meta rep) where
165− gftabulate = gftabulate @f @rep
166− gfindex = gfindex @f @rep
167−
168−
169−instance (RepresentableFields f a, RepresentableFields f b) => RepresentableFields f (a :+: b) where
170− gftabulate f =
171− gftabulate @f @a \a -> gftabulate @f @b \b -> f (a, b)
172− gfindex f (a, b) = gfindex @f @b (gfindex @f @a f a) b
173−
174−
175−instance Representable f rep => RepresentableFields f (M1 C meta rep) where
176− gftabulate = gtabulate @f @rep
177− gfindex = gindex @f @rep
178−
179−
180−type GConstructableADT
181− :: (Type -> Exp Constraint)
182− -> (Type -> Exp K.HTable)
183− -> (Type -> Exp Type)
184− -> K.Context -> (Type -> Type) -> Constraint
185−class GConstructableADT _Table _Columns f context rep where
186− gbuildADT :: ()
187− => ToColumns _Table _Columns f context
188− -> (Tag -> Nullifier context)
189− -> HIdentity Tag context
190− -> GFieldsADT f rep
191− -> GColumnsADT _Columns rep context
192−
193− gunbuildADT :: ()
194− => FromColumns _Table _Columns f context
195− -> Unnullifier context
196− -> GColumnsADT _Columns rep context
197− -> (HIdentity Tag context, GFieldsADT f rep)
198−
199− gconstructADT :: ()
200− => ToColumns _Table _Columns f context
201− -> Null context
202− -> Nullifier context
203− -> (Tag -> HIdentity Tag context)
204− -> GConstructors f rep (GColumnsADT _Columns rep context)
205−
206− gdeconstructADT :: ()
207− => FromColumns _Table _Columns f context
208− -> Unnullifier context
209− -> GConstructors f rep r
210− -> GColumnsADT _Columns rep context
211− -> (HIdentity Tag context, NonEmpty (Tag, r))
212−
213−
214−instance
215− ( htable ~ HLabel "tag" (HIdentity Tag)
216− , GConstructableADT' _Table _Columns f context htable rep
217− )
218− => GConstructableADT _Table _Columns f context (M1 D meta rep)
219− where
220− gbuildADT toColumns nullifier =
221− gbuildADT' @_Table @_Columns @f @context @htable @rep toColumns nullifier .
222− hlabel
223−
224− gunbuildADT fromColumns unnullifier =
225− first hunlabel .
226− gunbuildADT' @_Table @_Columns @f @context @htable @rep fromColumns unnullifier
227−
228− gconstructADT toColumns null nullifier mk =
229− gconstructADT' @_Table @_Columns @f @context @htable @rep toColumns null nullifier
230− (hlabel . mk)
231−
232− gdeconstructADT fromColumns unnullifier cases =
233− first hunlabel .
234− gdeconstructADT' @_Table @_Columns @f @context @htable @rep fromColumns unnullifier cases
235−
236−
237−type GConstructableADT'
238− :: (Type -> Exp Constraint)
239− -> (Type -> Exp K.HTable)
240− -> (Type -> Exp Type)
241− -> K.Context -> K.HTable -> (Type -> Type) -> Constraint
242−class GConstructableADT' _Table _Columns f context htable rep where
243− gbuildADT' :: ()
244− => ToColumns _Table _Columns f context
245− -> (Tag -> Nullifier context)
246− -> htable context
247− -> GFieldsADT f rep
248− -> GColumnsADT' _Columns htable rep context
249−
250− gunbuildADT' :: ()
251− => FromColumns _Table _Columns f context
252− -> Unnullifier context
253− -> GColumnsADT' _Columns htable rep context
254− -> (htable context, GFieldsADT f rep)
255−
256− gconstructADT' :: ()
257− => ToColumns _Table _Columns f context
258− -> Null context
259− -> Nullifier context
260− -> (Tag -> htable context)
261− -> GConstructors f rep (GColumnsADT' _Columns htable rep context)
262−
263− gdeconstructADT' :: ()
264− => FromColumns _Table _Columns f context
265− -> Unnullifier context
266− -> GConstructors f rep r
267− -> GColumnsADT' _Columns htable rep context
268− -> (htable context, NonEmpty (Tag, r))
269−
270− gfill :: ()
271− => Null context
272− -> htable context
273− -> GColumnsADT' _Columns htable rep context
274−
275−
276−instance
277− ( htable' ~ GColumnsADT' _Columns htable a
278− , Functor (GConstructors f a)
279− , GConstructableADT' _Table _Columns f context htable a
280− , GConstructableADT' _Table _Columns f context htable' b
281− )
282− => GConstructableADT' _Table _Columns f context htable (a :+: b)
283− where
284− gbuildADT' toColumns nullifier htable (a, b) =
285− gbuildADT' @_Table @_Columns @f @context @htable' @b toColumns nullifier
286− (gbuildADT' @_Table @_Columns @f @context @htable @a toColumns nullifier htable a)
287− b
288−
289− gunbuildADT' fromColumns unnullifier columns =
290− case gunbuildADT' @_Table @_Columns @f @context @htable' @b fromColumns unnullifier columns of
291− (htable', b) ->
292− case gunbuildADT' @_Table @_Columns @f @context @htable @a fromColumns unnullifier htable' of
293− (htable, a) -> (htable, (a, b))
294−
295− gconstructADT' toColumns null nullifier mk =
296− fmap (gfill @_Table @_Columns @f @context @htable' @b null) (gconstructADT' @_Table @_Columns @f @context @htable @a toColumns null nullifier mk) :*:
297− gconstructADT' @_Table @_Columns @f @context @htable' @b toColumns null nullifier (gfill @_Table @_Columns @f @context @htable @a null . mk)
298−
299− gdeconstructADT' fromColumns unnullifier (a :*: b) columns =
300− case gdeconstructADT' @_Table @_Columns @f @context @htable' @b fromColumns unnullifier b columns of
301− (htable', cases) ->
302− case gdeconstructADT' @_Table @_Columns @f @context @htable @a fromColumns unnullifier a htable' of
303− (htable, cases') -> (htable, cases' <> cases)
304−
305− gfill null =
306− gfill @_Table @_Columns @f @context @htable' @b null .
307− gfill @_Table @_Columns @f @context @htable @a null
308−
309−
310−instance (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) =>
311− GConstructableADT' _Table _Columns f context htable (M1 C meta U1)
312− where
313− gbuildADT' _ _ = const
314− gunbuildADT' _ _ = (, ())
315− gconstructADT' _ _ _ f _ = f tag
316− where
317− tag = Tag $ pack $ symbolVal (Proxy @label)
318− gdeconstructADT' _ _ r htable = (htable, pure (tag, r ()))
319− where
320− tag = Tag $ pack $ symbolVal (Proxy @label)
321− gfill _ = id
322−
323−
324−instance {-# OVERLAPPABLE #-}
325− ( HTable (GColumns _Columns rep)
326− , KnownSymbol label
327− , meta ~ 'MetaCons label _fixity _isRecord
328− , GConstructable _Table _Columns f context rep
329− , GColumnsADT' _Columns htable (M1 C meta rep) ~
330− HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))
331− )
332− => GConstructableADT' _Table _Columns f context htable (M1 C meta rep)
333− where
334− gbuildADT' toColumns nullifier htable =
335− HProduct htable .
336− hlabel .
337− hnullify (nullifier tag) .
338− gconstruct @_Table @_Columns @f @context @rep toColumns
339− where
340− tag = Tag $ pack $ symbolVal (Proxy @label)
341−
342− gunbuildADT' fromColumns unnullifier (HProduct htable a) =
343− ( htable
344− , gdeconstruct @_Table @_Columns @f @context @rep fromColumns $
345− runIdentity $
346− hunnullify (\spec -> pure . unnullifier spec) $
347− hunlabel
348− a
349− )
350−
351− gconstructADT' toColumns _ nullifier mk =
352− HProduct htable .
353− hlabel .
354− hnullify nullifier .
355− gconstruct @_Table @_Columns @f @context @rep toColumns
356− where
357− tag = Tag $ pack $ symbolVal (Proxy @label)
358− htable = mk tag
359−
360− gdeconstructADT' fromColumns unnullifier r (HProduct htable columns) =
361− ( htable
362− , pure (tag, r a)
363− )
364− where
365− a = gdeconstruct @_Table @_Columns @f @context @rep fromColumns $
366− runIdentity $
367− hunnullify (\spec -> pure . unnullifier spec) $
368− hunlabel
369− columns
370− tag = Tag $ pack $ symbolVal (Proxy @label)
371−
372− gfill null htable = HProduct htable (hlabel (hnulls null))
373−
374−
375−type GMakeableADT
376− :: (Type -> Exp Constraint)
377− -> (Type -> Exp K.HTable)
378− -> (Type -> Exp Type)
379− -> K.Context -> Symbol -> (Type -> Type) -> Constraint
380−class GMakeableADT _Table _Columns f context name rep where
381− gmakeADT :: ()
382− => ToColumns _Table _Columns f context
383− -> Null context
384− -> Nullifier context
385− -> (Tag -> HIdentity Tag context)
386− -> GFields f (GConstructorADT name rep)
387− -> GColumnsADT _Columns rep context
388−
389−
390−instance
391− ( htable ~ HLabel "tag" (HIdentity Tag)
392− , meta ~ 'MetaData datatype _module _package _newtype
393− , fallback ~ TypeError (NoConstructor datatype name)
394− , fields ~ GFields f (GConstructorADT' name rep fallback)
395− , GMakeableADT' _Table _Columns f context htable name rep fields
396− , KnownSymbol name
397− )
398− => GMakeableADT _Table _Columns f context name (M1 D meta rep)
399− where
400− gmakeADT toColumns null nullifier wrap =
401− gmakeADT'
402− @_Table @_Columns @f @context @htable @name @rep @fields
403− toColumns null nullifier htable
404− where
405− tag = Tag $ pack $ symbolVal (Proxy @name)
406− htable = hlabel (wrap tag)
407−
408−
409−type GMakeableADT'
410− :: (Type -> Exp Constraint)
411− -> (Type -> Exp K.HTable)
412− -> (Type -> Exp Type)
413− -> K.Context -> K.HTable -> Symbol -> (Type -> Type) -> Type -> Constraint
414−class GMakeableADT' _Table _Columns f context htable name rep fields where
415− gmakeADT' :: ()
416− => ToColumns _Table _Columns f context
417− -> Null context
418− -> Nullifier context
419− -> htable context
420− -> fields
421− -> GColumnsADT' _Columns htable rep context
422−
423−
424−instance
425− ( htable' ~ GColumnsADT' _Columns htable a
426− , GMakeableADT' _Table _Columns f context htable name a fields
427− , GMakeableADT' _Table _Columns f context htable' name b fields
428− )
429− => GMakeableADT' _Table _Columns f context htable name (a :+: b) fields
430− where
431− gmakeADT' toColumns null nullifier htable x =
432− gmakeADT' @_Table @_Columns @f @context @htable' @name @b @fields
433− toColumns null nullifier
434− (gmakeADT'
435− @_Table @_Columns @f @context @htable @name @a @fields toColumns
436− null nullifier htable x)
437− x
438−
439−
440−instance {-# OVERLAPPING #-}
441− GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons name _fixity _isRecord) U1) fields
442− where
443− gmakeADT' _ _ _ = const
444−
445−
446−instance {-# OVERLAPS #-}
447− GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons label _fixity _isRecord) U1) fields
448− where
449− gmakeADT' _ _ _ = const
450−
451−
452−instance {-# OVERLAPS #-}
453− ( HTable (GColumns _Columns rep)
454− , GConstructable _Table _Columns f context rep
455− , fields ~ GFields f rep
456− , GColumnsADT' _Columns htable (M1 C ('MetaCons name _fixity _isRecord) rep) ~
457− HProduct htable (HLabel name (HNullify (GColumns _Columns rep)))
458− )
459− => GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons name _fixity _isRecord) rep) fields
460− where
461− gmakeADT' toColumns _ nullifier htable =
462− HProduct htable .
463− hlabel .
464− hnullify nullifier .
465− gconstruct @_Table @_Columns @f @context @rep toColumns
466−
467−
468−instance {-# OVERLAPPABLE #-}
469− ( HTable (GColumns _Columns rep)
470− , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) rep) ~
471− HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))
472− )
473− => GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons label _fixity _isRecord) rep) fields
474− where
475− gmakeADT' _ null _ htable _ =
476− HProduct htable $
477− hlabel $
478− hnulls null
src/Rel8/Generic/Construction/Record.hsdeleted−168
@@ -1,168 +0,0 @@
1−{-# language AllowAmbiguousTypes #-}
2−{-# language BlockArguments #-}
3−{-# language DataKinds #-}
4−{-# language FlexibleInstances #-}
5−{-# language MultiParamTypeClasses #-}
6−{-# language RankNTypes #-}
7−{-# language ScopedTypeVariables #-}
8−{-# language StandaloneKindSignatures #-}
9−{-# language TypeApplications #-}
10−{-# language TypeFamilies #-}
11−{-# language TypeOperators #-}
12−{-# language UndecidableInstances #-}
13−
14−module Rel8.Generic.Construction.Record
15− ( GConstructor, GConstruct, GConstructable, gconstruct, gdeconstruct
16− , GFields, Representable, gtabulate, gindex
17− , FromColumns, ToColumns
18− )
19−where
20−
21−-- base
22−import Data.Kind ( Constraint, Type )
23−import Data.Proxy ( Proxy( Proxy ) )
24−import GHC.Generics
25− ( (:*:), K1, M1, U1
26− , D, C, S, Meta( MetaData, MetaCons, MetaSel )
27− )
28−import GHC.TypeLits
29− ( ErrorMessage( (:<>:), Text ), TypeError
30− , Symbol
31− )
32−import Prelude
33−
34−-- rel8
35−import Rel8.FCF ( Eval, Exp )
36−import Rel8.Generic.Table.Record ( GColumns )
37−import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
38−import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
39−import qualified Rel8.Schema.Kind as K
40−
41−
42−type FromColumns
43− :: (Type -> Exp Constraint)
44− -> (Type -> Exp K.HTable)
45− -> (Type -> Exp Type)
46− -> K.Context
47− -> Type
48−type FromColumns _Table _Columns f context = forall proxy x.
49− Eval (_Table x) => proxy x -> Eval (_Columns x) context -> Eval (f x)
50−
51−
52−type ToColumns
53− :: (Type -> Exp Constraint)
54− -> (Type -> Exp K.HTable)
55− -> (Type -> Exp Type)
56− -> K.Context
57− -> Type
58−type ToColumns _Table _Columns f context = forall proxy x.
59− Eval (_Table x) => proxy x -> Eval (f x) -> Eval (_Columns x) context
60−
61−
62−type GConstructor :: (Type -> Type) -> Symbol
63−type family GConstructor rep where
64− GConstructor (M1 D _ (M1 C ('MetaCons name _ _) _)) = name
65− GConstructor (M1 D ('MetaData name _ _ _) _) = TypeError (
66− 'Text "`" ':<>:
67− 'Text name ':<>:
68− 'Text "` does not appear to have exactly 1 constructor"
69− )
70−
71−
72−type GConstruct :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type
73−type family GConstruct f rep r where
74− GConstruct f (M1 _ _ rep) r = GConstruct f rep r
75− GConstruct f (a :*: b) r = GConstruct f a (GConstruct f b r)
76− GConstruct _ U1 r = r
77− GConstruct f (K1 _ a) r = Eval (f a) -> r
78−
79−
80−type GFields :: (Type -> Exp Type) -> (Type -> Type) -> Type
81−type family GFields f rep where
82− GFields f (M1 _ _ rep) = GFields f rep
83− GFields f (a :*: b) = (GFields f a, GFields f b)
84− GFields _ U1 = ()
85− GFields f (K1 _ a) = Eval (f a)
86−
87−
88−type Representable :: (Type -> Exp Type) -> (Type -> Type) -> Constraint
89−class Representable f rep where
90− gtabulate :: (GFields f rep -> a) -> GConstruct f rep a
91− gindex :: GConstruct f rep a -> GFields f rep -> a
92−
93−
94−instance Representable f rep => Representable f (M1 i meta rep) where
95− gtabulate = gtabulate @f @rep
96− gindex = gindex @f @rep
97−
98−
99−instance (Representable f a, Representable f b) =>
100− Representable f (a :*: b)
101− where
102− gtabulate f = gtabulate @f @a \a -> gtabulate @f @b \b -> f (a, b)
103− gindex f (a, b) = gindex @f @b (gindex @f @a f a) b
104−
105−
106−instance Representable f U1 where
107− gtabulate = ($ ())
108− gindex = const
109−
110−
111−instance Representable f (K1 i a) where
112− gtabulate = id
113− gindex = id
114−
115−
116−type GConstructable
117− :: (Type -> Exp Constraint)
118− -> (Type -> Exp K.HTable)
119− -> (Type -> Exp Type)
120− -> K.Context -> (Type -> Type) -> Constraint
121−class GConstructable _Table _Columns f context rep where
122− gconstruct :: ()
123− => ToColumns _Table _Columns f context
124− -> GFields f rep
125− -> GColumns _Columns rep context
126− gdeconstruct :: ()
127− => FromColumns _Table _Columns f context
128− -> GColumns _Columns rep context
129− -> GFields f rep
130−
131−
132−instance (GConstructable _Table _Columns f context rep) =>
133− GConstructable _Table _Columns f context (M1 D meta rep)
134− where
135− gconstruct = gconstruct @_Table @_Columns @f @context @rep
136− gdeconstruct = gdeconstruct @_Table @_Columns @f @context @rep
137−
138−
139−instance (GConstructable _Table _Columns f context rep) =>
140− GConstructable _Table _Columns f context (M1 C meta rep)
141− where
142− gconstruct = gconstruct @_Table @_Columns @f @context @rep
143− gdeconstruct = gdeconstruct @_Table @_Columns @f @context @rep
144−
145−
146−instance
147− ( GConstructable _Table _Columns f context a
148− , GConstructable _Table _Columns f context b
149− )
150− => GConstructable _Table _Columns f context (a :*: b)
151− where
152− gconstruct toColumns (a, b) = HProduct
153− (gconstruct @_Table @_Columns @f @context @a toColumns a)
154− (gconstruct @_Table @_Columns @f @context @b toColumns b)
155− gdeconstruct fromColumns (HProduct a b) =
156− ( gdeconstruct @_Table @_Columns @f @context @a fromColumns a
157− , gdeconstruct @_Table @_Columns @f @context @b fromColumns b
158− )
159−
160−
161−instance
162− ( Eval (_Table a)
163− , meta ~ 'MetaSel ('Just label) _su _ss _ds
164− )
165− => GConstructable _Table _Columns f context (M1 S meta (K1 i a))
166− where
167− gconstruct toColumns = hlabel . toColumns (Proxy @a)
168− gdeconstruct fromColumns = fromColumns (Proxy @a) . hunlabel
src/Rel8/Generic/Map.hsdeleted−49
@@ -1,49 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language StandaloneKindSignatures #-}
3−{-# language TypeFamilies #-}
4−{-# language TypeOperators #-}
5−{-# language UndecidableInstances #-}
6−
7−module Rel8.Generic.Map
8− ( GMap
9− , Map
10− )
11−where
12−
13−-- base
14−import Data.Kind ( Type )
15−import GHC.Generics
16− ( (:+:), (:*:), K1, M1, U1, V1
17− )
18−import Prelude ()
19−
20−-- rel8
21−import Rel8.FCF ( Eval, Exp )
22−
23−
24−type GMap :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type
25−type family GMap f rep where
26− GMap f (M1 i c rep) = M1 i c (GMap f rep)
27− GMap _ V1 = V1
28− GMap f (rep1 :+: rep2) = GMap f rep1 :+: GMap f rep2
29− GMap _ U1 = U1
30− GMap f (rep1 :*: rep2) = GMap f rep1 :*: GMap f rep2
31− GMap f (K1 i a) = K1 i (Eval (f a))
32−
33−
34−-- | Map a @Type -> Type@ function over the @Type@-kinded type variables in
35−-- of a type constructor.
36−type Map :: (Type -> Exp Type) -> Type -> Type
37−type family Map f a where
38− Map p (t a b c d e f g) =
39− t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e))
40− (Eval (p f)) (Eval (p g))
41− Map p (t a b c d e f) =
42− t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e))
43− (Eval (p f))
44− Map p (t a b c d e) =
45− t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e))
46− Map p (t a b c d) = t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d))
47− Map p (t a b c) = t (Eval (p a)) (Eval (p b)) (Eval (p c))
48− Map p (t a b) = t (Eval (p a)) (Eval (p b))
49− Map p (t a) = t (Eval (p a))
src/Rel8/Generic/Record.hsdeleted−155
@@ -1,155 +0,0 @@
1−{-# language AllowAmbiguousTypes #-}
2−{-# language DataKinds #-}
3−{-# language FlexibleContexts #-}
4−{-# language FlexibleInstances #-}
5−{-# language MultiParamTypeClasses #-}
6−{-# language PolyKinds #-}
7−{-# language ScopedTypeVariables #-}
8−{-# language StandaloneKindSignatures #-}
9−{-# language TypeApplications #-}
10−{-# language TypeFamilies #-}
11−{-# language TypeOperators #-}
12−{-# language UndecidableInstances #-}
13−
14−module Rel8.Generic.Record
15− ( Record(..)
16− , GRecordable, GRecord, grecord, gunrecord
17− )
18−where
19−
20−-- base
21−import Data.Kind ( Constraint, Type )
22−import GHC.Generics
23− ( Generic, Rep, from, to
24− , (:+:)( L1, R1 ), (:*:)( (:*:) ), M1( M1 )
25− , Meta( MetaCons, MetaSel ), D, C, S
26− )
27−import GHC.TypeLits ( type (+), AppendSymbol, Div, Mod, Nat, Symbol )
28−import Prelude hiding ( Show )
29−
30−
31−type GRecord :: (Type -> Type) -> Type -> Type
32−type family GRecord rep where
33− GRecord (M1 D meta rep) = M1 D meta (GRecord rep)
34− GRecord (l :+: r) = GRecord l :+: GRecord r
35− GRecord (M1 C ('MetaCons name fixity 'False) rep) =
36− M1 C ('MetaCons name fixity 'True) (Snd (Count 0 rep))
37− GRecord rep = rep
38−
39−
40−type Count :: Nat -> (Type -> Type) -> (Nat, Type -> Type)
41−type family Count n rep where
42− Count n (M1 S ('MetaSel _selector su ss ds) rep) =
43− '(n + 1, M1 S ('MetaSel ('Just (Show (n + 1))) su ss ds) rep)
44− Count n (a :*: b) = CountHelper1 (Count n a) b
45− Count n rep = '(n, rep)
46−
47−
48−type CountHelper1 :: (Nat, Type -> Type) -> (Type -> Type) -> (Nat, Type -> Type)
49−type family CountHelper1 tuple b where
50− CountHelper1 '(n, a) b = CountHelper2 a (Count n b)
51−
52−
53−type CountHelper2 :: (Type -> Type) -> (Nat, Type -> Type) -> (Nat, Type -> Type)
54−type family CountHelper2 a tuple where
55− CountHelper2 a '(n, b) = '(n, a :*: b)
56−
57−
58−type Show :: Nat -> Symbol
59−type Show n =
60− AppendSymbol "_" (AppendSymbol (Show' (Div n 10)) (ShowDigit (Mod n 10)))
61−
62−
63−type Show' :: Nat -> Symbol
64−type family Show' n where
65− Show' 0 = ""
66− Show' n = AppendSymbol (Show' (Div n 10)) (ShowDigit (Mod n 10))
67−
68−
69−type ShowDigit :: Nat -> Symbol
70−type family ShowDigit n where
71− ShowDigit 0 = "0"
72− ShowDigit 1 = "1"
73− ShowDigit 2 = "2"
74− ShowDigit 3 = "3"
75− ShowDigit 4 = "4"
76− ShowDigit 5 = "5"
77− ShowDigit 6 = "6"
78− ShowDigit 7 = "7"
79− ShowDigit 8 = "8"
80− ShowDigit 9 = "9"
81−
82−
83−type Snd :: (a, b) -> b
84−type family Snd tuple where
85− Snd '(_a, b) = b
86−
87−
88−type GRecordable :: (Type -> Type) -> Constraint
89−class GRecordable rep where
90− grecord :: rep x -> GRecord rep x
91− gunrecord :: GRecord rep x -> rep x
92−
93−
94−instance GRecordable rep => GRecordable (M1 D meta rep) where
95− grecord (M1 a) = M1 (grecord a)
96− gunrecord (M1 a) = M1 (gunrecord a)
97−
98−
99−instance (GRecordable l, GRecordable r) => GRecordable (l :+: r) where
100− grecord (L1 a) = L1 (grecord a)
101− grecord (R1 a) = R1 (grecord a)
102− gunrecord (L1 a) = L1 (gunrecord a)
103− gunrecord (R1 a) = R1 (gunrecord a)
104−
105−
106−instance Countable 0 rep =>
107− GRecordable (M1 C ('MetaCons name fixity 'False) rep)
108− where
109− grecord (M1 a) = M1 (count @0 a)
110− gunrecord (M1 a) = M1 (uncount @0 a)
111−
112−
113−instance {-# OVERLAPPABLE #-} GRecord rep ~ rep => GRecordable rep where
114− grecord = id
115− gunrecord = id
116−
117−
118−type Countable :: Nat -> (Type -> Type) -> Constraint
119−class Countable n rep where
120− count :: rep x -> Snd (Count n rep) x
121− uncount :: Snd (Count n rep) x -> rep x
122−
123−
124−instance Countable n (M1 S ('MetaSel selector su ss ds) rep) where
125− count (M1 a) = M1 a
126− uncount (M1 a) = M1 a
127−
128−
129−instance
130− ( Countable n a, Countable n' b
131− , '(n', a') ~ Count n a
132− , Snd (CountHelper2 a' (Count n' b)) ~ (a' :*: Snd (Count n' b))
133− )
134− => Countable n (a :*: b)
135− where
136− count (a :*: b) = count @n a :*: count @n' b
137− uncount (a :*: b) = uncount @n a :*: uncount @n' b
138−
139−
140−instance {-# OVERLAPPABLE #-} Snd (Count n rep) ~ rep => Countable n rep where
141− count = id
142− uncount = id
143−
144−
145−type Record :: Type -> Type
146−newtype Record a = Record
147− { unrecord :: a
148− }
149−
150−
151−instance (Generic a, GRecordable (Rep a)) => Generic (Record a) where
152− type Rep (Record a) = GRecord (Rep a)
153−
154− from (Record a) = grecord (from a)
155− to = Record . to . gunrecord
src/Rel8/Generic/Rel8able.hsdeleted−281
@@ -1,281 +0,0 @@
1−{-# language AllowAmbiguousTypes #-}
2−{-# language ConstraintKinds #-}
3−{-# language DataKinds #-}
4−{-# language DefaultSignatures #-}
5−{-# language FlexibleContexts #-}
6−{-# language FlexibleInstances #-}
7−{-# language LambdaCase #-}
8−{-# language MultiParamTypeClasses #-}
9−{-# language PolyKinds #-}
10−{-# language QuantifiedConstraints #-}
11−{-# language ScopedTypeVariables #-}
12−{-# language StandaloneKindSignatures #-}
13−{-# language TypeApplications #-}
14−{-# language TypeFamilyDependencies #-}
15−{-# language TypeOperators #-}
16−{-# language UndecidableInstances #-}
17−
18−module Rel8.Generic.Rel8able
19− ( KRel8able, Rel8able
20− , Algebra
21− , GRep
22− , GColumns, gfromColumns, gtoColumns
23− , GFromExprs, gfromResult, gtoResult
24− , TSerialize, serialize, deserialize
25− )
26−where
27−
28−-- base
29−import Data.Functor.Identity ( Identity )
30−import Data.Kind ( Constraint, Type )
31−import Data.Type.Bool ( type (&&) )
32−import GHC.Generics ( Generic, Rep, from, to )
33−import Prelude
34−
35−-- rel8
36−import Rel8.Aggregate ( Aggregate )
37−import Rel8.Expr ( Expr )
38−import Rel8.FCF ( Exp, Eval )
39−import Rel8.Generic.Record ( Record(..) )
40−import Rel8.Generic.Table ( GAlgebra )
41−import qualified Rel8.Generic.Table.Record as G
42−import qualified Rel8.Kind.Algebra as K ( Algebra(..) )
43−import Rel8.Kind.Context ( SContext(..) )
44−import Rel8.Schema.Field ( Field )
45−import Rel8.Schema.HTable ( HTable )
46−import qualified Rel8.Schema.Kind as K
47−import Rel8.Schema.Name ( Name )
48−import Rel8.Schema.Result ( Result )
49−import Rel8.Table
50− ( Table, Columns, Context, fromColumns, toColumns
51− , FromExprs, fromResult, toResult
52− , Transpose
53− , TTable, TColumns
54− )
55−import Rel8.Table.Transpose ( Transposes )
56−
57−
58−-- | The kind of 'Rel8able' types
59−type KRel8able :: Type
60−type KRel8able = K.Rel8able
61−
62−
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−
116−-- | This type class allows you to define custom 'Table's using higher-kinded
117−-- data types. Higher-kinded data types are data types of the pattern:
118−--
119−-- @
120−-- data MyType f =
121−-- MyType { field1 :: Column f T1 OR HK1 f
122−-- , field2 :: Column f T2 OR HK2 f
123−-- , ...
124−-- , fieldN :: Column f Tn OR HKn f
125−-- }
126−-- @
127−--
128−-- where @Tn@ is any Haskell type, and @HKn@ is any higher-kinded type.
129−--
130−-- That is, higher-kinded data are records where all fields in the record are
131−-- all either of the type @Column f T@ (for any @T@), or are themselves
132−-- higher-kinded data:
133−--
134−-- [Nested]
135−--
136−-- @
137−-- data Nested f =
138−-- Nested { nested1 :: MyType f
139−-- , nested2 :: MyType f
140−-- }
141−-- @
142−--
143−-- The @Rel8able@ type class is used to give us a special mapping operation
144−-- that lets us change the type parameter @f@.
145−--
146−-- [Supplying @Rel8able@ instances]
147−--
148−-- This type class should be derived generically for all table types in your
149−-- project. To do this, enable the @DeriveAnyClass@ and @DeriveGeneric@ language
150−-- extensions:
151−--
152−-- @
153−-- \{\-\# LANGUAGE DeriveAnyClass, DeriveGeneric #-\}
154−--
155−-- data MyType f = MyType { fieldA :: Column f T }
156−-- deriving ( GHC.Generics.Generic, Rel8able )
157−-- @
158−type Rel8able :: K.Rel8able -> Constraint
159−class HTable (GColumns t) => Rel8able t where
160− type GColumns t :: K.HTable
161− type GFromExprs t :: Type
162−
163− gfromColumns :: SContext context -> GColumns t context -> t context
164− gtoColumns :: SContext context -> t context -> GColumns t context
165−
166− gfromResult :: GColumns t Result -> GFromExprs t
167− gtoResult :: GFromExprs t -> GColumns t Result
168−
169− type GColumns t = G.GColumns TColumns (GRep t Expr)
170− type GFromExprs t = t Result
171−
172− 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
178− )
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
186−
187− 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
193− )
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
209−
210−
211−type Algebra :: K.Rel8able -> K.Algebra
212−type Algebra t = GAlgebra (GRep t Expr)
213−
214−
215−type GRep :: K.Rel8able -> K.Context -> Type -> Type
216−type GRep t context = Rep (Record (t context))
217−
218−
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
src/Rel8/Generic/Table.hsdeleted−103
@@ -1,103 +0,0 @@
1−{-# language AllowAmbiguousTypes #-}
2−{-# language DataKinds #-}
3−{-# language FlexibleContexts #-}
4−{-# language FlexibleInstances #-}
5−{-# language MultiParamTypeClasses #-}
6−{-# language RankNTypes #-}
7−{-# language ScopedTypeVariables #-}
8−{-# language StandaloneKindSignatures #-}
9−{-# language TypeApplications #-}
10−{-# language TypeFamilies #-}
11−{-# language TypeOperators #-}
12−{-# language UndecidableInstances #-}
13−
14−module Rel8.Generic.Table
15− ( GGSerialize, GGColumns, ggfromResult, ggtoResult
16− , GAlgebra
17− )
18−where
19−
20−-- base
21−import Data.Kind ( Constraint, Type )
22−import GHC.Generics ( (:+:), (:*:), K1, M1, U1, V1 )
23−import Prelude ()
24−
25−-- rel8
26−import Rel8.FCF ( Eval, Exp )
27−import Rel8.Generic.Table.ADT
28− ( GSerializeADT, GColumnsADT, gtoResultADT, gfromResultADT
29− )
30−import Rel8.Generic.Table.Record ( GSerialize, GColumns, gtoResult, gfromResult )
31−import Rel8.Kind.Algebra
32− ( Algebra( Product, Sum )
33− , SAlgebra( SProduct, SSum )
34− , KnownAlgebra, algebraSing
35− )
36−import qualified Rel8.Schema.Kind as K
37−import Rel8.Schema.Result ( Result )
38−
39−
40−data GGSerialize
41− :: Algebra
42− -> (Type -> Type -> Exp Constraint)
43− -> (Type -> Exp K.HTable)
44− -> (Type -> Type)
45− -> (Type -> Type)
46− -> Exp Constraint
47−
48−
49−type instance Eval (GGSerialize 'Product _Serialize _Columns exprs rep) =
50− GSerialize _Serialize _Columns exprs rep
51−
52−
53−type instance Eval (GGSerialize 'Sum _Serialize _Columns exprs rep) =
54− GSerializeADT _Serialize _Columns exprs rep
55−
56−
57−data GGColumns
58− :: Algebra
59− -> (Type -> Exp K.HTable)
60− -> (Type -> Type)
61− -> Exp K.HTable
62−
63−
64−type instance Eval (GGColumns 'Product _Columns rep) = GColumns _Columns rep
65−
66−
67−type instance Eval (GGColumns 'Sum _Columns rep) = GColumnsADT _Columns rep
68−
69−
70−type GAlgebra :: (Type -> Type) -> Algebra
71−type family GAlgebra rep where
72− GAlgebra (M1 _ _ rep) = GAlgebra rep
73− GAlgebra V1 = 'Sum
74− GAlgebra (_ :+: _) = 'Sum
75− GAlgebra U1 = 'Sum
76− GAlgebra (_ :*: _) = 'Product
77− GAlgebra (K1 _ _) = 'Product
78−
79−
80−ggfromResult :: forall algebra _Serialize _Columns exprs rep x.
81− ( KnownAlgebra algebra
82− , Eval (GGSerialize algebra _Serialize _Columns exprs rep)
83− )
84− => (forall expr a proxy. Eval (_Serialize expr a)
85− => proxy expr -> Eval (_Columns expr) Result -> a)
86− -> Eval (GGColumns algebra _Columns exprs) Result
87− -> rep x
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
91−
92−
93−ggtoResult :: forall algebra _Serialize _Columns exprs rep x.
94− ( KnownAlgebra algebra
95− , Eval (GGSerialize algebra _Serialize _Columns exprs rep)
96− )
97− => (forall expr a proxy. Eval (_Serialize expr a)
98− => proxy expr -> a -> Eval (_Columns expr) Result)
99− -> rep x
100− -> Eval (GGColumns algebra _Columns exprs) Result
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
src/Rel8/Generic/Table/ADT.hsdeleted−221
@@ -1,221 +0,0 @@
1−{-# language AllowAmbiguousTypes #-}
2−{-# language DataKinds #-}
3−{-# language FlexibleContexts #-}
4−{-# language FlexibleInstances #-}
5−{-# language LambdaCase #-}
6−{-# language MultiParamTypeClasses #-}
7−{-# language RankNTypes #-}
8−{-# language ScopedTypeVariables #-}
9−{-# language StandaloneKindSignatures #-}
10−{-# language TypeApplications #-}
11−{-# language TypeFamilies #-}
12−{-# language TypeOperators #-}
13−{-# language UndecidableInstances #-}
14−
15−module Rel8.Generic.Table.ADT
16− ( GSerializeADT, GColumnsADT, gfromResultADT, gtoResultADT
17− , GSerializeADT', GColumnsADT'
18− )
19−where
20−
21−-- base
22−import Data.Functor.Identity ( Identity( Identity ) )
23−import Data.Kind ( Constraint, Type )
24−import Data.Proxy ( Proxy( Proxy ) )
25−import GHC.Generics
26− ( (:+:)( L1, R1 ), M1( M1 ), U1( U1 )
27− , C, D
28− , Meta( MetaCons )
29− )
30−import GHC.TypeLits ( KnownSymbol, symbolVal )
31−import Prelude hiding ( null )
32−
33−-- rel8
34−import 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 ) )
38−import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
39−import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify )
40−import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
41−import qualified Rel8.Schema.Kind as K
42−import Rel8.Schema.Result ( Result, null, nullifier, unnullifier )
43−import Rel8.Type.Tag ( Tag( Tag ) )
44−
45−-- text
46−import Data.Text ( pack )
47−
48−
49−type GColumnsADT
50− :: (Type -> Exp K.HTable)
51− -> (Type -> Type) -> K.HTable
52−type family GColumnsADT _Columns rep where
53− GColumnsADT _Columns (M1 D _ rep) =
54− GColumnsADT' _Columns (HLabel "tag" (HIdentity Tag)) rep
55−
56−
57−type GColumnsADT'
58− :: (Type -> Exp K.HTable)
59− -> K.HTable -> (Type -> Type) -> K.HTable
60−type family GColumnsADT' _Columns htable rep where
61− GColumnsADT' _Columns htable (a :+: b) =
62− GColumnsADT' _Columns (GColumnsADT' _Columns htable a) b
63− GColumnsADT' _Columns htable (M1 C ('MetaCons _ _ _) U1) = htable
64− GColumnsADT' _Columns htable (M1 C ('MetaCons label _ _) rep) =
65− HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))
66−
67−
68−type GSerializeADT
69− :: (Type -> Type -> Exp Constraint)
70− -> (Type -> Exp K.HTable)
71− -> (Type -> Type) -> (Type -> Type) -> Constraint
72−class GSerializeADT _Serialize _Columns exprs rep where
73− gfromResultADT :: ()
74− => (forall expr a proxy. Eval (_Serialize expr a)
75− => proxy expr -> Eval (_Columns expr) Result -> a)
76− -> GColumnsADT _Columns exprs Result
77− -> rep x
78−
79− gtoResultADT :: ()
80− => (forall expr a proxy. Eval (_Serialize expr a)
81− => proxy expr -> a -> Eval (_Columns expr) Result)
82− -> rep x
83− -> GColumnsADT _Columns exprs Result
84−
85−
86−instance
87− ( htable ~ HLabel "tag" (HIdentity Tag)
88− , GSerializeADT' _Serialize _Columns htable exprs rep
89− )
90− => GSerializeADT _Serialize _Columns (M1 D meta exprs) (M1 D meta rep)
91− where
92− gfromResultADT fromResult columns =
93− case gfromResultADT' @_Serialize @_Columns @htable @exprs @rep fromResult tag columns of
94− Just rep -> M1 rep
95− _ -> error "ADT.fromColumns: mismatch between tag and data"
96− where
97− tag = (\(HIdentity (Identity a)) -> a) . hunlabel @"tag"
98−
99− gtoResultADT toResult (M1 rep) =
100− gtoResultADT' @_Serialize @_Columns @htable @exprs @rep toResult tag (Just rep)
101− where
102− tag = hlabel @"tag" . HIdentity . Identity
103−
104−
105−type GSerializeADT'
106− :: (Type -> Type -> Exp Constraint)
107− -> (Type -> Exp K.HTable)
108− -> K.HTable -> (Type -> Type) -> (Type -> Type) -> Constraint
109−class GSerializeADT' _Serialize _Columns htable exprs rep where
110− gfromResultADT' :: context ~ Result
111− => (forall expr a proxy. Eval (_Serialize expr a)
112− => proxy expr -> Eval (_Columns expr) context -> a)
113− -> (htable Result -> Tag)
114− -> GColumnsADT' _Columns htable exprs context
115− -> Maybe (rep x)
116−
117− gtoResultADT' :: context ~ Result
118− => (forall expr a proxy. Eval (_Serialize expr a)
119− => proxy expr -> a -> Eval (_Columns expr) context)
120− -> (Tag -> htable Result)
121− -> Maybe (rep x)
122− -> GColumnsADT' _Columns htable exprs context
123−
124− extract :: GColumnsADT' _Columns htable exprs context -> htable context
125−
126−
127−instance
128− ( htable' ~ GColumnsADT' _Columns htable exprs1
129− , GSerializeADT' _Serialize _Columns htable exprs1 a
130− , GSerializeADT' _Serialize _Columns htable' exprs2 b
131− )
132− => GSerializeADT' _Serialize _Columns htable (exprs1 :+: exprs2) (a :+: b)
133− where
134− gfromResultADT' fromResult f columns =
135− case ma of
136− Just a -> Just (L1 a)
137− Nothing -> R1 <$>
138− gfromResultADT' @_Serialize @_Columns @_ @exprs2 @b
139− fromResult
140− (f . extract @_Serialize @_Columns @_ @exprs1 @a)
141− columns
142− where
143− ma =
144− gfromResultADT' @_Serialize @_Columns @_ @exprs1 @a
145− fromResult
146− f
147− (extract @_Serialize @_Columns @_ @exprs2 @b columns)
148−
149− gtoResultADT' toResult tag = \case
150− Just (L1 a) ->
151− gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b
152− toResult
153− (\_ -> gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a
154− toResult
155− tag
156− (Just a))
157− Nothing
158− Just (R1 b) ->
159− gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b
160− toResult
161− (\tag' ->
162− gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a
163− toResult
164− (\_ -> tag tag')
165− Nothing)
166− (Just b)
167− Nothing ->
168− gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b
169− toResult
170− (\_ -> gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a toResult tag Nothing)
171− Nothing
172−
173− extract =
174− extract @_Serialize @_Columns @_ @exprs1 @a .
175− extract @_Serialize @_Columns @_ @exprs2 @b
176−
177−
178−instance (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) =>
179− GSerializeADT' _Serialize _Columns _htable (M1 C meta U1) (M1 C meta U1)
180− where
181− gfromResultADT' _ tag columns
182− | tag columns == tag' = Just (M1 U1)
183− | otherwise = Nothing
184− where
185− tag' = Tag $ pack $ symbolVal (Proxy @label)
186−
187− gtoResultADT' _ tag _ = tag tag'
188− where
189− tag' = Tag $ pack $ symbolVal (Proxy @label)
190−
191− extract = id
192−
193−
194−instance {-# OVERLAPPABLE #-}
195− ( HTable (GColumns _Columns exprs)
196− , GSerialize _Serialize _Columns exprs rep
197− , meta ~ 'MetaCons label _fixity _isRecord
198− , KnownSymbol label
199− , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) exprs) ~
200− HProduct htable (HLabel label (HNullify (GColumns _Columns exprs)))
201− )
202− => GSerializeADT' _Serialize _Columns htable (M1 C meta exprs) (M1 C meta rep)
203− where
204− gfromResultADT' fromResult tag (HProduct a b)
205− | tag a == tag' =
206− M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult <$>
207− hunnullify unnullifier (hunlabel b)
208− | otherwise = Nothing
209− where
210− tag' = Tag $ pack $ symbolVal (Proxy @label)
211−
212− gtoResultADT' toResult tag = \case
213− Nothing -> HProduct (tag tag') (hlabel (hnulls (const null)))
214− Just (M1 rep) -> HProduct (tag tag') $
215− hlabel $
216− hnullify nullifier $
217− gtoResult @_Serialize @_Columns @exprs @rep toResult rep
218− where
219− tag' = Tag $ pack $ symbolVal (Proxy @label)
220−
221− extract (HProduct a _) = a
src/Rel8/Generic/Table/Record.hsdeleted−181
@@ -1,181 +0,0 @@
1−{-# language AllowAmbiguousTypes #-}
2−{-# language DataKinds #-}
3−{-# language FlexibleContexts #-}
4−{-# language FlexibleInstances #-}
5−{-# language MultiParamTypeClasses #-}
6−{-# language PolyKinds #-}
7−{-# language RankNTypes #-}
8−{-# language ScopedTypeVariables #-}
9−{-# language StandaloneKindSignatures #-}
10−{-# language TypeApplications #-}
11−{-# language TypeFamilies #-}
12−{-# language TypeOperators #-}
13−{-# language UndecidableInstances #-}
14−
15−module Rel8.Generic.Table.Record
16− ( GTable, GColumns, GContext, gfromColumns, gtoColumns, gtable
17− , GSerialize, gfromResult, gtoResult
18− )
19−where
20−
21−-- base
22−import Data.Kind ( Constraint, Type )
23−import Data.Proxy ( Proxy( Proxy ) )
24−import GHC.Generics
25− ( (:*:)( (:*:) ), K1( K1 ), M1( M1 )
26− , C, D, S
27− , Meta( MetaSel )
28− )
29−import Prelude hiding ( null )
30−
31−-- rel8
32−import Rel8.FCF ( Eval, Exp )
33−import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
34−import Rel8.Schema.HTable.Product ( HProduct(..) )
35−import qualified Rel8.Schema.Kind as K
36−
37−
38−type GColumns :: (Type -> Exp K.HTable) -> (Type -> Type) -> K.HTable
39−type family GColumns _Columns rep where
40− GColumns _Columns (M1 D _ rep) = GColumns _Columns rep
41− GColumns _Columns (M1 C _ rep) = GColumns _Columns rep
42− GColumns _Columns (rep1 :*: rep2) =
43− HProduct (GColumns _Columns rep1) (GColumns _Columns rep2)
44− GColumns _Columns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ a)) =
45− HLabel label (Eval (_Columns a))
46−
47−
48−type GContext :: (Type -> Exp K.Context) -> (Type -> Type) -> K.Context
49−type family GContext _Context rep where
50− GContext _Context (M1 _ _ rep) = GContext _Context rep
51− GContext _Context (rep1 :*: _rep2) = GContext _Context rep1
52− GContext _Context (K1 _ a) = Eval (_Context a)
53−
54−
55−type GTable
56− :: (Type -> Exp Constraint)
57− -> (Type -> Exp K.HTable)
58− -> (Type -> Type) -> Constraint
59−class GTable _Table _Columns rep
60− where
61− gfromColumns :: ()
62− => (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)
63− -> GColumns _Columns rep context
64− -> rep x
65−
66− gtoColumns :: ()
67− => (forall a. Eval (_Table a) => a -> Eval (_Columns a) context)
68− -> rep x
69− -> GColumns _Columns rep context
70−
71− gtable :: ()
72− => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)
73− -> GColumns _Columns rep context
74−
75−
76−type GSerialize
77− :: (Type -> Type -> Exp Constraint)
78− -> (Type -> Exp K.HTable)
79− -> (Type -> Type) -> (Type -> Type) -> Constraint
80−class GSerialize _Serialize _Columns exprs rep
81− where
82− gfromResult :: ()
83− => (forall expr a proxy. Eval (_Serialize expr a)
84− => proxy expr -> Eval (_Columns expr) context -> a)
85− -> GColumns _Columns exprs context
86− -> rep x
87−
88− gtoResult :: ()
89− => (forall expr a proxy. Eval (_Serialize expr a)
90− => proxy expr -> a -> Eval (_Columns expr) context)
91− -> rep x
92− -> GColumns _Columns exprs context
93−
94−
95−instance GTable _Table _Columns rep => GTable _Table _Columns (M1 D c rep)
96− where
97− gfromColumns fromColumns =
98− M1 . gfromColumns @_Table @_Columns @rep fromColumns
99− gtoColumns toColumns (M1 a) =
100− gtoColumns @_Table @_Columns @rep toColumns a
101− gtable = gtable @_Table @_Columns @rep
102−
103−
104−instance GSerialize _Serialize _Columns exprs rep =>
105− GSerialize _Serialize _Columns (M1 D c exprs) (M1 D c rep)
106− where
107− gfromResult fromResult =
108− M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult
109− gtoResult toResult (M1 a) =
110− gtoResult @_Serialize @_Columns @exprs @rep toResult a
111−
112−
113−instance GTable _Table _Columns rep => GTable _Table _Columns (M1 C c rep)
114− 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
120−
121−
122−instance GSerialize _Serialize _Columns exprs rep =>
123− GSerialize _Serialize _Columns (M1 C c exprs) (M1 C c rep)
124− where
125− gfromResult fromResult =
126− M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult
127− gtoResult toResult (M1 a) =
128− gtoResult @_Serialize @_Columns @exprs @rep toResult a
129−
130−
131−instance (GTable _Table _Columns rep1, GTable _Table _Columns rep2) =>
132− GTable _Table _Columns (rep1 :*: rep2)
133− where
134− gfromColumns fromColumns (HProduct a b) =
135− gfromColumns @_Table @_Columns @rep1 fromColumns a :*:
136− gfromColumns @_Table @_Columns @rep2 fromColumns b
137− gtoColumns toColumns (a :*: b) = HProduct
138− (gtoColumns @_Table @_Columns @rep1 toColumns a)
139− (gtoColumns @_Table @_Columns @rep2 toColumns b)
140− gtable table = HProduct
141− (gtable @_Table @_Columns @rep1 table)
142− (gtable @_Table @_Columns @rep2 table)
143−
144−
145−instance
146− ( GSerialize _Serialize _Columns expr1 rep1
147− , GSerialize _Serialize _Columns expr2 rep2
148− )
149− => GSerialize _Serialize _Columns (expr1 :*: expr2) (rep1 :*: rep2)
150− where
151− gfromResult fromResult (HProduct a b) =
152− gfromResult @_Serialize @_Columns @expr1 @rep1 fromResult a :*:
153− gfromResult @_Serialize @_Columns @expr2 @rep2 fromResult b
154− gtoResult toResult (a :*: b) =
155− HProduct
156− (gtoResult @_Serialize @_Columns @expr1 @rep1 toResult a)
157− (gtoResult @_Serialize @_Columns @expr2 @rep2 toResult b)
158−
159−
160−instance
161− ( Eval (_Table a)
162− , 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
176− , k1' ~ K1 i a
177− )
178− => GSerialize _Serialize _Columns (M1 S meta k1) (M1 S meta k1')
179− where
180− gfromResult fromResult = M1 . K1 . fromResult (Proxy @expr) . hunlabel
181− gtoResult toResult (M1 (K1 a)) = hlabel (toResult (Proxy @expr) a)
src/Rel8/Kind/Algebra.hsdeleted−38
@@ -1,38 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
3−{-# language GADTs #-}
4−{-# language StandaloneKindSignatures #-}
5−
6−module Rel8.Kind.Algebra
7− ( Algebra( Product, Sum )
8− , SAlgebra( SProduct, SSum )
9− , KnownAlgebra( algebraSing )
10− )
11−where
12−
13−-- base
14−import Data.Kind ( Constraint, Type )
15−import Prelude ()
16−
17−
18−type Algebra :: Type
19−data Algebra = Product | Sum
20−
21−
22−type SAlgebra :: Algebra -> Type
23−data SAlgebra algebra where
24− SProduct :: SAlgebra 'Product
25− SSum :: SAlgebra 'Sum
26−
27−
28−type KnownAlgebra :: Algebra -> Constraint
29−class KnownAlgebra algebra where
30− algebraSing :: SAlgebra algebra
31−
32−
33−instance KnownAlgebra 'Product where
34− algebraSing = SProduct
35−
36−
37−instance KnownAlgebra 'Sum where
38− algebraSing = SSum
src/Rel8/Kind/Context.hsdeleted−56
@@ -1,56 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language GADTs #-}
3−{-# language StandaloneKindSignatures #-}
4−{-# language TypeSynonymInstances #-}
5−
6−module Rel8.Kind.Context
7− ( Reifiable( contextSing )
8− , SContext(..)
9− )
10−where
11−
12−-- base
13−import Data.Kind ( Constraint, Type )
14−import Prelude ()
15−
16−-- rel8
17−import Rel8.Aggregate ( Aggregate )
18−import Rel8.Expr ( Expr )
19−import Rel8.Schema.Field ( Field )
20−import Rel8.Schema.Kind ( Context )
21−import Rel8.Schema.Name ( Name )
22−import Rel8.Schema.Result ( Result )
23−
24−
25−type SContext :: Context -> Type
26−data SContext context where
27− SAggregate :: SContext Aggregate
28− SExpr :: SContext Expr
29− SField :: SContext (Field table)
30− SName :: SContext Name
31− SResult :: SContext Result
32−
33−
34−type Reifiable :: Context -> Constraint
35−class Reifiable context where
36− contextSing :: SContext context
37−
38−
39−instance Reifiable Aggregate where
40− contextSing = SAggregate
41−
42−
43−instance Reifiable Expr where
44− contextSing = SExpr
45−
46−
47−instance Reifiable (Field table) where
48− contextSing = SField
49−
50−
51−instance Reifiable Result where
52− contextSing = SResult
53−
54−
55−instance Reifiable Name where
56− contextSing = SName
src/Rel8/Kind/Labels.hsnew file+61
@@ -0,0 +1,61 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language FlexibleInstances #-}
4+{-# language GADTs #-}
5+{-# language LambdaCase #-}
6+{-# language StandaloneKindSignatures #-}
7+{-# language TypeOperators #-}
8+
9+module Rel8.Kind.Labels
10+ ( Labels
11+ , SLabels( SLabel, SLabels )
12+ , KnownLabels( labelsSing )
13+ , renderLabels
14+ )
15+where
16+
17+-- base
18+import Data.Kind ( Constraint, Type )
19+import Data.List.NonEmpty ( NonEmpty( (:|) ), (<|) )
20+import Data.Proxy ( Proxy( Proxy ) )
21+import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
22+import Prelude
23+
24+
25+type Labels :: Type
26+type Labels = [Symbol]
27+
28+
29+type SLabels :: Labels -> Type
30+data SLabels labels where
31+ SLabel :: KnownSymbol label => Proxy label -> SLabels '[label]
32+ SLabels :: KnownSymbol label => Proxy label -> SLabels labels -> SLabels (label ': labels)
33+
34+
35+type KnownLabels :: Labels -> Constraint
36+class KnownLabels labels where
37+ labelsSing :: SLabels labels
38+
39+
40+instance KnownSymbol label => KnownLabels (label ': '[]) where
41+ labelsSing = SLabel Proxy
42+
43+
44+instance (KnownSymbol label, KnownLabels (label_ ': labels)) =>
45+ KnownLabels (label ': (label_ ': labels))
46+ where
47+ labelsSing = SLabels Proxy labelsSing
48+
49+
50+renderLabels :: SLabels labels -> NonEmpty String
51+renderLabels = cleanup . go
52+ where
53+ go :: SLabels labels -> NonEmpty String
54+ go = \case
55+ SLabel label -> pure (symbolVal label)
56+ SLabels label labels -> symbolVal label <| go labels
57+
58+ cleanup ("" :| []) = "anon" :| []
59+ cleanup (a :| []) = a :| []
60+ cleanup (a :| [""]) = a :| []
61+ cleanup (a :| (b : c)) = a <| cleanup (b :| c)
src/Rel8/Kind/Necessity.hsnew file+38
@@ -0,0 +1,38 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language GADTs #-}
4+{-# language StandaloneKindSignatures #-}
5+
6+module Rel8.Kind.Necessity
7+ ( Necessity( Optional, Required )
8+ , SNecessity( SOptional, SRequired )
9+ , KnownNecessity( necessitySing )
10+ )
11+where
12+
13+-- base
14+import Data.Kind ( Constraint, Type )
15+import Prelude ()
16+
17+
18+type Necessity :: Type
19+data Necessity = Optional | Required
20+
21+
22+type SNecessity :: Necessity -> Type
23+data SNecessity necessity where
24+ SOptional :: SNecessity 'Optional
25+ SRequired :: SNecessity 'Required
26+
27+
28+type KnownNecessity :: Necessity -> Constraint
29+class KnownNecessity necessity where
30+ necessitySing :: SNecessity necessity
31+
32+
33+instance KnownNecessity 'Optional where
34+ necessitySing = SOptional
35+
36+
37+instance KnownNecessity 'Required where
38+ necessitySing = SRequired
src/Rel8/Opaque.hsnew file+15
@@ -0,0 +1,15 @@
1+{-# language PolyKinds #-}
2+{-# language StandaloneKindSignatures #-}
3+{-# language TypeFamilies #-}
4+
5+module Rel8.Opaque
6+ ( Opaque
7+ )
8+where
9+
10+-- base
11+import Prelude ()
12+
13+
14+type Opaque :: k
15+data family Opaque :: k
src/Rel8/Order.hs+2−2
@@ -16,7 +16,7 @@ import Prelude
1616import Data.Functor.Contravariant.Divisible ( Decidable, Divisible )
1717
1818-- opaleye
19−import qualified Opaleye.Order as Opaleye
19+import qualified Opaleye.Internal.Order as Opaleye
2020
2121
2222-- | An ordering expression for @a@. Primitive orderings are defined with
@@ -24,7 +24,7 @@ import qualified Opaleye.Order as Opaleye
2424-- instances.
2525--
2626-- A common pattern is to use '<>' to combine multiple orderings in sequence,
27−-- and 'Data.Functor.Contravariant.>$<' to select individual columns.
27+-- and '>$<' (from 'Contravariant') to select individual columns.
2828type Order :: Type -> Type
2929newtype Order a = Order (Opaleye.Order a)
3030 deriving newtype (Contravariant, Divisible, Decidable, Semigroup, Monoid)
src/Rel8/Query.hs+8−181
@@ -1,6 +1,7 @@
1−{-# language FlexibleContexts #-}
1+{-# language DerivingStrategies #-}
2+{-# language DerivingVia #-}
3+{-# language GeneralizedNewtypeDeriving #-}
24{-# language StandaloneKindSignatures #-}
3−{-# language UndecidableInstances #-}
45
56module Rel8.Query
67 ( Query( Query )
@@ -8,201 +9,37 @@ module Rel8.Query
89where
910
1011-- base
11−import Control.Applicative ( liftA2 )
12−import Control.Monad ( liftM2 )
1312import Data.Kind ( Type )
14−import Data.Monoid ( Any( Any ) )
1513import Prelude
1614
1715-- opaleye
18−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
19−import qualified Opaleye.Internal.PackMap as Opaleye
20−import qualified Opaleye.Internal.PrimQuery as Opaleye hiding (lateral)
21−import qualified Opaleye.Internal.QueryArr as Opaleye
22−import qualified Opaleye.Internal.Tag as Opaleye
16+import qualified Opaleye.Select as Opaleye
2317
2418-- rel8
25−import Rel8.Expr ( Expr )
2619import Rel8.Query.Set ( unionAll )
27−import Rel8.Query.Opaleye ( fromOpaleye )
2820import Rel8.Query.Values ( values )
29−import Rel8.Table ( Table, fromColumns, toColumns )
3021import Rel8.Table.Alternative
3122 ( AltTable, (<|>:)
3223 , AlternativeTable, emptyTable
3324 )
34−import Rel8.Table.Projection ( Projectable, apply, project )
3525
3626-- semigroupoids
37−import Data.Functor.Apply ( Apply, (<.>) )
27+import Data.Functor.Apply ( Apply, WrappedApplicative(..) )
3828import Data.Functor.Bind ( Bind, (>>-) )
3929
4030
4131-- | The @Query@ monad allows you to compose a @SELECT@ query. This monad has
4232-- semantics similar to the list (@[]@) monad.
4333type Query :: Type -> Type
44−newtype Query a =
45− Query (
46− -- This is based on Opaleye's Select monad, but with two addtions. We
47− -- maintain a stack of PrimExprs from parent previous subselects. In
48− -- practice, these are always the results of dummy calls to random().
49− --
50− -- We also return a Bool that indicates to the parent subselect whether
51− -- or not that stack of PrimExprs were used at any point. If they weren't,
52− -- then the call to random() is never added to the query.
53− --
54− -- This is all needed to implement evaluate. Consider the following code:
55− --
56− -- do
57− -- x <- values [lit 'a', lit 'b', lit 'c']
58− -- y <- evaluate $ nextval "user_id_seq"
59− -- pure (x, y)
60− --
61− -- If we just used Opaleye's Select monad directly, the SQL would come out
62− -- like this:
63− --
64− -- SELECT
65− -- a, b
66− -- FROM
67− -- (VALUES ('a'), ('b'), ('c')) Q1(a),
68− -- LATERAL (SELECT nextval('user_id_seq')) Q2(b);
69− --
70− -- From the Haskell code, you would intuitively expect to get back the
71− -- results of three different calls to nextval(), but from Postgres' point
72− -- of view, because the Q2 subquery doesn't reference anything from the Q1
73− -- query, it thinks it only needs to call nextval() once. This is actually
74− -- exactly the same problem you get with the deprecated ListT IO monad from
75− -- the transformers package — *> behaves differently to >>=, so
76− -- using ApplicativeDo can change the results of a program. ApplicativeDo
77− -- is exactly the optimisation Postgres does on a "LATERAL" query that
78− -- doesn't make any references to previous subselects.
79− --
80− -- Rel8's solution is generate the following SQL instead:
81− --
82− -- SELECT
83− -- a, b
84− -- FROM
85− -- (SELECT
86− -- random() AS dummy,
87− -- *
88− -- FROM
89− -- (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1,
90− -- LATERAL (SELECT
91− -- CASE
92− -- WHEN dummy IS NOT NULL
93− -- THEN nextval('user_id_seq')
94− -- END) Q2(b);
95− --
96− -- We use random() here as the dummy value (and not some constant) because
97− -- Postgres will again optimize if it sees that a value is constant
98− -- (and thus only call nextval() once), but because random() is marked as
99− -- VOLATILE, this inhibits Postgres from doing that optimisation.
100− --
101− -- Why not just reference the a column from the previous query directly
102− -- instead of adding a dummy value? Basically, even if we extract out all
103− -- the bindings introduced in a PrimQuery, we can't always be sure which
104− -- ones refer to constant values, so if we end up laterally referencing a
105− -- constant value, then all of this would be for nothing.
106− --
107− -- Why not just add the call to the previous subselect directly, like so:
108− --
109− -- SELECT
110− -- a, b
111− -- FROM
112− -- (SELECT
113− -- nextval('user_id_seq') AS eval,
114− -- *
115− -- FROM
116− -- (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1,
117− -- LATERAL (SELECT eval) Q2(b);
118− --
119− -- That would work in this case. But consider the following Rel8 code:
120− --
121− -- do
122− -- x <- values [lit 'a', lit 'b', lit 'c']
123− -- y <- values [lit 'd', lit 'e', lit 'f']
124− -- z <- evaluate $ nextval "user_id_seq"
125− -- pure (x, y, z)
126− --
127− -- How many calls to nextval should there be? Our Haskell intuition says
128− -- nine. But that's not what you would get if you used the above
129− -- technique. The problem is, which VALUES query should the nextval be
130− -- added to? You can choose one or the other to get three calls to
131− -- nextval, but you still need to make a superfluous LATERAL references to
132− -- the other if you want nine calls. So for the above Rel8 code we generate
133− -- the following SQL:
134− --
135− -- SELECT
136− -- a, b, c
137− -- FROM
138− -- (SELECT
139− -- random() AS dummy,
140− -- *
141− -- FROM
142− -- (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1,
143− -- (SELECT
144− -- random() AS dummy,
145− -- *
146− -- FROM
147− -- (VALUES ('d'), ('e'), ('f')) Q2(b)) Q2,
148− -- LATERAL (SELECT
149− -- CASE
150− -- WHEN Q1.dummy IS NOT NULL AND Q2.dummy IS NOT NULL
151− -- THEN nextval('user_id_seq')
152− -- END) Q3(c);
153− --
154− -- This gives nine calls to nextval() as we would expect.
155− [Opaleye.PrimExpr] -> Opaleye.Select (Any, a)
156− )
157−
158−
159−instance Projectable Query where
160− project f = fmap (fromColumns . apply f . toColumns)
161−
162−
163−instance Functor Query where
164− fmap f (Query a) = Query (fmap (fmap (fmap f)) a)
165−
166−
167−instance Apply Query where
168− (<.>) = (<*>)
169−
170−
171−instance Applicative Query where
172− pure = fromOpaleye . pure
173− liftA2 = liftM2
34+newtype Query a = Query (Opaleye.Select a)
35+ deriving newtype (Functor, Applicative, Monad)
36+ deriving Apply via (WrappedApplicative Opaleye.Select)
17437
17538
17639instance Bind Query where
17740 (>>-) = (>>=)
17841
17942
180−instance Monad Query where
181− Query q >>= f = Query $ \dummies -> Opaleye.stateQueryArr $ \_ tag ->
182− let
183− qa = q dummies
184− ((m, a), query, tag') = Opaleye.runStateQueryArr qa () tag
185− Query q' = f a
186− (dummies', query', tag'') =
187− ( dummy : dummies
188− , query <> Opaleye.aRebind bindings
189− , Opaleye.next tag'
190− )
191− where
192− (dummy, bindings) = Opaleye.run $ name random
193− where
194− random = Opaleye.FunExpr "random" []
195− name = Opaleye.extractAttr "dummy" tag'
196− qa' = Opaleye.lateral $ \_ -> q' dummies'
197− ((m'@(Any needsDummies), b), query'', tag''') = Opaleye.runStateQueryArr qa' () tag''
198− query'''
199− | needsDummies = query' <> query''
200− | otherwise = query <> query''
201− m'' = m <> m'
202− in
203− ((m'', b), query''', tag''')
204−
205−
20643-- | '<|>:' = 'unionAll'.
20744instance AltTable Query where
20845 (<|>:) = unionAll
@@ -211,13 +48,3 @@ instance AltTable Query where
21148-- | 'emptyTable' = 'values' @[]@.
21249instance AlternativeTable Query where
21350 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.hs-boot+1−3
@@ -7,13 +7,11 @@ where
77
88-- base
99import Data.Kind ( Type )
10−import Data.Monoid ( Any )
1110import Prelude ()
1211
1312-- opaleye
14−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
1513import qualified Opaleye.Select as Opaleye
1614
1715
1816type Query :: Type -> Type
19−newtype Query a = Query ([Opaleye.PrimExpr] -> Opaleye.Select (Any, a))
17+newtype Query a = Query (Opaleye.Select a)
src/Rel8/Query/Aggregate.hs+2−22
@@ -1,17 +1,12 @@
11{-# language FlexibleContexts #-}
2−{-# language MonoLocalBinds #-}
3−{-# language ScopedTypeVariables #-}
4−{-# language TypeApplications #-}
52
63module Rel8.Query.Aggregate
74 ( aggregate
85 , countRows
9− , mode
106 )
117where
128
139-- base
14−import Data.Functor.Contravariant ( (>$<) )
1510import Data.Int ( Int64 )
1611import Prelude
1712
@@ -19,25 +14,18 @@ import Prelude
1914import qualified Opaleye.Aggregate as Opaleye
2015
2116-- rel8
22−import Rel8.Aggregate ( Aggregates )
17+import Rel8.Aggregate ( Aggregate )
2318import Rel8.Expr ( Expr )
2419import Rel8.Expr.Aggregate ( countStar )
25−import Rel8.Expr.Order ( desc )
2620import Rel8.Query ( Query )
27−import Rel8.Query.Limit ( limit )
2821import Rel8.Query.Maybe ( optional )
2922import 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 )
3523import Rel8.Table.Opaleye ( aggregator )
3624import Rel8.Table.Maybe ( maybeTable )
3725
3826
3927-- | Apply an aggregation to all rows returned by a 'Query'.
40−aggregate :: Aggregates aggregates exprs => Query aggregates -> Query exprs
28+aggregate :: Query (Aggregate exprs) -> Query exprs
4129aggregate = mapOpaleye (Opaleye.aggregate aggregator)
4230
4331
@@ -46,11 +34,3 @@ aggregate = mapOpaleye (Opaleye.aggregate aggregator)
4634-- will return @0@.
4735countRows :: Query a -> Query (Expr Int64)
4836countRows = 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−4
@@ -1,5 +1,4 @@
11{-# language FlexibleContexts #-}
2−{-# language MonoLocalBinds #-}
32
43module Rel8.Query.Each
54 ( each
@@ -17,7 +16,7 @@ import Rel8.Query ( Query )
1716import Rel8.Query.Opaleye ( fromOpaleye )
1817import Rel8.Schema.Name ( Selects )
1918import Rel8.Schema.Table ( TableSchema )
20−import Rel8.Table.Cols ( fromCols, toCols )
19+import Rel8.Table ( fromColumns, toColumns )
2120import Rel8.Table.Opaleye ( table, unpackspec )
2221
2322
@@ -25,8 +24,8 @@ import Rel8.Table.Opaleye ( table, unpackspec )
2524-- table@.
2625each :: Selects names exprs => TableSchema names -> Query exprs
2726each =
28− fmap fromCols .
27+ fmap fromColumns .
2928 fromOpaleye .
3029 Opaleye.selectTableExplicit unpackspec .
3130 table .
32− fmap toCols
31+ fmap toColumns
src/Rel8/Query/Either.hs+17−27
@@ -3,22 +3,23 @@
33module Rel8.Query.Either
44 ( keepLeftTable
55 , keepRightTable
6+ , bindEitherTable
67 , bitraverseEitherTable
78 )
89where
910
1011-- base
12+import Data.Functor ( (<&>) )
1113import Prelude
1214
13−-- comonad
14−import Control.Comonad ( extract )
15−
1615-- rel8
1716import Rel8.Expr ( Expr )
1817import Rel8.Expr.Eq ( (==.) )
1918import Rel8.Query ( Query )
2019import Rel8.Query.Filter ( where_ )
2120import Rel8.Query.Maybe ( optional )
21+import Rel8.Table ( Table )
22+import Rel8.Table.Bool ( bool )
2223import Rel8.Table.Either
2324 ( EitherTable( EitherTable )
2425 , isLeftTable, isRightTable
@@ -26,41 +27,30 @@ import Rel8.Table.Either
2627import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
2728
2829
29−-- | Filter 'EitherTable's, keeping only 'leftTable's.
30−keepLeftTable :: EitherTable Expr a b -> Query a
30+keepLeftTable :: EitherTable a b -> Query a
3131keepLeftTable e@(EitherTable _ a _) = do
3232 where_ $ isLeftTable e
33− pure (extract a)
33+ pure a
3434
3535
36−-- | Filter 'EitherTable's, keeping only 'rightTable's.
37−keepRightTable :: EitherTable Expr a b -> Query b
36+keepRightTable :: EitherTable a b -> Query b
3837keepRightTable e@(EitherTable _ _ b) = do
3938 where_ $ isRightTable e
40− pure (extract b)
39+ pure b
40+
41+
42+bindEitherTable :: (Table Expr a, Functor m)
43+ => (i -> m (EitherTable a b)) -> EitherTable a i -> m (EitherTable a b)
44+bindEitherTable query e@(EitherTable input a i) = do
45+ query i <&> \(EitherTable output a' b) ->
46+ EitherTable (input <> output) (bool a a' (isRightTable e)) b
4147
4248
43−-- | @bitraverseEitherTable f g x@ will pass all @leftTable@s through @f@ and
44−-- all @rightTable@s through @g@. The results are then lifted back into
45−-- @leftTable@ and @rightTable@, respectively. This is similar to 'bitraverse'
46−-- for 'Either'.
47−--
48−-- For example,
49−--
50−-- >>> :{
51−-- select do
52−-- x <- values (map lit [ Left True, Right (42 :: Int32) ])
53−-- bitraverseEitherTable (\y -> values [y, not_ y]) (\y -> pure (y * 100)) x
54−-- :}
55−-- [ Left True
56−-- , Left False
57−-- , Right 4200
58−-- ]
5949bitraverseEitherTable :: ()
6050 => (a -> Query c)
6151 -> (b -> Query d)
62− -> EitherTable Expr a b
63− -> Query (EitherTable Expr c d)
52+ -> EitherTable a b
53+ -> Query (EitherTable c d)
6454bitraverseEitherTable f g e@(EitherTable tag _ _) = do
6555 mc@(MaybeTable _ c) <- optional (f =<< keepLeftTable e)
6656 md@(MaybeTable _ d) <- optional (g =<< keepRightTable e)
src/Rel8/Query/Evaluate.hsdeleted−49
@@ -1,49 +0,0 @@
1−{-# language FlexibleContexts #-}
2−{-# language TupleSections #-}
3−
4−module Rel8.Query.Evaluate
5− ( evaluate
6− )
7−where
8−
9−-- base
10−import Control.Monad ( (>=>) )
11−import Data.Foldable ( foldl' )
12−import Data.List.NonEmpty ( NonEmpty( (:|) ), nonEmpty )
13−import Data.Monoid ( Any( Any ) )
14−import Prelude hiding ( undefined )
15−
16−-- opaleye
17−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
18−
19−-- rel8
20−import Rel8.Expr ( Expr )
21−import Rel8.Expr.Bool ( (&&.) )
22−import Rel8.Expr.Opaleye ( fromPrimExpr )
23−import Rel8.Query ( Query( Query ) )
24−import Rel8.Query.Rebind ( rebind )
25−import Rel8.Table ( Table )
26−import Rel8.Table.Bool ( case_ )
27−import Rel8.Table.Undefined ( undefined )
28−
29−
30−-- | 'evaluate' takes expressions that could potentially have side effects and
31−-- \"runs\" them in the 'Query' monad. The returned expressions have no side
32−-- effects and can safely be reused.
33−evaluate :: Table Expr a => a -> Query a
34−evaluate = laterally >=> rebind "eval"
35−
36−
37−laterally :: Table Expr a => a -> Query a
38−laterally a = Query $ \bindings -> pure $ (Any True,) $
39− case nonEmpty bindings of
40− Nothing -> a
41− Just bindings' -> case_ [(condition, a)] undefined
42− where
43− condition = foldl1' (&&.) (fmap go bindings')
44− where
45− go = fromPrimExpr . Opaleye.UnExpr Opaleye.OpIsNotNull
46−
47−
48−foldl1' :: (a -> a -> a) -> NonEmpty a -> a
49−foldl1' f (a :| as) = foldl' f a as
src/Rel8/Query/Exists.hs+17−15
@@ -2,8 +2,8 @@
22
33module Rel8.Query.Exists
44 ( exists, inQuery
5− , present, with, withBy
6− , absent, without, withoutBy
5+ , whereExists, with, withBy
6+ , whereNotExists, without, withoutBy
77 )
88where
99
@@ -11,54 +11,56 @@ where
1111import Prelude hiding ( filter )
1212
1313-- opaleye
14−import qualified Opaleye.Exists as Opaleye
1514import qualified Opaleye.Operators as Opaleye
1615
1716-- rel8
1817import Rel8.Expr ( Expr )
19−import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )
2018import Rel8.Query ( Query )
2119import Rel8.Query.Filter ( filter )
20+import Rel8.Query.Maybe ( optional )
2221import Rel8.Query.Opaleye ( mapOpaleye )
2322import Rel8.Table.Eq ( EqTable, (==:) )
23+import Rel8.Table.Maybe ( isJustTable )
2424
2525
2626-- | Checks if a query returns at least one row.
2727exists :: Query a -> Query (Expr Bool)
28−exists = fmap (fromPrimExpr . fromColumn) . mapOpaleye Opaleye.exists
28+exists = fmap isJustTable . optional . whereExists
29+-- FIXME: change this when b7aacc07c6392654cae439fc3b997620c3aa7a87 makes it
30+-- into a release of Opaleye
2931
3032
3133inQuery :: EqTable a => a -> Query a -> Query (Expr Bool)
3234inQuery a = exists . (>>= filter (a ==:))
3335
3436
35−-- | Produce the empty query if the given query returns no rows. @present@
37+-- | Produce the empty query if the given query returns no rows. @whereExists@
3638-- is equivalent to @WHERE EXISTS@ in SQL.
37−present :: Query a -> Query ()
38−present = mapOpaleye Opaleye.restrictExists
39+whereExists :: Query a -> Query ()
40+whereExists = mapOpaleye Opaleye.restrictExists
3941
4042
41−-- | Produce the empty query if the given query returns rows. @absent@
43+-- | Produce the empty query if the given query returns rows. @whereNotExists@
4244-- is equivalent to @WHERE NOT EXISTS@ in SQL.
43−absent :: Query a -> Query ()
44−absent = mapOpaleye Opaleye.restrictNotExists
45+whereNotExists :: Query a -> Query ()
46+whereNotExists = mapOpaleye Opaleye.restrictNotExists
4547
4648
4749-- | @with@ is similar to 'filter', but allows the predicate to be a full query.
4850--
49−-- @with f a = a <$ present (f a)@, but this form matches 'filter'.
51+-- @with f a = a <$ whereExists (f a)@, but this form matches 'filter'.
5052with :: (a -> Query b) -> a -> Query a
51−with f a = a <$ present (f a)
53+with f a = a <$ whereExists (f a)
5254
5355
5456-- | Like @with@, but with a custom membership test.
55−withBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a
57+withBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a
5658withBy predicate bs = with $ \a -> bs >>= filter (predicate a)
5759
5860
5961-- | Filter rows where @a -> Query b@ yields no rows.
6062without :: (a -> Query b) -> a -> Query a
61−without f a = a <$ absent (f a)
63+without f a = a <$ whereNotExists (f a)
6264
6365
6466-- | Like @without@, but with a custom membership test.
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+14−93
@@ -1,58 +1,23 @@
11{-# language FlexibleContexts #-}
2−{-# language GADTs #-}
3−{-# language NamedFieldPuns #-}
42
53module Rel8.Query.List
64 ( many, some
7− , manyExpr, someExpr
8− , catListTable, catNonEmptyTable
9− , catList, catNonEmpty
105 )
116where
127
138-- base
14−import Data.Functor.Identity ( runIdentity )
15−import Data.List.NonEmpty ( NonEmpty )
169import Prelude
1710
18−-- opaleye
19−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
20−
2111-- rel8
2212import Rel8.Expr ( Expr )
23−import Rel8.Expr.Aggregate ( listAggExpr, nonEmptyAggExpr )
24−import Rel8.Expr.Opaleye ( mapPrimExpr )
2513import Rel8.Query ( Query )
2614import Rel8.Query.Aggregate ( aggregate )
2715import Rel8.Query.Maybe ( optional )
28−import Rel8.Query.Rebind ( rebind )
29−import Rel8.Schema.HTable.Vectorize ( hunvectorize )
30−import 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 )
16+import Rel8.Table ( Table )
3417import Rel8.Table.Aggregate ( listAgg, nonEmptyAgg )
35−import Rel8.Table.List ( ListTable( ListTable ) )
18+import Rel8.Table.List ( ListTable )
3619import Rel8.Table.Maybe ( maybeTable )
37−import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )
38−import Rel8.Type ( DBType, typeInformation )
39−import Rel8.Type.Array ( extractArrayElement )
40−import Rel8.Type.Information ( TypeInformation )
41−
42−
43−-- | Aggregate a 'Query' into a 'ListTable'. If the supplied query returns 0
44−-- rows, this function will produce a 'Query' that returns one row containing
45−-- the empty @ListTable@. If the supplied @Query@ does return rows, @many@ will
46−-- return exactly one row, with a @ListTable@ collecting all returned rows.
47−--
48−-- @many@ is analogous to 'Control.Applicative.many' from
49−-- @Control.Applicative@.
50−many :: Table Expr a => Query a -> Query (ListTable Expr a)
51−many =
52− fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .
53− optional .
54− aggregate .
55− fmap (listAgg . toCols)
20+import Rel8.Table.NonEmpty ( NonEmptyTable )
5621
5722
5823-- | Aggregate a 'Query' into a 'NonEmptyTable'. If the supplied query returns
@@ -63,60 +28,16 @@ many =
6328--
6429-- @some@ is analogous to 'Control.Applicative.some' from
6530-- @Control.Applicative@.
66−some :: Table Expr a => Query a -> Query (NonEmptyTable Expr a)
67−some =
68− fmap (\(NonEmptyTable a) -> NonEmptyTable a) .
69− aggregate .
70− fmap (nonEmptyAgg . toCols)
71−
72−
73−-- | A version of 'many' specialised to single expressions.
74−manyExpr :: Sql DBType a => Query (Expr a) -> Query (Expr [a])
75−manyExpr = fmap (maybeTable mempty id) . optional . aggregate . fmap listAggExpr
76−
77−
78−-- | A version of 'many' specialised to single expressions.
79−someExpr :: Sql DBType a => Query (Expr a) -> Query (Expr (NonEmpty a))
80−someExpr = aggregate . fmap nonEmptyAggExpr
81−
82−
83−-- | Expand a 'ListTable' into a 'Query', where each row in the query is an
84−-- element of the given @ListTable@.
85−--
86−-- @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
91−
92−
93−-- | Expand a 'NonEmptyTable' into a 'Query', where each row in the query is an
94−-- element of the given @NonEmptyTable@.
95−--
96−-- @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
101−
102−
103−-- | Expand an expression that contains a list into a 'Query', where each row
104−-- in the query is an element of the given list.
105−--
106−-- @catList@ is an inverse to 'manyExpr'.
107−catList :: Sql DBType a => Expr [a] -> Query (Expr a)
108−catList = rebind "unnest" . sunnest typeInformation
109−
110−
111−-- | Expand an expression that contains a non-empty list into a 'Query', where
112−-- each row in the query is an element of the given list.
113−--
114−-- @catNonEmpty@ is an inverse to 'someExpr'.
115−catNonEmpty :: Sql DBType a => Expr (NonEmpty a) -> Query (Expr a)
116−catNonEmpty = rebind "unnest" . sunnest typeInformation
31+some :: Table Expr a => Query a -> Query (NonEmptyTable a)
32+some = aggregate . fmap nonEmptyAgg
11733
11834
119−sunnest :: TypeInformation (Unnullify a) -> Expr (list a) -> Expr a
120−sunnest info = mapPrimExpr $
121− extractArrayElement info .
122− Opaleye.UnExpr (Opaleye.UnOpOther "UNNEST")
35+-- | Aggregate a 'Query' into a 'ListTable'. If the supplied query returns 0
36+-- rows, this function will produce a 'Query' that returns one row containing
37+-- the empty @ListTable@. If the supplied @Query@ does return rows, @many@ will
38+-- return exactly one row, with a @ListTable@ collecting all returned rows.
39+--
40+-- @many@ is analogous to 'Control.Applicative.many' from
41+-- @Control.Applicative@.
42+many :: Table Expr a => Query a -> Query (ListTable a)
43+many = fmap (maybeTable mempty id) . optional . aggregate . fmap listAgg
src/Rel8/Query/Maybe.hs+45−26
@@ -1,10 +1,7 @@
1−{-# language GADTs #-}
2−{-# language LambdaCase #-}
3−{-# language NamedFieldPuns #-}
4−
51module Rel8.Query.Maybe
62 ( optional
73 , catMaybeTable
4+ , bindMaybeTable
85 , traverseMaybeTable
96 )
107where
@@ -12,20 +9,23 @@ where
129-- base
1310import Prelude
1411
15−-- comonad
16−import Control.Comonad ( extract )
17−
1812-- opaleye
19−import qualified Opaleye.Internal.MaybeFields as Opaleye
13+import qualified Opaleye.Internal.PackMap as Opaleye
14+import qualified Opaleye.Internal.PrimQuery as Opaleye
15+import qualified Opaleye.Internal.QueryArr as Opaleye
16+import qualified Opaleye.Internal.Tag as Opaleye
17+import qualified Opaleye.Internal.Unpackspec as Opaleye
2018
2119-- rel8
22−import Rel8.Expr ( Expr )
20+import Rel8.Expr.Bool ( true )
2321import Rel8.Expr.Eq ( (==.) )
24−import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )
22+import Rel8.Expr.Opaleye ( toPrimExpr )
2523import Rel8.Query ( Query )
2624import Rel8.Query.Filter ( where_ )
2725import Rel8.Query.Opaleye ( mapOpaleye )
28−import Rel8.Table.Maybe ( MaybeTable(..), isJustTable )
26+import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
27+import Rel8.Table.Opaleye ( unpackspec )
28+import Rel8.Table.Tag ( Tag(..), fromExpr )
2929
3030
3131-- | Convert a query that might return zero rows to a query that always returns
@@ -33,11 +33,18 @@ import Rel8.Table.Maybe ( MaybeTable(..), isJustTable )
3333--
3434-- To speak in more concrete terms, 'optional' is most useful to write @LEFT
3535-- 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− }
36+optional :: Query a -> Query (MaybeTable a)
37+optional = mapOpaleye $ Opaleye.QueryArr . go
38+ where
39+ go query (i, left, tag) =
40+ (MaybeTable (fromExpr t') a, join, Opaleye.next tag')
41+ where
42+ (MaybeTable Tag {expr = t} a, right, tag') =
43+ Opaleye.runSimpleQueryArr (pure <$> query) (i, tag)
44+ (t', bindings) = Opaleye.run $
45+ Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr "maybe" tag') t
46+ join = Opaleye.Join Opaleye.LeftJoin condition [] bindings left right
47+ condition = toPrimExpr true
4148
4249
4350-- | Filter out 'MaybeTable's, returning only the tables that are not-null.
@@ -45,24 +52,36 @@ optional = mapOpaleye $ Opaleye.optionalInternal $ \tag a -> MaybeTable
4552-- This operation can be used to "undo" the effect of 'optional', which
4653-- operationally is like turning a @LEFT JOIN@ back into a full @JOIN@. You
4754-- can think of this as analogous to 'Data.Maybe.catMaybes'.
48−catMaybeTable :: MaybeTable Expr a -> Query a
55+catMaybeTable :: MaybeTable a -> Query a
4956catMaybeTable ma@(MaybeTable _ a) = do
5057 where_ $ isJustTable ma
51− pure (extract a)
58+ pure a
59+
60+
61+-- | @bindMaybeTable f x@ is similar to the monadic bind (@>>=@) operation. It
62+-- allows you to "extend" an optional query with another query. If either the
63+-- input or output are 'Rel8.nothingTable', then the result is
64+-- 'Rel8.nothingTable'.
65+--
66+-- This is similar to 'traverseMaybeTable', followed by a @join@ on the
67+-- resulting @MaybeTable@s.
68+bindMaybeTable :: Monad m
69+ => (a -> m (MaybeTable b)) -> MaybeTable a -> m (MaybeTable b)
70+bindMaybeTable query (MaybeTable input a) = do
71+ MaybeTable output b <- query a
72+ pure $ MaybeTable (input <> output) b
5273
5374
5475-- | Extend an optional query with another query. This is useful if you want
5576-- to step through multiple @LEFT JOINs@.
5677--
5778-- 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
79+-- you also have the ability to "expand" one row into multiple rows. If the
5980-- @a -> Query b@ function returns no rows, then the resulting query will also
6081-- have no rows. However, regardless of the given @a -> Query b@ function, if
61−-- the input is @nothingTable@, you will always get exactly one @nothingTable@
62−-- back.
63−traverseMaybeTable :: (a -> Query b) -> MaybeTable Expr a -> Query (MaybeTable Expr b)
82+-- the input is @noTable@, you will always get exactly one @noTable@ back.
83+traverseMaybeTable :: (a -> Query b) -> MaybeTable a -> Query (MaybeTable b)
6484traverseMaybeTable 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
85+ MaybeTable output b <- optional (query =<< catMaybeTable ma)
86+ where_ $ expr output ==. expr input
87+ pure $ MaybeTable input b
src/Rel8/Query/Null.hs+3−18
@@ -1,8 +1,5 @@
1−{-# language FlexibleContexts #-}
2−
31module Rel8.Query.Null
4− ( catNull
5− , catNullTable
2+ ( catNullable
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
@@ -22,17 +17,7 @@ import Rel8.Query.Filter ( where_ )
2217-- @null@s.
2318--
2419-- Corresponds to 'Data.Maybe.catMaybes'.
25−catNull :: Expr (Maybe a) -> Query (Expr a)
26−catNull a = do
20+catNullable :: Expr (Maybe a) -> Query (Expr a)
21+catNullable 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+5−41
@@ -1,70 +1,34 @@
1−{-# language TupleSections #-}
2−
31module Rel8.Query.Opaleye
42 ( fromOpaleye
53 , toOpaleye
64 , mapOpaleye
75 , zipOpaleyeWith
8− , unsafePeekQuery
96 )
107where
118
129-- base
13−import Control.Applicative ( liftA2 )
1410import Prelude
1511
1612-- opaleye
17−import qualified Opaleye.Internal.QueryArr as Opaleye
18−import qualified Opaleye.Internal.Tag as Opaleye
13+import qualified Opaleye.Select as Opaleye
1914
2015-- rel8
2116import {-# SOURCE #-} Rel8.Query ( Query( Query ) )
2217
2318
2419fromOpaleye :: Opaleye.Select a -> Query a
25−fromOpaleye = Query . pure . fmap pure
20+fromOpaleye = Query
2621
2722
2823toOpaleye :: Query a -> Opaleye.Select a
29−toOpaleye (Query a) = snd <$> a mempty
24+toOpaleye (Query a) = a
3025
3126
3227mapOpaleye :: (Opaleye.Select a -> Opaleye.Select b) -> Query a -> Query b
33−mapOpaleye f (Query a) = Query (fmap (mapping f) a)
28+mapOpaleye f = fromOpaleye . f . toOpaleye
3429
3530
3631zipOpaleyeWith :: ()
3732 => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)
3833 -> Query a -> Query b -> Query c
39−zipOpaleyeWith f (Query a) (Query b) = Query $ liftA2 (zipping f) a b
40−
41−
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−
48−mapping :: ()
49− => (Opaleye.Select a -> Opaleye.Select b)
50− -> Opaleye.Select (m, a) -> Opaleye.Select (m, b)
51−mapping f q = Opaleye.stateQueryArr $ \_ tag ->
52− let
53− ((m, _), _, _) = Opaleye.runStateQueryArr q () tag
54− q' = (m,) <$> f (snd <$> q)
55− in
56− Opaleye.runStateQueryArr q' () tag
57−
58−
59−zipping :: Semigroup m
60− => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)
61− -> Opaleye.Select (m, a) -> Opaleye.Select (m, b) -> Opaleye.Select (m, c)
62−zipping f q q' =
63− Opaleye.stateQueryArr $ \_ tag ->
64− let
65− ((m, _), _, _) = Opaleye.runStateQueryArr q () tag
66− ((m', _), _, _) = Opaleye.runStateQueryArr q' () tag
67− m'' = m <> m'
68− q'' = (m'',) <$> f (snd <$> q) (snd <$> q')
69− in
70− Opaleye.runStateQueryArr q'' () tag
34+zipOpaleyeWith f a b = fromOpaleye $ f (toOpaleye a) (toOpaleye b)
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+58−6
@@ -1,21 +1,73 @@
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(..) )
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 ( Selects, Col(..) )
31+import Rel8.Schema.HTable ( htabulateA, hfield )
32+import Rel8.Table ( Table, toColumns )
33+import Rel8.Table.Name ( namesFromLabels )
1734
1835
19−-- | Convert a 'Query' to a 'String' containing a @SELECT@ statement.
36+-- | Convert a query to a 'String' containing the query as a @SELECT@
37+-- statement.
2038showQuery :: Table Expr a => Query a -> String
21−showQuery = show . ppSelect
39+showQuery = fold . sqlForQuery
40+
41+
42+sqlForQuery :: Table Expr a
43+ => Query a -> Maybe String
44+sqlForQuery = sqlForQueryWithNames namesFromLabels . fmap toColumns
45+
46+
47+sqlForQueryWithNames :: Selects names exprs
48+ => names -> Query exprs -> Maybe String
49+sqlForQueryWithNames names query =
50+ show . Opaleye.ppSql . selectFrom names exprs <$> optimize primQuery
51+ where
52+ (exprs, primQuery, _) =
53+ Opaleye.runSimpleQueryArrStart (toOpaleye query) ()
54+
55+
56+optimize :: Opaleye.PrimQuery' a -> Maybe (Opaleye.PrimQuery' Void)
57+optimize = Opaleye.removeEmpty . Opaleye.optimize
58+
59+
60+selectFrom :: Selects names exprs
61+ => names -> exprs -> Opaleye.PrimQuery' Void -> Opaleye.Select
62+selectFrom (toColumns -> names) (toColumns -> exprs) query =
63+ Opaleye.SelectFrom $ Opaleye.newSelect
64+ { Opaleye.attrs = Opaleye.SelectAttrs attributes
65+ , Opaleye.tables = Opaleye.oneTable select
66+ }
67+ where
68+ select = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator query
69+ attributes = getConst $ htabulateA $ \field -> case hfield names field of
70+ NameCol name -> case hfield exprs field of
71+ DB (toPrimExpr -> expr) -> Const (pure (makeAttr name expr))
72+ makeAttr label expr =
73+ (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+45−52
@@ -1,5 +1,4 @@
11{-# language FlexibleContexts #-}
2−{-# language GADTs #-}
32
43module Rel8.Query.These
54 ( alignBy
@@ -8,6 +7,7 @@ module Rel8.Query.These
87 , keepThisTable, loseThisTable
98 , keepThatTable, loseThatTable
109 , keepThoseTable, loseThoseTable
10+ , bindTheseTable
1111 , bitraverseTheseTable
1212 )
1313where
@@ -15,29 +15,27 @@ where
1515-- base
1616import Prelude
1717
18−-- comonad
19−import Control.Comonad ( extract )
20−
2118-- opaleye
22−import qualified Opaleye.Internal.PackMap as Opaleye
19+import qualified Opaleye.Internal.Join as Opaleye
2320import qualified Opaleye.Internal.PrimQuery as Opaleye
24−import qualified Opaleye.Internal.QueryArr as Opaleye
25−import qualified Opaleye.Internal.Tag as Opaleye
2621
2722-- rel8
2823import Rel8.Expr ( Expr )
2924import Rel8.Expr.Bool ( boolExpr, not_ )
3025import Rel8.Expr.Eq ( (==.) )
31−import Rel8.Expr.Opaleye ( toPrimExpr, traversePrimExpr )
26+import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
3227import Rel8.Expr.Serialize ( litExpr )
3328import Rel8.Query ( Query )
3429import Rel8.Query.Filter ( where_ )
3530import Rel8.Query.Maybe ( optional )
3631import Rel8.Query.Opaleye ( zipOpaleyeWith )
32+import Rel8.Table ( Table )
3733import Rel8.Table.Either ( EitherTable( EitherTable ) )
3834import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
35+import Rel8.Table.Opaleye ( unpackspec )
36+import Rel8.Table.Tag ( Tag(..) )
3937import Rel8.Table.These
40− ( TheseTable( TheseTable, here, there )
38+ ( TheseTable( TheseTable )
4139 , hasHereTable, hasThereTable
4240 , isThisTable, isThatTable, isThoseTable
4341 )
@@ -45,91 +43,86 @@ import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) )
4543
4644
4745-- | Corresponds to a @FULL OUTER JOIN@ between two queries.
48−alignBy :: ()
46+alignBy :: (Table Expr a, Table Expr b)
4947 => (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''')
53− 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
58− (hasHere', lbindings) = Opaleye.run $ do
59− traversePrimExpr (Opaleye.extractAttr "hasHere" tag'') hasHere
60− (hasThere', rbindings) = Opaleye.run $ do
61− traversePrimExpr (Opaleye.extractAttr "hasThere" tag'') hasThere
62− tag''' = Opaleye.next tag''
63− join = Opaleye.Join Opaleye.FullJoin on left'' right''
64− 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
70− tab = TheseTable {here = ma', there = mb'}
71− join' = Opaleye.aProduct join
72−
73−
74−keepHereTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)
48+ -> Query a -> Query b -> Query (TheseTable a b)
49+alignBy condition as bs =
50+ uncurry TheseTable <$> zipOpaleyeWith fullOuterJoin as bs
51+ where
52+ fullOuterJoin a b =
53+ Opaleye.joinExplicit unpackspec unpackspec pure pure full a b on
54+ where
55+ full = Opaleye.FullJoin
56+ on = toColumn . toPrimExpr . uncurry condition
57+
58+
59+keepHereTable :: TheseTable a b -> Query (a, MaybeTable b)
7560keepHereTable = loseThatTable
7661
7762
78−loseHereTable :: TheseTable Expr a b -> Query b
63+loseHereTable :: TheseTable a b -> Query b
7964loseHereTable = keepThatTable
8065
8166
82−keepThereTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)
67+keepThereTable :: TheseTable a b -> Query (MaybeTable a, b)
8368keepThereTable = loseThisTable
8469
8570
86−loseThereTable :: TheseTable Expr a b -> Query a
71+loseThereTable :: TheseTable a b -> Query a
8772loseThereTable = keepThisTable
8873
8974
90−keepThisTable :: TheseTable Expr a b -> Query a
75+keepThisTable :: TheseTable a b -> Query a
9176keepThisTable t@(TheseTable (MaybeTable _ a) _) = do
9277 where_ $ isThisTable t
93− pure (extract a)
78+ pure a
9479
9580
96−loseThisTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)
81+loseThisTable :: TheseTable a b -> Query (MaybeTable a, b)
9782loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do
9883 where_ $ not_ $ isThisTable t
99− pure (ma, extract b)
84+ pure (ma, b)
10085
10186
102−keepThatTable :: TheseTable Expr a b -> Query b
87+keepThatTable :: TheseTable a b -> Query b
10388keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do
10489 where_ $ isThatTable t
105− pure (extract b)
90+ pure b
10691
10792
108−loseThatTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)
93+loseThatTable :: TheseTable a b -> Query (a, MaybeTable b)
10994loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do
11095 where_ $ not_ $ isThatTable t
111− pure (extract a, mb)
96+ pure (a, mb)
11297
11398
114−keepThoseTable :: TheseTable Expr a b -> Query (a, b)
99+keepThoseTable :: TheseTable a b -> Query (a, b)
115100keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
116101 where_ $ isThoseTable t
117− pure (extract a, extract b)
102+ pure (a, b)
118103
119104
120−loseThoseTable :: TheseTable Expr a b -> Query (EitherTable Expr a b)
105+loseThoseTable :: TheseTable a b -> Query (EitherTable a b)
121106loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
122107 where_ $ not_ $ isThoseTable t
123− pure $ EitherTable tag a b
108+ pure $ EitherTable result a b
124109 where
125110 tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)
111+ result = (mempty `asTypeOf` result) {expr = tag}
112+
113+
114+bindTheseTable :: (Table Expr a, Semigroup a, Monad m)
115+ => (i -> m (TheseTable a b)) -> TheseTable a i -> m (TheseTable a b)
116+bindTheseTable query (TheseTable here (MaybeTable input i)) = do
117+ TheseTable here' (MaybeTable output b) <- query i
118+ pure $ TheseTable (here <> here') (MaybeTable (input <> output) b)
126119
127120
128121bitraverseTheseTable :: ()
129122 => (a -> Query c)
130123 -> (b -> Query d)
131− -> TheseTable Expr a b
132− -> Query (TheseTable Expr c d)
124+ -> TheseTable a b
125+ -> Query (TheseTable c d)
133126bitraverseTheseTable f g t = do
134127 mc <- optional (f . fst =<< keepHereTable t)
135128 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/Column.hsnew file+142
@@ -0,0 +1,142 @@
1+{-# language DataKinds #-}
2+{-# language TypeFamilies #-}
3+{-# language StandaloneKindSignatures #-}
4+
5+module Rel8.Schema.Column
6+ ( Column, Default, Label
7+ , HEither
8+ , HList
9+ , HMaybe
10+ , HNonEmpty
11+ , HThese
12+ )
13+where
14+
15+-- base
16+import Data.Functor.Identity ( Identity )
17+import Data.Kind ( Type )
18+import Data.List.NonEmpty ( NonEmpty )
19+import GHC.TypeLits ( Symbol )
20+import Prelude
21+
22+-- rel8
23+import Rel8.Aggregate ( Aggregate )
24+import Rel8.Expr ( Expr )
25+import Rel8.Kind.Labels ( Labels )
26+import Rel8.Kind.Necessity ( Necessity( Required, Optional ) )
27+import Rel8.Schema.Field ( Field )
28+import Rel8.Schema.Insert ( Insert )
29+import qualified Rel8.Schema.Kind as K
30+import Rel8.Schema.Name ( Name )
31+import Rel8.Schema.Structure
32+ ( Structure
33+ , Shape( Either, List, Maybe, NonEmpty, These )
34+ , Shape1
35+ , Shape2
36+ )
37+import Rel8.Table.Either ( EitherTable )
38+import Rel8.Table.List ( ListTable )
39+import Rel8.Table.Maybe ( MaybeTable )
40+import Rel8.Table.NonEmpty ( NonEmptyTable )
41+import Rel8.Table.These ( TheseTable )
42+
43+-- these
44+import Data.These ( These )
45+
46+
47+type Label :: Symbol -> Type -> Type
48+data Label label a
49+
50+
51+type Default :: Type -> Type
52+data Default a
53+
54+
55+type GetLabel :: Type -> Labels
56+type family GetLabel a where
57+ GetLabel (Label label _) = '[label]
58+ GetLabel _ = '[]
59+
60+
61+type UnwrapLabel :: Type -> Type
62+type family UnwrapLabel a where
63+ UnwrapLabel (Label _ a) = a
64+ UnwrapLabel a = a
65+
66+
67+type GetNecessity :: Type -> Necessity
68+type family GetNecessity a where
69+ GetNecessity (Default _) = 'Optional
70+ GetNecessity _ = 'Required
71+
72+
73+type UnwrapDefault :: Type -> Type
74+type family UnwrapDefault a where
75+ UnwrapDefault (Default a) = a
76+ UnwrapDefault a = a
77+
78+
79+-- | The @Column@ type family should be used to indicate which fields of your
80+-- data types are single columns in queries. This type family has special
81+-- support when a query is executed, allowing you to use a single data type for
82+-- both query data and rows decoded to Haskell.
83+type Column :: K.Context -> Type -> Type
84+type Column context a =
85+ Field context (GetLabel a)
86+ (GetNecessity (UnwrapLabel a))
87+ (UnwrapDefault (UnwrapLabel a))
88+
89+
90+type HEither :: K.Context -> Type -> Type -> Type
91+type family HEither context where
92+ HEither Structure = Shape2 'Either
93+ HEither Aggregate = EitherTable
94+ HEither Expr = EitherTable
95+ HEither Identity = Either
96+ HEither Insert = EitherTable
97+ HEither Name = EitherTable
98+ HEither _ = Either
99+
100+
101+type HList :: K.Context -> Type -> Type
102+type family HList context where
103+ HList Structure = Shape1 'List
104+ HList Aggregate = ListTable
105+ HList Expr = ListTable
106+ HList Identity = []
107+ HList Insert = ListTable
108+ HList Name = ListTable
109+ HList _ = []
110+
111+
112+type HMaybe :: K.Context -> Type -> Type
113+type family HMaybe context where
114+ HMaybe Structure = Shape1 'Maybe
115+ HMaybe Aggregate = MaybeTable
116+ HMaybe Expr = MaybeTable
117+ HMaybe Identity = Maybe
118+ HMaybe Insert = MaybeTable
119+ HMaybe Name = MaybeTable
120+ HMaybe _ = Maybe
121+
122+
123+type HNonEmpty :: K.Context -> Type -> Type
124+type family HNonEmpty context where
125+ HNonEmpty Structure = Shape1 'NonEmpty
126+ HNonEmpty Aggregate = NonEmptyTable
127+ HNonEmpty Expr = NonEmptyTable
128+ HNonEmpty Identity = NonEmpty
129+ HNonEmpty Insert = NonEmptyTable
130+ HNonEmpty Name = NonEmptyTable
131+ HNonEmpty _ = NonEmpty
132+
133+
134+type HThese :: K.Context -> Type -> Type -> Type
135+type family HThese context where
136+ HThese Structure = Shape2 'These
137+ HThese Aggregate = TheseTable
138+ HThese Expr = TheseTable
139+ HThese Identity = These
140+ HThese Insert = TheseTable
141+ HThese Name = TheseTable
142+ HThese _ = These
src/Rel8/Schema/Context.hsnew file+28
@@ -0,0 +1,28 @@
1+{-# language DataKinds #-}
2+{-# language GADTs #-}
3+{-# language StandaloneKindSignatures #-}
4+{-# language TypeFamilies #-}
5+
6+module Rel8.Schema.Context
7+ ( Interpretation(..), Col( Result )
8+ )
9+where
10+
11+-- base
12+import Data.Functor.Identity ( Identity )
13+import Data.Kind ( Constraint )
14+import Prelude ()
15+
16+-- rel8
17+import Rel8.Schema.Kind ( Context, HContext )
18+import Rel8.Schema.Spec ( Spec( Spec ) )
19+
20+
21+type Interpretation :: Context -> Constraint
22+class Interpretation context where
23+ data Col context :: HContext
24+
25+
26+instance Interpretation Identity where
27+ data Col Identity _spec where
28+ Result :: a -> Col Identity ('Spec labels necessity a)
src/Rel8/Schema/Context/Identity.hsnew file+199
@@ -0,0 +1,199 @@
1+{-# language DataKinds #-}
2+{-# language DisambiguateRecordFields #-}
3+{-# language NamedFieldPuns #-}
4+{-# language TypeFamilies #-}
5+
6+module Rel8.Schema.Context.Identity
7+ ( fromHEitherTable, toHEitherTable
8+ , fromHListTable, toHListTable
9+ , fromHMaybeTable, toHMaybeTable
10+ , fromHNonEmptyTable, toHNonEmptyTable
11+ , fromHTheseTable, toHTheseTable
12+ )
13+where
14+
15+-- base
16+import Data.Functor ( ($>) )
17+import Data.Functor.Identity ( Identity )
18+import Data.List.NonEmpty ( NonEmpty )
19+import Prelude hiding ( null )
20+
21+-- rel8
22+import Rel8.Schema.Context ( Col( Result ) )
23+import Rel8.Schema.HTable ( HTable )
24+import Rel8.Schema.HTable.Either ( HEitherTable(..) )
25+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
26+import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
27+import Rel8.Schema.HTable.List ( HListTable )
28+import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
29+import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify )
30+import Rel8.Schema.HTable.These ( HTheseTable(..) )
31+import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )
32+import Rel8.Schema.Nullability
33+ ( Nullify
34+ , Nullability( Nullable, NonNullable )
35+ )
36+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
37+import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )
38+
39+-- these
40+import Data.These ( These( This, That, These ) )
41+import Data.These.Combinators ( justHere, justThere )
42+
43+
44+toHEitherTable :: (HTable t, HTable u)
45+ => Either (t (Col Identity)) (u (Col Identity))
46+ -> HEitherTable t u (Col Identity)
47+toHEitherTable = either hleft hright
48+ where
49+ hleft table = HEitherTable
50+ { htag = HIdentity (Result IsLeft)
51+ , hleft = hnullify nullifier table
52+ , hright = hnulls null
53+ }
54+ hright table = HEitherTable
55+ { htag = HIdentity (Result IsRight)
56+ , hleft = hnulls null
57+ , hright = hnullify nullifier table
58+ }
59+{-# INLINABLE toHEitherTable #-}
60+
61+
62+fromHEitherTable :: (HTable t, HTable u)
63+ => HEitherTable t u (Col Identity)
64+ -> Either (t (Col Identity)) (u (Col Identity))
65+fromHEitherTable HEitherTable {htag, hleft, hright} = case htag of
66+ HIdentity (Result tag) -> case tag of
67+ IsLeft -> maybe err Left $ hunnullify unnullifier hleft
68+ IsRight -> maybe err Right $ hunnullify unnullifier hright
69+ where
70+ err = error "fromHEitherTable: mismatch between tag and data"
71+{-# INLINABLE fromHEitherTable #-}
72+
73+
74+toHListTable :: HTable t => [t (Col Identity)] -> HListTable t (Col Identity)
75+toHListTable = hvectorize vectorizer
76+{-# INLINABLE toHListTable #-}
77+
78+
79+fromHListTable :: HTable t => HListTable t (Col Identity) -> [t (Col Identity)]
80+fromHListTable = hunvectorize unvectorizer
81+{-# INLINABLE fromHListTable #-}
82+
83+
84+toHMaybeTable :: HTable t => Maybe (t (Col Identity)) -> HMaybeTable t (Col Identity)
85+toHMaybeTable = maybe hnothing hjust
86+ where
87+ hnothing = HMaybeTable
88+ { htag = HIdentity (Result Nothing)
89+ , hjust = hnulls null
90+ }
91+ hjust table = HMaybeTable
92+ { htag = HIdentity (Result (Just IsJust))
93+ , hjust = hnullify nullifier table
94+ }
95+{-# INLINABLE toHMaybeTable #-}
96+
97+
98+fromHMaybeTable :: HTable t => HMaybeTable t (Col Identity) -> Maybe (t (Col Identity))
99+fromHMaybeTable HMaybeTable {htag, hjust} = case htag of
100+ HIdentity (Result tag) -> tag $>
101+ case hunnullify unnullifier hjust of
102+ Nothing -> error "fromHMaybeTable: mismatch between tag and data"
103+ Just just -> just
104+{-# INLINABLE fromHMaybeTable #-}
105+
106+
107+toHNonEmptyTable :: HTable t => NonEmpty (t (Col Identity)) -> HNonEmptyTable t (Col Identity)
108+toHNonEmptyTable = hvectorize vectorizer
109+{-# INLINABLE toHNonEmptyTable #-}
110+
111+
112+fromHNonEmptyTable :: HTable t => HNonEmptyTable t (Col Identity) -> NonEmpty (t (Col Identity))
113+fromHNonEmptyTable = hunvectorize unvectorizer
114+{-# INLINABLE fromHNonEmptyTable #-}
115+
116+
117+toHTheseTable :: (HTable t, HTable u)
118+ => These (t (Col Identity)) (u (Col Identity))
119+ -> HTheseTable t u (Col Identity)
120+toHTheseTable tables = HTheseTable
121+ { hhereTag = relabel hhereTag
122+ , hhere
123+ , hthereTag = relabel hthereTag
124+ , hthere
125+ }
126+ where
127+ HMaybeTable
128+ { htag = hhereTag
129+ , hjust = hhere
130+ } = toHMaybeTable (justHere tables)
131+ HMaybeTable
132+ { htag = hthereTag
133+ , hjust = hthere
134+ } = toHMaybeTable (justThere tables)
135+{-# INLINABLE toHTheseTable #-}
136+
137+
138+fromHTheseTable :: (HTable t, HTable u)
139+ => HTheseTable t u (Col Identity)
140+ -> These (t (Col Identity)) (u (Col Identity))
141+fromHTheseTable HTheseTable {hhereTag, hhere, hthereTag, hthere} =
142+ case (fromHMaybeTable mhere, fromHMaybeTable mthere) of
143+ (Just a, Nothing) -> This a
144+ (Nothing, Just b) -> That b
145+ (Just a, Just b) -> These a b
146+ _ -> error "fromHTheseTable: mismatch between tags and data"
147+ where
148+ mhere = HMaybeTable
149+ { htag = relabel hhereTag
150+ , hjust = hhere
151+ }
152+ mthere = HMaybeTable
153+ { htag = relabel hthereTag
154+ , hjust = hthere
155+ }
156+{-# INLINABLE fromHTheseTable #-}
157+
158+
159+null :: Col Identity ('Spec labels necessity (Maybe a))
160+null = Result Nothing
161+
162+
163+nullifier :: ()
164+ => SSpec ('Spec labels necessity a)
165+ -> Col Identity ('Spec labels necessity a)
166+ -> Col Identity ('Spec labels necessity (Nullify a))
167+nullifier SSpec {nullability} (Result a) = Result $ case nullability of
168+ Nullable -> a
169+ NonNullable -> Just a
170+
171+
172+unnullifier :: ()
173+ => SSpec ('Spec labels necessity a)
174+ -> Col Identity ('Spec labels necessity (Nullify a))
175+ -> Maybe (Col Identity ('Spec labels necessity a))
176+unnullifier SSpec {nullability} (Result a) =
177+ case nullability of
178+ Nullable -> pure $ Result a
179+ NonNullable -> Result <$> a
180+
181+
182+vectorizer :: Functor f
183+ => SSpec ('Spec labels necessity a)
184+ -> f (Col Identity ('Spec labels necessity a))
185+ -> Col Identity ('Spec labels necessity (f a))
186+vectorizer _ = Result . fmap (\(Result a) -> a)
187+
188+
189+unvectorizer :: Functor f
190+ => SSpec ('Spec labels necessity a)
191+ -> Col Identity ('Spec labels necessity (f a))
192+ -> f (Col Identity ('Spec labels necessity a))
193+unvectorizer _ (Result results) = Result <$> results
194+
195+
196+relabel :: ()
197+ => HIdentity ('Spec labels necessity a) (Col Identity)
198+ -> HIdentity ('Spec relabels necessity a) (Col Identity)
199+relabel (HIdentity (Result a)) = HIdentity (Result a)
src/Rel8/Schema/Context/Label.hsnew file+60
@@ -0,0 +1,60 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleInstances #-}
3+{-# language StandaloneKindSignatures #-}
4+{-# language TypeFamilies #-}
5+{-# language TypeOperators #-}
6+
7+module Rel8.Schema.Context.Label
8+ ( Labelable( labeler, unlabeler )
9+ , HLabelable( hlabeler, hunlabeler )
10+ )
11+where
12+
13+-- base
14+import Data.Functor.Identity ( Identity )
15+import Data.Kind ( Constraint )
16+import Prelude hiding ( null )
17+
18+-- rel8
19+import Rel8.Schema.Context ( Interpretation, Col(..) )
20+import Rel8.Schema.Dict ( Dict( Dict ) )
21+import Rel8.Schema.Kind ( Context, HContext )
22+import Rel8.Schema.Spec ( Spec( Spec ) )
23+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
24+
25+
26+type Labelable :: Context -> Constraint
27+class Interpretation context => Labelable context where
28+ labeler :: ()
29+ => Col context ('Spec labels necessity a)
30+ -> Col context ('Spec (label ': labels) necessity a)
31+
32+ unlabeler :: ()
33+ => Col context ('Spec (label ': labels) necessity a)
34+ -> Col context ('Spec labels necessity a)
35+
36+
37+instance Labelable Identity where
38+ labeler (Result a) = Result a
39+ unlabeler (Result a) = Result a
40+
41+
42+type HLabelable :: HContext -> Constraint
43+class HLabelable context where
44+ hlabeler :: ()
45+ => context ('Spec labels necessity a)
46+ -> context ('Spec (label ': labels) necessity a)
47+
48+ hunlabeler :: ()
49+ => context ('Spec (label ': labels) necessity a)
50+ -> context ('Spec labels necessity a)
51+
52+
53+instance Labelable context => HLabelable (Col context) where
54+ hlabeler = labeler
55+ hunlabeler = unlabeler
56+
57+
58+instance HLabelable (Dict (ConstrainDBType constraint)) where
59+ hlabeler Dict = Dict
60+ hunlabeler Dict = Dict
src/Rel8/Schema/Context/Nullify.hs+166−105
@@ -1,144 +1,205 @@
11{-# language DataKinds #-}
2−{-# language EmptyCase #-}
32{-# language FlexibleContexts #-}
4−{-# language GADTs #-}
3+{-# language FlexibleInstances #-}
4+{-# language InstanceSigs #-}
55{-# language LambdaCase #-}
6+{-# language MultiParamTypeClasses #-}
67{-# language NamedFieldPuns #-}
8+{-# language ScopedTypeVariables #-}
79{-# language StandaloneKindSignatures #-}
10+{-# language TypeApplications #-}
11+{-# language TypeFamilies #-}
812
913module Rel8.Schema.Context.Nullify
10− ( Nullifiability(..), NonNullifiability(..), nullifiableOrNot, absurd
11− , Nullifiable, nullifiability
12− , guarder, nullifier, unnullifier
13− , sguard, snullify
14+ ( Nullifiable( ConstrainTag, encodeTag, decodeTag, nullifier, unnullifier )
15+ , HNullifiable( HConstrainTag, hencodeTag, hdecodeTag, hnullifier, hunnullifier )
16+ , runTag, unnull
1417 )
1518where
1619
1720-- base
18−import Data.Bool ( bool )
19−import Data.Functor.Identity ( Identity( Identity ) )
2021import Data.Kind ( Constraint, Type )
22+import GHC.TypeLits ( KnownSymbol )
2123import Prelude hiding ( null )
2224
2325-- opaleye
2426import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
2527
2628-- rel8
27−import Rel8.Aggregate ( Aggregate(..), zipOutputs )
28−import Rel8.Expr ( Expr )
29+import Rel8.Aggregate
30+ ( Aggregate, Col(..)
31+ , mapInputs
32+ , unsafeMakeAggregate
33+ )
34+import Rel8.Expr ( Expr, Col(..) )
2935import Rel8.Expr.Bool ( boolExpr )
3036import Rel8.Expr.Null ( nullify, unsafeUnnullify )
31−import Rel8.Expr.Opaleye ( fromPrimExpr )
32−import Rel8.Kind.Context ( SContext(..) )
33−import Rel8.Schema.Field ( Field )
37+import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
38+import Rel8.Kind.Necessity ( Necessity( Required ) )
39+import Rel8.Schema.Context ( Interpretation )
3440import 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
41+import Rel8.Schema.Name ( Name( Name ), Col(..) )
42+import Rel8.Schema.Nullability
43+ ( Nullify
44+ , Nullability( Nullable, NonNullable )
45+ , Sql
46+ )
47+import Rel8.Schema.Dict ( Dict( Dict ) )
48+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
49+import Rel8.Schema.Spec.ConstrainDBType
50+ ( ConstrainDBType
51+ , dbTypeDict, dbTypeNullability, fromNullabilityDict
52+ )
53+import Rel8.Table.Tag ( Tag(..), Taggable, fromAggregate, fromExpr, fromName )
4654
4755
4856type Nullifiable :: K.Context -> Constraint
49−class Nullifiable context where
50− nullifiability :: Nullifiability context
57+class Interpretation context => Nullifiable context where
58+ type ConstrainTag context :: Type -> Constraint
59+ type ConstrainTag _context = DefaultConstrainTag
60+
61+ encodeTag ::
62+ ( Sql (ConstrainTag context) a
63+ , KnownSymbol label
64+ , Taggable a
65+ )
66+ => Tag label a
67+ -> Col context ('Spec labels 'Required a)
68+
69+ decodeTag ::
70+ ( Sql (ConstrainTag context) a
71+ , KnownSymbol label
72+ , Taggable a
73+ )
74+ => Col context ('Spec labels 'Required a)
75+ -> Tag label a
76+
77+ nullifier :: ()
78+ => Tag label a
79+ -> (Expr a -> Expr Bool)
80+ -> SSpec ('Spec labels necessity x)
81+ -> Col context ('Spec labels necessity x)
82+ -> Col context ('Spec labels necessity (Nullify x))
83+
84+ unnullifier :: ()
85+ => SSpec ('Spec labels necessity x)
86+ -> Col context ('Spec labels necessity (Nullify x))
87+ -> Col context ('Spec labels necessity x)
5188
5289
5390instance Nullifiable Aggregate where
54− nullifiability = NAggregate
91+ encodeTag Tag {aggregator, expr} =
92+ Aggregation $ unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr
93+
94+ decodeTag (Aggregation aggregate) = fromAggregate aggregate
95+
96+ nullifier Tag {expr} test SSpec {nullability} (Aggregation aggregate) =
97+ Aggregation $
98+ mapInputs (toPrimExpr . runTag nullability condition . fromPrimExpr) $
99+ runTag nullability condition <$> aggregate
100+ where
101+ condition = test expr
102+
103+ unnullifier SSpec {nullability} (Aggregation aggregate) =
104+ Aggregation $ unnull nullability <$> aggregate
105+
106+ {-# INLINABLE encodeTag #-}
107+ {-# INLINABLE decodeTag #-}
108+ {-# INLINABLE nullifier #-}
109+ {-# INLINABLE unnullifier #-}
55110
56111
57112instance Nullifiable Expr where
58− nullifiability = NExpr
113+ encodeTag Tag {expr} = DB expr
114+ decodeTag (DB a) = fromExpr a
115+ nullifier Tag {expr} test SSpec {nullability} (DB a) =
116+ DB $ runTag nullability (test expr) a
117+ unnullifier SSpec {nullability} (DB a) = DB $ unnull nullability a
118+
119+ {-# INLINABLE encodeTag #-}
120+ {-# INLINABLE decodeTag #-}
121+ {-# INLINABLE nullifier #-}
122+ {-# INLINABLE unnullifier #-}
59123
60124
61125instance 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
126+ encodeTag Tag {name = Name name} = NameCol name
127+ decodeTag (NameCol name) = fromName (Name name)
128+ nullifier _ _ _ (NameCol name) = NameCol name
129+ unnullifier _ (NameCol name) = NameCol name
130+
131+ {-# INLINABLE encodeTag #-}
132+ {-# INLINABLE decodeTag #-}
133+ {-# INLINABLE nullifier #-}
134+ {-# INLINABLE unnullifier #-}
135+
136+
137+runTag :: Nullability a -> Expr Bool -> Expr a -> Expr (Nullify a)
138+runTag nullability tag a = case nullability of
139+ Nullable -> boolExpr null a tag
140+ NonNullable -> boolExpr null (nullify a) tag
131141 where
132142 null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit
133143
134144
135−snullify :: Nullity a -> Expr a -> Expr (Nullify a)
136−snullify nullity a = case nullity of
137− Null -> a
138− NotNull -> nullify a
145+unnull :: Nullability a -> Expr (Nullify a) -> Expr a
146+unnull nullability a = case nullability of
147+ Nullable -> a
148+ NonNullable -> unsafeUnnullify a
149+
150+
151+type HNullifiable :: K.HContext -> Constraint
152+class HNullifiable context where
153+ type HConstrainTag context :: Type -> Constraint
154+ type HConstrainTag _context = DefaultConstrainTag
155+
156+ hencodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)
157+ => Tag label a
158+ -> context ('Spec labels 'Required a)
159+
160+ hdecodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)
161+ => context ('Spec labels 'Required a)
162+ -> Tag label a
163+
164+ hnullifier :: ()
165+ => Tag label a
166+ -> (Expr a -> Expr Bool)
167+ -> SSpec ('Spec labels necessity x)
168+ -> context ('Spec labels necessity x)
169+ -> context ('Spec labels necessity (Nullify x))
170+
171+ hunnullifier :: ()
172+ => SSpec ('Spec labels necessity x)
173+ -> context ('Spec labels necessity (Nullify x))
174+ -> context ('Spec labels necessity x)
175+
176+
177+instance Nullifiable context => HNullifiable (Col context) where
178+ type HConstrainTag (Col context) = ConstrainTag context
179+ hencodeTag = encodeTag
180+ hdecodeTag = decodeTag
181+ hnullifier = nullifier
182+ hunnullifier = unnullifier
183+
184+
185+instance HNullifiable (Dict (ConstrainDBType constraint)) where
186+ type HConstrainTag (Dict (ConstrainDBType constraint)) = constraint
187+
188+ hencodeTag _ = Dict
189+ hdecodeTag = mempty
190+
191+ hnullifier _ _ SSpec {} dict = case dbTypeDict dict of
192+ Dict -> case dbTypeNullability dict of
193+ Nullable -> Dict
194+ NonNullable -> Dict
195+
196+ hunnullifier SSpec {nullability} dict = case dbTypeDict dict of
197+ Dict -> case nullability of
198+ Nullable -> Dict
199+ NonNullable -> case dbTypeNullability dict of
200+ Nullable -> fromNullabilityDict nullability Dict
139201
140202
141−sunnullify :: Nullity a -> Expr (Nullify a) -> Expr a
142−sunnullify nullity a = case nullity of
143− Null -> a
144− NotNull -> unsafeUnnullify a
203+type DefaultConstrainTag :: Type -> Constraint
204+class DefaultConstrainTag a
205+instance DefaultConstrainTag a
src/Rel8/Schema/Field.hs+21−37
@@ -1,50 +1,34 @@
11{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
3−{-# language MultiParamTypeClasses #-}
42{-# language StandaloneKindSignatures #-}
53{-# language TypeFamilies #-}
64
75module Rel8.Schema.Field
8− ( Field(..)
9− , fields
6+ ( Field
107 )
118where
129
1310-- base
14−import Data.Functor.Identity ( Identity( Identity ) )
11+import Data.Functor.Identity ( Identity )
1512import Data.Kind ( Type )
1613import Prelude
1714
1815-- 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
16+import Rel8.Aggregate ( Aggregate )
17+import Rel8.Expr ( Expr )
18+import Rel8.Kind.Labels ( Labels )
19+import Rel8.Kind.Necessity ( Necessity( Required, Optional ) )
20+import Rel8.Schema.Insert ( Insert )
21+import qualified Rel8.Schema.Kind as K
22+import Rel8.Schema.Spec ( Spec( Spec ) )
23+import Rel8.Schema.Structure ( Structure, Shape( Column ), Shape1 )
24+
25+
26+type Field :: K.Context -> Labels -> Necessity -> Type -> Type
27+type family Field labels context necessity a where
28+ Field Identity _labels _necessity a = a
29+ Field Expr _labels _necessity a = Expr a
30+ Field Insert _labels 'Required a = Expr a
31+ Field Insert _labels 'Optional a = Maybe (Expr a)
32+ Field Aggregate _labels _necessity a = Aggregate (Expr a)
33+ Field Structure labels necessity a = Shape1 'Column ('Spec labels necessity a)
34+ Field context _labels _necessity a = context a
src/Rel8/Schema/Generic.hsnew file+1049
@@ -0,0 +1,1049 @@
1+{-# language AllowAmbiguousTypes #-}
2+{-# language DataKinds #-}
3+{-# language DisambiguateRecordFields #-}
4+{-# language DefaultSignatures #-}
5+{-# language FlexibleContexts #-}
6+{-# language FlexibleInstances #-}
7+{-# language GADTs #-}
8+{-# language MultiParamTypeClasses #-}
9+{-# language ScopedTypeVariables #-}
10+{-# language StandaloneKindSignatures #-}
11+{-# language TypeApplications #-}
12+{-# language TypeFamilies #-}
13+{-# language TypeOperators #-}
14+{-# language UndecidableInstances #-}
15+{-# language ViewPatterns #-}
16+
17+{-# options_ghc -fno-warn-orphans #-}
18+
19+module Rel8.Schema.Generic
20+ ( Rel8able
21+ )
22+where
23+
24+-- base
25+import Data.Bifunctor ( bimap )
26+import Data.Functor.Identity ( Identity )
27+import Data.Kind ( Constraint, Type )
28+import Data.List.NonEmpty ( NonEmpty )
29+import GHC.Generics
30+ ( Generic, Rep, from, to
31+ , (:*:)( (:*:) ), K1( K1 ), M1( M1 )
32+ , D, C, S
33+ , Meta( MetaSel )
34+ )
35+import GHC.TypeLits ( Symbol, KnownSymbol )
36+import Prelude
37+
38+-- rel8
39+import Rel8.Aggregate ( Aggregate, Col(..) )
40+import Rel8.Expr ( Expr, Col(..) )
41+import Rel8.Kind.Necessity
42+ ( SNecessity( SRequired, SOptional )
43+ , KnownNecessity, necessitySing
44+ )
45+import Rel8.Schema.Context ( Col(..) )
46+import Rel8.Schema.Context.Identity
47+ ( fromHEitherTable, toHEitherTable
48+ , fromHListTable, toHListTable
49+ , fromHMaybeTable, toHMaybeTable
50+ , fromHNonEmptyTable, toHNonEmptyTable
51+ , fromHTheseTable, toHTheseTable
52+ )
53+import Rel8.Schema.Context.Label
54+ ( Labelable, labeler, unlabeler
55+ , hlabeler, hunlabeler
56+ )
57+import Rel8.Schema.Field ( Field )
58+import Rel8.Schema.HTable ( HTable )
59+import Rel8.Schema.HTable.Either ( HEitherTable )
60+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
61+import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
62+import Rel8.Schema.HTable.List ( HListTable )
63+import Rel8.Schema.HTable.Maybe ( HMaybeTable )
64+import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
65+import Rel8.Schema.HTable.Pair ( HPair(..) )
66+import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
67+import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
68+import Rel8.Schema.HTable.These ( HTheseTable )
69+import Rel8.Schema.HTable.Trio ( HTrio(..) )
70+import Rel8.Schema.HTable.Vectorize ( hrelabel )
71+import Rel8.Schema.Insert ( Insert, Col(..) )
72+import qualified Rel8.Schema.Kind as K
73+import Rel8.Schema.Name ( Name( Name ), Col(..) )
74+import Rel8.Schema.Spec ( Spec( Spec ), KTable )
75+import Rel8.Schema.Structure
76+ ( IsStructure, Shape(..), Shape1, Shape2
77+ , Structure
78+ )
79+import Rel8.Table
80+ ( Table, Columns, Context, fromColumns, toColumns
81+ )
82+import Rel8.Table.Either ( EitherTable )
83+import Rel8.Table.Lifted
84+ ( fromColumns1, toColumns1
85+ , fromColumns2, toColumns2
86+ )
87+import Rel8.Table.List ( ListTable )
88+import Rel8.Table.Maybe ( MaybeTable(..) )
89+import Rel8.Table.NonEmpty ( NonEmptyTable )
90+import Rel8.Table.These ( TheseTable )
91+
92+-- these
93+import Data.These ( These )
94+
95+
96+instance (Rel8able t, TableHelper context) => Table context (t context) where
97+ type Columns (t context) = GRep t
98+ type Context (t context) = context
99+ fromColumns = gfromColumns
100+ toColumns = gtoColumns
101+
102+
103+type TableHelper :: K.Context -> Constraint
104+class TableHelper context where
105+ gfromColumns :: Rel8able t => GRep t (Col context) -> t context
106+ gtoColumns :: Rel8able t => t context -> GRep t (Col context)
107+
108+
109+instance TableHelper Aggregate where
110+ gfromColumns = fromAggregateColumns
111+ gtoColumns = toAggregateColumns
112+
113+
114+instance TableHelper Expr where
115+ gfromColumns = fromExprColumns
116+ gtoColumns = toExprColumns
117+
118+
119+instance TableHelper Insert where
120+ gfromColumns = fromInsertColumns
121+ gtoColumns = toInsertColumns
122+
123+
124+instance TableHelper Identity where
125+ gfromColumns = fromIdentityColumns
126+ gtoColumns = toIdentityColumns
127+
128+
129+instance TableHelper Name where
130+ gfromColumns = fromNameColumns
131+ gtoColumns = toNameColumns
132+
133+
134+-- | This type class allows you to define custom 'Table's using higher-kinded
135+-- data types. Higher-kinded data types are data types of the pattern:
136+--
137+-- @
138+-- data MyType f =
139+-- MyType { field1 :: Column f T1 OR HK1 f
140+-- , field2 :: Column f T2 OR HK2 f
141+-- , ...
142+-- , fieldN :: Column f Tn OR HKn f
143+-- }
144+-- @
145+--
146+-- where @Tn@ is any Haskell type, and @HKn@ is any higher-kinded type.
147+--
148+-- That is, higher-kinded data are records where all fields in the record are
149+-- all either of the type @Column f T@ (for any @T@), or are themselves
150+-- higher-kinded data:
151+--
152+-- [Nested]
153+--
154+-- @
155+-- data Nested f =
156+-- Nested { nested1 :: MyType f
157+-- , nested2 :: MyType f
158+-- }
159+-- @
160+--
161+-- The @Rel8able@ type class is used to give us a special mapping operation
162+-- that lets us change the type parameter @f@.
163+--
164+-- [Supplying @Rel8able@ instances]
165+--
166+-- This type class should be derived generically for all table types in your
167+-- project. To do this, enable the @DeriveAnyType@ and @DeriveGeneric@ language
168+-- extensions:
169+--
170+-- @
171+-- \{\-\# LANGUAGE DeriveAnyClass, DeriveGeneric #-\}
172+--
173+-- data MyType f = MyType { fieldA :: Column f T }
174+-- deriving ( GHC.Generics.Generic, Rel8able )
175+-- @
176+type Rel8able :: KTable -> Constraint
177+class HTable (GRep t) => Rel8able t where
178+ type GRep t :: K.HTable
179+
180+ fromAggregateColumns :: GRep t (Col Aggregate) -> t Aggregate
181+ toAggregateColumns :: t Aggregate -> GRep t (Col Aggregate)
182+
183+ fromExprColumns :: GRep t (Col Expr) -> t Expr
184+ toExprColumns :: t Expr -> GRep t (Col Expr)
185+
186+ fromInsertColumns :: GRep t (Col Insert) -> t Insert
187+ toInsertColumns :: t Insert -> GRep t (Col Insert)
188+
189+ fromIdentityColumns :: GRep t (Col Identity) -> t Identity
190+ toIdentityColumns :: t Identity -> GRep t (Col Identity)
191+
192+ fromNameColumns :: GRep t (Col Name) -> t Name
193+ toNameColumns :: t Name -> GRep t (Col Name)
194+
195+ type GRep t = GColumns (Rep (t Structure))
196+
197+ default fromAggregateColumns ::
198+ ( Generic (t Aggregate)
199+ , GColumns (Rep (t Structure)) ~ GRep t
200+ , GRel8able Aggregate (Rep (t Structure)) (Rep (t Aggregate))
201+ ) => GRep t (Col Aggregate) -> t Aggregate
202+ fromAggregateColumns = to . fromGColumns @_ @(Rep (t Structure))
203+
204+ default toAggregateColumns ::
205+ ( Generic (t Aggregate)
206+ , GColumns (Rep (t Structure)) ~ GRep t
207+ , GRel8able Aggregate (Rep (t Structure)) (Rep (t Aggregate))
208+ ) => t Aggregate -> GRep t (Col Aggregate)
209+ toAggregateColumns = toGColumns @_ @(Rep (t Structure)) . from
210+
211+ default fromExprColumns ::
212+ ( Generic (t Expr)
213+ , GColumns (Rep (t Structure)) ~ GRep t
214+ , GRel8able Expr (Rep (t Structure)) (Rep (t Expr))
215+ ) => GRep t (Col Expr) -> t Expr
216+ fromExprColumns = to . fromGColumns @_ @(Rep (t Structure))
217+
218+ default toExprColumns ::
219+ ( Generic (t Expr)
220+ , GColumns (Rep (t Structure)) ~ GRep t
221+ , GRel8able Expr (Rep (t Structure)) (Rep (t Expr))
222+ ) => t Expr -> GRep t (Col Expr)
223+ toExprColumns = toGColumns @_ @(Rep (t Structure)) . from
224+
225+ default fromInsertColumns ::
226+ ( Generic (t Insert)
227+ , GColumns (Rep (t Structure)) ~ GRep t
228+ , GRel8able Insert (Rep (t Structure)) (Rep (t Insert))
229+ ) => GRep t (Col Insert) -> t Insert
230+ fromInsertColumns = to . fromGColumns @_ @(Rep (t Structure))
231+
232+ default toInsertColumns ::
233+ ( Generic (t Insert)
234+ , GColumns (Rep (t Structure)) ~ GRep t
235+ , GRel8able Insert (Rep (t Structure)) (Rep (t Insert))
236+ ) => t Insert -> GRep t (Col Insert)
237+ toInsertColumns = toGColumns @_ @(Rep (t Structure)) . from
238+
239+ default fromIdentityColumns ::
240+ ( Generic (t Identity)
241+ , GColumns (Rep (t Structure)) ~ GRep t
242+ , GRel8able Identity (Rep (t Structure)) (Rep (t Identity))
243+ ) => GRep t (Col Identity) -> t Identity
244+ fromIdentityColumns = to . fromGColumns @_ @(Rep (t Structure))
245+
246+ default toIdentityColumns ::
247+ ( Generic (t Identity)
248+ , GColumns (Rep (t Structure)) ~ GRep t
249+ , GRel8able Identity (Rep (t Structure)) (Rep (t Identity))
250+ ) => t Identity -> GRep t (Col Identity)
251+ toIdentityColumns = toGColumns @_ @(Rep (t Structure)) . from
252+
253+ default fromNameColumns ::
254+ ( Generic (t Name)
255+ , GColumns (Rep (t Structure)) ~ GRep t
256+ , GRel8able Name (Rep (t Structure)) (Rep (t Name))
257+ ) => GRep t (Col Name) -> t Name
258+ fromNameColumns = to . fromGColumns @_ @(Rep (t Structure))
259+
260+ default toNameColumns ::
261+ ( Generic (t Name)
262+ , GColumns (Rep (t Structure)) ~ GRep t
263+ , GRel8able Name (Rep (t Structure)) (Rep (t Name))
264+ ) => t Name -> GRep t (Col Name)
265+ toNameColumns = toGColumns @_ @(Rep (t Structure)) . from
266+
267+
268+type GColumns :: (Type -> Type) -> K.HTable
269+type family GColumns structure where
270+ GColumns (M1 D _ structure) = GColumns structure
271+ GColumns (M1 C _ structure) = GColumns structure
272+ GColumns (a :*: b) = HPair (GColumns a) (GColumns b)
273+ GColumns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ structure)) =
274+ K1Columns label structure
275+
276+
277+type GRel8able :: K.Context -> (Type -> Type) -> (Type -> Type) -> Constraint
278+class GRel8able context structure rep where
279+ fromGColumns :: GColumns structure (Col context) -> rep x
280+ toGColumns :: rep x -> GColumns structure (Col context)
281+
282+
283+instance GRel8able context structure rep => GRel8able context (M1 D c structure) (M1 D c rep) where
284+ fromGColumns = M1 . fromGColumns @context @structure @rep
285+ toGColumns (M1 a) = toGColumns @context @structure @rep a
286+
287+
288+instance GRel8able context structure rep => GRel8able context (M1 C c structure) (M1 C c rep) where
289+ fromGColumns = M1 . fromGColumns @context @structure @rep
290+ toGColumns (M1 a) = toGColumns @context @structure @rep a
291+
292+
293+instance (GRel8able context structure1 rep1, GRel8able context structure2 rep2) =>
294+ GRel8able context (structure1 :*: structure2) (rep1 :*: rep2)
295+ where
296+ fromGColumns (HPair a b) =
297+ fromGColumns @context @structure1 @rep1 a :*:
298+ fromGColumns @context @structure2 @rep2 b
299+ toGColumns (a :*: b) =
300+ HPair
301+ (toGColumns @context @structure1 @rep1 a)
302+ (toGColumns @context @structure2 @rep2 b)
303+
304+
305+instance
306+ ( K1Table label context isStructure structure a
307+ , meta ~ 'MetaSel ('Just label) _su _ss _ds
308+ , structureK1 ~ K1 i structure
309+ , k1 ~ K1 i a
310+ ) => GRel8able context (M1 S meta structureK1) (M1 S meta k1)
311+ where
312+ fromGColumns = M1 . K1 . fromK1Columns @label @_ @_ @structure
313+ toGColumns (M1 (K1 a)) = toK1Columns @label @_ @_ @structure a
314+
315+
316+type K1Columns :: Symbol -> Type -> K.HTable
317+type family K1Columns label structure where
318+ K1Columns label (Shape1 'Column ('Spec '[] necessity a)) =
319+ HIdentity ('Spec '[label] necessity a)
320+ K1Columns _label (Shape1 'Column ('Spec (label ': labels) necessity a)) =
321+ HIdentity ('Spec (label ': labels) necessity a)
322+ K1Columns label (Shape2 'Either a b) =
323+ HLabel label (HEitherTable (K1Columns "Left" a) (K1Columns "Right" b))
324+ K1Columns label (Shape1 'List a) = HListTable (K1Columns label a)
325+ K1Columns label (Shape1 'Maybe a) = HLabel label (HMaybeTable (K1Columns "Just" a))
326+ K1Columns label (Shape1 'NonEmpty a) = HNonEmptyTable (K1Columns label a)
327+ K1Columns label (Shape2 'These a b) =
328+ HLabel label (HTheseTable (K1Columns "Here" a) (K1Columns "There" b))
329+ K1Columns label (a, b) =
330+ HLabel label
331+ (HPair
332+ (K1Columns "fst" a)
333+ (K1Columns "snd" b))
334+ K1Columns label (a, b, c) =
335+ HLabel label
336+ (HTrio
337+ (K1Columns "fst" a)
338+ (K1Columns "snd" b)
339+ (K1Columns "trd" c))
340+ K1Columns label (a, b, c, d) =
341+ HLabel label
342+ (HQuartet
343+ (K1Columns "fst" a)
344+ (K1Columns "snd" b)
345+ (K1Columns "trd" c)
346+ (K1Columns "frt" d))
347+ K1Columns label (a, b, c, d, e) =
348+ HLabel label
349+ (HQuintet
350+ (K1Columns "fst" a)
351+ (K1Columns "snd" b)
352+ (K1Columns "trd" c)
353+ (K1Columns "frt" d)
354+ (K1Columns "fft" e))
355+ K1Columns label a = HLabel label (Columns a)
356+
357+
358+type K1Table :: Symbol -> K.Context -> Bool -> Type -> Type -> Constraint
359+class isStructure ~ IsStructure structure =>
360+ K1Table label context isStructure structure a
361+ where
362+ fromK1Columns :: K1Columns label structure (Col context) -> a
363+ toK1Columns :: a -> K1Columns label structure (Col context)
364+
365+
366+instance
367+ ( x ~ Field Aggregate '[] necessity a
368+ ) => K1Table label Aggregate 'True (Shape1 'Column ('Spec '[] necessity a)) x
369+ where
370+ fromK1Columns (HIdentity (Aggregation a)) = a
371+ toK1Columns = HIdentity . Aggregation
372+ {-# INLINABLE fromK1Columns #-}
373+ {-# INLINABLE toK1Columns #-}
374+
375+
376+instance
377+ ( x ~ Field Aggregate (label ': labels) necessity a
378+ ) => K1Table _label Aggregate 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x
379+ where
380+ fromK1Columns (HIdentity (Aggregation a)) = a
381+ toK1Columns = HIdentity . Aggregation
382+ {-# INLINABLE fromK1Columns #-}
383+ {-# INLINABLE toK1Columns #-}
384+
385+
386+instance
387+ ( x ~ Field Expr '[] necessity a
388+ ) => K1Table label Expr 'True (Shape1 'Column ('Spec '[] necessity a)) x
389+ where
390+ fromK1Columns (HIdentity (DB a)) = a
391+ toK1Columns = HIdentity . DB
392+ {-# INLINABLE fromK1Columns #-}
393+ {-# INLINABLE toK1Columns #-}
394+
395+
396+instance
397+ ( x ~ Field Expr (label ': labels) necessity a
398+ ) => K1Table _label Expr 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x
399+ where
400+ fromK1Columns (HIdentity (DB a)) = a
401+ toK1Columns = HIdentity . DB
402+ {-# INLINABLE fromK1Columns #-}
403+ {-# INLINABLE toK1Columns #-}
404+
405+
406+instance
407+ ( x ~ Field Insert '[] necessity a
408+ , KnownNecessity necessity
409+ ) => K1Table label Insert 'True (Shape1 'Column ('Spec '[] necessity a)) x
410+ where
411+ fromK1Columns (HIdentity insert) = case insert of
412+ RequiredInsert a -> a
413+ OptionalInsert ma -> ma
414+ toK1Columns a = HIdentity $ case necessitySing @necessity of
415+ SRequired -> RequiredInsert a
416+ SOptional -> OptionalInsert a
417+ {-# INLINABLE fromK1Columns #-}
418+ {-# INLINABLE toK1Columns #-}
419+
420+
421+instance
422+ ( x ~ Field Insert (label ': labels) necessity a
423+ , KnownNecessity necessity
424+ ) => K1Table _label Insert 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x
425+ where
426+ fromK1Columns (HIdentity insert) = case insert of
427+ RequiredInsert a -> a
428+ OptionalInsert ma -> ma
429+ toK1Columns a = HIdentity $ case necessitySing @necessity of
430+ SRequired -> RequiredInsert a
431+ SOptional -> OptionalInsert a
432+ {-# INLINABLE fromK1Columns #-}
433+ {-# INLINABLE toK1Columns #-}
434+
435+
436+instance
437+ ( x ~ Field Identity '[] necessity a
438+ ) => K1Table label Identity 'True (Shape1 'Column ('Spec '[] necessity a)) x
439+ where
440+ fromK1Columns (HIdentity (Result a)) = a
441+ toK1Columns = HIdentity . Result
442+ {-# INLINABLE fromK1Columns #-}
443+ {-# INLINABLE toK1Columns #-}
444+
445+
446+instance
447+ ( x ~ Field Identity (label ': labels) necessity a
448+ ) => K1Table _label Identity 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x
449+ where
450+ fromK1Columns (HIdentity (Result a)) = a
451+ toK1Columns = HIdentity . Result
452+ {-# INLINABLE fromK1Columns #-}
453+ {-# INLINABLE toK1Columns #-}
454+
455+
456+instance
457+ ( x ~ Field Name '[] necessity a
458+ ) => K1Table _label Name 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x
459+ where
460+ fromK1Columns (HIdentity (NameCol a)) = Name a
461+ toK1Columns (Name a) = HIdentity (NameCol a)
462+ {-# INLINABLE fromK1Columns #-}
463+ {-# INLINABLE toK1Columns #-}
464+
465+
466+instance
467+ ( x ~ Field Name (label ': labels) necessity a
468+ ) => K1Table label Name 'True (Shape1 'Column ('Spec '[] necessity a)) x
469+ where
470+ fromK1Columns = Name . (\(NameCol a) -> a) . unlabeler . unHIdentity
471+ toK1Columns = HIdentity . labeler . NameCol . (\(Name a) -> a)
472+ {-# INLINABLE fromK1Columns #-}
473+ {-# INLINABLE toK1Columns #-}
474+
475+
476+instance
477+ ( HTable (K1Columns "Left" structure1)
478+ , HTable (K1Columns "Right" structure2)
479+ , K1Table "Left" Aggregate (IsStructure structure1) structure1 a
480+ , K1Table "Right" Aggregate (IsStructure structure2) structure2 b
481+ , e ~ EitherTable a b
482+ , KnownSymbol label
483+ ) => K1Table label Aggregate 'True (Shape2 'Either structure1 structure2) e
484+ where
485+ fromK1Columns =
486+ fromColumns2
487+ (fromK1Columns @"Left" @_ @_ @structure1)
488+ (fromK1Columns @"Right" @_ @_ @structure2) .
489+ hunlabel unlabeler
490+ toK1Columns =
491+ hlabel labeler .
492+ toColumns2
493+ (toK1Columns @"Left" @_ @_ @structure1)
494+ (toK1Columns @"Right" @_ @_ @structure2)
495+ {-# INLINABLE fromK1Columns #-}
496+ {-# INLINABLE toK1Columns #-}
497+
498+
499+instance
500+ ( HTable (K1Columns "Left" structure1)
501+ , HTable (K1Columns "Right" structure2)
502+ , K1Table "Left" Expr (IsStructure structure1) structure1 a
503+ , K1Table "Right" Expr (IsStructure structure2) structure2 b
504+ , e ~ EitherTable a b
505+ , KnownSymbol label
506+ ) => K1Table label Expr 'True (Shape2 'Either structure1 structure2) e
507+ where
508+ fromK1Columns =
509+ fromColumns2
510+ (fromK1Columns @"Left" @_ @_ @structure1)
511+ (fromK1Columns @"Right" @_ @_ @structure2) .
512+ hunlabel unlabeler
513+ toK1Columns =
514+ hlabel labeler .
515+ toColumns2
516+ (toK1Columns @"Left" @_ @_ @structure1)
517+ (toK1Columns @"Right" @_ @_ @structure2)
518+ {-# INLINABLE fromK1Columns #-}
519+ {-# INLINABLE toK1Columns #-}
520+
521+
522+instance
523+ ( HTable (K1Columns "Left" structure1)
524+ , HTable (K1Columns "Right" structure2)
525+ , K1Table "Left" Insert (IsStructure structure1) structure1 a
526+ , K1Table "Right" Insert (IsStructure structure2) structure2 b
527+ , e ~ EitherTable a b
528+ , KnownSymbol label
529+ ) => K1Table label Insert 'True (Shape2 'Either structure1 structure2) e
530+ where
531+ fromK1Columns =
532+ fromColumns2
533+ (fromK1Columns @"Left" @_ @_ @structure1)
534+ (fromK1Columns @"Right" @_ @_ @structure2) .
535+ hunlabel unlabeler
536+ toK1Columns =
537+ hlabel labeler .
538+ toColumns2
539+ (toK1Columns @"Left" @_ @_ @structure1)
540+ (toK1Columns @"Right" @_ @_ @structure2)
541+ {-# INLINABLE fromK1Columns #-}
542+ {-# INLINABLE toK1Columns #-}
543+
544+
545+instance
546+ ( HTable (K1Columns "Left" structure1)
547+ , HTable (K1Columns "Right" structure2)
548+ , K1Table "Left" Identity (IsStructure structure1) structure1 a
549+ , K1Table "Right" Identity (IsStructure structure2) structure2 b
550+ , e ~ Either a b
551+ , KnownSymbol label
552+ ) => K1Table label Identity 'True (Shape2 'Either structure1 structure2) e
553+ where
554+ fromK1Columns
555+ = bimap
556+ (fromK1Columns @"Left" @_ @_ @structure1)
557+ (fromK1Columns @"Right" @_ @_ @structure2)
558+ . fromHEitherTable
559+ . hunlabel unlabeler
560+ toK1Columns
561+ = hlabel labeler
562+ . toHEitherTable
563+ . bimap
564+ (toK1Columns @"Left" @_ @_ @structure1)
565+ (toK1Columns @"Right" @_ @_ @structure2)
566+ {-# INLINABLE fromK1Columns #-}
567+ {-# INLINABLE toK1Columns #-}
568+
569+
570+instance
571+ ( HTable (K1Columns "Left" structure1)
572+ , HTable (K1Columns "Right" structure2)
573+ , K1Table "Left" Name (IsStructure structure1) structure1 a
574+ , K1Table "Right" Name (IsStructure structure2) structure2 b
575+ , e ~ EitherTable a b
576+ , KnownSymbol label
577+ ) => K1Table label Name 'True (Shape2 'Either structure1 structure2) e
578+ where
579+ fromK1Columns =
580+ fromColumns2
581+ (fromK1Columns @"Left" @_ @_ @structure1)
582+ (fromK1Columns @"Right" @_ @_ @structure2) .
583+ hunlabel unlabeler
584+ toK1Columns =
585+ hlabel labeler .
586+ toColumns2
587+ (toK1Columns @"Left" @_ @_ @structure1)
588+ (toK1Columns @"Right" @_ @_ @structure2)
589+ {-# INLINABLE fromK1Columns #-}
590+ {-# INLINABLE toK1Columns #-}
591+
592+
593+instance
594+ ( Table Aggregate a
595+ , K1Columns label structure ~ HLabel label (Columns a)
596+ , as ~ ListTable a
597+ , KnownSymbol label
598+ ) => K1Table label Aggregate 'True (Shape1 'List structure) as
599+ where
600+ fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
601+ toK1Columns = hrelabel (hlabel hlabeler) . toColumns
602+ {-# INLINABLE fromK1Columns #-}
603+ {-# INLINABLE toK1Columns #-}
604+
605+
606+instance
607+ ( Table Expr a
608+ , K1Columns label structure ~ HLabel label (Columns a)
609+ , as ~ ListTable a
610+ , KnownSymbol label
611+ ) => K1Table label Expr 'True (Shape1 'List structure) as
612+ where
613+ fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
614+ toK1Columns = hrelabel (hlabel hlabeler) . toColumns
615+ {-# INLINABLE fromK1Columns #-}
616+ {-# INLINABLE toK1Columns #-}
617+
618+
619+instance
620+ ( Table Insert a
621+ , K1Columns label structure ~ HLabel label (Columns a)
622+ , as ~ ListTable a
623+ , KnownSymbol label
624+ ) => K1Table label Insert 'True (Shape1 'List structure) as
625+ where
626+ fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
627+ toK1Columns = hrelabel (hlabel hlabeler) . toColumns
628+ {-# INLINABLE fromK1Columns #-}
629+ {-# INLINABLE toK1Columns #-}
630+
631+
632+instance
633+ ( K1Table label Identity (IsStructure structure) structure a
634+ , HTable (K1Columns label structure)
635+ , as ~ [a]
636+ ) => K1Table label Identity 'True (Shape1 'List structure) as
637+ where
638+ fromK1Columns = fmap (fromK1Columns @label @_ @_ @structure) . fromHListTable
639+ toK1Columns = toHListTable . fmap (toK1Columns @label @_ @_ @structure)
640+ {-# INLINABLE fromK1Columns #-}
641+ {-# INLINABLE toK1Columns #-}
642+
643+
644+instance
645+ ( Table Name a
646+ , K1Columns label structure ~ HLabel label (Columns a)
647+ , as ~ ListTable a
648+ , KnownSymbol label
649+ ) => K1Table label Name 'True (Shape1 'List structure) as
650+ where
651+ fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
652+ toK1Columns = hrelabel (hlabel hlabeler) . toColumns
653+ {-# INLINABLE fromK1Columns #-}
654+ {-# INLINABLE toK1Columns #-}
655+
656+
657+instance
658+ ( HTable (K1Columns "Just" structure)
659+ , K1Table "Just" Aggregate (IsStructure structure) structure a
660+ , ma ~ MaybeTable a
661+ , KnownSymbol label
662+ ) => K1Table label Aggregate 'True (Shape1 'Maybe structure) ma
663+ where
664+ fromK1Columns =
665+ fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .
666+ hunlabel unlabeler
667+ toK1Columns =
668+ hlabel labeler .
669+ toColumns1 (toK1Columns @"Just" @_ @_ @structure)
670+ {-# INLINABLE fromK1Columns #-}
671+ {-# INLINABLE toK1Columns #-}
672+
673+
674+instance
675+ ( HTable (K1Columns "Just" structure)
676+ , K1Table "Just" Expr (IsStructure structure) structure a
677+ , ma ~ MaybeTable a
678+ , KnownSymbol label
679+ ) => K1Table label Expr 'True (Shape1 'Maybe structure) ma
680+ where
681+ fromK1Columns =
682+ fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .
683+ hunlabel unlabeler
684+ toK1Columns =
685+ hlabel labeler .
686+ toColumns1 (toK1Columns @"Just" @_ @_ @structure)
687+ {-# INLINABLE fromK1Columns #-}
688+ {-# INLINABLE toK1Columns #-}
689+
690+
691+instance
692+ ( HTable (K1Columns "Just" structure)
693+ , K1Table "Just" Insert (IsStructure structure) structure a
694+ , ma ~ MaybeTable a
695+ , KnownSymbol label
696+ ) => K1Table label Insert 'True (Shape1 'Maybe structure) ma
697+ where
698+ fromK1Columns =
699+ fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .
700+ hunlabel unlabeler
701+ toK1Columns =
702+ hlabel labeler .
703+ toColumns1 (toK1Columns @"Just" @_ @_ @structure)
704+ {-# INLINABLE fromK1Columns #-}
705+ {-# INLINABLE toK1Columns #-}
706+
707+
708+instance
709+ ( HTable (K1Columns "Just" structure)
710+ , K1Table "Just" Identity (IsStructure structure) structure a
711+ , ma ~ Maybe a
712+ , KnownSymbol label
713+ ) => K1Table label Identity 'True (Shape1 'Maybe structure) ma
714+ where
715+ fromK1Columns
716+ = fmap (fromK1Columns @"Just" @_ @_ @structure)
717+ . fromHMaybeTable
718+ . hunlabel unlabeler
719+ toK1Columns
720+ = hlabel labeler
721+ . toHMaybeTable
722+ . fmap (toK1Columns @"Just" @_ @_ @structure)
723+ {-# INLINABLE fromK1Columns #-}
724+ {-# INLINABLE toK1Columns #-}
725+
726+
727+instance
728+ ( HTable (K1Columns "Just" structure)
729+ , K1Table "Just" Name (IsStructure structure) structure a
730+ , ma ~ MaybeTable a
731+ , KnownSymbol label
732+ ) => K1Table label Name 'True (Shape1 'Maybe structure) ma
733+ where
734+ fromK1Columns =
735+ fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .
736+ hunlabel unlabeler
737+ toK1Columns =
738+ hlabel labeler .
739+ toColumns1 (toK1Columns @"Just" @_ @_ @structure)
740+ {-# INLINABLE fromK1Columns #-}
741+ {-# INLINABLE toK1Columns #-}
742+
743+
744+instance
745+ ( Table Aggregate a
746+ , K1Columns label structure ~ HLabel label (Columns a)
747+ , as ~ NonEmptyTable a
748+ , KnownSymbol label
749+ ) => K1Table label Aggregate 'True (Shape1 'NonEmpty structure) as
750+ where
751+ fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
752+ toK1Columns = hrelabel (hlabel hlabeler) . toColumns
753+ {-# INLINABLE fromK1Columns #-}
754+ {-# INLINABLE toK1Columns #-}
755+
756+
757+instance
758+ ( Table Expr a
759+ , K1Columns label structure ~ HLabel label (Columns a)
760+ , as ~ NonEmptyTable a
761+ , KnownSymbol label
762+ ) => K1Table label Expr 'True (Shape1 'NonEmpty structure) as
763+ where
764+ fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
765+ toK1Columns = hrelabel (hlabel hlabeler) . toColumns
766+ {-# INLINABLE fromK1Columns #-}
767+ {-# INLINABLE toK1Columns #-}
768+
769+
770+instance
771+ ( Table Insert a
772+ , K1Columns label structure ~ HLabel label (Columns a)
773+ , as ~ NonEmptyTable a
774+ , KnownSymbol label
775+ ) => K1Table label Insert 'True (Shape1 'NonEmpty structure) as
776+ where
777+ fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
778+ toK1Columns = hrelabel (hlabel hlabeler) . toColumns
779+ {-# INLINABLE fromK1Columns #-}
780+ {-# INLINABLE toK1Columns #-}
781+
782+
783+instance
784+ ( K1Table label Identity (IsStructure structure) structure a
785+ , HTable (K1Columns label structure)
786+ , as ~ NonEmpty a
787+ ) => K1Table label Identity 'True (Shape1 'NonEmpty structure) as
788+ where
789+ fromK1Columns = fmap (fromK1Columns @label @_ @_ @structure) . fromHNonEmptyTable
790+ toK1Columns = toHNonEmptyTable . fmap (toK1Columns @label @_ @_ @structure)
791+ {-# INLINABLE fromK1Columns #-}
792+ {-# INLINABLE toK1Columns #-}
793+
794+
795+instance
796+ ( Table Name a
797+ , K1Columns label structure ~ HLabel label (Columns a)
798+ , as ~ NonEmptyTable a
799+ , KnownSymbol label
800+ ) => K1Table label Name 'True (Shape1 'NonEmpty structure) as
801+ where
802+ fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
803+ toK1Columns = hrelabel (hlabel hlabeler) . toColumns
804+ {-# INLINABLE fromK1Columns #-}
805+ {-# INLINABLE toK1Columns #-}
806+
807+
808+instance
809+ ( HTable (K1Columns "Here" structure1)
810+ , HTable (K1Columns "There" structure2)
811+ , K1Table "Here" Aggregate (IsStructure structure1) structure1 a
812+ , K1Table "There" Aggregate (IsStructure structure2) structure2 b
813+ , e ~ TheseTable a b
814+ , KnownSymbol label
815+ ) => K1Table label Aggregate 'True (Shape2 'These structure1 structure2) e
816+ where
817+ fromK1Columns =
818+ fromColumns2
819+ (fromK1Columns @"Here" @_ @_ @structure1)
820+ (fromK1Columns @"There" @_ @_ @structure2) .
821+ hunlabel unlabeler
822+ toK1Columns =
823+ hlabel labeler .
824+ toColumns2
825+ (toK1Columns @"Here" @_ @_ @structure1)
826+ (toK1Columns @"There" @_ @_ @structure2)
827+ {-# INLINABLE fromK1Columns #-}
828+ {-# INLINABLE toK1Columns #-}
829+
830+
831+instance
832+ ( HTable (K1Columns "Here" structure1)
833+ , HTable (K1Columns "There" structure2)
834+ , K1Table "Here" Expr (IsStructure structure1) structure1 a
835+ , K1Table "There" Expr (IsStructure structure2) structure2 b
836+ , e ~ TheseTable a b
837+ , KnownSymbol label
838+ ) => K1Table label Expr 'True (Shape2 'These structure1 structure2) e
839+ where
840+ fromK1Columns =
841+ fromColumns2
842+ (fromK1Columns @"Here" @_ @_ @structure1)
843+ (fromK1Columns @"There" @_ @_ @structure2) .
844+ hunlabel unlabeler
845+ toK1Columns =
846+ hlabel labeler .
847+ toColumns2
848+ (toK1Columns @"Here" @_ @_ @structure1)
849+ (toK1Columns @"There" @_ @_ @structure2)
850+ {-# INLINABLE fromK1Columns #-}
851+ {-# INLINABLE toK1Columns #-}
852+
853+
854+instance
855+ ( HTable (K1Columns "Here" structure1)
856+ , HTable (K1Columns "There" structure2)
857+ , K1Table "Here" Insert (IsStructure structure1) structure1 a
858+ , K1Table "There" Insert (IsStructure structure2) structure2 b
859+ , e ~ TheseTable a b
860+ , KnownSymbol label
861+ ) => K1Table label Insert 'True (Shape2 'These structure1 structure2) e
862+ where
863+ fromK1Columns =
864+ fromColumns2
865+ (fromK1Columns @"Here" @_ @_ @structure1)
866+ (fromK1Columns @"There" @_ @_ @structure2) .
867+ hunlabel unlabeler
868+ toK1Columns =
869+ hlabel labeler .
870+ toColumns2
871+ (toK1Columns @"Here" @_ @_ @structure1)
872+ (toK1Columns @"There" @_ @_ @structure2)
873+ {-# INLINABLE fromK1Columns #-}
874+ {-# INLINABLE toK1Columns #-}
875+
876+
877+instance
878+ ( HTable (K1Columns "Here" structure1)
879+ , HTable (K1Columns "There" structure2)
880+ , K1Table "Here" Identity (IsStructure structure1) structure1 a
881+ , K1Table "There" Identity (IsStructure structure2) structure2 b
882+ , e ~ These a b
883+ , KnownSymbol label
884+ ) => K1Table label Identity 'True (Shape2 'These structure1 structure2) e
885+ where
886+ fromK1Columns
887+ = bimap
888+ (fromK1Columns @"Here" @_ @_ @structure1)
889+ (fromK1Columns @"There" @_ @_ @structure2)
890+ . fromHTheseTable
891+ . hunlabel unlabeler
892+ toK1Columns
893+ = hlabel labeler
894+ . toHTheseTable
895+ . bimap
896+ (toK1Columns @"Here" @_ @_ @structure1)
897+ (toK1Columns @"There" @_ @_ @structure2)
898+ {-# INLINABLE fromK1Columns #-}
899+ {-# INLINABLE toK1Columns #-}
900+
901+
902+instance
903+ ( HTable (K1Columns "Here" structure1)
904+ , HTable (K1Columns "There" structure2)
905+ , K1Table "Here" Name (IsStructure structure1) structure1 a
906+ , K1Table "There" Name (IsStructure structure2) structure2 b
907+ , e ~ TheseTable a b
908+ , KnownSymbol label
909+ ) => K1Table label Name 'True (Shape2 'These structure1 structure2) e
910+ where
911+ fromK1Columns =
912+ fromColumns2
913+ (fromK1Columns @"Here" @_ @_ @structure1)
914+ (fromK1Columns @"There" @_ @_ @structure2) .
915+ hunlabel unlabeler
916+ toK1Columns =
917+ hlabel labeler .
918+ toColumns2
919+ (toK1Columns @"Here" @_ @_ @structure1)
920+ (toK1Columns @"There" @_ @_ @structure2)
921+ {-# INLINABLE fromK1Columns #-}
922+ {-# INLINABLE toK1Columns #-}
923+
924+
925+instance
926+ ( K1Table "fst" context (IsStructure structure1) structure1 a1
927+ , K1Table "snd" context (IsStructure structure2) structure2 a2
928+ , HTable (K1Columns "fst" structure1)
929+ , HTable (K1Columns "snd" structure2)
930+ , Labelable context
931+ , a ~ (a1, a2)
932+ , KnownSymbol label
933+ ) => K1Table label context 'True (structure1, structure2) a
934+ where
935+ fromK1Columns (hunlabel unlabeler -> (HPair a b)) =
936+ ( fromK1Columns @"fst" @_ @_ @structure1 a
937+ , fromK1Columns @"snd" @_ @_ @structure2 b
938+ )
939+ toK1Columns (a, b) = hlabel labeler $ HPair
940+ { hfst = toK1Columns @"fst" @_ @_ @structure1 a
941+ , hsnd = toK1Columns @"snd" @_ @_ @structure2 b
942+ }
943+ {-# INLINABLE fromK1Columns #-}
944+ {-# INLINABLE toK1Columns #-}
945+
946+
947+instance
948+ ( K1Table "fst" context (IsStructure structure1) structure1 a1
949+ , K1Table "snd" context (IsStructure structure2) structure2 a2
950+ , K1Table "trd" context (IsStructure structure3) structure3 a3
951+ , HTable (K1Columns "fst" structure1)
952+ , HTable (K1Columns "snd" structure2)
953+ , HTable (K1Columns "trd" structure3)
954+ , Labelable context
955+ , a ~ (a1, a2, a3)
956+ , KnownSymbol label
957+ ) => K1Table label context 'True (structure1, structure2, structure3) a
958+ where
959+ fromK1Columns (hunlabel unlabeler -> (HTrio a b c)) =
960+ ( fromK1Columns @"fst" @_ @_ @structure1 a
961+ , fromK1Columns @"snd" @_ @_ @structure2 b
962+ , fromK1Columns @"trd" @_ @_ @structure3 c
963+ )
964+ toK1Columns (a, b, c) = hlabel labeler $ HTrio
965+ { hfst = toK1Columns @"fst" @_ @_ @structure1 a
966+ , hsnd = toK1Columns @"snd" @_ @_ @structure2 b
967+ , htrd = toK1Columns @"trd" @_ @_ @structure3 c
968+ }
969+ {-# INLINABLE fromK1Columns #-}
970+ {-# INLINABLE toK1Columns #-}
971+
972+
973+instance
974+ ( K1Table "fst" context (IsStructure structure1) structure1 a1
975+ , K1Table "snd" context (IsStructure structure2) structure2 a2
976+ , K1Table "trd" context (IsStructure structure3) structure3 a3
977+ , K1Table "frt" context (IsStructure structure3) structure4 a4
978+ , HTable (K1Columns "fst" structure1)
979+ , HTable (K1Columns "snd" structure2)
980+ , HTable (K1Columns "trd" structure3)
981+ , HTable (K1Columns "frt" structure4)
982+ , Labelable context
983+ , a ~ (a1, a2, a3, a4)
984+ , KnownSymbol label
985+ ) => K1Table label context 'True (structure1, structure2, structure3, structure4) a
986+ where
987+ fromK1Columns (hunlabel unlabeler -> (HQuartet a b c d)) =
988+ ( fromK1Columns @"fst" @_ @_ @structure1 a
989+ , fromK1Columns @"snd" @_ @_ @structure2 b
990+ , fromK1Columns @"trd" @_ @_ @structure3 c
991+ , fromK1Columns @"frt" @_ @_ @structure4 d
992+ )
993+ toK1Columns (a, b, c, d) = hlabel labeler $ HQuartet
994+ { hfst = toK1Columns @"fst" @_ @_ @structure1 a
995+ , hsnd = toK1Columns @"snd" @_ @_ @structure2 b
996+ , htrd = toK1Columns @"trd" @_ @_ @structure3 c
997+ , hfrt = toK1Columns @"frt" @_ @_ @structure4 d
998+ }
999+ {-# INLINABLE fromK1Columns #-}
1000+ {-# INLINABLE toK1Columns #-}
1001+
1002+
1003+instance
1004+ ( K1Table "fst" context (IsStructure structure1) structure1 a1
1005+ , K1Table "snd" context (IsStructure structure2) structure2 a2
1006+ , K1Table "trd" context (IsStructure structure3) structure3 a3
1007+ , K1Table "frt" context (IsStructure structure3) structure4 a4
1008+ , K1Table "fft" context (IsStructure structure3) structure5 a5
1009+ , HTable (K1Columns "fst" structure1)
1010+ , HTable (K1Columns "snd" structure2)
1011+ , HTable (K1Columns "trd" structure3)
1012+ , HTable (K1Columns "frt" structure4)
1013+ , HTable (K1Columns "fft" structure5)
1014+ , Labelable context
1015+ , a ~ (a1, a2, a3, a4, a5)
1016+ , KnownSymbol label
1017+ ) => K1Table label context 'True (structure1, structure2, structure3, structure4, structure5) a
1018+ where
1019+ fromK1Columns (hunlabel unlabeler -> (HQuintet a b c d e)) =
1020+ ( fromK1Columns @"fst" @_ @_ @structure1 a
1021+ , fromK1Columns @"snd" @_ @_ @structure2 b
1022+ , fromK1Columns @"trd" @_ @_ @structure3 c
1023+ , fromK1Columns @"frt" @_ @_ @structure4 d
1024+ , fromK1Columns @"fft" @_ @_ @structure5 e
1025+ )
1026+ toK1Columns (a, b, c, d, e) = hlabel labeler $ HQuintet
1027+ { hfst = toK1Columns @"fst" @_ @_ @structure1 a
1028+ , hsnd = toK1Columns @"snd" @_ @_ @structure2 b
1029+ , htrd = toK1Columns @"trd" @_ @_ @structure3 c
1030+ , hfrt = toK1Columns @"frt" @_ @_ @structure4 d
1031+ , hfft = toK1Columns @"fft" @_ @_ @structure5 e
1032+ }
1033+ {-# INLINABLE fromK1Columns #-}
1034+ {-# INLINABLE toK1Columns #-}
1035+
1036+
1037+instance
1038+ ( IsStructure structure ~ 'False
1039+ , K1Columns label structure ~ HLabel label (Columns structure)
1040+ , Columns structure ~ Columns a
1041+ , Labelable context
1042+ , Table context a
1043+ , KnownSymbol label
1044+ ) => K1Table label context 'False structure a
1045+ where
1046+ fromK1Columns = fromColumns . hunlabel unlabeler
1047+ toK1Columns = hlabel labeler . toColumns
1048+ {-# INLINABLE fromK1Columns #-}
1049+ {-# INLINABLE toK1Columns #-}
src/Rel8/Schema/Generic/Test.hsnew file+79
@@ -0,0 +1,79 @@
1+{-# language DataKinds #-}
2+{-# language DeriveAnyClass #-}
3+{-# language DeriveGeneric #-}
4+{-# language DerivingStrategies #-}
5+{-# language DuplicateRecordFields #-}
6+
7+{-# options_ghc -O0 #-}
8+
9+module Rel8.Schema.Generic.Test
10+ ( module Rel8.Schema.Generic.Test
11+ )
12+where
13+
14+-- base
15+import GHC.Generics ( Generic )
16+import Prelude
17+
18+-- rel8
19+import Rel8.Schema.Column
20+import Rel8.Schema.Generic
21+
22+-- text
23+import Data.Text ( Text )
24+
25+
26+data Table f = Table
27+ { foo :: Column f (Label "blah" Bool)
28+ , bar :: Column f (Maybe Bool)
29+ }
30+ deriving stock Generic
31+ deriving anyclass Rel8able
32+
33+
34+data TablePair f = TablePair
35+ { foo :: Column f (Default Bool)
36+ , bars :: (Column f Text, Column f Text)
37+ }
38+ deriving stock Generic
39+ deriving anyclass Rel8able
40+
41+
42+data TableMaybe f = TableMaybe
43+ { foo :: Column f (Label "ABC" [Maybe Bool])
44+ , bars :: HMaybe f (TablePair f, TablePair f)
45+ }
46+ deriving stock Generic
47+ deriving anyclass Rel8able
48+
49+
50+data TableEither f = TableEither
51+ { foo :: Column f Bool
52+ , bars :: HEither f (HMaybe f (TablePair f, TablePair f)) (Column f (Label "XYZ" Char))
53+ }
54+ deriving stock Generic
55+ deriving anyclass Rel8able
56+
57+
58+data TableThese f = TableThese
59+ { foo :: Column f Bool
60+ , bars :: HThese f (TableMaybe f) (TableEither f)
61+ }
62+ deriving stock Generic
63+ deriving anyclass Rel8able
64+
65+
66+data TableList f = TableList
67+ { foo :: Column f Bool
68+ , bars :: HList f (TableThese f)
69+ }
70+ deriving stock Generic
71+ deriving anyclass Rel8able
72+
73+
74+data TableNonEmpty f = TableNonEmpty
75+ { foo :: Column f Bool
76+ , bars :: HNonEmpty f (TableList f)
77+ }
78+ deriving stock Generic
79+ deriving anyclass Rel8able
src/Rel8/Schema/HTable.hs+36−68
@@ -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+ , 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 )
45−import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
37+import Rel8.Schema.Spec ( Spec, SSpec )
38+import Rel8.Schema.HTable.Pair ( HPair( HPair ) )
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,17 @@ 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−
128−hmap :: HTable t
129− => (forall a. context a -> context' a) -> t context -> t context'
130−hmap f a = htabulate $ \field -> f (hfield a field)
131−
132−
133117htabulateA :: (HTable t, Apply m)
134− => (forall a. HField t a -> m (context a)) -> m (t context)
118+ => (forall spec. HField t spec -> m (context spec)) -> m (t context)
135119htabulateA f = htraverse getCompose $ htabulate $ Compose . f
136120{-# INLINABLE htabulateA #-}
137121
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)
154122
155−type GHField :: K.HTable -> Type -> Type
156−newtype GHField t a = GHField (HField (GHColumns (Rep (t Proxy))) a)
123+type GHField :: K.HTable -> Spec -> Type
124+newtype GHField t spec = GHField (HField (GHColumns (Rep (t Proxy))) spec)
157125
158126
159−type GHTable :: K.Context -> (Type -> Type) -> Constraint
127+type GHTable :: K.HContext -> (Type -> Type) -> Constraint
160128class HTable (GHColumns rep) => GHTable context rep | rep -> context where
161129 type GHColumns rep :: K.HTable
162130 toGHColumns :: rep x -> GHColumns rep context
@@ -176,30 +144,30 @@ instance HTable table => GHTable context (K1 i (table context)) where
176144
177145
178146instance (GHTable context a, GHTable context b) => GHTable context (a :*: b) where
179− type GHColumns (a :*: b) = HProduct (GHColumns a) (GHColumns b)
180− toGHColumns (a :*: b) = HProduct (toGHColumns a) (toGHColumns b)
181− fromGHColumns (HProduct a b) = fromGHColumns a :*: fromGHColumns b
147+ type GHColumns (a :*: b) = HPair (GHColumns a) (GHColumns b)
148+ toGHColumns (a :*: b) = HPair (toGHColumns a) (toGHColumns b)
149+ fromGHColumns (HPair a b) = fromGHColumns a :*: fromGHColumns b
182150
183151
184−-- | 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)
152+-- | A HField type for indexing into HPair.
153+type HPairField :: K.HTable -> K.HTable -> Spec -> Type
154+data HPairField x y spec
155+ = HFst (HField x spec)
156+ | HSnd (HField y spec)
189157
190158
191−instance (HTable x, HTable y) => HTable (HProduct x y) where
192− type HConstrainTable (HProduct x y) c = (HConstrainTable x c, HConstrainTable y c)
193− type HField (HProduct x y) = HProductField x y
159+instance (HTable x, HTable y) => HTable (HPair x y) where
160+ type HConstrainTable (HPair x y) c = (HConstrainTable x c, HConstrainTable y c)
161+ type HField (HPair x y) = HPairField x y
194162
195− hfield (HProduct l r) = \case
163+ hfield (HPair l r) = \case
196164 HFst i -> hfield l i
197165 HSnd i -> hfield r i
198166
199− htabulate f = HProduct (htabulate (f . HFst)) (htabulate (f . HSnd))
200− htraverse f (HProduct x y) = HProduct <$> htraverse f x <.> htraverse f y
201− hdicts = HProduct hdicts hdicts
202− hspecs = HProduct hspecs hspecs
167+ htabulate f = HPair (htabulate (f . HFst)) (htabulate (f . HSnd))
168+ htraverse f (HPair x y) = HPair <$> htraverse f x <.> htraverse f y
169+ hdicts = HPair hdicts hdicts
170+ hspecs = HPair hspecs hspecs
203171
204172 {-# INLINABLE hfield #-}
205173 {-# INLINABLE htabulate #-}
src/Rel8/Schema/HTable/Either.hs+17−5
@@ -2,31 +2,43 @@
22{-# language DeriveAnyClass #-}
33{-# language DeriveGeneric #-}
44{-# language DerivingStrategies #-}
5+{-# language FlexibleInstances #-}
56{-# language StandaloneKindSignatures #-}
7+{-# language UndecidableInstances #-}
8+{-# language UndecidableSuperClasses #-}
69
710module Rel8.Schema.HTable.Either
811 ( HEitherTable(..)
12+ , HEitherNullifiable
913 )
1014where
1115
1216-- base
17+import Data.Kind ( Constraint )
1318import GHC.Generics ( Generic )
1419import Prelude ()
1520
1621-- rel8
22+import Rel8.Kind.Necessity ( Necessity( Required ) )
23+import Rel8.Schema.Context.Nullify ( HNullifiable, HConstrainTag )
1724import Rel8.Schema.HTable ( HTable )
18−import Rel8.Schema.HTable.Identity ( HIdentity )
19−import Rel8.Schema.HTable.Label ( HLabel )
25+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
2026import Rel8.Schema.HTable.Nullify ( HNullify )
2127import qualified Rel8.Schema.Kind as K
28+import Rel8.Schema.Spec ( Spec( Spec ) )
2229import Rel8.Type.Tag ( EitherTag )
2330
2431
2532type HEitherTable :: K.HTable -> K.HTable -> K.HTable
2633data HEitherTable left right context = HEitherTable
27− { htag :: HLabel "isRight" (HIdentity EitherTag) context
28− , hleft :: HLabel "Left" (HNullify left) context
29− , hright :: HLabel "Right" (HNullify right) context
34+ { htag :: HIdentity ('Spec '["isRight"] 'Required EitherTag) context
35+ , hleft :: HNullify left context
36+ , hright :: HNullify right context
3037 }
3138 deriving stock Generic
3239 deriving anyclass HTable
40+
41+
42+type HEitherNullifiable :: K.HContext -> Constraint
43+class (HNullifiable context, HConstrainTag context EitherTag) => HEitherNullifiable context
44+instance (HNullifiable context, HConstrainTag context EitherTag) => HEitherNullifiable context
src/Rel8/Schema/HTable/Identity.hs+17−16
@@ -1,17 +1,15 @@
11{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
2+{-# language GADTs #-}
33{-# language StandaloneKindSignatures #-}
44{-# language TypeFamilies #-}
5−{-# language UndecidableInstances #-}
65
76module Rel8.Schema.HTable.Identity
8− ( HIdentity( HIdentity, unHIdentity )
7+ ( HIdentity(..)
98 )
109where
1110
1211-- base
1312import Data.Kind ( Type )
14−import Data.Type.Equality ( (:~:)( Refl ) )
1513import Prelude
1614
1715-- rel8
@@ -21,23 +19,26 @@ import Rel8.Schema.HTable
2119 , hfield, htabulate, htraverse, hdicts, hspecs
2220 )
2321import qualified Rel8.Schema.Kind as K
24−import Rel8.Schema.Null ( Sql )
25−import Rel8.Schema.Spec ( specification )
26−import Rel8.Type ( DBType )
22+import Rel8.Schema.Spec ( Spec, KnownSpec, specSing )
2723
2824
29−type HIdentity :: Type -> K.HTable
30−newtype HIdentity a context = HIdentity
31− { unHIdentity :: context a
25+type HIdentity :: Spec -> K.HTable
26+newtype HIdentity spec context = HIdentity
27+ { unHIdentity :: context spec
3228 }
3329
3430
35−instance Sql DBType a => HTable (HIdentity a) where
36− type HConstrainTable (HIdentity a) constraint = constraint a
37− type HField (HIdentity a) = (:~:) a
31+type HIdentityField :: Spec -> Spec -> Type
32+data HIdentityField _spec spec where
33+ HIdentityField :: HIdentityField spec spec
3834
39− hfield (HIdentity a) Refl = a
40− htabulate f = HIdentity $ f Refl
35+
36+instance KnownSpec spec => HTable (HIdentity spec) where
37+ type HConstrainTable (HIdentity spec) c = c spec
38+ type HField (HIdentity spec) = HIdentityField spec
39+
40+ hfield (HIdentity a) HIdentityField = a
41+ htabulate f = HIdentity $ f HIdentityField
4142 htraverse f (HIdentity a) = HIdentity <$> f a
4243 hdicts = HIdentity Dict
43− hspecs = HIdentity specification
44+ hspecs = HIdentity specSing
src/Rel8/Schema/HTable/Label.hs+51−36
@@ -1,70 +1,85 @@
1+{-# LANGUAGE DeriveAnyClass #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DerivingStrategies #-}
4+{-# LANGUAGE LambdaCase #-}
5+{-# language ConstraintKinds #-}
16{-# language DataKinds #-}
7+{-# language FlexibleInstances #-}
8+{-# language GADTs #-}
9+{-# language InstanceSigs #-}
10+{-# language MultiParamTypeClasses #-}
11+{-# language QuantifiedConstraints #-}
212{-# language RankNTypes #-}
313{-# language RecordWildCards #-}
414{-# language ScopedTypeVariables #-}
515{-# language StandaloneKindSignatures #-}
616{-# language TypeApplications #-}
717{-# language TypeFamilies #-}
18+{-# language TypeOperators #-}
19+{-# language UndecidableInstances #-}
820
921module Rel8.Schema.HTable.Label
10− ( HLabel, hlabel, hrelabel, hunlabel
11− , hproject
22+ ( HLabel, Label
23+ , hlabel, hunlabel
1224 )
1325where
1426
1527-- base
16−import Data.Kind ( Type )
1728import Data.Proxy ( Proxy( Proxy ) )
18−import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
29+import GHC.TypeLits ( KnownSymbol, Symbol )
1930import Prelude
2031
2132-- rel8
33+import Rel8.Kind.Labels ( SLabels( SLabels ) )
2234import Rel8.Schema.HTable
23− ( HTable, HConstrainTable, HField
24− , htabulate, hfield, htraverse, hdicts, hspecs
35+ ( HTable
36+ , hfield, htabulate, hspecs
2537 )
2638import qualified Rel8.Schema.Kind as K
27−import Rel8.Schema.Spec ( Spec(..) )
39+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
40+import Rel8.FCF
41+import Rel8.Schema.HTable.MapTable
42+import GHC.Generics (Generic)
2843
2944
3045type HLabel :: Symbol -> K.HTable -> K.HTable
31−newtype HLabel label table context = HLabel (table context)
46+newtype HLabel label table context = HLabel (HMapTable (Label label) table context)
47+ deriving stock Generic
48+ deriving anyclass HTable
3249
3350
34−type HLabelField :: Symbol -> K.HTable -> Type -> Type
35−newtype HLabelField label table a = HLabelField (HField table a)
51+data Label :: Symbol -> Spec -> Exp Spec
3652
3753
38−instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where
39− type HField (HLabel label table) = HLabelField label table
40− type HConstrainTable (HLabel label table) constraint =
41− HConstrainTable table constraint
54+type instance Eval (Label label ('Spec labels necessity a)) = 'Spec (label : labels) necessity a
4255
43− hfield (HLabel a) (HLabelField field) = hfield a field
44− htabulate f = HLabel (htabulate (f . HLabelField))
45− htraverse f (HLabel a) = HLabel <$> htraverse f a
46− hdicts = HLabel (hdicts @table)
47− hspecs = HLabel $ htabulate $ \field -> case hfield (hspecs @table) field of
48− Spec {..} -> Spec {labels = symbolVal (Proxy @label) : labels, ..}
49− {-# INLINABLE hspecs #-}
5056
51−
52−hlabel :: forall label t context. t context -> HLabel label t context
53−hlabel = HLabel
54−{-# INLINABLE hlabel #-}
57+instance KnownSymbol l => MapSpec (Label l) where
58+ mapInfo = \case
59+ SSpec {..} -> SSpec {labels = SLabels Proxy labels, ..}
5560
5661
57−hrelabel :: forall label' label t context. HLabel label t context -> HLabel label' t context
58−hrelabel = hlabel . hunlabel
59−{-# INLINABLE hrelabel #-}
62+hlabel :: (HTable t, KnownSymbol label)
63+ => (forall labels necessity a. ()
64+ => context ('Spec labels necessity a)
65+ -> context ('Spec (label ': labels) necessity a))
66+ -> t context
67+ -> HLabel label t context
68+hlabel labeler a = HLabel $ htabulate $ \(HMapTableField field) ->
69+ case hfield hspecs field of
70+ SSpec {} -> labeler (hfield a field)
71+{-# INLINABLE hlabel #-}
6072
6173
62−hunlabel :: forall label t context. HLabel label t context -> t context
63−hunlabel (HLabel a) = a
74+hunlabel :: (HTable t, KnownSymbol label)
75+ => (forall labels necessity a. ()
76+ => context ('Spec (label ': labels) necessity a)
77+ -> context ('Spec labels necessity a))
78+ -> HLabel label t context
79+ -> t context
80+hunlabel unlabler (HLabel as) =
81+ htabulate $ \field ->
82+ case hfield hspecs field of
83+ SSpec {} -> case hfield as (HMapTableField field) of
84+ a -> unlabler a
6485{-# 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+14−28
@@ -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,32 @@ 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)
44− }
37+type HMapTable :: (a -> Exp b) -> ((a -> Type) -> Type) -> (b -> Type) -> Type
38+data HMapTable f t g where
39+ HMapTable :: { unHMapTable :: t (Precompose f g) } -> HMapTable f t g
4540
4641
47−type Precompose :: (Type -> Exp Type) -> K.Context -> K.Context
48−newtype Precompose f g x = Precompose
49− { precomposed :: g (Eval (f x))
50− }
42+type Precompose :: (a -> Exp b) -> (b -> Type) -> a -> Type
43+newtype Precompose f g x where
44+ Precompose :: { precomposed :: g (Eval (f x)) } -> Precompose f g x
5145
5246
53−type HMapTableField :: (Type -> Exp Type) -> K.HTable -> K.Context
47+type HMapTableField :: (Spec -> Exp a) -> K.HTable -> a -> Type
5448data HMapTableField f t x where
5549 HMapTableField :: HField t a -> HMapTableField f t (Eval (f a))
5650
@@ -70,7 +64,6 @@ instance (HTable t, MapSpec f) => HTable (HMapTable f t) where
7064
7165 htraverse f (HMapTable x) =
7266 HMapTable <$> htraverse (fmap Precompose . f . precomposed) x
73− {-# INLINABLE htraverse #-}
7467
7568 hdicts :: forall c. HConstrainTable (HMapTable f t) c => HMapTable f t (Dict c)
7669 hdicts =
@@ -80,20 +73,13 @@ instance (HTable t, MapSpec f) => HTable (HMapTable f t) where
8073
8174 hspecs =
8275 HMapTable $ htabulate $ Precompose . mapInfo @f . hfield hspecs
83− {-# INLINABLE hspecs #-}
8476
8577
86−type MapSpec :: (Type -> Exp Type) -> Constraint
78+type MapSpec :: (Spec -> Exp Spec) -> Constraint
8779class MapSpec f where
88− mapInfo :: Spec x -> Spec (Eval (f x))
80+ mapInfo :: SSpec x -> SSpec (Eval (f x))
8981
9082
91−type ComposeConstraint :: (Type -> Exp Type) -> (Type -> Constraint) -> Type -> Constraint
83+type ComposeConstraint :: (a -> Exp b) -> (b -> Constraint) -> a -> Constraint
9284class c (Eval (f a)) => ComposeConstraint f c a
9385instance 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+17−5
@@ -2,30 +2,42 @@
22{-# language DeriveAnyClass #-}
33{-# language DeriveGeneric #-}
44{-# language DerivingStrategies #-}
5+{-# language FlexibleInstances #-}
56{-# language StandaloneKindSignatures #-}
7+{-# language UndecidableInstances #-}
8+{-# language UndecidableSuperClasses #-}
69
710module Rel8.Schema.HTable.Maybe
811 ( HMaybeTable(..)
12+ , HMaybeNullifiable
913 )
1014where
1115
1216-- base
17+import Data.Kind ( Constraint )
1318import GHC.Generics ( Generic )
1419import Prelude
1520
1621-- rel8
22+import Rel8.Kind.Necessity ( Necessity( Required ) )
23+import Rel8.Schema.Context.Nullify ( HConstrainTag, HNullifiable )
1724import Rel8.Schema.HTable ( HTable )
18−import Rel8.Schema.HTable.Identity ( HIdentity )
19−import Rel8.Schema.HTable.Label ( HLabel )
20−import Rel8.Schema.HTable.Nullify ( HNullify )
25+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
2126import qualified Rel8.Schema.Kind as K
27+import Rel8.Schema.Spec ( Spec( Spec ) )
2228import Rel8.Type.Tag ( MaybeTag )
29+import Rel8.Schema.HTable.Nullify ( HNullify )
2330
2431
2532type HMaybeTable :: K.HTable -> K.HTable
2633data HMaybeTable table context = HMaybeTable
27− { htag :: HLabel "isJust" (HIdentity (Maybe MaybeTag)) context
28− , hjust :: HLabel "Just" (HNullify table) context
34+ { htag :: HIdentity ('Spec '["isJust"] 'Required (Maybe MaybeTag)) context
35+ , hjust :: HNullify table context
2936 }
3037 deriving stock Generic
3138 deriving anyclass HTable
39+
40+
41+type HMaybeNullifiable :: K.HContext -> Constraint
42+class (HNullifiable context, HConstrainTag context MaybeTag) => HMaybeNullifiable context
43+instance (HNullifiable context, HConstrainTag context MaybeTag) => HMaybeNullifiable context
src/Rel8/Schema/HTable/Nullify.hs+46−55
@@ -1,52 +1,48 @@
1+{-# LANGUAGE DeriveAnyClass #-}
2+{-# LANGUAGE DerivingStrategies #-}
3+{-# LANGUAGE DeriveGeneric #-}
4+{-# LANGUAGE NamedFieldPuns #-}
5+{-# LANGUAGE LambdaCase #-}
16{-# language ConstraintKinds #-}
27{-# language DataKinds #-}
3−{-# language DeriveAnyClass #-}
4−{-# language DerivingStrategies #-}
5−{-# language DeriveGeneric #-}
68{-# language FlexibleInstances #-}
79{-# language GADTs #-}
8−{-# language LambdaCase #-}
10+{-# language InstanceSigs #-}
911{-# language MultiParamTypeClasses #-}
10−{-# language NamedFieldPuns #-}
1112{-# language QuantifiedConstraints #-}
1213{-# language RankNTypes #-}
1314{-# language RecordWildCards #-}
1415{-# language ScopedTypeVariables #-}
1516{-# language StandaloneKindSignatures #-}
17+{-# language TypeApplications #-}
1618{-# language TypeFamilies #-}
1719{-# language UndecidableInstances #-}
1820
1921module Rel8.Schema.HTable.Nullify
2022 ( HNullify( HNullify )
2123 , Nullify
22− , hguard
23− , hnulls
24− , hnullify
25− , hunnullify
26− , hproject
24+ , hnulls, hnullify, hunnullify
2725 )
2826where
2927
3028-- base
31−import Data.Kind ( Type )
32−import GHC.Generics ( Generic )
3329import Prelude hiding ( null )
3430
3531-- rel8
36−import Rel8.FCF ( Eval, Exp )
37−import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )
38−import Rel8.Schema.HTable.MapTable
39− ( HMapTable, HMapTableField( HMapTableField )
40− , MapSpec, mapInfo
32+import Rel8.Schema.HTable
33+ ( HTable
34+ , hfield, htabulate, htabulateA, hspecs
4135 )
42−import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )
4336import qualified Rel8.Schema.Kind as K
44−import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
45−import qualified Rel8.Schema.Null as Type ( Nullify )
46−import Rel8.Schema.Spec ( Spec(..) )
37+import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
38+import qualified Rel8.Schema.Nullability as Type ( Nullify )
39+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
4740
4841-- semigroupoids
4942import Data.Functor.Apply ( Apply )
43+import Rel8.Schema.HTable.MapTable
44+import Rel8.FCF
45+import GHC.Generics (Generic)
5046
5147
5248type HNullify :: K.HTable -> K.HTable
@@ -55,63 +51,58 @@ newtype HNullify table context = HNullify (HMapTable Nullify table context)
5551 deriving anyclass HTable
5652
5753
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
54+
55+-- | Transform a 'Spec' by allowing it to be @null@.
56+data Nullify :: Spec -> Exp Spec
57+
58+
59+type instance Eval (Nullify ('Spec labels necessity a)) =
60+ 'Spec labels necessity (Type.Nullify a)
6161
6262
6363instance MapSpec Nullify where
6464 mapInfo = \case
65− Spec {nullity, ..} -> Spec
66− { nullity = case nullity of
67− Null -> Null
68− NotNull -> Null
69− , ..
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+ SSpec{labels, necessity, info, nullability} -> SSpec
66+ { labels
67+ , necessity
68+ , info
69+ , nullability = case nullability of
70+ Nullable -> Nullable
71+ NonNullable -> Nullable
72+ }
8273
8374
8475hnulls :: HTable t
85− => (forall a. Spec a -> context (Type.Nullify a))
76+ => (forall labels necessity a. ()
77+ => context ('Spec labels necessity (Maybe a)))
8678 -> HNullify t context
87−hnulls null = HNullify $ htabulate $ \(HMapTableField field) ->
88− case hfield hspecs field of
89− spec@Spec {} -> null spec
79+hnulls null = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
80+ SSpec {} -> null
9081{-# INLINABLE hnulls #-}
9182
9283
9384hnullify :: HTable t
94− => (forall a. Spec a -> context a -> context (Type.Nullify a))
85+ => (forall labels necessity a. ()
86+ => SSpec ('Spec labels necessity a)
87+ -> context ('Spec labels necessity a)
88+ -> context ('Spec labels necessity (Type.Nullify a)))
9589 -> t context
9690 -> HNullify t context
9791hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->
9892 case hfield hspecs field of
99− spec@Spec {} -> nullifier spec (hfield a field)
93+ spec@SSpec {} -> nullifier spec (hfield a field)
10094{-# INLINABLE hnullify #-}
10195
10296
10397hunnullify :: (HTable t, Apply m)
104− => (forall a. Spec a -> context (Type.Nullify a) -> m (context a))
98+ => (forall labels necessity a. ()
99+ => SSpec ('Spec labels necessity a)
100+ -> context ('Spec labels necessity (Type.Nullify a))
101+ -> m (context ('Spec labels necessity a)))
105102 -> HNullify t context
106103 -> m (t context)
107104hunnullify unnullifier (HNullify as) =
108105 htabulateA $ \field -> case hfield hspecs field of
109− spec@Spec {} -> case hfield as (HMapTableField field) of
106+ spec@SSpec {} -> case hfield as (HMapTableField field) of
110107 a -> unnullifier spec a
111108{-# 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/Pair.hsnew file+20
@@ -0,0 +1,20 @@
1+{-# language DataKinds #-}
2+{-# language StandaloneKindSignatures #-}
3+
4+module Rel8.Schema.HTable.Pair
5+ ( HPair(..)
6+ )
7+where
8+
9+-- base
10+import Prelude ()
11+
12+-- rel8
13+import qualified Rel8.Schema.Kind as K
14+
15+
16+type HPair :: K.HTable -> K.HTable -> K.HTable
17+data HPair fst snd context = HPair
18+ { hfst :: fst context
19+ , hsnd :: snd context
20+ }
src/Rel8/Schema/HTable/Product.hsdeleted−17
@@ -1,17 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language StandaloneKindSignatures #-}
3−
4−module Rel8.Schema.HTable.Product
5− ( HProduct(..)
6− )
7−where
8−
9−-- base
10−import Prelude ()
11−
12−-- rel8
13−import qualified Rel8.Schema.Kind as K
14−
15−
16−type HProduct :: K.HTable -> K.HTable -> K.HTable
17−data HProduct a b context = HProduct (a context) (b context)
src/Rel8/Schema/HTable/Quartet.hsnew file+29
@@ -0,0 +1,29 @@
1+{-# language DataKinds #-}
2+{-# language DeriveAnyClass #-}
3+{-# language DeriveGeneric #-}
4+{-# language DerivingStrategies #-}
5+{-# language StandaloneKindSignatures #-}
6+
7+module Rel8.Schema.HTable.Quartet
8+ ( HQuartet(..)
9+ )
10+where
11+
12+-- base
13+import GHC.Generics ( Generic )
14+import Prelude ()
15+
16+-- rel8
17+import Rel8.Schema.HTable ( HTable )
18+import qualified Rel8.Schema.Kind as K
19+
20+
21+type HQuartet :: K.HTable -> K.HTable -> K.HTable -> K.HTable -> K.HTable
22+data HQuartet w x y z context = HQuartet
23+ { hfst :: w context
24+ , hsnd :: x context
25+ , htrd :: y context
26+ , hfrt :: z context
27+ }
28+ deriving stock Generic
29+ deriving anyclass HTable
src/Rel8/Schema/HTable/Quintet.hsnew file+30
@@ -0,0 +1,30 @@
1+{-# language DataKinds #-}
2+{-# language DeriveAnyClass #-}
3+{-# language DeriveGeneric #-}
4+{-# language DerivingStrategies #-}
5+{-# language StandaloneKindSignatures #-}
6+
7+module Rel8.Schema.HTable.Quintet
8+ ( HQuintet(..)
9+ )
10+where
11+
12+-- base
13+import GHC.Generics ( Generic )
14+import Prelude ()
15+
16+-- rel8
17+import Rel8.Schema.HTable ( HTable )
18+import qualified Rel8.Schema.Kind as K
19+
20+
21+type HQuintet :: K.HTable -> K.HTable -> K.HTable -> K.HTable -> K.HTable -> K.HTable
22+data HQuintet v w x y z context = HQuintet
23+ { hfst :: v context
24+ , hsnd :: w context
25+ , htrd :: x context
26+ , hfrt :: y context
27+ , hfft :: z context
28+ }
29+ deriving stock Generic
30+ deriving anyclass HTable
src/Rel8/Schema/HTable/These.hs+6−5
@@ -14,20 +14,21 @@ import GHC.Generics ( Generic )
1414import Prelude
1515
1616-- rel8
17+import Rel8.Kind.Necessity ( Necessity( Required ) )
1718import Rel8.Schema.HTable ( HTable )
1819import Rel8.Schema.HTable.Identity ( HIdentity )
19−import Rel8.Schema.HTable.Label ( HLabel )
2020import Rel8.Schema.HTable.Nullify ( HNullify )
2121import qualified Rel8.Schema.Kind as K
22+import Rel8.Schema.Spec ( Spec( Spec ) )
2223import Rel8.Type.Tag ( MaybeTag )
2324
2425
2526type HTheseTable :: K.HTable -> K.HTable -> K.HTable
2627data HTheseTable here there context = HTheseTable
27− { hhereTag :: HLabel "hereTag" (HIdentity (Maybe MaybeTag)) context
28− , hhere :: HLabel "Here" (HNullify here) context
29− , hthereTag :: HLabel "thereTag" (HIdentity (Maybe MaybeTag)) context
30− , hthere :: HLabel "There" (HNullify there) context
28+ { hhereTag :: HIdentity ('Spec '["hasHere"] 'Required (Maybe MaybeTag)) context
29+ , hhere :: HNullify here context
30+ , hthereTag :: HIdentity ('Spec '["hasThere"] 'Required (Maybe MaybeTag)) context
31+ , hthere :: HNullify there context
3132 }
3233 deriving stock Generic
3334 deriving anyclass HTable
src/Rel8/Schema/HTable/Trio.hsnew file+28
@@ -0,0 +1,28 @@
1+{-# language DataKinds #-}
2+{-# language DeriveAnyClass #-}
3+{-# language DeriveGeneric #-}
4+{-# language DerivingStrategies #-}
5+{-# language StandaloneKindSignatures #-}
6+
7+module Rel8.Schema.HTable.Trio
8+ ( HTrio(..)
9+ )
10+where
11+
12+-- base
13+import GHC.Generics ( Generic )
14+import Prelude ()
15+
16+-- rel8
17+import Rel8.Schema.HTable ( HTable )
18+import qualified Rel8.Schema.Kind as K
19+
20+
21+type HTrio :: K.HTable -> K.HTable -> K.HTable -> K.HTable
22+data HTrio x y z context = HTrio
23+ { hfst :: x context
24+ , hsnd :: y context
25+ , htrd :: z context
26+ }
27+ deriving stock Generic
28+ deriving anyclass HTable
src/Rel8/Schema/HTable/Type.hsnew file+61
@@ -0,0 +1,61 @@
1+{-# language DataKinds #-}
2+{-# language GADTs #-}
3+{-# language StandaloneKindSignatures #-}
4+{-# language TypeFamilies #-}
5+{-# language UndecidableInstances #-}
6+
7+module Rel8.Schema.HTable.Type
8+ ( HType(..)
9+ )
10+where
11+
12+-- base
13+import Data.Kind ( Type )
14+import Data.Proxy ( Proxy( Proxy ) )
15+import Prelude
16+
17+-- rel8
18+import Rel8.Kind.Labels ( SLabels( SLabel ) )
19+import Rel8.Kind.Necessity ( Necessity( Required ), SNecessity( SRequired ) )
20+import Rel8.Schema.Dict ( Dict( Dict ) )
21+import Rel8.Schema.HTable
22+ ( HTable, HConstrainTable, HField
23+ , hfield, htabulate, htraverse, hdicts, hspecs
24+ )
25+import qualified Rel8.Schema.Kind as K
26+import Rel8.Schema.Nullability ( Sql, nullabilization )
27+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
28+import Rel8.Type ( DBType, typeInformation )
29+
30+
31+type HType :: Type -> K.HTable
32+newtype HType a context = HType
33+ { unHType :: context ('Spec '[""] 'Required a)
34+ }
35+
36+
37+type HTypeField :: Type -> Spec -> Type
38+data HTypeField a spec where
39+ HTypeField :: HTypeField a ('Spec '[""] 'Required a)
40+
41+
42+instance Sql DBType a => HTable (HType a) where
43+ type HConstrainTable (HType a) c = c ('Spec '[""] 'Required a)
44+ type HField (HType a) = HTypeField a
45+
46+ hfield (HType a) HTypeField = a
47+ htabulate f = HType $ f HTypeField
48+ htraverse f (HType a) = HType <$> f a
49+ hdicts = HType Dict
50+ hspecs = HType SSpec
51+ { labels = SLabel Proxy
52+ , necessity = SRequired
53+ , info = typeInformation
54+ , nullability = nullabilization
55+ }
56+
57+ {-# INLINABLE hfield #-}
58+ {-# INLINABLE htabulate #-}
59+ {-# INLINABLE htraverse #-}
60+ {-# INLINABLE hdicts #-}
61+ {-# INLINABLE hspecs #-}
src/Rel8/Schema/HTable/Vectorize.hs+67−45
@@ -1,63 +1,67 @@
1+{-# LANGUAGE DeriveAnyClass #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DerivingStrategies #-}
4+{-# LANGUAGE LambdaCase #-}
15{-# language AllowAmbiguousTypes #-}
26{-# language ConstraintKinds #-}
37{-# language DataKinds #-}
4−{-# language DeriveAnyClass #-}
5−{-# language DeriveGeneric #-}
6−{-# language DerivingStrategies #-}
78{-# language FlexibleContexts #-}
89{-# language FlexibleInstances #-}
910{-# language GADTs #-}
10−{-# language LambdaCase #-}
11+{-# language InstanceSigs #-}
1112{-# language MultiParamTypeClasses #-}
13+{-# language NamedFieldPuns #-}
14+{-# language QuantifiedConstraints #-}
1215{-# language RankNTypes #-}
1316{-# language RecordWildCards #-}
1417{-# language ScopedTypeVariables #-}
1518{-# language StandaloneKindSignatures #-}
1619{-# language TypeApplications #-}
1720{-# language TypeFamilies #-}
21+{-# language TypeOperators #-}
1822{-# language UndecidableInstances #-}
1923
2024module Rel8.Schema.HTable.Vectorize
2125 ( HVectorize
2226 , hvectorize, hunvectorize
2327 , happend, hempty
24− , hproject
25− , hcolumn
28+ , hrelabel
2629 )
2730where
2831
2932-- base
30−import Data.Kind ( Constraint, Type )
33+import Data.Kind ( Type )
3134import Data.List.NonEmpty ( NonEmpty )
32−import GHC.Generics (Generic)
3335import Prelude
3436
3537-- rel8
36−import Rel8.FCF ( Eval, Exp )
38+import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )
3739import Rel8.Schema.Dict ( Dict( Dict ) )
3840import 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 )
41+import Rel8.Schema.HTable
42+ ( HTable
43+ , hfield, htabulate, htabulateA, hspecs
44+ )
45+import Rel8.Schema.Nullability
46+ ( Unnullify
47+ , NotNull
48+ , Nullability( NonNullable )
4549 )
46−import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )
47−import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )
48−import Rel8.Schema.Spec ( Spec(..) )
50+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
4951import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
5052import Rel8.Type.Information ( TypeInformation )
5153
5254-- semialign
53−import Data.Zip ( Unzip, Zip, Zippy(..) )
55+import Data.Zip ( Unzip, Repeat, Zippy(..) )
56+import Rel8.FCF
57+import Rel8.Schema.HTable.MapTable
58+import GHC.Generics (Generic)
5459
5560
56−type Vector :: (Type -> Type) -> Constraint
5761class Vector list where
5862 listNotNull :: proxy a -> Dict NotNull (list a)
5963 vectorTypeInformation :: ()
60− => Nullity a
64+ => Nullability a
6165 -> TypeInformation (Unnullify a)
6266 -> TypeInformation (list a)
6367
@@ -78,66 +82,84 @@ newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) t
7882 deriving anyclass HTable
7983
8084
81−data Vectorize :: (Type -> Type) -> Type -> Exp Type
85+data Vectorize :: (Type -> Type) -> Spec -> Exp Spec
8286
8387
84−type instance Eval (Vectorize list a) = list a
88+type instance Eval (Vectorize list ('Spec labels necessity a)) = 'Spec labels necessity (list a)
8589
8690
8791instance Vector list => MapSpec (Vectorize list) where
8892 mapInfo = \case
89− Spec {..} -> case listNotNull @list nullity of
90− Dict -> Spec
91− { nullity = NotNull
92− , info = vectorTypeInformation nullity info
93+ SSpec {..} -> case listNotNull @list nullability of
94+ Dict -> SSpec
95+ { nullability = NonNullable
96+ , info = vectorTypeInformation nullability info
9397 , ..
9498 }
9599
96100
97101hvectorize :: (HTable t, Unzip f, Vector list)
98− => (forall a. Spec a -> f (context a) -> context' (list a))
102+ => (forall labels necessity a. ()
103+ => SSpec ('Spec labels necessity a)
104+ -> f (context ('Spec labels necessity a))
105+ -> context' ('Spec labels necessity (list a)))
99106 -> f (t context)
100107 -> HVectorize list t context'
101108hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->
102109 case hfield hspecs field of
103− spec -> vectorizer spec (fmap (`hfield` field) as)
110+ spec@SSpec {} -> vectorizer spec (fmap (`hfield` field) as)
104111{-# INLINABLE hvectorize #-}
105112
106113
107−hunvectorize :: (HTable t, Zip f, Vector list)
108− => (forall a. Spec a -> context (list a) -> f (context' a))
114+hunvectorize :: (HTable t, Repeat f, Vector list)
115+ => (forall labels necessity a. ()
116+ => SSpec ('Spec labels necessity a)
117+ -> context ('Spec labels necessity (list a))
118+ -> f (context' ('Spec labels necessity a)))
109119 -> HVectorize list t context
110120 -> f (t context')
111121hunvectorize unvectorizer (HVectorize table) =
112122 getZippy $ htabulateA $ \field -> case hfield hspecs field of
113− spec -> case hfield table (HMapTableField field) of
123+ spec@SSpec{} -> case hfield table (HMapTableField field) of
114124 a -> Zippy (unvectorizer spec a)
115125{-# INLINABLE hunvectorize #-}
116126
117127
118−happend :: (HTable t, Vector list)
119− => (forall a. Spec a -> context (list a) -> context (list a) -> context (list a))
128+happend :: (HTable t, Vector list) =>
129+ ( forall labels necessity a. ()
130+ => Nullability a
131+ -> TypeInformation (Unnullify a)
132+ -> context ('Spec labels necessity (list a))
133+ -> context ('Spec labels necessity (list a))
134+ -> context ('Spec labels necessity (list a))
135+ )
120136 -> HVectorize list t context
121137 -> HVectorize list t context
122138 -> HVectorize list t context
123139happend append (HVectorize as) (HVectorize bs) = HVectorize $
124140 htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of
125141 (a, b) -> case hfield hspecs j of
126− spec -> append spec a b
142+ SSpec {nullability, info} -> append nullability info a b
127143
128144
129−hempty :: HTable t
130− => (forall a. Spec a -> context [a])
145+hempty :: HTable t =>
146+ ( forall labels necessity a. ()
147+ => Nullability a
148+ -> TypeInformation (Unnullify a)
149+ -> context ('Spec labels necessity [a])
150+ )
131151 -> HVectorize [] t context
132−hempty empty = HVectorize $ htabulate $ \(HMapTableField field) ->
133− empty (hfield hspecs field)
152+hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
153+ SSpec {nullability, info} -> empty nullability info
134154
135155
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)
156+instance HLabelable g => HLabelable (Precompose (Vectorize list) g) where
157+ hlabeler = Precompose . hlabeler . precomposed
158+ hunlabeler = Precompose . hunlabeler . precomposed
140159
141160
142−hcolumn :: HVectorize list (HIdentity a) context -> context (list a)
143−hcolumn (HVectorize (HMapTable (HIdentity (Precompose a)))) = a
161+hrelabel :: HLabelable context
162+ => (forall ctx. HLabelable ctx => t ctx -> u ctx)
163+ -> HVectorize list t context
164+ -> HVectorize list u context
165+hrelabel f (HVectorize (HMapTable table)) = HVectorize (HMapTable (f table))
src/Rel8/Schema/Insert.hsnew file+164
@@ -0,0 +1,164 @@
1+{-# language DataKinds #-}
2+{-# language DuplicateRecordFields #-}
3+{-# language FlexibleContexts #-}
4+{-# language FlexibleInstances #-}
5+{-# language GADTs #-}
6+{-# language LambdaCase #-}
7+{-# language MultiParamTypeClasses #-}
8+{-# language NamedFieldPuns #-}
9+{-# language ScopedTypeVariables #-}
10+{-# language StandaloneKindSignatures #-}
11+{-# language TypeApplications #-}
12+{-# language TypeFamilies #-}
13+{-# language UndecidableInstances #-}
14+{-# language UndecidableSuperClasses #-}
15+
16+module Rel8.Schema.Insert
17+ ( Insert(..)
18+ , OnConflict(..)
19+ , Col( RequiredInsert, OptionalInsert )
20+ , Insertion(..)
21+ , Inserts
22+ )
23+where
24+
25+-- base
26+import Data.Functor.Identity ( Identity )
27+import Data.Kind ( Constraint, Type )
28+import Prelude
29+
30+-- rel8
31+import Rel8.Aggregate ( Aggregate )
32+import Rel8.Expr ( Expr )
33+import Rel8.Kind.Necessity ( Necessity(Optional, Required) )
34+import Rel8.Opaque ( Opaque )
35+import Rel8.Schema.Context ( Interpretation(..) )
36+import Rel8.Schema.Context.Label ( Labelable(..) )
37+import Rel8.Schema.Context.Nullify
38+ ( Nullifiable, encodeTag, decodeTag, nullifier, unnullifier
39+ , runTag, unnull
40+ )
41+import Rel8.Schema.HTable.Type ( HType(HType) )
42+import qualified Rel8.Schema.Kind as K
43+import Rel8.Schema.Name ( Name, Selects )
44+import Rel8.Schema.Nullability ( Sql )
45+import Rel8.Schema.Spec ( SSpec(SSpec, nullability), Spec(Spec) )
46+import Rel8.Schema.Table ( TableSchema )
47+import Rel8.Statement.Returning ( Returning )
48+import Rel8.Table ( Table(..) )
49+import Rel8.Table.Recontextualize ( Recontextualize )
50+import Rel8.Table.Tag ( Tag(..), fromExpr )
51+import Rel8.Type ( DBType )
52+
53+
54+-- | @OnConflict@ allows you to add an @ON CONFLICT@ clause to an @INSERT@
55+-- statement.
56+data OnConflict
57+ = Abort -- ^ @ON CONFLICT ABORT@
58+ | DoNothing -- ^ @ON CONFLICT DO NOTHING@
59+
60+
61+-- | The constituent parts of a SQL @INSERT@ statement.
62+type Insert :: K.Context
63+data Insert a where
64+ Insert :: (Selects names exprs, Inserts exprs inserts) =>
65+ { into :: TableSchema names
66+ -- ^ Which table to insert into.
67+ , rows :: [inserts]
68+ -- ^ The rows to insert.
69+ , onConflict :: OnConflict
70+ -- ^ What to do if the inserted rows conflict with data already in the
71+ -- table.
72+ , returning :: Returning names a
73+ -- ^ What information to return on completion.
74+ }
75+ -> Insert a
76+
77+
78+instance Interpretation Insert where
79+ data Col Insert _spec where
80+ RequiredInsert :: Expr a -> Col Insert ('Spec labels 'Required a)
81+ OptionalInsert :: Maybe (Expr a) -> Col Insert ('Spec labels 'Optional a)
82+
83+
84+type Insertion :: K.Context
85+newtype Insertion a = Insertion (Expr a)
86+
87+
88+instance Sql DBType a => Table Insert (Insertion a) where
89+ type Columns (Insertion a) = HType a
90+ type Context (Insertion a) = Insert
91+
92+ toColumns (Insertion a) = HType (RequiredInsert a)
93+ fromColumns (HType (RequiredInsert a)) = Insertion a
94+
95+
96+instance Sql DBType a =>
97+ Recontextualize Aggregate Insert (Aggregate (Expr a)) (Insertion a)
98+
99+
100+instance Sql DBType a => Recontextualize Expr Insert (Expr a) (Insertion a)
101+
102+
103+instance Sql DBType a =>
104+ Recontextualize Identity Insert (Identity a) (Insertion a)
105+
106+
107+instance Sql DBType a =>
108+ Recontextualize Insert Aggregate (Insertion a) (Aggregate (Expr a))
109+
110+
111+instance Sql DBType a => Recontextualize Insert Expr (Insertion a) (Expr a)
112+
113+
114+instance Sql DBType a =>
115+ Recontextualize Insert Identity (Insertion a) (Identity a)
116+
117+
118+instance Sql DBType a => Recontextualize Insert Insert (Insertion a) (Insertion a)
119+
120+
121+instance Sql DBType a => Recontextualize Insert Name (Insertion a) (Name a)
122+
123+
124+instance Sql DBType a => Recontextualize Name Insert (Name a) (Insertion a)
125+
126+
127+instance Labelable Insert where
128+ labeler = \case
129+ RequiredInsert a -> RequiredInsert a
130+ OptionalInsert ma -> OptionalInsert ma
131+
132+ unlabeler = \case
133+ RequiredInsert a -> RequiredInsert a
134+ OptionalInsert ma -> OptionalInsert ma
135+
136+
137+instance Nullifiable Insert where
138+ encodeTag = RequiredInsert . expr
139+ decodeTag (RequiredInsert a) = fromExpr a
140+
141+ nullifier Tag {expr} test SSpec {nullability} = \case
142+ RequiredInsert a ->
143+ RequiredInsert $ runTag nullability condition a
144+ OptionalInsert ma ->
145+ OptionalInsert $ runTag nullability condition <$> ma
146+ where
147+ condition = test expr
148+
149+ unnullifier SSpec {nullability} = \case
150+ RequiredInsert a -> RequiredInsert $ unnull nullability a
151+ OptionalInsert ma -> OptionalInsert $ unnull nullability <$> ma
152+
153+ {-# INLINABLE encodeTag #-}
154+ {-# INLINABLE decodeTag #-}
155+ {-# INLINABLE nullifier #-}
156+ {-# INLINABLE unnullifier #-}
157+
158+
159+-- | @Inserts a b@ means that the columns in @a@ are compatible for inserting
160+-- with the table @b@.
161+type Inserts :: Type -> Type -> Constraint
162+class Recontextualize Expr Insert exprs inserts => Inserts exprs inserts
163+instance Recontextualize Expr Insert exprs inserts => Inserts exprs inserts
164+instance {-# OVERLAPPING #-} Inserts (Opaque Expr Opaque) (Opaque Insert Opaque)
src/Rel8/Schema/Kind.hs+14−8
@@ -1,9 +1,8 @@
11{-# language StandaloneKindSignatures #-}
22
33module Rel8.Schema.Kind
4− ( Rel8able
5− , Context
6− , HTable
4+ ( Context, Table
5+ , HContext, HTable
76 )
87where
98
@@ -11,14 +10,21 @@ 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+type Context :: Type
26+type Context = Type -> Type
2127
2228
23−type Rel8able :: Type
24−type Rel8able = Context -> Type
29+type Table :: Type
30+type Table = Context -> Type
src/Rel8/Schema/Name.hs+43−32
@@ -2,45 +2,39 @@
22{-# language DerivingStrategies #-}
33{-# language FlexibleContexts #-}
44{-# language FlexibleInstances #-}
5−{-# language GADTs #-}
65{-# language GeneralizedNewtypeDeriving #-}
76{-# language MultiParamTypeClasses #-}
87{-# language RankNTypes #-}
8+{-# language ScopedTypeVariables #-}
99{-# language StandaloneKindSignatures #-}
10+{-# language TypeApplications #-}
1011{-# language TypeFamilies #-}
1112{-# language UndecidableInstances #-}
13+{-# language UndecidableSuperClasses #-}
1214
1315module Rel8.Schema.Name
1416 ( Name(..)
17+ , Col( NameCol )
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 )
2325import Data.String ( IsString )
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 )
30+import Rel8.Opaque ( Opaque )
31+import Rel8.Schema.Context ( Interpretation, Col )
32+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
33+import Rel8.Schema.HTable.Type ( HType( HType ) )
3534import qualified Rel8.Schema.Kind as K
36−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
37−import Rel8.Schema.Null ( Sql )
38−import Rel8.Table
39− ( Table, Columns, Context, fromColumns, toColumns
40− , FromExprs, fromResult, toResult
41− , Transpose
42− )
43−import Rel8.Table.Transpose ( Transposes )
35+import Rel8.Schema.Nullability ( Sql )
36+import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
37+import Rel8.Table.Recontextualize ( Recontextualize )
4438import Rel8.Type ( DBType )
4539
4640
@@ -51,27 +45,44 @@ import Rel8.Type ( DBType )
5145type Name :: K.Context
5246newtype Name a = Name String
5347 deriving stock Show
54− deriving newtype IsString
48+ deriving newtype (IsString, Monoid, Semigroup)
5549
5650
5751instance Sql DBType a => Table Name (Name a) where
58− type Columns (Name a) = HIdentity a
52+ type Columns (Name a) = HType a
5953 type Context (Name a) = Name
60− type FromExprs (Name a) = a
61− type Transpose to (Name a) = to a
6254
63− toColumns a = HIdentity a
64− fromColumns (HIdentity a) = a
65− toResult a = HIdentity (Identity a)
66− fromResult (HIdentity (Identity a)) = a
55+ toColumns (Name a) = HType (NameCol a)
56+ fromColumns (HType (NameCol a)) = Name a
57+
58+
59+instance Sql DBType a => Recontextualize Expr Name (Expr a) (Name a)
60+
61+
62+instance Sql DBType a => Recontextualize Identity Name (Identity a) (Name a)
63+
64+
65+instance Sql DBType a => Recontextualize Name Expr (Name a) (Expr a)
66+
67+
68+instance Sql DBType a => Recontextualize Name Identity (Name a) (Identity a)
69+
70+
71+instance Sql DBType a => Recontextualize Name Name (Name a) (Name a)
72+
73+
74+instance Interpretation Name where
75+ newtype Col Name _spec = NameCol String
76+
77+
78+instance Labelable Name where
79+ labeler (NameCol a) = NameCol a
80+ unlabeler (NameCol a) = NameCol a
6781
6882
6983-- | @Selects a b@ means that @a@ is a schema (i.e., a 'Table' of 'Name's) for
7084-- the 'Expr' columns in @b@.
7185type 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
86+class Recontextualize Name Expr names exprs => Selects names exprs
87+instance Recontextualize Name Expr names exprs => Selects names exprs
88+instance {-# OVERLAPPING #-} Selects (Opaque Name Opaque) (Opaque Expr Opaque)
src/Rel8/Schema/Null.hsdeleted−110
@@ -1,110 +0,0 @@
1−{-# language ConstraintKinds #-}
2−{-# language DataKinds #-}
3−{-# language FlexibleContexts #-}
4−{-# language FlexibleInstances #-}
5−{-# language GADTs #-}
6−{-# language MultiParamTypeClasses #-}
7−{-# language RankNTypes #-}
8−{-# language StandaloneKindSignatures #-}
9−{-# language TypeFamilies #-}
10−{-# language UndecidableInstances #-}
11−{-# language UndecidableSuperClasses #-}
12−
13−module Rel8.Schema.Null
14− ( Nullify, Unnullify
15− , NotNull
16− , Homonullable
17− , Nullity( Null, NotNull )
18− , Nullable, nullable
19− , Sql
20− )
21−where
22−
23−-- base
24−import Data.Kind ( Constraint, Type )
25−import Prelude
26−
27−
28−type IsMaybe :: Type -> Bool
29−type family IsMaybe a where
30− IsMaybe (Maybe _) = 'True
31− IsMaybe _ = 'False
32−
33−
34−type Unnullify' :: Bool -> Type -> Type
35−type family Unnullify' isMaybe ma where
36− Unnullify' 'False a = a
37− Unnullify' 'True (Maybe a) = a
38−
39−
40−type Unnullify :: Type -> Type
41−type Unnullify a = Unnullify' (IsMaybe a) a
42−
43−
44−type Nullify' :: Bool -> Type -> Type
45−type family Nullify' isMaybe a where
46− Nullify' 'False a = a
47− Nullify' 'True a = Maybe a
48−
49−
50−type Nullify :: Type -> Type
51−type Nullify a = Maybe (Unnullify a)
52−
53−
54−-- | @nullify a@ means @a@ cannot take @null@ as a value.
55−type NotNull :: Type -> Constraint
56−class (Nullable a, IsMaybe a ~ 'False) => NotNull a
57−instance (Nullable a, IsMaybe a ~ 'False) => NotNull a
58−
59−
60−-- | @Homonullable a b@ means that both @a@ and @b@ can be @null@, or neither
61−-- @a@ or @b@ can be @null@.
62−type Homonullable :: Type -> Type -> Constraint
63−class IsMaybe a ~ IsMaybe b => Homonullable a b
64−instance IsMaybe a ~ IsMaybe b => Homonullable a b
65−
66−
67−type Nullity :: Type -> Type
68−data Nullity a where
69− NotNull :: NotNull a => Nullity a
70− Null :: NotNull a => Nullity (Maybe a)
71−
72−
73−type Nullable' :: Bool -> Type -> Constraint
74−class
75− ( IsMaybe a ~ isMaybe
76− , IsMaybe (Unnullify a) ~ 'False
77− , Nullify' isMaybe (Unnullify a) ~ a
78− ) => Nullable' isMaybe a
79− where
80− nullable' :: Nullity a
81−
82−
83−instance IsMaybe a ~ 'False => Nullable' 'False a where
84− nullable' = NotNull
85−
86−
87−instance IsMaybe a ~ 'False => Nullable' 'True (Maybe a) where
88− nullable' = Null
89−
90−
91−-- | @Nullable a@ means that @rel8@ is able to check if the type @a@ is a
92−-- type that can take @null@ values or not.
93−type Nullable :: Type -> Constraint
94−class Nullable' (IsMaybe a) a => Nullable a
95−instance Nullable' (IsMaybe a) a => Nullable a
96−
97−
98−nullable :: Nullable a => Nullity a
99−nullable = nullable'
100−
101−
102−-- | The @Sql@ type class describes both null and not null database values,
103−-- constrained by a specific class.
104−--
105−-- For example, if you see @Sql DBEq a@, this means any database type that
106−-- supports equality, and @a@ can either be exactly an @a@, or it could also be
107−-- @Maybe a@.
108−type Sql :: (Type -> Constraint) -> Type -> Constraint
109−class (constraint (Unnullify a), Nullable a) => Sql constraint a
110−instance (constraint (Unnullify a), Nullable a) => Sql constraint a
src/Rel8/Schema/Nullability.hsnew file+22
@@ -0,0 +1,22 @@
1+{-# language ConstraintKinds #-}
2+{-# language FlexibleInstances #-}
3+{-# language MonoLocalBinds #-}
4+{-# language MultiParamTypeClasses #-}
5+{-# language UndecidableInstances #-}
6+
7+{-# options_ghc -fno-warn-orphans #-}
8+
9+module Rel8.Schema.Nullability
10+ ( module Rel8.Schema.Nullability.Internal
11+ )
12+where
13+
14+-- base
15+import Prelude ()
16+
17+-- rel8
18+import Rel8.Opaque ( Opaque )
19+import Rel8.Schema.Nullability.Internal
20+
21+
22+instance {-# OVERLAPPING #-} (c Opaque, Sql c Opaque) => Sql c Opaque
src/Rel8/Schema/Nullability/Internal.hsnew file+142
@@ -0,0 +1,142 @@
1+{-# language ConstraintKinds #-}
2+{-# language DataKinds #-}
3+{-# language FlexibleContexts #-}
4+{-# language FlexibleInstances #-}
5+{-# language FunctionalDependencies #-}
6+{-# language GADTs #-}
7+{-# language MultiParamTypeClasses #-}
8+{-# language RankNTypes #-}
9+{-# language QuantifiedConstraints #-}
10+{-# language StandaloneKindSignatures #-}
11+{-# language TypeFamilies #-}
12+{-# language UndecidableInstances #-}
13+{-# language UndecidableSuperClasses #-}
14+
15+module Rel8.Schema.Nullability.Internal
16+ ( Nullify, Unnullify
17+ , NotNull
18+ , Homonullable
19+ , Nullability( Nullable, NonNullable )
20+ , HasNullability, nullabilization
21+ , Sql, fromSql, mapSql, toSql
22+ )
23+where
24+
25+-- base
26+import Data.Kind ( Constraint, Type )
27+import Prelude
28+
29+-- rel8
30+import Rel8.Opaque ( Opaque )
31+import Rel8.Schema.Dict ( Dict( Dict ) )
32+
33+
34+type IsMaybe :: Type -> Bool
35+type family IsMaybe a where
36+ IsMaybe (Maybe _) = 'True
37+ IsMaybe _ = 'False
38+
39+
40+type Unnullify' :: Bool -> Type -> Type
41+type family Unnullify' isMaybe ma where
42+ Unnullify' 'False a = a
43+ Unnullify' 'True (Maybe a) = a
44+
45+
46+type Unnullify :: Type -> Type
47+type Unnullify a = Unnullify' (IsMaybe a) a
48+
49+
50+type Nullify' :: Bool -> Type -> Type
51+type family Nullify' isMaybe a where
52+ Nullify' 'False a = a
53+ Nullify' 'True a = Maybe a
54+
55+
56+type Nullify :: Type -> Type
57+type Nullify a = Maybe (Unnullify a)
58+
59+
60+-- | @NotNull a@ means @a@ cannot take @null@ as a value.
61+type NotNull :: Type -> Constraint
62+class (HasNullability a, IsMaybe a ~ 'False) => NotNull a
63+instance (HasNullability a, IsMaybe a ~ 'False) => NotNull a
64+instance {-# OVERLAPPING #-} NotNull Opaque
65+
66+
67+-- | @Homonullable a b@ means that both @a@ and @b@ can be @null@, or neither
68+-- @a@ or @b@ can be @null@.
69+type Homonullable :: Type -> Type -> Constraint
70+class IsMaybe a ~ IsMaybe b => Homonullable a b
71+instance IsMaybe a ~ IsMaybe b => Homonullable a b
72+instance {-# OVERLAPPING #-} Homonullable Opaque Opaque
73+
74+
75+type Nullability :: Type -> Type
76+data Nullability a where
77+ NonNullable :: NotNull a => Nullability a
78+ Nullable :: NotNull a => Nullability (Maybe a)
79+
80+
81+type HasNullability' :: Bool -> Type -> Constraint
82+class
83+ ( IsMaybe a ~ isMaybe
84+ , IsMaybe (Unnullify a) ~ 'False
85+ , Nullify' isMaybe (Unnullify a) ~ a
86+ ) => HasNullability' isMaybe a
87+ where
88+ nullabilization' :: Nullability a
89+
90+
91+instance IsMaybe a ~ 'False => HasNullability' 'False a where
92+ nullabilization' = NonNullable
93+
94+
95+instance IsMaybe a ~ 'False => HasNullability' 'True (Maybe a) where
96+ nullabilization' = Nullable
97+
98+
99+-- | @HasNullability a@ means that @rel8@ is able to check if the type @a@ is a
100+-- type that can take @null@ values or not.
101+type HasNullability :: Type -> Constraint
102+class HasNullability' (IsMaybe a) a => HasNullability a
103+instance HasNullability' (IsMaybe a) a => HasNullability a
104+instance {-# OVERLAPPING #-} HasNullability Opaque
105+
106+
107+nullabilization :: HasNullability a => Nullability a
108+nullabilization = nullabilization'
109+
110+
111+-- | The @Sql@ type class describes both null and not null database values,
112+-- constrained by a specific class.
113+--
114+-- For example, if you see @Sql DBEq a@, this means any database type that
115+-- supports equality, and @a@ can either be exactly an @a@, or it could also be
116+-- @Maybe a@.
117+type Sql :: (Type -> Constraint) -> Type -> Constraint
118+class
119+ ( (forall c. (forall x. (constraint x => c x)) => Sql c a)
120+ , HasNullability a
121+ , constraint (Unnullify a)
122+ )
123+ => Sql constraint a
124+instance (constraint (Unnullify a), HasNullability a) => Sql constraint a
125+
126+
127+fromSql :: Dict (Sql constraint) a -> (Nullability a, Dict constraint (Unnullify a))
128+fromSql Dict = (nullabilization, Dict)
129+{-# INLINABLE fromSql #-}
130+
131+
132+mapSql :: ()
133+ => (forall x. Dict constraint x -> Dict constraint' x)
134+ -> Dict (Sql constraint) a -> Dict (Sql constraint') a
135+mapSql f dict = case fromSql dict of
136+ (nullability, dict') -> toSql nullability (f dict')
137+
138+
139+toSql :: Nullability a -> Dict constraint (Unnullify a) -> Dict (Sql constraint) a
140+toSql NonNullable Dict = Dict
141+toSql Nullable Dict = Dict
142+{-# INLINABLE toSql #-}
src/Rel8/Schema/Result.hsdeleted−54
@@ -1,54 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language GADTs #-}
3−{-# language NamedFieldPuns #-}
4−{-# language StandaloneKindSignatures #-}
5−{-# language TypeFamilies #-}
6−
7−module Rel8.Schema.Result
8− ( Result
9− , null, nullifier, unnullifier
10− , vectorizer, unvectorizer
11− )
12−where
13−
14−-- base
15−import Data.Functor.Identity ( Identity( Identity), runIdentity )
16−import Prelude hiding ( null )
17−
18−-- rel8
19−import Rel8.Schema.Kind ( Context )
20−import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )
21−import Rel8.Schema.Spec ( Spec(..) )
22−
23−
24−-- | The @Result@ context is the context used for decoded query results.
25−--
26−-- When a query is executed against a PostgreSQL database, Rel8 parses the
27−-- returned rows, decoding each row into the @Result@ context.
28−type Result :: Context
29−type Result = Identity
30−
31−
32−null :: Result (Maybe a)
33−null = Identity Nothing
34−
35−
36−nullifier :: Spec a -> Result a -> Result (Nullify a)
37−nullifier Spec {nullity} (Identity a) = Identity $ case nullity of
38− Null -> a
39− NotNull -> Just a
40−
41−
42−unnullifier :: Spec a -> Result (Nullify a) -> Maybe (Result a)
43−unnullifier Spec {nullity} (Identity a) =
44− case nullity of
45− Null -> pure $ Identity a
46− NotNull -> Identity <$> a
47−
48−
49−vectorizer :: Functor f => Spec a -> f (Result a) -> Result (f a)
50−vectorizer _ = Identity . fmap runIdentity
51−
52−
53−unvectorizer :: Functor f => Spec a -> Result (f a) -> f (Result a)
54−unvectorizer _ (Identity results) = Identity <$> results
src/Rel8/Schema/Spec.hs+60−18
@@ -1,34 +1,76 @@
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, necessity, info, nullability )
10+ , KnownSpec( specSing )
11+ , KContext, HKTable
12+ , KTable
813 )
914where
1015
1116-- base
12−import Data.Kind ( Type )
13−import Prelude
17+import Data.Kind ( Constraint, Type )
18+import Prelude ()
1419
1520-- rel8
16−import Rel8.Schema.Null ( Nullity, Sql, Unnullify, nullable )
21+import Rel8.Kind.Labels ( Labels, SLabels, KnownLabels, labelsSing )
22+import Rel8.Kind.Necessity
23+ ( Necessity
24+ , SNecessity
25+ , KnownNecessity, necessitySing
26+ )
27+import Rel8.Schema.Nullability ( Nullability, Sql, Unnullify, nullabilization )
1728import Rel8.Type ( DBType, typeInformation )
1829import Rel8.Type.Information ( TypeInformation )
1930
2031
21−type Spec :: Type -> Type
22−data Spec a = Spec
23− { labels :: [String]
24− , info :: TypeInformation (Unnullify a)
25− , nullity :: Nullity a
26− }
32+type Spec :: Type
33+data Spec = Spec Labels Necessity Type
34+
35+
36+type SSpec :: Spec -> Type
37+data SSpec spec where
38+ SSpec ::
39+ { labels :: SLabels labels
40+ , necessity :: SNecessity necessity
41+ , info :: TypeInformation (Unnullify a)
42+ , nullability :: Nullability a
43+ }
44+ -> SSpec ('Spec labels necessity a)
45+
46+
47+type KnownSpec :: Spec -> Constraint
48+class KnownSpec spec where
49+ specSing :: SSpec spec
50+
51+
52+instance
53+ ( KnownLabels labels
54+ , KnownNecessity necessity
55+ , Sql DBType a
56+ )
57+ => KnownSpec ('Spec labels necessity a)
58+ where
59+ specSing = SSpec
60+ { labels = labelsSing
61+ , necessity = necessitySing
62+ , info = typeInformation
63+ , nullability = nullabilization
64+ }
65+
66+
67+type KContext :: Type
68+type KContext = Spec -> Type
69+
70+
71+type HKTable :: Type
72+type HKTable = KContext -> Type
2773
2874
29−specification :: Sql DBType a => Spec a
30−specification = Spec
31− { labels = []
32− , info = typeInformation
33− , nullity = nullable
34− }
75+type KTable :: Type
76+type KTable = (Type -> Type) -> Type
src/Rel8/Schema/Spec/ConstrainDBType.hsnew file+70
@@ -0,0 +1,70 @@
1+{-# language ConstraintKinds #-}
2+{-# language DataKinds #-}
3+{-# language FlexibleInstances #-}
4+{-# language MultiParamTypeClasses #-}
5+{-# language QuantifiedConstraints #-}
6+{-# language StandaloneKindSignatures #-}
7+{-# language TypeFamilies #-}
8+{-# language UndecidableInstances #-}
9+
10+module Rel8.Schema.Spec.ConstrainDBType
11+ ( ConstrainDBType
12+ , dbTypeNullability
13+ , dbTypeDict
14+ , fromNullabilityDict
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.Nullability
25+ ( Unnullify
26+ , Nullability
27+ , Sql, nullabilization, toSql
28+ )
29+import Rel8.Schema.Spec ( Spec( Spec ) )
30+
31+
32+type ConstrainDBType :: (Type -> Constraint) -> Spec -> Constraint
33+class
34+ ( forall c labels necessity a. ()
35+ => (spec ~ 'Spec labels necessity a)
36+ => (forall x. (constraint x => c x)) => Sql c a
37+ )
38+ => ConstrainDBType constraint spec
39+instance
40+ ( spec ~ 'Spec labels necessity a
41+ , Sql constraint a
42+ )
43+ => ConstrainDBType constraint spec
44+
45+
46+dbTypeNullability :: Dict (ConstrainDBType c) ('Spec l n a) -> Nullability a
47+dbTypeNullability = step2 . step1
48+ where
49+ step1 :: Dict (ConstrainDBType c) ('Spec l n a) -> Dict (Sql c) a
50+ step1 Dict = Dict
51+
52+ step2 :: Dict (Sql c) a -> Nullability a
53+ step2 Dict = nullabilization
54+
55+
56+dbTypeDict :: Dict (ConstrainDBType c) ('Spec l n a) -> Dict c (Unnullify a)
57+dbTypeDict = step2 . step1
58+ where
59+ step1 :: Dict (ConstrainDBType c) ('Spec l n 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+fromNullabilityDict :: Nullability a -> Dict c (Unnullify a) -> Dict (ConstrainDBType c) ('Spec l n a)
67+fromNullabilityDict nullability = step2 . toSql nullability
68+ where
69+ step2 :: Dict (Sql c) a -> Dict (ConstrainDBType c) ('Spec l n a)
70+ step2 Dict = Dict
src/Rel8/Schema/Spec/ConstrainType.hsnew file+31
@@ -0,0 +1,31 @@
1+{-# language ConstraintKinds #-}
2+{-# language DataKinds #-}
3+{-# language FlexibleInstances #-}
4+{-# language MultiParamTypeClasses #-}
5+{-# language QuantifiedConstraints #-}
6+{-# language StandaloneKindSignatures #-}
7+{-# language TypeFamilies #-}
8+{-# language UndecidableInstances #-}
9+
10+module Rel8.Schema.Spec.ConstrainType
11+ ( ConstrainType
12+ )
13+where
14+
15+-- base
16+import Data.Kind ( Constraint, Type )
17+import Prelude ()
18+
19+-- rel8
20+import Rel8.Schema.Spec ( Spec( Spec ) )
21+
22+
23+type ConstrainType :: (Type -> Constraint) -> Spec -> Constraint
24+class
25+ ( forall labels necessity a. ()
26+ => (spec ~ 'Spec labels necessity a)
27+ => constraint a
28+ ) =>
29+ ConstrainType constraint spec
30+instance (spec ~ 'Spec labels necessity a, constraint a) =>
31+ ConstrainType constraint spec
src/Rel8/Schema/Structure.hsnew file+54
@@ -0,0 +1,54 @@
1+{-# language DataKinds #-}
2+{-# language StandaloneKindSignatures #-}
3+{-# language PolyKinds #-}
4+{-# language TypeFamilies #-}
5+
6+module Rel8.Schema.Structure
7+ ( Structure
8+ , Shape( Column, Either, List, Maybe, NonEmpty, These )
9+ , Shape1
10+ , Shape2
11+ , IsStructure
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.Spec ( Spec )
22+
23+
24+type Structure :: K.Context
25+data Structure a
26+
27+
28+type Shape :: Type
29+data Shape
30+ = Column Spec
31+ | Either Type Type
32+ | List Type
33+ | Maybe Type
34+ | NonEmpty Type
35+ | These Type Type
36+
37+
38+type Shape1 :: (a -> Shape) -> a -> Type
39+data Shape1 shape a
40+
41+
42+type Shape2 :: (a -> b -> Shape) -> a -> b -> Type
43+data Shape2 shape a b
44+
45+
46+type IsStructure :: Type -> Bool
47+type family IsStructure a where
48+ IsStructure (Shape1 _ _) = 'True
49+ IsStructure (Shape2 _ _ _) = 'True
50+ IsStructure (_, _) = 'True
51+ IsStructure (_, _, _) = 'True
52+ IsStructure (_, _, _, _) = 'True
53+ IsStructure (_, _, _, _, _) = 'True
54+ IsStructure _ = 'False
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 ( 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' = 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+60−60
@@ -1,89 +1,89 @@
1−{-# language DuplicateRecordFields #-}
2−{-# language FlexibleContexts #-}
31{-# language GADTs #-}
42{-# language NamedFieldPuns #-}
5−{-# language RecordWildCards #-}
6−{-# language StandaloneKindSignatures #-}
7−{-# language StrictData #-}
3+{-# language ScopedTypeVariables #-}
4+{-# language TypeApplications #-}
85
96module Rel8.Statement.Insert
107 ( Insert(..)
8+ , OnConflict(..)
119 , insert
12− , ppInsert
13− , ppInto
1410 )
1511where
1612
1713-- base
18−import Data.Foldable ( toList )
19−import Data.Kind ( Type )
14+import Control.Exception ( throwIO )
15+import Data.List.NonEmpty ( NonEmpty( (:|) ) )
2016import Prelude
2117
2218-- hasql
19+import Hasql.Connection ( Connection )
20+import qualified Hasql.Decoders as Hasql
2321import qualified Hasql.Encoders as Hasql
22+import qualified Hasql.Session as Hasql
2423import qualified Hasql.Statement as Hasql
2524
2625-- opaleye
27−import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye
28−
29−-- pretty
30−import Text.PrettyPrint ( Doc, (<+>), ($$), parens, text )
26+import qualified Opaleye.Internal.Manipulation as Opaleye
27+import qualified Opaleye.Manipulation as Opaleye
3128
3229-- 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 )
30+import Rel8.Schema.Insert ( Insert(..), OnConflict(..) )
31+import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) )
32+import Rel8.Table ( fromColumns, toColumns )
33+import Rel8.Table.Opaleye ( table, unpackspec )
34+import Rel8.Table.Serialize ( Serializable, parse )
4135
4236-- text
4337import qualified Data.Text as Text ( pack )
4438import Data.Text.Encoding ( encodeUtf8 )
4539
4640
47−-- | The constituent parts of a SQL @INSERT@ statement.
48−type Insert :: Type -> Type
49−data Insert a where
50− Insert :: Selects names exprs =>
51− { into :: TableSchema names
52− -- ^ 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
57− -- ^ What to do if the inserted rows conflict with data already in the
58− -- table.
59− , returning :: Returning names a
60− -- ^ What information to return on completion.
61− }
62− -> Insert a
63−
64−
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
41+-- | Run an @INSERT@ statement
42+insert :: Connection -> Insert a -> IO a
43+insert c Insert {into, rows, onConflict, returning} =
44+ case (rows, returning) of
45+ ([], NumberOfRowsAffected) -> pure 0
46+ ([], Projection _) -> pure []
7247
48+ (x:xs, NumberOfRowsAffected) -> Hasql.run session c >>= either throwIO pure
49+ where
50+ session = Hasql.statement () statement
51+ statement = Hasql.Statement bytes params decode prepare
52+ bytes = encodeUtf8 $ Text.pack sql
53+ params = Hasql.noParams
54+ decode = Hasql.rowsAffected
55+ prepare = False
56+ sql = Opaleye.arrangeInsertManySql into' rows' onConflict'
57+ where
58+ into' = table $ toColumns <$> into
59+ rows' = toColumns <$> x :| xs
7360
74−ppInto :: Table Name a => TableSchema a -> Doc
75−ppInto table@TableSchema {columns} =
76− ppTable table <+>
77− parens (Opaleye.commaV ppColumn (toList (showNames columns)))
61+ (x:xs, Projection project) -> Hasql.run session c >>= either throwIO pure
62+ where
63+ session = Hasql.statement () statement
64+ statement = Hasql.Statement bytes params decode prepare
65+ bytes = encodeUtf8 $ Text.pack sql
66+ params = Hasql.noParams
67+ decode = decoder project
68+ prepare = False
69+ sql =
70+ Opaleye.arrangeInsertManyReturningSql
71+ unpackspec
72+ into'
73+ rows'
74+ project'
75+ onConflict'
76+ where
77+ into' = table $ toColumns <$> into
78+ rows' = toColumns <$> x :| xs
79+ project' = toColumns . project . fromColumns
7880
79−
80−-- | Run an 'Insert' statement.
81−insert :: Insert a -> Hasql.Statement () a
82−insert i@Insert {returning} = Hasql.Statement bytes params decode prepare
8381 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
82+ onConflict' =
83+ case onConflict of
84+ DoNothing -> Just Opaleye.DoNothing
85+ Abort -> Nothing
86+
87+ decoder :: forall exprs projection a. Serializable projection a
88+ => (exprs -> projection) -> Hasql.Result [a]
89+ 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−121
@@ -1,147 +1,61 @@
1−{-# language DeriveTraversable #-}
2−{-# language DerivingStrategies #-}
3−{-# language FlexibleContexts #-}
4−{-# language MonoLocalBinds #-}
51{-# language ScopedTypeVariables #-}
6−{-# language StandaloneKindSignatures #-}
72{-# language TypeApplications #-}
83
94module Rel8.Statement.Select
105 ( select
11− , ppSelect
12−
13− , Optimized(..)
14− , ppPrimSelect
15− , ppRows
6+ , selectWithNames
167 )
178where
189
1910-- base
20−import Data.Foldable ( toList )
21−import Data.Kind ( Type )
22−import Data.Void ( Void )
23−import Prelude hiding ( undefined )
11+import Control.Exception ( throwIO )
12+import Prelude
2413
2514-- hasql
15+import Hasql.Connection ( Connection )
2616import qualified Hasql.Decoders as Hasql
2717import qualified Hasql.Encoders as Hasql
18+import qualified Hasql.Session as Hasql
2819import qualified Hasql.Statement as Hasql
2920
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−
4421-- rel8
45−import Rel8.Expr ( Expr )
46−import Rel8.Expr.Bool ( false )
47−import Rel8.Expr.Opaleye ( toPrimExpr )
4822import Rel8.Query ( Query )
49−import Rel8.Query.Opaleye ( toOpaleye )
23+import Rel8.Query.SQL ( sqlForQuery, sqlForQueryWithNames )
5024import 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
5625import Rel8.Table.Serialize ( Serializable, parse )
57−import Rel8.Table.Undefined ( undefined )
5826
5927-- text
6028import qualified Data.Text as Text
6129import Data.Text.Encoding ( encodeUtf8 )
6230
6331
64−-- | Run a @SELECT@ statement, returning all rows.
32+-- | Run a @SELECT@ query, returning all rows.
6533select :: 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))
34+ => Connection -> Query exprs -> IO [a]
35+select c query = case sqlForQuery query of
36+ Nothing -> pure []
37+ Just sql -> Hasql.run session c >>= either throwIO pure
38+ where
39+ session = Hasql.statement () statement
40+ statement = Hasql.Statement bytes params decode prepare
41+ bytes = encodeUtf8 (Text.pack sql)
42+ params = Hasql.noParams
43+ decode = Hasql.rowList (parse @exprs @a)
44+ prepare = False
45+
46+
47+selectWithNames :: forall exprs a names.
48+ ( Selects names exprs
49+ , Serializable exprs a
50+ )
51+ => Connection -> names -> Query exprs -> IO [a]
52+selectWithNames c names query = case sqlForQueryWithNames names query of
53+ Nothing -> pure []
54+ Just sql -> Hasql.run session c >>= either throwIO pure
55+ where
56+ session = Hasql.statement () statement
57+ statement = Hasql.Statement bytes params decode prepare
58+ bytes = encodeUtf8 (Text.pack sql)
59+ params = Hasql.noParams
60+ decode = Hasql.rowList (parse @exprs @a)
61+ 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+60−38
@@ -1,37 +1,43 @@
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
27+
28+-- profunctors
29+import Data.Profunctor ( lmap )
2530
2631-- rel8
2732import Rel8.Expr ( Expr )
28−import Rel8.Query ( Query )
33+import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
2934import 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 )
35+import Rel8.Schema.Table ( TableSchema )
36+import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) )
37+import Rel8.Table ( fromColumns, toColumns )
38+import Rel8.Table.Insert ( toInsert )
39+import Rel8.Table.Opaleye ( table, unpackspec )
40+import Rel8.Table.Serialize ( Serializable, parse )
3541
3642-- text
3743import qualified Data.Text as Text
@@ -44,12 +50,9 @@ data Update a where
4450 Update :: Selects names exprs =>
4551 { target :: TableSchema names
4652 -- ^ 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
53+ , set :: exprs -> exprs
5154 -- ^ How to update each selected row.
52− , updateWhere :: from -> exprs -> Expr Bool
55+ , updateWhere :: exprs -> Expr Bool
5356 -- ^ Which rows to select for update.
5457 , returning :: Returning names a
5558 -- ^ What to return from the @UPDATE@ statement.
@@ -57,27 +60,46 @@ data Update a where
5760 -> Update a
5861
5962
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
63+-- | Run an @UPDATE@ statement.
64+update :: Connection -> Update a -> IO a
65+update c Update {target, set, updateWhere, returning} =
66+ case returning of
67+ NumberOfRowsAffected -> Hasql.run session c >>= either throwIO pure
68+ where
69+ session = Hasql.statement () statement
70+ statement = Hasql.Statement bytes params decode prepare
71+ bytes = encodeUtf8 $ Text.pack sql
72+ params = Hasql.noParams
73+ decode = Hasql.rowsAffected
74+ prepare = False
75+ sql = Opaleye.arrangeUpdateSql target' set' where'
76+ where
77+ target' = lmap toInsert $ table $ toColumns <$> target
78+ set' = toColumns . set . fromColumns
79+ where' = toColumn . toPrimExpr . updateWhere . fromColumns
7280
81+ Projection project -> Hasql.run session c >>= either throwIO pure
82+ where
83+ session = Hasql.statement () statement
84+ statement = Hasql.Statement bytes params decode prepare
85+ bytes = encodeUtf8 $ Text.pack sql
86+ params = Hasql.noParams
87+ decode = decoder project
88+ prepare = False
89+ sql =
90+ Opaleye.arrangeUpdateReturningSql
91+ unpackspec
92+ target'
93+ set'
94+ where'
95+ project'
96+ where
97+ target' = lmap toInsert $ table $ toColumns <$> target
98+ set' = toColumns . set . fromColumns
99+ where' = toColumn . toPrimExpr . updateWhere . fromColumns
100+ project' = toColumns . project . fromColumns
73101
74−-- | Run an @UPDATE@ statement.
75−update :: Update a -> Hasql.Statement () a
76−update u@Update {returning} = Hasql.Statement bytes params decode prepare
77102 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
103+ decoder :: forall exprs projection a. Serializable projection a
104+ => (exprs -> projection) -> Hasql.Result [a]
105+ 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−44
@@ -1,78 +1,62 @@
11{-# language FlexibleContexts #-}
2−{-# language MonoLocalBinds #-}
32
43module Rel8.Statement.View
54 ( createView
6− , createOrReplaceView
75 )
86where
97
108-- base
9+import Control.Exception ( throwIO )
10+import Control.Monad ( (>=>) )
11+import Data.Foldable ( fold )
12+import Data.Maybe ( fromMaybe )
1113import Prelude
1214
1315-- hasql
16+import Hasql.Connection ( Connection )
1417import qualified Hasql.Decoders as Hasql
1518import qualified Hasql.Encoders as Hasql
19+import qualified Hasql.Session as Hasql
1620import qualified Hasql.Statement as Hasql
1721
1822-- rel8
1923import Rel8.Query ( Query )
24+import Rel8.Query.SQL ( sqlForQueryWithNames )
2025import 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 )
26+import Rel8.Schema.Table ( TableSchema( TableSchema ) )
27+import Rel8.Table.Alternative ( emptyTable )
2728
2829-- text
2930import qualified Data.Text as Text
3031import Data.Text.Encoding ( encodeUtf8 )
3132
3233
33−data CreateView = Create | CreateOrReplace
34−
35−
3634-- | Given a 'TableSchema' and 'Query', @createView@ runs a @CREATE VIEW@
3735-- statement that will save the given query as a view. This can be useful if
3836-- you want to share Rel8 queries with other applications.
3937createView :: 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
38+ => TableSchema names -> Query exprs -> Connection -> IO ()
39+createView (TableSchema name mschema names) query =
40+ Hasql.run session >=> either throwIO pure
6041 where
42+ session = Hasql.statement () statement
43+ statement = Hasql.Statement bytes params decode prepare
6144 bytes = encodeUtf8 (Text.pack sql)
6245 params = Hasql.noParams
6346 decode = Hasql.noResult
6447 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
48+ sql = "CREATE VIEW " <> title <> " WITH " <> select
49+ where
50+ title = case mschema of
51+ Nothing -> quote name
52+ Just schema -> quote schema <> "." <> quote name
53+ select = fromMaybe fallback $ sqlForQueryWithNames names query
54+ where
55+ fallback = fold $ sqlForQueryWithNames names emptyTable
56+
57+
58+quote :: String -> String
59+quote string = "\"" <> concatMap go string <> "\""
7660 where
77− createOrReplace Create = text "CREATE VIEW"
78− createOrReplace CreateOrReplace = text "CREATE OR REPLACE VIEW"
61+ go '"' = "\"\""
62+ 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+144−144
@@ -1,46 +1,40 @@
1−{-# language AllowAmbiguousTypes #-}
21{-# language DataKinds #-}
3−{-# language DefaultSignatures #-}
2+{-# language DisambiguateRecordFields #-}
43{-# language FlexibleContexts #-}
54{-# language FlexibleInstances #-}
65{-# language FunctionalDependencies #-}
7−{-# language ScopedTypeVariables #-}
86{-# language StandaloneKindSignatures #-}
9−{-# language TypeApplications #-}
107{-# language TypeFamilies #-}
118{-# language UndecidableInstances #-}
129
1310module Rel8.Table
14− ( Table
15− ( Columns, Context, fromColumns, toColumns
16− , FromExprs, fromResult, toResult
17− , Transpose
18− )
11+ ( Table (Columns, Context)
12+ , toColumns, fromColumns
1913 , Congruent
20− , TTable, TColumns, TContext, TFromExprs, TTranspose
21− , TSerialize
2214 )
2315where
2416
2517-- base
2618import Data.Functor.Identity ( Identity( Identity ) )
2719import Data.Kind ( Constraint, Type )
28−import GHC.Generics ( Generic, Rep, from, to )
29−import Prelude hiding ( null )
20+import Prelude
3021
3122-- rel8
32−import 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
37− )
38−import Rel8.Generic.Record ( Record(..) )
23+import {-# SOURCE #-} Rel8.Expr ( Expr )
24+import Rel8.Opaque ( Opaque )
25+import Rel8.Schema.Context ( Col(..) )
26+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
3927import Rel8.Schema.HTable ( HTable )
40−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
28+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
29+import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
30+import Rel8.Schema.HTable.Pair ( HPair(..) )
31+import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
32+import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
33+import Rel8.Schema.HTable.Trio ( HTrio(..) )
34+import Rel8.Schema.HTable.Type ( HType( HType ) )
4135import qualified Rel8.Schema.Kind as K
42−import Rel8.Schema.Null ( Sql )
43−import Rel8.Schema.Result ( Result )
36+import Rel8.Schema.Nullability ( Sql )
37+import Rel8.Schema.Spec ( KnownSpec )
4438import Rel8.Type ( DBType )
4539
4640
@@ -56,165 +50,171 @@ import Rel8.Type ( DBType )
5650-- yourself, as anything that's an instance of 'Rel8.Rel8able' is always a
5751-- 'Table'.
5852type 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
53+class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where
6654 -- | The 'HTable' functor that describes the schema of this table.
6755 type Columns a :: K.HTable
6856
6957 -- | The common context that all columns use as an interpretation.
7058 type Context a :: K.Context
7159
72− -- | The @FromExprs@ type family maps a type in the @Expr@ context to the
73− -- corresponding Haskell type.
74− type FromExprs a :: Type
60+ toColumns :: a -> Columns a (Col (Context a))
61+ fromColumns :: Columns a (Col (Context a)) -> a
7562
76− type Transpose (context' :: K.Context) a :: Type
7763
64+-- | Any 'HTable' is also a 'Table'.
65+instance HTable t => Table context (t (Col context)) where
66+ type Columns (t (Col context)) = t
67+ type Context (t (Col context)) = context
7868
79− toColumns :: a -> Columns a context
80− fromColumns :: Columns a context -> a
69+ toColumns = id
70+ fromColumns = id
8171
82− fromResult :: Columns a Result -> FromExprs a
83− toResult :: FromExprs a -> Columns a Result
8472
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
89−
90− default toColumns ::
91− ( Generic (Record a)
92− , GTable (TTable context) TColumns (Rep (Record a))
93− , Columns a ~ GColumns TColumns (Rep (Record a))
94− )
95− => a -> Columns a context
96− toColumns =
97− gtoColumns @(TTable context) @TColumns toColumns .
98− from .
99− Record
100−
101− default fromColumns ::
102− ( Generic (Record a)
103− , GTable (TTable context) TColumns (Rep (Record a))
104− , Columns a ~ GColumns TColumns (Rep (Record a))
105− )
106− => Columns a context -> a
107− fromColumns =
108− unrecord .
109− to .
110− gfromColumns @(TTable context) @TColumns fromColumns
111−
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))
116− )
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) .
125− from .
126− Record
127−
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))
132− )
133− => Columns a Result -> FromExprs a
134− fromResult =
135− unrecord .
136− 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
73+-- | Any context is trivially a table.
74+instance KnownSpec spec => Table context (Col context spec) where
75+ type Columns (Col context spec) = HIdentity spec
76+ type Context (Col context spec) = context
15077
15178 toColumns = HIdentity
152− fromColumns (HIdentity a) = a
153− toResult a = HIdentity (Identity a)
154− fromResult (HIdentity (Identity a)) = a
155−
79+ fromColumns = unHIdentity
15680
157−data TTable :: K.Context -> Type -> Exp Constraint
158−type instance Eval (TTable context a) = Table context a
15981
82+instance Sql DBType a => Table Identity (Identity a) where
83+ type Columns (Identity a) = HType a
84+ type Context (Identity a) = Identity
16085
161−data TColumns :: Type -> Exp K.HTable
162−type instance Eval (TColumns a) = Columns a
86+ toColumns (Identity a) = HType (Result a)
87+ fromColumns (HType (Result a)) = Identity a
16388
16489
165−data TContext :: Type -> Exp K.Context
166−type instance Eval (TContext a) = Context a
90+{-}
91+instance Sql DBType a => Table Insertion (Insertion a) where
92+ type Columns (Insertion a) = HType a
93+ type Context (Insertion a) = Insertion
16794
95+ toColumns (Insertion a) = HType (RequiredInsert a)
96+ fromColumns (HType (RequiredInsert a)) = Insertion a
97+-}
16898
169−data TFromExprs :: Type -> Exp Type
170−type instance Eval (TFromExprs a) = FromExprs a
17199
172−
173−data TTranspose :: K.Context -> Type -> Exp Type
174−type instance Eval (TTranspose context a) = Transpose context a
175−
176−
177−data TSerialize :: Type -> Type -> Exp Constraint
178−type instance Eval (TSerialize expr a) =
179− ( Table (Context expr) expr
180− , a ~ FromExprs expr
181− )
182−
183−
184−instance (Table context a, Table context b) => Table context (a, b)
100+instance
101+ ( Table context a, Table context b
102+ , Labelable context
103+ ) =>
104+ Table context (a, b)
105+ where
106+ type Columns (a, b) =
107+ HPair
108+ (HLabel "fst" (Columns a))
109+ (HLabel "snd" (Columns b))
110+ type Context (a, b) = Context a
111+
112+ toColumns (a, b) = HPair
113+ { hfst = hlabel labeler $ toColumns a
114+ , hsnd = hlabel labeler $ toColumns b
115+ }
116+ fromColumns (HPair a b) =
117+ ( fromColumns $ hunlabel unlabeler a
118+ , fromColumns $ hunlabel unlabeler b
119+ )
185120
186121
187122instance
188123 ( Table context a, Table context b, Table context c
189− )
190− => Table context (a, b, c)
124+ , Labelable context
125+ ) => Table context (a, b, c)
126+ where
127+ type Columns (a, b, c) =
128+ HTrio
129+ (HLabel "fst" (Columns a))
130+ (HLabel "snd" (Columns b))
131+ (HLabel "trd" (Columns c))
132+ type Context (a, b, c) = Context a
133+
134+ toColumns (a, b, c) = HTrio
135+ { hfst = hlabel labeler $ toColumns a
136+ , hsnd = hlabel labeler $ toColumns b
137+ , htrd = hlabel labeler $ toColumns c
138+ }
139+ fromColumns (HTrio a b c) =
140+ ( fromColumns $ hunlabel unlabeler a
141+ , fromColumns $ hunlabel unlabeler b
142+ , fromColumns $ hunlabel unlabeler c
143+ )
191144
192145
193146instance
194147 ( Table context a, Table context b, Table context c, Table context d
195− )
196− => Table context (a, b, c, d)
148+ , Labelable context
149+ ) => Table context (a, b, c, d)
150+ where
151+ type Columns (a, b, c, d) =
152+ HQuartet
153+ (HLabel "fst" (Columns a))
154+ (HLabel "snd" (Columns b))
155+ (HLabel "trd" (Columns c))
156+ (HLabel "frt" (Columns d))
157+ type Context (a, b, c, d) = Context a
158+
159+ toColumns (a, b, c, d) = HQuartet
160+ { hfst = hlabel labeler $ toColumns a
161+ , hsnd = hlabel labeler $ toColumns b
162+ , htrd = hlabel labeler $ toColumns c
163+ , hfrt = hlabel labeler $ toColumns d
164+ }
165+ fromColumns (HQuartet a b c d) =
166+ ( fromColumns $ hunlabel unlabeler a
167+ , fromColumns $ hunlabel unlabeler b
168+ , fromColumns $ hunlabel unlabeler c
169+ , fromColumns $ hunlabel unlabeler d
170+ )
197171
198172
199173instance
200174 ( Table context a, Table context b, Table context c, Table context d
201175 , Table context e
202− )
203− => Table context (a, b, c, d, e)
176+ , Labelable context
177+ ) => Table context (a, b, c, d, e)
178+ where
179+ type Columns (a, b, c, d, e) =
180+ HQuintet
181+ (HLabel "fst" (Columns a))
182+ (HLabel "snd" (Columns b))
183+ (HLabel "trd" (Columns c))
184+ (HLabel "frt" (Columns d))
185+ (HLabel "fft" (Columns e))
186+ type Context (a, b, c, d, e) = Context a
187+
188+ toColumns (a, b, c, d, e) = HQuintet
189+ { hfst = hlabel labeler $ toColumns a
190+ , hsnd = hlabel labeler $ toColumns b
191+ , htrd = hlabel labeler $ toColumns c
192+ , hfrt = hlabel labeler $ toColumns d
193+ , hfft = hlabel labeler $ toColumns e
194+ }
195+ fromColumns (HQuintet a b c d e) =
196+ ( fromColumns $ hunlabel unlabeler a
197+ , fromColumns $ hunlabel unlabeler b
198+ , fromColumns $ hunlabel unlabeler c
199+ , fromColumns $ hunlabel unlabeler d
200+ , fromColumns $ hunlabel unlabeler e
201+ )
204202
205203
206−instance
207− ( Table context a, Table context b, Table context c, Table context d
208− , Table context e, Table context f
209− )
210− => Table context (a, b, c, d, e, f)
204+instance Table Expr Opaque where
205+ type Columns Opaque = HType Opaque
206+ type Context Opaque = Expr
211207
208+ fromColumns = error "opaque"
209+ toColumns = error "opaque"
212210
213−instance
214− ( Table context a, Table context b, Table context c, Table context d
215− , Table context e, Table context f, Table context g
216− )
217− => Table context (a, b, c, d, e, f, g)
211+
212+instance Table context (Opaque context a) where
213+ type Columns (Opaque context a) = HType Opaque
214+ type Context (Opaque context a) = context
215+
216+ fromColumns = error "opaque"
217+ toColumns = error "opaque"
218218
219219
220220type Congruent :: Type -> Type -> Constraint
src/Rel8/Table/ADT.hsdeleted−173
@@ -1,173 +0,0 @@
1−{-# language AllowAmbiguousTypes #-}
2−{-# language DataKinds #-}
3−{-# language FlexibleContexts #-}
4−{-# language FlexibleInstances #-}
5−{-# language MultiParamTypeClasses #-}
6−{-# language RankNTypes #-}
7−{-# language ScopedTypeVariables #-}
8−{-# language StandaloneKindSignatures #-}
9−{-# language TypeApplications #-}
10−{-# language TypeFamilyDependencies #-}
11−{-# language UndecidableInstances #-}
12−{-# language UndecidableSuperClasses #-}
13−
14−module Rel8.Table.ADT
15− ( ADT( ADT )
16− , ADTable
17− , BuildableADT
18− , BuildADT, buildADT
19− , ConstructableADT
20− , ConstructADT, constructADT
21− , DeconstructADT, deconstructADT
22− , NameADT, nameADT
23− , AggregateADT, aggregateADT
24− , ADTRep
25− )
26−where
27−
28−-- base
29−import Data.Kind ( Constraint, Type )
30−import GHC.Generics ( Generic, from, to )
31−import GHC.TypeLits ( Symbol )
32−import Prelude
33−
34−-- rel8
35−import Rel8.Aggregate ( Aggregate )
36−import Rel8.Expr ( Expr )
37−import Rel8.FCF ( Eval, Exp )
38−import Rel8.Generic.Construction
39− ( GGBuildable
40− , GGBuild, ggbuild
41− , GGConstructable
42− , GGConstruct, ggconstruct
43− , GGDeconstruct, ggdeconstruct
44− , GGName, ggname
45− , GGAggregate, ggaggregate
46− )
47−import Rel8.Generic.Record ( Record( Record ), unrecord )
48−import Rel8.Generic.Rel8able
49− ( Rel8able
50− , GRep, GColumns, gfromColumns, gtoColumns
51− , GFromExprs, gfromResult, gtoResult
52− , TSerialize, deserialize, serialize
53− )
54−import qualified Rel8.Generic.Table.ADT as G
55−import qualified Rel8.Kind.Algebra as K
56−import Rel8.Schema.HTable ( HTable )
57−import qualified Rel8.Schema.Kind as K
58−import Rel8.Schema.Name ( Name )
59−import Rel8.Schema.Result ( Result )
60−import Rel8.Table ( Table, TColumns )
61−
62−
63−type ADT :: K.Rel8able -> K.Rel8able
64−newtype ADT t context = ADT (GColumnsADT t context)
65−
66−
67−instance ADTable t => Rel8able (ADT t) where
68− type GColumns (ADT t) = GColumnsADT t
69− type GFromExprs (ADT t) = t Result
70−
71− gfromColumns _ = ADT
72− gtoColumns _ (ADT a) = a
73−
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)
83−
84− gtoResult =
85− G.gtoResultADT
86− @TSerialize
87− @TColumns
88− @(Eval (ADTRep t Expr))
89− @(Eval (ADTRep t Result))
90− (\(_ :: proxy x) -> serialize @_ @x) .
91− from .
92− Record
93−
94−
95−type ADTable :: K.Rel8able -> Constraint
96−class
97− ( Generic (Record (t Result))
98− , HTable (GColumnsADT t)
99− , G.GSerializeADT TSerialize TColumns (Eval (ADTRep t Expr)) (Eval (ADTRep t Result))
100− )
101− => ADTable t
102−instance
103− ( Generic (Record (t Result))
104− , HTable (GColumnsADT t)
105− , G.GSerializeADT TSerialize TColumns (Eval (ADTRep t Expr)) (Eval (ADTRep t Result))
106− )
107− => ADTable t
108−
109−
110−type BuildableADT :: K.Rel8able -> Symbol -> Constraint
111−class GGBuildable 'K.Sum name (ADTRep t) => BuildableADT t name
112−instance GGBuildable 'K.Sum name (ADTRep t) => BuildableADT t name
113−
114−
115−type BuildADT :: K.Rel8able -> Symbol -> Type
116−type BuildADT t name = GGBuild 'K.Sum name (ADTRep t) (ADT t Expr)
117−
118−
119−buildADT :: forall t name. BuildableADT t name => BuildADT t name
120−buildADT =
121− ggbuild @'K.Sum @name @(ADTRep t) @(ADT t Expr) ADT
122−
123−
124−type ConstructableADT :: K.Rel8able -> Constraint
125−class GGConstructable 'K.Sum (ADTRep t) => ConstructableADT t
126−instance GGConstructable 'K.Sum (ADTRep t) => ConstructableADT t
127−
128−
129−type ConstructADT :: K.Rel8able -> Type
130−type ConstructADT t = forall r. GGConstruct 'K.Sum (ADTRep t) r
131−
132−
133−constructADT :: forall t. ConstructableADT t => ConstructADT t -> ADT t Expr
134−constructADT f =
135− ggconstruct @'K.Sum @(ADTRep t) @(ADT t Expr) ADT
136− (f @(ADT t Expr))
137−
138−
139−type DeconstructADT :: K.Rel8able -> Type -> Type
140−type DeconstructADT t r = GGDeconstruct 'K.Sum (ADTRep t) (ADT t Expr) r
141−
142−
143−deconstructADT :: forall t r. (ConstructableADT t, Table Expr r)
144− => DeconstructADT t r
145−deconstructADT =
146− ggdeconstruct @'K.Sum @(ADTRep t) @(ADT t Expr) @r (\(ADT a) -> a)
147−
148−
149−type NameADT :: K.Rel8able -> Type
150−type NameADT t = GGName 'K.Sum (ADTRep t) (ADT t Name)
151−
152−
153−nameADT :: forall t. ConstructableADT t => NameADT t
154−nameADT = ggname @'K.Sum @(ADTRep t) @(ADT t Name) ADT
155−
156−
157−type AggregateADT :: K.Rel8able -> Type
158−type AggregateADT t = forall r. GGAggregate 'K.Sum (ADTRep t) r
159−
160−
161−aggregateADT :: forall t. ConstructableADT t
162− => AggregateADT t -> ADT t Expr -> ADT t Aggregate
163−aggregateADT f =
164− ggaggregate @'K.Sum @(ADTRep t) @(ADT t Expr) @(ADT t Aggregate) ADT (\(ADT a) -> a)
165− (f @(ADT t Aggregate))
166−
167−
168−data ADTRep :: K.Rel8able -> K.Context -> Exp (Type -> Type)
169−type instance Eval (ADTRep t context) = GRep t context
170−
171−
172−type GColumnsADT :: K.Rel8able -> K.HTable
173−type GColumnsADT t = G.GColumnsADT TColumns (GRep t Expr)
src/Rel8/Table/Aggregate.hs+17−40
@@ -6,8 +6,9 @@
66{-# language ViewPatterns #-}
77
88module Rel8.Table.Aggregate
9− ( groupBy, hgroupBy
10− , listAgg, nonEmptyAgg
9+ ( groupBy
10+ , listAgg
11+ , nonEmptyAgg
1112 )
1213where
1314
@@ -16,49 +17,25 @@ import Data.Functor.Identity ( Identity( Identity ) )
1617import Prelude
1718
1819-- rel8
19−import Rel8.Aggregate ( Aggregate, Aggregates )
20−import Rel8.Expr ( Expr )
21−import Rel8.Expr.Aggregate
22− ( groupByExpr
23− , slistAggExpr
24− , snonEmptyAggExpr
25− )
20+import Rel8.Aggregate ( Aggregate, Col(..) )
21+import Rel8.Expr ( Expr, Col(..) )
22+import Rel8.Expr.Aggregate ( groupByExpr, listAggExpr, nonEmptyAggExpr )
2623import Rel8.Schema.Dict ( Dict( Dict ) )
27−import Rel8.Schema.HTable ( HTable, hfield, htabulate )
24+import Rel8.Schema.HTable ( htabulate, hfield )
2825import Rel8.Schema.HTable.Vectorize ( hvectorize )
29−import Rel8.Schema.Null ( Sql )
30−import Rel8.Schema.Spec ( Spec( Spec, info ) )
31−import Rel8.Table ( toColumns, fromColumns )
26+import Rel8.Table ( Table, toColumns, fromColumns )
3227import Rel8.Table.Eq ( EqTable, eqTable )
3328import Rel8.Table.List ( ListTable )
3429import Rel8.Table.NonEmpty ( NonEmptyTable )
35−import Rel8.Type.Eq ( DBEq )
3630
3731
3832-- | Group equal tables together. This works by aggregating each column in the
3933-- 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−-- @
52−groupBy :: forall exprs aggregates. (EqTable exprs, Aggregates aggregates exprs)
53− => exprs -> aggregates
54−groupBy = fromColumns . hgroupBy (eqTable @exprs) . toColumns
55−
56−
57−hgroupBy :: HTable t => t (Dict (Sql DBEq)) -> t Expr -> t Aggregate
58−hgroupBy eqs exprs = htabulate $ \field ->
59− case hfield eqs field of
34+groupBy :: forall exprs. EqTable exprs => exprs -> Aggregate exprs
35+groupBy (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
36+ case hfield (eqTable @exprs) field of
6037 Dict -> case hfield exprs field of
61− expr -> groupByExpr expr
38+ DB expr -> Aggregation $ groupByExpr expr
6239
6340
6441-- | Aggregate rows into a single row containing an array of all aggregated
@@ -71,22 +48,22 @@ hgroupBy eqs exprs = htabulate $ \field ->
7148-- items:
7249--
7350-- @
74−-- ordersWithItems :: Query (Order Expr, ListTable Expr (Item Expr))
51+-- ordersWithItems :: Query (Order Expr, ListTable (Item Expr))
7552-- ordersWithItems = do
7653-- order <- each orderSchema
7754-- items <- aggregate $ listAgg <$> itemsFromOrder order
7855-- return (order, items)
7956-- @
80−listAgg :: Aggregates aggregates exprs => exprs -> ListTable Aggregate aggregates
57+listAgg :: Table Expr exprs => exprs -> Aggregate (ListTable exprs)
8158listAgg (toColumns -> exprs) = fromColumns $
8259 hvectorize
83− (\Spec {info} (Identity a) -> slistAggExpr info a)
60+ (\_ (Identity (DB a)) -> Aggregation $ listAggExpr a)
8461 (pure exprs)
8562
8663
8764-- | Like 'listAgg', but the result is guaranteed to be a non-empty list.
88−nonEmptyAgg :: Aggregates aggregates exprs => exprs -> NonEmptyTable Aggregate aggregates
65+nonEmptyAgg :: Table Expr exprs => exprs -> Aggregate (NonEmptyTable exprs)
8966nonEmptyAgg (toColumns -> exprs) = fromColumns $
9067 hvectorize
91− (\Spec {info} (Identity a) -> snonEmptyAggExpr info a)
68+ (\_ (Identity (DB a)) -> Aggregation $ nonEmptyAggExpr a)
9269 (pure exprs)
src/Rel8/Table/Bool.hs+6−12
@@ -5,7 +5,6 @@
55module Rel8.Table.Bool
66 ( bool
77 , case_
8− , nullable
98 )
109where
1110
@@ -13,9 +12,8 @@ where
1312import Prelude
1413
1514-- rel8
16−import Rel8.Expr ( Expr )
15+import Rel8.Expr ( Expr, Col(..) )
1716import Rel8.Expr.Bool ( boolExpr, caseExpr )
18−import Rel8.Expr.Null ( isNull, unsafeUnnullify )
1917import Rel8.Schema.HTable ( htabulate, hfield )
2018import Rel8.Table ( Table, fromColumns, toColumns )
2119
@@ -28,7 +26,8 @@ bool :: Table Expr a => a -> a -> Expr Bool -> a
2826bool (toColumns -> false) (toColumns -> true) condition =
2927 fromColumns $ htabulate $ \field ->
3028 case (hfield false field, hfield true field) of
31− (falseExpr, trueExpr) -> boolExpr falseExpr trueExpr condition
29+ (DB falseExpr, DB trueExpr) ->
30+ DB (boolExpr falseExpr trueExpr condition)
3231{-# INLINABLE bool #-}
3332
3433
@@ -38,11 +37,6 @@ bool (toColumns -> false) (toColumns -> true) condition =
3837case_ :: Table Expr a => [(Expr Bool, a)] -> a -> a
3938case_ (map (fmap toColumns) -> branches) (toColumns -> fallback) =
4039 fromColumns $ htabulate $ \field -> case hfield fallback field of
41− fallbackExpr ->
42− case map (fmap (`hfield` field)) branches of
43− branchExprs -> caseExpr branchExprs fallbackExpr
44−
45−
46−-- | Like 'maybe', but to eliminate @null@.
47−nullable :: Table Expr b => b -> (Expr a -> b) -> Expr (Maybe a) -> b
48−nullable b f ma = bool (f (unsafeUnnullify ma)) b (isNull ma)
40+ DB fallbackExpr ->
41+ case map (fmap (unDB . (`hfield` field))) branches of
42+ branchExprs -> DB (caseExpr branchExprs fallbackExpr)
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+116−154
@@ -3,7 +3,6 @@
33{-# language DerivingStrategies #-}
44{-# language FlexibleContexts #-}
55{-# language FlexibleInstances #-}
6−{-# language LambdaCase #-}
76{-# language MultiParamTypeClasses #-}
87{-# language NamedFieldPuns #-}
98{-# language ScopedTypeVariables #-}
@@ -12,232 +11,195 @@
1211{-# language TypeFamilies #-}
1312{-# language UndecidableInstances #-}
1413
15−{-# options_ghc -fno-warn-orphans #-}
16−
1714module Rel8.Table.Either
1815 ( EitherTable(..)
1916 , eitherTable, leftTable, rightTable
2017 , isLeftTable, isRightTable
21− , aggregateEitherTable
22− , nameEitherTable
18+ , aggregateEitherTable, nameEitherTable
2319 )
2420where
2521
2622-- base
2723import Data.Bifunctor ( Bifunctor, bimap )
28−import Data.Functor.Identity ( Identity( Identity ) )
24+import Data.Functor.Identity ( runIdentity )
2925import Data.Kind ( Type )
3026import Prelude hiding ( undefined )
3127
32−-- comonad
33−import Control.Comonad ( extract )
34−
3528-- rel8
36−import Rel8.Aggregate ( Aggregate )
29+import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )
3730import Rel8.Expr ( Expr )
38−import Rel8.Expr.Aggregate ( groupByExpr )
31+import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
3932import Rel8.Expr.Serialize ( litExpr )
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.Either ( HEitherTable(..) )
33+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler, hlabeler )
34+import Rel8.Schema.Context.Nullify
35+ ( Nullifiable, ConstrainTag
36+ , hencodeTag, hdecodeTag
37+ , hnullifier, hunnullifier
38+ )
39+import Rel8.Schema.HTable.Either ( HEitherTable(..), HEitherNullifiable )
4440import Rel8.Schema.HTable.Identity ( HIdentity(..) )
45−import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
46−import qualified Rel8.Schema.Kind as K
41+import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
42+import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
4743import Rel8.Schema.Name ( Name )
48−import Rel8.Table
49− ( Table, Columns, Context, fromColumns, toColumns
50− , FromExprs, fromResult, toResult
51− , Transpose
52− )
44+import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
5345import Rel8.Table.Bool ( bool )
5446import Rel8.Table.Eq ( EqTable, eqTable )
55−import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )
47+import Rel8.Table.Lifted
48+ ( Table2, Columns2, ConstrainHContext2, fromColumns2, toColumns2
49+ )
5650import Rel8.Table.Ord ( OrdTable, ordTable )
57−import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )
58−import Rel8.Table.Serialize ( ToExprs )
51+import Rel8.Table.Recontextualize ( Recontextualize )
52+import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )
5953import Rel8.Table.Undefined ( undefined )
6054import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
6155
6256-- semigroupoids
63−import Data.Functor.Apply ( Apply, (<.>) )
57+import Data.Functor.Apply ( Apply, (<.>), liftF3 )
6458import Data.Functor.Bind ( Bind, (>>-) )
6559
6660
67−-- | An @EitherTable a b@ is a Rel8 table that contains either the table @a@ or
68−-- the table @b@. You can construct an @EitherTable@ using 'leftTable' and
69−-- 'rightTable', and eliminate/pattern match using 'eitherTable'.
70−--
71−-- An @EitherTable@ is operationally the same as Haskell's 'Either' type, but
72−-- 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
61+type EitherTable :: Type -> Type -> Type
62+data EitherTable a b = EitherTable
63+ { tag :: Tag "isRight" EitherTag
64+ , left :: a
65+ , right :: b
7866 }
7967 deriving stock Functor
8068
8169
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)
89−
70+instance Bifunctor EitherTable where
71+ bimap f g (EitherTable tag a b) = EitherTable tag (f a) (g b)
9072
91−instance Projectable (EitherTable context a) where
92− project f (EitherTable tag a b) = EitherTable tag a (project f b)
9373
94−
95−instance (context ~ Expr, Table Expr a) => Apply (EitherTable context a) where
74+instance Table Expr a => Apply (EitherTable a) where
9675 EitherTable tag l1 f <.> EitherTable tag' l2 a =
97− EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f <.> a)
76+ EitherTable (tag <> tag') (bool l1 l2 (isLeft (expr tag))) (f a)
9877
9978
100−instance (context ~ Expr, Table Expr a) => Applicative (EitherTable context a) where
79+instance Table Expr a => Applicative (EitherTable a) where
10180 pure = rightTable
10281 (<*>) = (<.>)
10382
10483
105−instance (context ~ Expr, Table Expr a) => Bind (EitherTable context a) where
106− EitherTable tag l1 a >>- f = case f (extract a) of
84+instance Table Expr a => Bind (EitherTable a) where
85+ EitherTable tag l1 a >>- f = case f a of
10786 EitherTable tag' l2 b ->
108− EitherTable (tag <> tag') (bool l1 l2 (isRight tag)) b
87+ EitherTable (tag <> tag') (bool l1 l2 (isRight (expr tag))) b
10988
11089
111−instance (context ~ Expr, Table Expr a) => Monad (EitherTable context a) where
90+instance Table Expr a => Monad (EitherTable a) where
11291 (>>=) = (>>-)
11392
11493
115−instance (context ~ Expr, Table Expr a, Table Expr b) =>
116− Semigroup (EitherTable context a b)
117− where
94+instance (Table Expr a, Table Expr b) => Semigroup (EitherTable a b) where
11895 a <> b = bool a b (isRightTable a)
11996
12097
121−instance
122− ( Table context a, Table context b
123− , Reifiable context, context ~ context'
124− )
125− => Table context' (EitherTable context a b)
126− 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− }
98+instance Table2 EitherTable where
99+ type Columns2 EitherTable = HEitherTable
100+ type ConstrainHContext2 EitherTable = HEitherNullifiable
138101
139− fromColumns HEitherTable {htag, hleft, hright} = EitherTable
140− { tag = unHIdentity $ hunlabel htag
141− , left = fromColumns $ hunlabel hleft
142− , right = fromColumns $ hunlabel hright
102+ toColumns2 f g EitherTable {tag, left, right} = HEitherTable
103+ { htag
104+ , hleft = hnullify (hnullifier tag isLeft) $ f left
105+ , hright = hnullify (hnullifier tag isRight) $ g right
143106 }
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))
107+ where
108+ htag = HIdentity (hencodeTag tag)
109+
110+ fromColumns2 f g HEitherTable {htag = htag, hleft, hright} =
111+ EitherTable
112+ { tag
113+ , left = f $ runIdentity $
114+ hunnullify (\a -> pure . hunnullifier a) hleft
115+ , right = g $ runIdentity $
116+ hunnullify (\a -> pure . hunnullifier a) hright
155117 }
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)
161118 where
162− err = error "Either.fromColumns: mismatch between tag and data"
119+ tag = hdecodeTag $ unHIdentity htag
120+
121+ {-# INLINABLE fromColumns2 #-}
122+ {-# INLINABLE toColumns2 #-}
163123
164124
165−instance (EqTable a, EqTable b, context ~ Expr) =>
166− EqTable (EitherTable context a b)
125+instance
126+ ( Table context a, Table context b
127+ , Labelable context, Nullifiable context, ConstrainTag context EitherTag
128+ ) =>
129+ Table context (EitherTable a b)
167130 where
168− eqTable = HEitherTable
169− { htag = hlabel (HIdentity Dict)
170− , hleft = hlabel (eqTable @(Nullify context a))
171− , hright = hlabel (eqTable @(Nullify context b))
172− }
131+ type Columns (EitherTable a b) =
132+ HEitherTable (HLabel "Left" (Columns a)) (HLabel "Right" (Columns b))
133+ type Context (EitherTable a b) = Context a
173134
135+ toColumns =
136+ toColumns2
137+ (hlabel labeler . toColumns)
138+ (hlabel labeler . toColumns)
139+ fromColumns =
140+ fromColumns2
141+ (fromColumns . hunlabel unlabeler)
142+ (fromColumns . hunlabel unlabeler)
143+
144+
145+instance
146+ ( Nullifiable from, Labelable from, ConstrainTag from EitherTag
147+ , Nullifiable to, Labelable to, ConstrainTag to EitherTag
148+ , Recontextualize from to a1 b1
149+ , Recontextualize from to a2 b2
150+ ) =>
151+ Recontextualize from to (EitherTable a1 a2) (EitherTable b1 b2)
174152
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− }
183153
154+instance (EqTable a, EqTable b) => EqTable (EitherTable a b) where
155+ eqTable =
156+ toColumns2 (hlabel hlabeler) (hlabel hlabeler)
157+ (rightTableWith (eqTable @a) (eqTable @b))
184158
185−instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable Expr exprs1 exprs2) =>
186− ToExprs x (Either a b)
187159
160+instance (OrdTable a, OrdTable b) => OrdTable (EitherTable a b) where
161+ ordTable =
162+ toColumns2 (hlabel hlabeler) (hlabel hlabeler)
163+ (rightTableWith (ordTable @a) (ordTable @b))
188164
189−-- | Test if an 'EitherTable' is a 'leftTable'.
190−isLeftTable :: EitherTable Expr a b -> Expr Bool
191−isLeftTable EitherTable {tag} = isLeft tag
192165
166+isLeftTable :: EitherTable a b -> Expr Bool
167+isLeftTable = isLeft . expr . tag
193168
194−-- | Test if an 'EitherTable' is a 'rightTable'.
195−isRightTable :: EitherTable Expr a b -> Expr Bool
196−isRightTable EitherTable {tag} = isRight tag
169+
170+isRightTable :: EitherTable a b -> Expr Bool
171+isRightTable = isRight . expr . tag
197172
198173
199−-- | Pattern match/eliminate an 'EitherTable', by providing mappings from a
200−-- 'leftTable' and 'rightTable'.
201174eitherTable :: Table Expr c
202− => (a -> c) -> (b -> c) -> EitherTable Expr a b -> c
175+ => (a -> c) -> (b -> c) -> EitherTable a b -> c
203176eitherTable f g EitherTable {tag, left, right} =
204− bool (f (extract left)) (g (extract right)) (isRight tag)
177+ bool (f left) (g right) (isRight (expr tag))
205178
206179
207−-- | 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
180+leftTable :: Table Expr b => a -> EitherTable a b
181+leftTable a = EitherTable (fromExpr (litExpr IsLeft)) a undefined
210182
211183
212−-- | Construct a right 'EitherTable'. Like 'Right'.
213−rightTable :: Table Expr a => b -> EitherTable Expr a b
214−rightTable = EitherTable (litExpr IsRight) undefined . pure
184+rightTable :: Table Expr a => b -> EitherTable a b
185+rightTable = rightTableWith undefined
215186
216187
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− }
188+rightTableWith :: a -> b -> EitherTable a b
189+rightTableWith = EitherTable (fromExpr (litExpr IsRight))
229190
230191
231−-- | Construct a 'EitherTable' in the 'Name' context. This can be useful if you
232−-- have a 'EitherTable' that you are storing in a table and need to construct a
233−-- 'TableSchema'.
234−nameEitherTable
235− :: Name EitherTag
236− -- ^ The name of the column to track whether a row is a 'leftTable' or
237− -- 'rightTable'.
238− -> a
239− -- ^ Names of the columns in the @a@ table.
240− -> b
241− -- ^ Names of the columns in the @b@ table.
242− -> EitherTable Name a b
243−nameEitherTable tag left right = EitherTable tag (pure left) (pure right)
192+aggregateEitherTable :: ()
193+ => (a -> Aggregate c)
194+ -> (b -> Aggregate d)
195+ -> EitherTable a b
196+ -> Aggregate (EitherTable c d)
197+aggregateEitherTable f g EitherTable {tag, left, right} =
198+ liftF3 EitherTable (tag <$ aggregate) (f left) (g right)
199+ where
200+ Tag {aggregator, expr} = tag
201+ aggregate = unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr
202+
203+
204+nameEitherTable :: Name EitherTag -> a -> b -> EitherTable a b
205+nameEitherTable = EitherTable . fromName
src/Rel8/Table/Eq.hs+69−38
@@ -5,12 +5,14 @@
55{-# language DisambiguateRecordFields #-}
66{-# language FlexibleContexts #-}
77{-# language FlexibleInstances #-}
8+{-# language LambdaCase #-}
9+{-# language NamedFieldPuns #-}
810{-# language ScopedTypeVariables #-}
911{-# language StandaloneKindSignatures #-}
1012{-# language TypeApplications #-}
1113{-# language TypeFamilies #-}
12−{-# language TypeOperators #-}
1314{-# language UndecidableInstances #-}
15+{-# language UndecidableSuperClasses #-}
1416{-# language ViewPatterns #-}
1517
1618module Rel8.Table.Eq
@@ -23,22 +25,27 @@ import Data.Foldable ( foldl' )
2325import Data.Functor.Const ( Const( Const ), getConst )
2426import Data.Kind ( Constraint, Type )
2527import Data.List.NonEmpty ( NonEmpty( (:|) ) )
26−import GHC.Generics ( Rep )
2728import Prelude
2829
2930-- rel8
30−import Rel8.Expr ( Expr )
31+import Rel8.Expr ( Expr, Col(..) )
3132import Rel8.Expr.Bool ( (||.), (&&.) )
3233import Rel8.Expr.Eq ( (==.), (/=.) )
33−import Rel8.FCF ( Eval, Exp )
34−import Rel8.Generic.Record ( Record )
35−import Rel8.Generic.Table.Record ( GTable, GColumns, gtable )
34+import Rel8.Schema.Context.Label ( hlabeler )
3635import Rel8.Schema.Dict ( Dict( Dict ) )
37−import Rel8.Schema.HTable ( htabulateA, hfield )
38−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
39−import Rel8.Schema.Null ( Sql )
40−import Rel8.Table ( Table, Columns, toColumns, TColumns )
36+import Rel8.Schema.HTable
37+ ( HTable, HConstrainTable
38+ , htabulateA, hfield, hdicts
39+ )
40+import Rel8.Schema.HTable.Label ( hlabel )
41+import Rel8.Schema.HTable.Pair ( HPair(..) )
42+import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
43+import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
44+import Rel8.Schema.HTable.Trio ( HTrio(..) )
45+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
46+import Rel8.Table ( Table, Columns, toColumns )
4147import Rel8.Type.Eq ( DBEq )
48+import Rel8.Schema.Nullability ( Sql )
4249
4350
4451-- | The class of 'Table's that can be compared for equality. Equality on
@@ -46,48 +53,72 @@ import Rel8.Type.Eq ( DBEq )
4653-- means "all columns in a 'Table' have an instance of 'DBEq'".
4754type EqTable :: Type -> Constraint
4855class Table Expr a => EqTable a where
49− eqTable :: Columns a (Dict (Sql DBEq))
56+ eqTable :: Columns a (Dict (ConstrainDBType DBEq))
57+
58+ default eqTable :: ()
59+ => HConstrainTable (Columns a) (ConstrainDBType DBEq)
60+ => Columns a (Dict (ConstrainDBType DBEq))
61+ eqTable = hdicts @(Columns a) @(ConstrainDBType DBEq)
5062
51− default eqTable ::
52− ( GTable TEqTable TColumns (Rep (Record a))
53− , Columns a ~ GColumns TColumns (Rep (Record a))
54− )
55− => Columns a (Dict (Sql DBEq))
56− eqTable = gtable @TEqTable @TColumns @(Rep (Record a)) table
57− where
58− table (_ :: proxy x) = eqTable @x
5963
64+instance
65+ ( Table Expr (t Expr)
66+ , f ~ Expr
67+ , HConstrainTable (Columns (t Expr)) (ConstrainDBType DBEq)
68+ )
69+ => EqTable (t f)
6070
61−data TEqTable :: Type -> Exp Constraint
62−type instance Eval (TEqTable a) = EqTable a
71+
72+instance
73+ ( HTable t
74+ , f ~ Col Expr
75+ , HConstrainTable t (ConstrainDBType DBEq)
76+ )
77+ => EqTable (t f)
6378
6479
65−instance Sql DBEq a => EqTable (Expr a) where
66− eqTable = HIdentity Dict
80+instance Sql DBEq a => EqTable (Expr a)
6781
6882
69−instance (EqTable a, EqTable b) => EqTable (a, b)
83+instance (EqTable a, EqTable b) => EqTable (a, b) where
84+ eqTable =
85+ HPair
86+ { hfst = hlabel hlabeler (eqTable @a)
87+ , hsnd = hlabel hlabeler (eqTable @b)
88+ }
7089
7190
72−instance (EqTable a, EqTable b, EqTable c) => EqTable (a, b, c)
91+instance (EqTable a, EqTable b, EqTable c) => EqTable (a, b, c) where
92+ eqTable =
93+ HTrio
94+ { hfst = hlabel hlabeler (eqTable @a)
95+ , hsnd = hlabel hlabeler (eqTable @b)
96+ , htrd = hlabel hlabeler (eqTable @c)
97+ }
7398
7499
75100instance (EqTable a, EqTable b, EqTable c, EqTable d) => EqTable (a, b, c, d)
101+ where
102+ eqTable =
103+ HQuartet
104+ { hfst = hlabel hlabeler (eqTable @a)
105+ , hsnd = hlabel hlabeler (eqTable @b)
106+ , htrd = hlabel hlabeler (eqTable @c)
107+ , hfrt = hlabel hlabeler (eqTable @d)
108+ }
76109
77110
78111instance (EqTable a, EqTable b, EqTable c, EqTable d, EqTable e) =>
79112 EqTable (a, b, c, d, e)
80−
81−
82−instance (EqTable a, EqTable b, EqTable c, EqTable d, EqTable e, EqTable f) =>
83− EqTable (a, b, c, d, e, f)
84−
85−
86−instance
87− ( EqTable a, EqTable b, EqTable c, EqTable d, EqTable e, EqTable f
88− , EqTable g
89− )
90− => EqTable (a, b, c, d, e, f, g)
113+ where
114+ eqTable =
115+ HQuintet
116+ { hfst = hlabel hlabeler (eqTable @a)
117+ , hsnd = hlabel hlabeler (eqTable @b)
118+ , htrd = hlabel hlabeler (eqTable @c)
119+ , hfrt = hlabel hlabeler (eqTable @d)
120+ , hfft = hlabel hlabeler (eqTable @e)
121+ }
91122
92123
93124-- | Compare two 'Table's for equality. This corresponds to comparing all
@@ -97,7 +128,7 @@ instance
97128(toColumns -> as) ==: (toColumns -> bs) =
98129 foldl1' (&&.) $ getConst $ htabulateA $ \field ->
99130 case (hfield as field, hfield bs field) of
100− (a, b) -> case hfield (eqTable @a) field of
131+ (DB a, DB b) -> case hfield (eqTable @a) field of
101132 Dict -> Const (pure (a ==. b))
102133infix 4 ==:
103134
@@ -109,7 +140,7 @@ infix 4 ==:
109140(toColumns -> as) /=: (toColumns -> bs) =
110141 foldl1' (||.) $ getConst $ htabulateA $ \field ->
111142 case (hfield as field, hfield bs field) of
112− (a, b) -> case hfield (eqTable @a) field of
143+ (DB a, DB b) -> case hfield (eqTable @a) field of
113144 Dict -> Const (pure (a /=. b))
114145infix 4 /=:
115146
src/Rel8/Table/HKD.hsdeleted−228
@@ -1,228 +0,0 @@
1−{-# language AllowAmbiguousTypes #-}
2−{-# language DataKinds #-}
3−{-# language FlexibleContexts #-}
4−{-# language FlexibleInstances #-}
5−{-# language MultiParamTypeClasses #-}
6−{-# language RankNTypes #-}
7−{-# language ScopedTypeVariables #-}
8−{-# language StandaloneKindSignatures #-}
9−{-# language TypeApplications #-}
10−{-# language TypeFamilies #-}
11−{-# language UndecidableInstances #-}
12−{-# language UndecidableSuperClasses #-}
13−
14−module Rel8.Table.HKD
15− ( HKD( HKD )
16− , HKDable
17− , BuildableHKD
18− , BuildHKD, buildHKD
19− , ConstructableHKD
20− , ConstructHKD, constructHKD
21− , DeconstructHKD, deconstructHKD
22− , NameHKD, nameHKD
23− , AggregateHKD, aggregateHKD
24− , HKDRep
25− )
26−where
27−
28−-- base
29−import Data.Kind ( Constraint, Type )
30−import GHC.Generics ( Generic, Rep, from, to )
31−import GHC.TypeLits ( Symbol )
32−import Prelude
33−
34−-- rel8
35−import Rel8.Aggregate ( Aggregate )
36−import Rel8.Column ( TColumn )
37−import Rel8.Expr ( Expr )
38−import Rel8.FCF ( Eval, Exp )
39−import Rel8.Kind.Algebra ( KnownAlgebra )
40−import Rel8.Generic.Construction
41− ( GGBuildable
42− , GGBuild, ggbuild
43− , GGConstructable
44− , GGConstruct, ggconstruct
45− , GGDeconstruct, ggdeconstruct
46− , GGName, ggname
47− , GGAggregate, ggaggregate
48− )
49−import Rel8.Generic.Map ( GMap )
50−import Rel8.Generic.Record
51− ( GRecord, GRecordable, grecord, gunrecord
52− , Record( Record ), unrecord
53− )
54−import Rel8.Generic.Rel8able
55− ( Rel8able
56− , GColumns, gfromColumns, gtoColumns
57− , GFromExprs, gfromResult, gtoResult
58− )
59−import Rel8.Generic.Table
60− ( GGSerialize, GGColumns, GAlgebra, ggfromResult, ggtoResult
61− )
62−import Rel8.Generic.Table.Record ( GTable, GContext )
63−import qualified Rel8.Generic.Table.Record as G
64−import qualified Rel8.Schema.Kind as K
65−import Rel8.Schema.HTable ( HTable )
66−import Rel8.Schema.Name ( Name )
67−import Rel8.Schema.Result ( Result )
68−import Rel8.Table
69− ( Table, fromColumns, toColumns, fromResult, toResult
70− , TTable, TColumns, TContext
71− , TSerialize
72− )
73−
74−
75−type GColumnsHKD :: Type -> K.HTable
76−type GColumnsHKD a =
77− Eval (GGColumns (GAlgebra (Rep a)) TColumns (GRecord (GMap (TColumn Expr) (Rep a))))
78−
79−
80−type HKD :: Type -> K.Rel8able
81−newtype HKD a f = HKD (GColumnsHKD a f)
82−
83−
84−instance HKDable a => Rel8able (HKD a) where
85− type GColumns (HKD a) = GColumnsHKD a
86− type GFromExprs (HKD a) = a
87−
88− gfromColumns _ = HKD
89− gtoColumns _ (HKD a) = a
90−
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
112−
113−
114−instance
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))
119− )
120− => Generic (HKD a f)
121− where
122− type Rep (HKD a f) = GMap (TColumn f) (Rep a)
123−
124− from =
125− gunrecord @(GMap (TColumn f) (Rep a)) .
126− G.gfromColumns
127− @(TTable f)
128− @TColumns
129− fromColumns .
130− (\(HKD a) -> a)
131−
132− to =
133− HKD .
134− G.gtoColumns
135− @(TTable f)
136− @TColumns
137− toColumns .
138− grecord @(GMap (TColumn f) (Rep a))
139−
140−
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
150−instance
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− )
157− => HKDable a
158−
159−
160−type Top_ :: Constraint
161−class Top_
162−instance Top_
163−
164−
165−data Top :: Type -> Exp Constraint
166−type instance Eval (Top _) = Top_
167−
168−
169−type BuildableHKD :: Type -> Symbol -> Constraint
170−class GGBuildable (GAlgebra (Rep a)) name (HKDRep a) => BuildableHKD a name
171−instance GGBuildable (GAlgebra (Rep a)) name (HKDRep a) => BuildableHKD a name
172−
173−
174−type BuildHKD :: Type -> Symbol -> Type
175−type BuildHKD a name = GGBuild (GAlgebra (Rep a)) name (HKDRep a) (HKD a Expr)
176−
177−
178−buildHKD :: forall a name. BuildableHKD a name => BuildHKD a name
179−buildHKD =
180− ggbuild @(GAlgebra (Rep a)) @name @(HKDRep a) @(HKD a Expr) HKD
181−
182−
183−type ConstructableHKD :: Type -> Constraint
184−class GGConstructable (GAlgebra (Rep a)) (HKDRep a) => ConstructableHKD a
185−instance GGConstructable (GAlgebra (Rep a)) (HKDRep a) => ConstructableHKD a
186−
187−
188−type ConstructHKD :: Type -> Type
189−type ConstructHKD a = forall r. GGConstruct (GAlgebra (Rep a)) (HKDRep a) r
190−
191−
192−constructHKD :: forall a. ConstructableHKD a => ConstructHKD a -> HKD a Expr
193−constructHKD f =
194− ggconstruct @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) HKD
195− (f @(HKD a Expr))
196−
197−
198−type DeconstructHKD :: Type -> Type -> Type
199−type DeconstructHKD a r = GGDeconstruct (GAlgebra (Rep a)) (HKDRep a) (HKD a Expr) r
200−
201−
202−deconstructHKD :: forall a r. (ConstructableHKD a, Table Expr r)
203− => DeconstructHKD a r
204−deconstructHKD = ggdeconstruct @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) @r (\(HKD a) -> a)
205−
206−
207−type NameHKD :: Type -> Type
208−type NameHKD a = GGName (GAlgebra (Rep a)) (HKDRep a) (HKD a Name)
209−
210−
211−nameHKD :: forall a. ConstructableHKD a => NameHKD a
212−nameHKD = ggname @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Name) HKD
213−
214−
215−type AggregateHKD :: Type -> Type
216−type AggregateHKD a = forall r. GGAggregate (GAlgebra (Rep a)) (HKDRep a) r
217−
218−
219−aggregateHKD :: forall a. ConstructableHKD a
220− => AggregateHKD a -> HKD a Expr -> HKD a Aggregate
221−aggregateHKD f =
222− ggaggregate @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) @(HKD a Aggregate) HKD (\(HKD a) -> a)
223− (f @(HKD a Aggregate))
224−
225−
226−data HKDRep :: Type -> K.Context -> Exp (Type -> Type)
227−type instance Eval (HKDRep a context) =
228− GRecord (GMap (TColumn context) (Rep a))
src/Rel8/Table/Insert.hsnew file+51
@@ -0,0 +1,51 @@
1+{-# language FlexibleContexts #-}
2+{-# language NamedFieldPuns #-}
3+{-# language TypeFamilies #-}
4+{-# language ViewPatterns #-}
5+
6+module Rel8.Table.Insert
7+ ( toInsert
8+ , toInsertDefaults
9+ )
10+where
11+
12+-- base
13+import Prelude
14+
15+-- rel8
16+import Rel8.Expr ( Col(..) )
17+import Rel8.Kind.Necessity ( SNecessity( SOptional, SRequired ) )
18+import Rel8.Schema.HTable ( hfield, htabulate, hspecs )
19+import Rel8.Schema.Insert ( Inserts, Col(..) )
20+import Rel8.Schema.Spec ( SSpec(..) )
21+import Rel8.Table ( fromColumns, toColumns )
22+
23+
24+-- | @toInsert@ converts a 'Table' of 'Expr's into a 'Table' that can be used
25+-- with 'Rel8.insert'. This will override any columns that have default values
26+-- to use exactly what is given. If you want to use default values, you can
27+-- either override the result of @toInsert@, or use 'toInsertDefaults'.
28+toInsert :: Inserts exprs inserts => exprs -> inserts
29+toInsert (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
30+ case hfield hspecs field of
31+ SSpec {necessity} -> case hfield exprs field of
32+ DB expr -> case necessity of
33+ SRequired -> RequiredInsert expr
34+ SOptional -> OptionalInsert (Just expr)
35+
36+
37+-- | @toInsertDefaults@ converts a 'Table' of 'Expr's into a 'Table' that can
38+-- be used with 'Rel8.insert'. Any columns that have a default value will
39+-- override whatever is in the input expression.
40+--
41+-- One example where this is useful is for any table that has a special @id@
42+-- column, which has a default value to draw a new value from a sequence. If we
43+-- use 'toInsertDefaults', we can provide a dummy value that will be replaced
44+-- with a call to @DEFAULT@.
45+toInsertDefaults :: Inserts exprs inserts => exprs -> inserts
46+toInsertDefaults (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
47+ case hfield hspecs field of
48+ SSpec {necessity} -> case hfield exprs field of
49+ DB expr -> case necessity of
50+ SRequired -> RequiredInsert expr
51+ SOptional -> OptionalInsert Nothing
src/Rel8/Table/Lifted.hsnew file+82
@@ -0,0 +1,82 @@
1+{-# language ConstrainedClassMethods #-}
2+{-# language ConstraintKinds #-}
3+{-# language DataKinds #-}
4+{-# language FlexibleContexts #-}
5+{-# language FlexibleInstances #-}
6+{-# language MultiParamTypeClasses #-}
7+{-# language QuantifiedConstraints #-}
8+{-# language StandaloneKindSignatures #-}
9+{-# language TypeFamilies #-}
10+{-# language UndecidableInstances #-}
11+
12+module Rel8.Table.Lifted
13+ ( Table1( Columns1, ConstrainHContext1, toColumns1, fromColumns1 )
14+ , Table2( Columns2, ConstrainHContext2, toColumns2, fromColumns2 )
15+ , ConstrainContext
16+ )
17+where
18+
19+-- base
20+import Data.Kind ( Constraint, Type )
21+import Prelude ()
22+
23+-- rel8
24+import Rel8.Schema.Context ( Col )
25+import Rel8.Schema.HTable ( HTable )
26+import Rel8.Schema.HTable.Pair
27+import qualified Rel8.Schema.Kind as K
28+
29+
30+type Table1 :: (Type -> Type) -> Constraint
31+class Table1 f where
32+ type Columns1 f :: K.HTable -> K.HTable
33+ type ConstrainHContext1 f :: K.HContext -> Constraint
34+ type ConstrainHContext1 _ = DefaultConstrainContext
35+
36+ toColumns1 :: (ConstrainHContext1 f context, HTable t)
37+ => (a -> t context)
38+ -> f a
39+ -> Columns1 f t context
40+
41+ fromColumns1 :: (ConstrainHContext1 f context, HTable t)
42+ => (t context -> a)
43+ -> Columns1 f t context
44+ -> f a
45+
46+
47+type Table2 :: (Type -> Type -> Type) -> Constraint
48+class Table2 p where
49+ type Columns2 p :: K.HTable -> K.HTable -> K.HTable
50+ type ConstrainHContext2 p :: K.HContext -> Constraint
51+ type ConstrainHContext2 _ = DefaultConstrainContext
52+
53+ toColumns2 :: (ConstrainHContext2 p context, HTable t, HTable u)
54+ => (a -> t context)
55+ -> (b -> u context)
56+ -> p a b
57+ -> Columns2 p t u context
58+
59+ fromColumns2 :: (ConstrainHContext2 p context, HTable t, HTable u)
60+ => (t context -> a)
61+ -> (u context -> b)
62+ -> Columns2 p t u context
63+ -> p a b
64+
65+
66+instance Table2 (,) where
67+ type Columns2 (,) = HPair
68+
69+ toColumns2 f g (a, b) = HPair (f a) (g b)
70+ fromColumns2 f g (HPair a b) = (f a, g b)
71+
72+
73+type DefaultConstrainContext :: K.HContext -> Constraint
74+class DefaultConstrainContext context
75+instance DefaultConstrainContext context
76+
77+
78+type ConstrainContext :: (K.Context -> Constraint) -> K.HContext -> Constraint
79+class (forall context. hcontext ~ Col context => constraint context)
80+ => ConstrainContext constraint hcontext
81+instance (hcontext ~ Col context, constraint context) =>
82+ ConstrainContext constraint hcontext
src/Rel8/Table/List.hs+36−84
@@ -1,4 +1,3 @@
1−{-# language DataKinds #-}
21{-# language FlexibleContexts #-}
32{-# language FlexibleInstances #-}
43{-# language MultiParamTypeClasses #-}
@@ -11,9 +10,7 @@
1110
1211module Rel8.Table.List
1312 ( ListTable(..)
14− , ($*)
1513 , listTable
16− , nameListTable
1714 )
1815where
1916
@@ -23,127 +20,82 @@ import Data.Kind ( Type )
2320import Prelude
2421
2522-- rel8
26−import Rel8.Expr ( Expr )
23+import Rel8.Expr ( Expr, Col(..) )
2724import Rel8.Expr.Array ( sappend, sempty, slistOf )
2825import Rel8.Schema.Dict ( Dict( Dict ) )
2926import 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 ) )
37−import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
38−import Rel8.Schema.Result ( vectorizer, unvectorizer )
39−import Rel8.Schema.Spec ( Spec(..) )
40−import Rel8.Table
41− ( Table, Context, Columns, fromColumns, toColumns
42− , FromExprs, fromResult, toResult
43− , Transpose
44− )
27+import Rel8.Schema.HTable.Vectorize ( happend, hempty, hvectorize )
28+import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
29+import Rel8.Schema.Spec ( SSpec(..) )
30+import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullability )
31+import Rel8.Table ( Table, Context, Columns, fromColumns, toColumns )
4532import Rel8.Table.Alternative
4633 ( AltTable, (<|>:)
4734 , AlternativeTable, emptyTable
4835 )
4936import Rel8.Table.Eq ( EqTable, eqTable )
5037import Rel8.Table.Ord ( OrdTable, ordTable )
51−import Rel8.Table.Projection
52− ( Projectable, Projecting, Projection, project, apply
53− )
54−import Rel8.Table.Serialize ( ToExprs )
38+import Rel8.Table.Recontextualize ( Recontextualize )
5539
5640
5741-- | A @ListTable@ value contains zero or more instances of @a@. You construct
5842-- @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−
43+type ListTable :: Type -> Type
44+newtype ListTable a = ListTable (HListTable (Columns a) (Col (Context a)))
6345
64−instance Projectable (ListTable context) where
65− project f (ListTable a) = ListTable (hproject (apply f) a)
6646
67−
68−instance (Table context a, context ~ context') =>
69− Table context' (ListTable context a)
70− 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)
47+instance Table context a => Table context (ListTable a) where
48+ type Columns (ListTable a) = HListTable (Columns a)
49+ type Context (ListTable a) = Context a
7550
7651 fromColumns = ListTable
7752 toColumns (ListTable a) = a
78− fromResult = fmap (fromResult @_ @a) . hunvectorize unvectorizer
79− toResult = hvectorize vectorizer . fmap (toResult @_ @a)
8053
8154
82−instance (EqTable a, context ~ Expr) => EqTable (ListTable context a) where
55+instance Recontextualize from to a b =>
56+ Recontextualize from to (ListTable a) (ListTable b)
57+
58+
59+instance EqTable a => EqTable (ListTable a) where
8360 eqTable =
8461 hvectorize
85− (\Spec {nullity} (Identity Dict) -> case nullity of
86− Null -> Dict
87− NotNull -> Dict)
62+ (\SSpec {} (Identity dict) -> case dbTypeDict dict of
63+ Dict -> case dbTypeNullability dict of
64+ Nullable -> Dict
65+ NonNullable -> Dict)
8866 (Identity (eqTable @a))
8967
9068
91−instance (OrdTable a, context ~ Expr) => OrdTable (ListTable context a) where
69+instance OrdTable a => OrdTable (ListTable a) where
9270 ordTable =
9371 hvectorize
94− (\Spec {nullity} (Identity Dict) -> case nullity of
95− Null -> Dict
96− NotNull -> Dict)
72+ (\SSpec {} (Identity dict) -> case dbTypeDict dict of
73+ Dict -> case dbTypeNullability dict of
74+ Nullable -> Dict
75+ NonNullable -> Dict)
9776 (Identity (ordTable @a))
9877
9978
100−instance (ToExprs exprs a, context ~ Expr) =>
101− ToExprs (ListTable context exprs) [a]
102−
103−
104−instance context ~ Expr => AltTable (ListTable context) where
79+instance AltTable ListTable where
10580 (<|>:) = (<>)
10681
10782
108−instance context ~ Expr => AlternativeTable (ListTable context) where
83+instance AlternativeTable ListTable where
10984 emptyTable = mempty
11085
11186
112−instance (context ~ Expr, Table Expr a) => Semigroup (ListTable context a)
113− where
114− ListTable as <> ListTable bs = ListTable $ happend (const sappend) as bs
115−
116−
117−instance (context ~ Expr, Table Expr a) =>
118− Monoid (ListTable context a)
119− where
120− mempty = ListTable $ hempty $ \Spec {info} -> sempty info
87+instance Table Expr a => Semigroup (ListTable a) where
88+ ListTable as <> ListTable bs = ListTable $
89+ happend (\_ _ (DB a) (DB b) -> DB (sappend a b)) as bs
12190
12291
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 $*
92+instance Table Expr a => Monoid (ListTable a) where
93+ mempty = ListTable $ hempty $ \nullability info ->
94+ DB (sempty nullability info)
12895
12996
130−-- | Construct a @ListTable@ from a list of expressions.
131−listTable :: Table Expr a => [a] -> ListTable Expr a
97+listTable :: Table Expr a => [a] -> ListTable a
13298listTable =
13399 ListTable .
134− hvectorize (\Spec {info} -> slistOf info) .
100+ hvectorize (\SSpec {info} -> DB . slistOf info . fmap unDB) .
135101 fmap toColumns
136−
137−
138−-- | Construct a 'ListTable' in the 'Name' context. This can be useful if you
139−-- have a 'ListTable' that you are storing in a table and need to construct a
140−-- 'TableSchema'.
141−nameListTable
142− :: Table Name a
143− => a -- ^ The names of the columns of elements of the list.
144− -> ListTable Name a
145−nameListTable =
146− ListTable .
147− hvectorize (\_ (Identity (Name a)) -> Name a) .
148− pure .
149− toColumns
src/Rel8/Table/Maybe.hs+110−124
@@ -15,7 +15,6 @@ module Rel8.Table.Maybe
1515 ( MaybeTable(..)
1616 , maybeTable, nothingTable, justTable
1717 , isNothingTable, isJustTable
18− , fromMaybeTable
1918 , ($?)
2019 , aggregateMaybeTable
2120 , nameMaybeTable
@@ -23,51 +22,51 @@ module Rel8.Table.Maybe
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 )
30−import Prelude hiding ( null, undefined )
31−
32−-- comonad
33−import Control.Comonad ( extract )
27+import Prelude hiding ( null, repeat, undefined, zipWith )
3428
3529-- rel8
36−import Rel8.Aggregate ( Aggregate )
30+import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )
3731import Rel8.Expr ( Expr )
38−import Rel8.Expr.Aggregate ( groupByExpr )
3932import Rel8.Expr.Bool ( boolExpr )
4033import 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
34+import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
35+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler, hlabeler )
36+import Rel8.Schema.Context.Nullify
37+ ( Nullifiable, ConstrainTag
38+ , hencodeTag, hdecodeTag
39+ , hnullifier, hunnullifier
40+ )
4441import Rel8.Schema.HTable.Identity ( HIdentity(..) )
45−import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
46−import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
42+import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
43+import Rel8.Schema.HTable.Maybe ( HMaybeTable(..), HMaybeNullifiable )
44+import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
4745import Rel8.Schema.Name ( Name )
48−import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
49−import qualified Rel8.Schema.Null as N
50−import Rel8.Table
51− ( Table, Columns, Context, fromColumns, toColumns
52− , FromExprs, fromResult, toResult
53− , Transpose
46+import Rel8.Schema.Nullability
47+ ( Nullify
48+ , Nullability( Nullable, NonNullable )
49+ , Sql, nullabilization
5450 )
51+import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
5552import Rel8.Table.Alternative
5653 ( AltTable, (<|>:)
5754 , AlternativeTable, emptyTable
5855 )
5956import Rel8.Table.Bool ( bool )
6057import Rel8.Table.Eq ( EqTable, eqTable )
58+import Rel8.Table.Lifted
59+ ( Table1, Columns1, ConstrainHContext1, fromColumns1, toColumns1
60+ )
6161import 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 )
62+import Rel8.Table.Recontextualize ( Recontextualize )
63+import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )
6564import Rel8.Table.Undefined ( undefined )
6665import Rel8.Type ( DBType )
67−import Rel8.Type.Tag ( MaybeTag( IsJust ) )
66+import Rel8.Type.Tag ( MaybeTag )
6867
6968-- semigroupoids
70−import Data.Functor.Apply ( Apply, (<.>) )
69+import Data.Functor.Apply ( Apply, (<.>), liftF2 )
7170import Data.Functor.Bind ( Bind, (>>-) )
7271
7372
@@ -79,168 +78,155 @@ import Data.Functor.Bind ( Bind, (>>-) )
7978-- entirely of nulls, you can't distinguish if you matched an all null row, or
8079-- if the match failed. For this reason @MaybeTable@ contains an extra field -
8180-- 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
81+type MaybeTable :: Type -> Type
82+data MaybeTable a = MaybeTable
83+ { tag :: Tag "isJust" (Maybe MaybeTag)
84+ , just :: a
8685 }
8786 deriving stock Functor
8887
8988
90−instance Projectable (MaybeTable context) where
91− project f (MaybeTable tag a) = MaybeTable tag (project f a)
92−
93−
94−instance context ~ Expr => Apply (MaybeTable context) where
95− MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f <.> a)
89+instance Apply MaybeTable where
90+ MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f a)
9691
9792
9893-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:
9994-- 'Rel8.traverseMaybeTable'.
100−instance context ~ Expr => Applicative (MaybeTable context) where
95+instance Applicative MaybeTable where
10196 (<*>) = (<.>)
10297 pure = justTable
10398
10499
105−instance context ~ Expr => Bind (MaybeTable context) where
106− MaybeTable tag a >>- f = case f (extract a) of
100+instance Bind MaybeTable where
101+ MaybeTable tag a >>- f = case f a of
107102 MaybeTable tag' b -> MaybeTable (tag <> tag') b
108103
109104
110−-- | Has the same behavior as the @Monad@ instance for @Maybe@.
111−instance context ~ Expr => Monad (MaybeTable context) where
105+-- | Has the same behavior as the @Monad@ instance for @Maybe@. See also:
106+-- 'Rel8.bindMaybeTable'.
107+instance Monad MaybeTable where
112108 (>>=) = (>>-)
113109
114110
115−instance context ~ Expr => AltTable (MaybeTable context) where
116− ma <|>: mb = bool ma mb (isNothingTable ma)
111+instance AltTable MaybeTable where
112+ ma@(MaybeTable tag a) <|>: MaybeTable tag' b = MaybeTable
113+ { tag = (tag <> tag')
114+ { expr = boolExpr (expr tag) (expr tag') condition
115+ }
116+ , just = bool a b condition
117+ }
118+ where
119+ condition = isNothingTable ma
117120
118121
119−instance context ~ Expr => AlternativeTable (MaybeTable context) where
122+instance AlternativeTable MaybeTable where
120123 emptyTable = nothingTable
121124
122125
123−instance (context ~ Expr, Table Expr a, Semigroup a) =>
124− Semigroup (MaybeTable context a)
125− where
126+instance (Table Expr a, Semigroup a) => Semigroup (MaybeTable a) where
126127 ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma
127128
128129
129−instance (context ~ Expr, Table Expr a, Semigroup a) =>
130− Monoid (MaybeTable context a)
131− where
130+instance (Table Expr a, Semigroup a) => Monoid (MaybeTable a) where
132131 mempty = nothingTable
133132
134133
135−instance (Table context a, Reifiable context, context ~ context') =>
136− Table context' (MaybeTable context a)
137− 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− }
134+instance Table1 MaybeTable where
135+ type Columns1 MaybeTable = HMaybeTable
136+ type ConstrainHContext1 MaybeTable = HMaybeNullifiable
147137
148− fromColumns HMaybeTable {htag, hjust} = MaybeTable
149− { tag = unHIdentity $ hunlabel htag
150− , just = fromColumns $ hunlabel hjust
138+ toColumns1 f MaybeTable {tag, just} = HMaybeTable
139+ { htag
140+ , hjust = hnullify (hnullifier tag isNonNull) $ f just
151141 }
142+ where
143+ htag = HIdentity (hencodeTag tag)
152144
153− toResult ma = HMaybeTable
154− { htag = hlabel (HIdentity (Identity (IsJust <$ ma)))
155− , hjust = hlabel (toResult @_ @(Nullify context a) ma)
145+ fromColumns1 f HMaybeTable {htag = HIdentity htag, hjust} = MaybeTable
146+ { tag
147+ , just = f $ runIdentity $
148+ hunnullify (\a -> pure . hunnullifier a) hjust
156149 }
157−
158− fromResult HMaybeTable {htag, hjust} = case hunlabel htag of
159− HIdentity (Identity tag) -> tag $>
160− fromMaybe err (fromResult @_ @(Nullify context a) (hunlabel hjust))
161150 where
162− err = error "Maybe.fromColumns: mismatch between tag and data"
151+ tag = hdecodeTag htag
163152
153+ {-# INLINABLE fromColumns1 #-}
154+ {-# INLINABLE toColumns1 #-}
164155
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− }
170156
157+instance
158+ ( Table context a
159+ , Labelable context, Nullifiable context
160+ , ConstrainTag context MaybeTag
161+ ) => Table context (MaybeTable a)
162+ where
163+ type Columns (MaybeTable a) = HMaybeTable (HLabel "Just" (Columns a))
164+ type Context (MaybeTable a) = Context a
165+
166+ toColumns = toColumns1 (hlabel labeler . toColumns)
167+ fromColumns = fromColumns1 (fromColumns . hunlabel unlabeler)
171168
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− }
169+
170+instance
171+ ( Labelable from, Nullifiable from, ConstrainTag from MaybeTag
172+ , Labelable to, Nullifiable to, ConstrainTag to MaybeTag
173+ , Recontextualize from to a b
174+ ) => Recontextualize from to (MaybeTable a) (MaybeTable b)
177175
178176
179−instance (ToExprs exprs a, context ~ Expr) =>
180− ToExprs (MaybeTable context exprs) (Maybe a)
177+instance EqTable a => EqTable (MaybeTable a) where
178+ eqTable = toColumns1 (hlabel hlabeler) (justTable (eqTable @a))
179+
180+
181+instance OrdTable a => OrdTable (MaybeTable a) where
182+ ordTable = toColumns1 (hlabel hlabeler) (justTable (ordTable @a))
181183
182184
183185-- | 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
186+isNothingTable :: MaybeTable a -> Expr Bool
187+isNothingTable (MaybeTable tag _) = isNull (expr tag)
186188
187189
188190-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.
189−isJustTable :: MaybeTable Expr a -> Expr Bool
190−isJustTable (MaybeTable tag _) = isNonNull tag
191+isJustTable :: MaybeTable a -> Expr Bool
192+isJustTable (MaybeTable tag _) = isNonNull (expr tag)
191193
192194
193195-- | 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)
196+maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable a -> b
197+maybeTable b f ma@(MaybeTable _ a) = bool (f a) b (isNothingTable ma)
196198{-# INLINABLE maybeTable #-}
197199
198200
199201-- | The null table. Like 'Nothing'.
200−nothingTable :: Table Expr a => MaybeTable Expr a
201−nothingTable = MaybeTable null (pure undefined)
202+nothingTable :: Table Expr a => MaybeTable a
203+nothingTable = MaybeTable (fromExpr null) undefined
202204
203205
204206-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use
205207-- '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
208+justTable :: a -> MaybeTable a
209+justTable = MaybeTable (fromExpr mempty)
213210
214211
215212-- | Project a single expression out of a 'MaybeTable'. You can think of this
216213-- operator like the '$' operator, but it also has the ability to return
217214-- @null@.
218215($?) :: forall a b. Sql DBType b
219− => (a -> Expr b) -> MaybeTable Expr a -> Expr (N.Nullify b)
220−f $? 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)
216+ => (a -> Expr b) -> MaybeTable a -> Expr (Nullify b)
217+f $? ma@(MaybeTable _ a) = case nullabilization @b of
218+ Nullable -> boolExpr (f a) null (isNothingTable ma)
219+ NonNullable -> boolExpr (nullify (f a)) null (isNothingTable ma)
223220infixl 4 $?
224221
225222
226−-- | Lift an aggregating function to operate on a 'MaybeTable'.
227−-- @nothingTable@s and @justTable@s are grouped separately.
228223aggregateMaybeTable :: ()
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−
236−-- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you
237−-- have a 'MaybeTable' that you are storing in a table and need to construct a
238−-- 'TableSchema'.
239−nameMaybeTable
240− :: Name (Maybe MaybeTag)
241− -- ^ The name of the column to track whether a row is a 'justTable' or
242− -- 'nothingTable'.
243− -> a
244− -- ^ Names of the columns in @a@.
245− -> MaybeTable Name a
246−nameMaybeTable tag = MaybeTable tag . pure
224+ => (a -> Aggregate b) -> MaybeTable a -> Aggregate (MaybeTable b)
225+aggregateMaybeTable f MaybeTable {tag = tag@Tag {aggregator, expr}, just} =
226+ liftF2 MaybeTable (tag <$ aggregate) (f just)
227+ where
228+ aggregate = unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr
229+
230+
231+nameMaybeTable :: Name (Maybe MaybeTag) -> a -> MaybeTable a
232+nameMaybeTable = MaybeTable . fromName
src/Rel8/Table/Name.hs+22−37
@@ -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 )
@@ -20,60 +17,48 @@ where
2017-- base
2118import Data.Foldable ( fold )
2219import Data.Functor.Const ( Const( Const ), getConst )
23−import Data.List.NonEmpty ( NonEmpty, intersperse, nonEmpty )
24−import Data.Maybe ( fromMaybe )
20+import Data.List.NonEmpty ( NonEmpty, intersperse )
2521import Prelude
2622
23+-- casing
24+import Text.Casing ( quietSnake )
25+
2726-- rel8
27+import Rel8.Expr ( Expr, Col(..) )
28+import Rel8.Kind.Labels ( renderLabels )
2829import 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(..) )
30+import Rel8.Schema.Name ( Name, Col(..) )
31+import Rel8.Schema.Spec ( SSpec(..) )
32+import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
3233
3334
34−-- | Construct a table in the 'Name' context containing the names of all
35−-- columns. Nested column names will be combined with @/@.
36−--
37−-- See also: 'namesFromLabelsWith'.
3835namesFromLabels :: Table Name a => a
3936namesFromLabels = namesFromLabelsWith go
4037 where
41− go = fold . intersperse "/"
38+ go = fold . intersperse "/" . fmap quietSnake
4239
4340
44−-- | Construct a table in the 'Name' context containing the names of all
45−-- columns. The supplied function can be used to transform column names.
46−--
47−-- This function can be used to generically derive the columns for a
48−-- 'TableSchema'. For example,
49−--
50−-- @
51−-- myTableSchema :: TableSchema (MyTable Name)
52−-- myTableSchema = TableSchema
53−-- { columns = namesFromLabelsWith last
54−-- }
55−-- @
56−--
57−-- will construct a 'TableSchema' where each columns names exactly corresponds
58−-- to the name of the Haskell field.
5941namesFromLabelsWith :: Table Name a
6042 => (NonEmpty String -> String) -> a
6143namesFromLabelsWith f = fromColumns $ htabulate $ \field ->
6244 case hfield hspecs field of
63− Spec {labels} -> Name (f (renderLabels labels))
45+ SSpec {labels} -> NameCol (f (renderLabels labels))
46+
47+
48+showExprs :: Table Expr a => a -> [(String, String)]
49+showExprs as = case (namesFromLabels, toColumns as) of
50+ (names, exprs) -> getConst $ htabulateA $ \field ->
51+ case (hfield names field, hfield exprs field) of
52+ (NameCol name, DB expr) -> Const [(name, show expr)]
6453
6554
6655showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]
6756showLabels _ = getConst $
6857 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
69− Spec {labels} -> Const (pure (renderLabels labels))
58+ SSpec {labels} -> Const [renderLabels labels]
7059
7160
72−showNames :: forall a. Table Name a => a -> NonEmpty String
61+showNames :: forall a. Table Name a => a -> [String]
7362showNames (toColumns -> names) = getConst $
7463 htabulateA @(Columns a) $ \field -> case hfield names field of
75− Name name -> Const (pure name)
76−
77−
78−renderLabels :: [String] -> NonEmpty String
79−renderLabels labels = fromMaybe (pure "anon") (nonEmpty labels )
64+ NameCol name -> Const [name]
src/Rel8/Table/NonEmpty.hs+34−85
@@ -1,4 +1,3 @@
1−{-# language DataKinds #-}
21{-# language FlexibleContexts #-}
32{-# language FlexibleInstances #-}
43{-# language MultiParamTypeClasses #-}
@@ -11,9 +10,8 @@
1110
1211module Rel8.Table.NonEmpty
1312 ( NonEmptyTable(..)
14− , ($+)
13+ , HNonEmptyTable
1514 , nonEmptyTable
16− , nameNonEmptyTable
1715 )
1816where
1917
@@ -21,123 +19,74 @@ where
2119import Data.Functor.Identity ( Identity( Identity ) )
2220import Data.Kind ( Type )
2321import Data.List.NonEmpty ( NonEmpty )
24−import Prelude hiding ( id )
22+import Prelude
2523
2624-- rel8
27−import Rel8.Expr ( Expr )
25+import Rel8.Expr ( Expr, Col(..) )
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 ) )
38−import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
39−import Rel8.Schema.Result ( vectorizer, unvectorizer )
40−import Rel8.Schema.Spec ( Spec(..) )
41−import Rel8.Table
42− ( Table, Context, Columns, fromColumns, toColumns
43− , FromExprs, fromResult, toResult
44− , Transpose
45− )
29+import Rel8.Schema.HTable.Vectorize ( happend, hvectorize )
30+import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
31+import Rel8.Schema.Spec ( SSpec(..) )
32+import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullability )
33+import Rel8.Table ( Table, Context, Columns, fromColumns, toColumns )
4634import Rel8.Table.Alternative ( AltTable, (<|>:) )
4735import Rel8.Table.Eq ( EqTable, eqTable )
4836import Rel8.Table.Ord ( OrdTable, ordTable )
49−import Rel8.Table.Projection
50− ( Projectable, Projecting, Projection, project, apply
51− )
52−import Rel8.Table.Serialize ( ToExprs )
37+import Rel8.Table.Recontextualize ( Recontextualize )
5338
5439
5540-- | A @NonEmptyTable@ value contains one or more instances of @a@. You
5641-- 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−
42+type NonEmptyTable :: Type -> Type
43+newtype NonEmptyTable a =
44+ NonEmptyTable (HNonEmptyTable (Columns a) (Col (Context a)))
6145
62−instance Projectable (NonEmptyTable context) where
63− project f (NonEmptyTable a) = NonEmptyTable (hproject (apply f) a)
6446
65−
66−instance (Table context a, context ~ context') =>
67− Table context' (NonEmptyTable context a)
68− 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)
47+instance Table context a => Table context (NonEmptyTable a) where
48+ type Columns (NonEmptyTable a) = HNonEmptyTable (Columns a)
49+ type Context (NonEmptyTable a) = Context a
7450
7551 fromColumns = NonEmptyTable
7652 toColumns (NonEmptyTable a) = a
77− fromResult = fmap (fromResult @_ @a) . hunvectorize unvectorizer
78− toResult = hvectorize vectorizer . fmap (toResult @_ @a)
7953
8054
81−instance (EqTable a, context ~ Expr) =>
82− EqTable (NonEmptyTable context a)
83− where
55+instance Recontextualize from to a b =>
56+ Recontextualize from to (NonEmptyTable a) (NonEmptyTable b)
57+
58+
59+instance EqTable a => EqTable (NonEmptyTable a) where
8460 eqTable =
8561 hvectorize
86− (\Spec {nullity} (Identity Dict) -> case nullity of
87− Null -> Dict
88− NotNull -> Dict)
62+ (\SSpec {} (Identity dict) -> case dbTypeDict dict of
63+ Dict -> case dbTypeNullability dict of
64+ Nullable -> Dict
65+ NonNullable -> Dict)
8966 (Identity (eqTable @a))
9067
9168
92−instance (OrdTable a, context ~ Expr) =>
93− OrdTable (NonEmptyTable context a)
94− where
69+instance OrdTable a => OrdTable (NonEmptyTable a) where
9570 ordTable =
9671 hvectorize
97− (\Spec {nullity} (Identity Dict) -> case nullity of
98− Null -> Dict
99− NotNull -> Dict)
72+ (\SSpec {} (Identity dict) -> case dbTypeDict dict of
73+ Dict -> case dbTypeNullability dict of
74+ Nullable -> Dict
75+ NonNullable -> Dict)
10076 (Identity (ordTable @a))
10177
10278
103−instance (ToExprs exprs a, context ~ Expr) =>
104− ToExprs (NonEmptyTable context exprs) (NonEmpty a)
105−
106−
107−instance context ~ Expr => AltTable (NonEmptyTable context) where
79+instance AltTable NonEmptyTable where
10880 (<|>:) = (<>)
10981
11082
111−instance (Table Expr a, context ~ Expr) => Semigroup (NonEmptyTable context a)
112− where
83+instance Table Expr a => Semigroup (NonEmptyTable a) where
11384 NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $
114− happend (const sappend1) as bs
115−
116−
117−-- | Project a single expression out of a 'NonEmptyTable'.
118−($+) :: Projecting a (Expr b)
119− => Projection a (Expr b) -> NonEmptyTable Expr a -> Expr (NonEmpty b)
120−f $+ NonEmptyTable a = hcolumn $ hproject (apply f) a
121−infixl 4 $+
85+ happend (\_ _ (DB a) (DB b) -> DB (sappend1 a b)) as bs
12286
12387
124−-- | Construct a @NonEmptyTable@ from a non-empty list of expressions.
125−nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable Expr a
88+nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable a
12689nonEmptyTable =
12790 NonEmptyTable .
128− hvectorize (\Spec {info} -> snonEmptyOf info) .
91+ hvectorize (\SSpec {info} -> DB . snonEmptyOf info . fmap unDB) .
12992 fmap toColumns
130−
131−
132−-- | Construct a 'NonEmptyTable' in the 'Name' context. This can be useful if
133−-- you have a 'NonEmptyTable' that you are storing in a table and need to
134−-- construct a 'TableSchema'.
135−nameNonEmptyTable
136− :: Table Name a
137− => a -- ^ The names of the columns of elements of the list.
138− -> NonEmptyTable Name a
139−nameNonEmptyTable =
140− NonEmptyTable .
141− hvectorize (\_ (Identity (Name a)) -> Name a) .
142− pure .
143− 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+68−92
@@ -1,150 +1,126 @@
1−{-# language BlockArguments #-}
2−{-# language DataKinds #-}
31{-# language DisambiguateRecordFields #-}
42{-# language FlexibleContexts #-}
53{-# language NamedFieldPuns #-}
6−{-# language RankNTypes #-}
74{-# language TypeFamilies #-}
85{-# language ViewPatterns #-}
96
10−{-# options_ghc -Wno-deprecations #-}
11−
127module Rel8.Table.Opaleye
138 ( aggregator
14− , attributes
159 , binaryspec
1610 , distinctspec
17− , exprs
18− , exprsWithNames
1911 , table
2012 , tableFields
2113 , unpackspec
2214 , valuesspec
23− , view
24− , castTable
2515 )
2616where
2717
2818-- base
29−import Data.Functor.Const ( Const( Const ), getConst )
30−import Data.List.NonEmpty ( NonEmpty )
31−import Prelude
19+import Prelude hiding ( undefined )
3220
3321-- opaleye
34−import qualified Opaleye.Adaptors as Opaleye
35−import qualified Opaleye.Field as Opaleye ( Field_ )
3622import qualified Opaleye.Internal.Aggregate as Opaleye
23+import qualified Opaleye.Internal.Binary as Opaleye
24+import qualified Opaleye.Internal.Distinct as Opaleye
3725import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
26+import qualified Opaleye.Internal.PackMap as Opaleye
27+import qualified Opaleye.Internal.Unpackspec as Opaleye
3828import qualified Opaleye.Internal.Values as Opaleye
39−import qualified Opaleye.Table as Opaleye
29+import qualified Opaleye.Internal.Table as Opaleye
4030
4131-- profunctors
4232import Data.Profunctor ( dimap, lmap )
4333
4434-- rel8
45−import Rel8.Aggregate ( Aggregate( Aggregate ), Aggregates )
46−import Rel8.Expr ( Expr )
35+import Rel8.Aggregate ( Aggregate( Aggregate ) )
36+import Rel8.Expr ( Expr, Col(..) )
4737import Rel8.Expr.Opaleye
4838 ( fromPrimExpr, toPrimExpr
49− , scastExpr, traverseFieldP
39+ , traversePrimExpr
40+ , fromColumn, toColumn
5041 )
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 )
42+import Rel8.Kind.Necessity ( SNecessity( SRequired, SOptional ) )
43+import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs )
44+import Rel8.Schema.Insert ( Insert, Inserts, Col(..) )
45+import Rel8.Schema.Name ( Name, Selects, Col(..) )
46+import Rel8.Schema.Spec ( SSpec(..) )
47+import Rel8.Schema.Table ( TableSchema(..) )
5648import Rel8.Table ( Table, fromColumns, toColumns )
57−import Rel8.Type.Information ( typeName )
49+import Rel8.Table.Undefined ( undefined )
5850
5951-- semigroupoids
6052import Data.Functor.Apply ( WrappedApplicative(..) )
61−import Data.Profunctor.Product ( ProductProfunctor )
62−
63−
64−aggregator :: Aggregates aggregates exprs => Opaleye.Aggregator aggregates exprs
65−aggregator = dimap toColumns fromColumns $
66− htraverseP $
67− lmap (\(Aggregate a) -> (a, ())) Opaleye.aggregatorApply
68−
6953
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)
7654
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))
55+aggregator :: Opaleye.Aggregator (Aggregate exprs) exprs
56+aggregator = Opaleye.Aggregator $ Opaleye.PackMap $
57+ \f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner))) -> inner f ()
8358
8459
8560binaryspec :: Table Expr a => Opaleye.Binaryspec a a
86−binaryspec = fromOpaleyespec Opaleye.binaryspecField
61+binaryspec = Opaleye.Binaryspec $ Opaleye.PackMap $ \f (as, bs) ->
62+ fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->
63+ WrapApplicative $
64+ case (hfield (toColumns as) field, hfield (toColumns bs) field) of
65+ (DB a, DB b) -> DB . fromPrimExpr <$> f (toPrimExpr a, toPrimExpr b)
8766
8867
8968distinctspec :: 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))
104−
105−
106−table :: Selects names exprs => TableSchema names -> Opaleye.Table exprs exprs
69+distinctspec =
70+ Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap $ \f ->
71+ fmap fromColumns .
72+ unwrapApplicative .
73+ htraverse
74+ (\(DB a) ->
75+ WrapApplicative $ DB . fromPrimExpr <$> f (Nothing, toPrimExpr a)) .
76+ toColumns
77+
78+
79+table ::(Selects names exprs, Inserts exprs inserts)
80+ => TableSchema names -> Opaleye.Table inserts exprs
10781table (TableSchema name schema columns) =
10882 case schema of
109− Nothing -> Opaleye.table name (tableFields columns)
110− Just schemaName -> Opaleye.tableWithSchema schemaName name (tableFields columns)
83+ Nothing -> Opaleye.Table name (tableFields columns)
84+ Just schemaName -> Opaleye.TableWithSchema schemaName name (tableFields columns)
11185
11286
113−tableFields :: Selects names exprs
114− => names -> Opaleye.TableFields exprs exprs
87+tableFields :: (Selects names exprs, Inserts exprs inserts)
88+ => names -> Opaleye.TableFields inserts exprs
11589tableFields (toColumns -> names) = dimap toColumns fromColumns $
11690 unwrapApplicative $ htabulateA $ \field -> WrapApplicative $
117− case hfield names field of
118− name -> lmap (`hfield` field) (go name)
91+ case hfield hspecs field of
92+ specs -> case hfield names field of
93+ name -> lmap (`hfield` field) (go specs name)
11994 where
120− go :: Name a -> Opaleye.TableFields (Expr a) (Expr a)
121− go (Name name) =
122− traverseFieldP $
123− Opaleye.requiredTableField name
95+ go :: SSpec spec -> Col Name spec -> Opaleye.TableFields (Col Insert spec) (Col Expr spec)
96+ go SSpec {necessity} (NameCol name) = case necessity of
97+ SRequired ->
98+ lmap (\(RequiredInsert a) -> toColumn $ toPrimExpr a) $
99+ DB . fromPrimExpr . fromColumn <$>
100+ Opaleye.requiredTableField name
101+ SOptional ->
102+ lmap (\(OptionalInsert ma) -> toColumn . toPrimExpr <$> ma) $
103+ DB . fromPrimExpr . fromColumn <$>
104+ Opaleye.optionalTableField name
124105
125106
126107unpackspec :: Table Expr a => Opaleye.Unpackspec a a
127−unpackspec = fromOpaleyespec Opaleye.unpackspecField
108+unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->
109+ fmap fromColumns .
110+ unwrapApplicative .
111+ htraverse (\(DB a) -> WrapApplicative $ DB <$> traversePrimExpr f a) .
112+ toColumns
128113{-# INLINABLE unpackspec #-}
129114
130115
131−valuesspec :: Table Expr a => Opaleye.Valuesspec a a
132−valuesspec = dimap toColumns fromColumns $
133− htraversePWithField (traverseFieldP . Opaleye.valuesspecFieldType . typeName)
134− where typeName = Rel8.Type.Information.typeName . info . hfield hspecs
135−
136−
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
116+valuesspec :: Table Expr a => Opaleye.ValuesspecSafe a a
117+valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec
141118
142119
143−-- | Transform a table by adding 'CAST' to all columns. This is most useful for
144−-- finalising a SELECT or RETURNING statement, guaranteed that the output
145−-- matches what is encoded in each columns TypeInformation.
146−castTable :: 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
120+toPackMap :: Table Expr a
121+ => a -> Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () a
122+toPackMap as = Opaleye.PackMap $ \f () ->
123+ fmap fromColumns $
124+ unwrapApplicative .
125+ htraverse (\(DB a) -> WrapApplicative $ DB <$> traversePrimExpr f a) $
126+ toColumns as
src/Rel8/Table/Ord.hs+73−45
@@ -2,14 +2,14 @@
22{-# language DataKinds #-}
33{-# language DefaultSignatures #-}
44{-# language DisambiguateRecordFields #-}
5−{-# language FlexibleContexts #-}
65{-# language FlexibleInstances #-}
6+{-# language NamedFieldPuns #-}
77{-# language ScopedTypeVariables #-}
88{-# language StandaloneKindSignatures #-}
99{-# language TypeApplications #-}
1010{-# language TypeFamilies #-}
11−{-# language TypeOperators #-}
1211{-# language UndecidableInstances #-}
12+{-# language UndecidableSuperClasses #-}
1313{-# language ViewPatterns #-}
1414
1515module Rel8.Table.Ord
@@ -20,25 +20,31 @@ where
2020-- base
2121import Data.Functor.Const ( Const( Const ), getConst )
2222import Data.Kind ( Constraint, Type )
23−import GHC.Generics ( Rep )
2423import Prelude hiding ( seq )
2524
2625-- rel8
27−import Rel8.Expr ( Expr )
26+import Rel8.Expr ( Expr, Col(..) )
2827import Rel8.Expr.Bool ( (||.), (&&.), false, true )
2928import Rel8.Expr.Eq ( (==.) )
3029import Rel8.Expr.Ord ( (<.), (>.) )
31−import Rel8.FCF ( Eval, Exp )
32−import Rel8.Generic.Record ( Record )
33−import Rel8.Generic.Table.Record ( GTable, GColumns, gtable )
30+import Rel8.Schema.Context.Label ( hlabeler )
3431import Rel8.Schema.Dict ( Dict( Dict ) )
35−import Rel8.Schema.HTable ( htabulateA, hfield )
36−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
37−import Rel8.Schema.Null (Sql)
38−import Rel8.Table ( Columns, toColumns, TColumns )
32+import Rel8.Schema.HTable
33+ ( HTable, HConstrainTable
34+ , htabulateA, hfield, hdicts
35+ )
36+import Rel8.Schema.HTable.Label ( hlabel )
37+import Rel8.Schema.HTable.Pair ( HPair(..) )
38+import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
39+import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
40+import Rel8.Schema.HTable.Trio ( HTrio(..) )
41+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
42+import Rel8.Table ( Table, Columns, toColumns )
3943import Rel8.Table.Bool ( bool )
4044import Rel8.Table.Eq ( EqTable )
45+import Rel8.Type.Eq ( DBEq )
4146import Rel8.Type.Ord ( DBOrd )
47+import Rel8.Schema.Nullability (Sql)
4248
4349
4450-- | The class of 'Table's that can be ordered. Ordering on tables is defined
@@ -46,50 +52,72 @@ import Rel8.Type.Ord ( DBOrd )
4652-- columns in a 'Table' have an instance of 'DBOrd'".
4753type OrdTable :: Type -> Constraint
4854class EqTable a => OrdTable a where
49− ordTable :: Columns a (Dict (Sql DBOrd))
55+ ordTable :: Columns a (Dict (ConstrainDBType DBOrd))
56+
57+ default ordTable :: HConstrainTable (Columns a) (ConstrainDBType DBOrd) => Columns a (Dict (ConstrainDBType DBOrd))
58+ ordTable = hdicts @(Columns a) @(ConstrainDBType DBOrd)
5059
51− default ordTable ::
52− ( GTable TOrdTable TColumns (Rep (Record a))
53− , Columns a ~ GColumns TColumns (Rep (Record a))
54− )
55− => Columns a (Dict (Sql DBOrd))
56− ordTable = gtable @TOrdTable @TColumns @(Rep (Record a)) table
57− where
58− table (_ :: proxy x) = ordTable @x
60+
61+instance
62+ ( Table Expr (t Expr)
63+ , f ~ Expr
64+ , HConstrainTable (Columns (t Expr)) (ConstrainDBType DBEq)
65+ , HConstrainTable (Columns (t Expr)) (ConstrainDBType DBOrd)
66+ )
67+ => OrdTable (t f)
5968
6069
61−data TOrdTable :: Type -> Exp Constraint
62−type instance Eval (TOrdTable a) = OrdTable a
70+instance
71+ ( HTable t
72+ , f ~ Col Expr
73+ , HConstrainTable t (ConstrainDBType DBEq)
74+ , HConstrainTable t (ConstrainDBType DBOrd)
75+ )
76+ => OrdTable (t f)
6377
6478
65−instance Sql DBOrd a => OrdTable (Expr a) where
66− ordTable = HIdentity Dict
79+instance Sql DBOrd a => OrdTable (Expr a)
6780
6881
69−instance (OrdTable a, OrdTable b) => OrdTable (a, b)
82+instance (OrdTable a, OrdTable b) => OrdTable (a, b) where
83+ ordTable =
84+ HPair
85+ { hfst = hlabel hlabeler (ordTable @a)
86+ , hsnd = hlabel hlabeler (ordTable @b)
87+ }
7088
7189
72−instance (OrdTable a, OrdTable b, OrdTable c) => OrdTable (a, b, c)
90+instance (OrdTable a, OrdTable b, OrdTable c) => OrdTable (a, b, c) where
91+ ordTable =
92+ HTrio
93+ { hfst = hlabel hlabeler (ordTable @a)
94+ , hsnd = hlabel hlabeler (ordTable @b)
95+ , htrd = hlabel hlabeler (ordTable @c)
96+ }
7397
7498
7599instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d) => OrdTable (a, b, c, d)
100+ where
101+ ordTable =
102+ HQuartet
103+ { hfst = hlabel hlabeler (ordTable @a)
104+ , hsnd = hlabel hlabeler (ordTable @b)
105+ , htrd = hlabel hlabeler (ordTable @c)
106+ , hfrt = hlabel hlabeler (ordTable @d)
107+ }
76108
77109
78110instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e) =>
79111 OrdTable (a, b, c, d, e)
80−
81−
82−instance
83− ( OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e, OrdTable f
84− )
85− => OrdTable (a, b, c, d, e, f)
86−
87−
88−instance
89− ( OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e, OrdTable f
90− , OrdTable g
91− )
92− => OrdTable (a, b, c, d, e, f, g)
112+ where
113+ ordTable =
114+ HQuintet
115+ { hfst = hlabel hlabeler (ordTable @a)
116+ , hsnd = hlabel hlabeler (ordTable @b)
117+ , htrd = hlabel hlabeler (ordTable @c)
118+ , hfrt = hlabel hlabeler (ordTable @d)
119+ , hfft = hlabel hlabeler (ordTable @e)
120+ }
93121
94122
95123-- | Test if one 'Table' sorts before another. Corresponds to comparing all
@@ -98,7 +126,7 @@ instance
98126(toColumns -> as) <: (toColumns -> bs) =
99127 foldr @[] go false $ getConst $ htabulateA $ \field ->
100128 case (hfield as field, hfield bs field) of
101− (a, b) -> case hfield (ordTable @a) field of
129+ (DB a, DB b) -> case hfield (ordTable @a) field of
102130 Dict -> Const [(a <. b, a ==. b)]
103131 where
104132 go (lt, eq) a = lt ||. (eq &&. a)
@@ -111,7 +139,7 @@ infix 4 <:
111139(toColumns -> as) <=: (toColumns -> bs) =
112140 foldr @[] go true $ getConst $ htabulateA $ \field ->
113141 case (hfield as field, hfield bs field) of
114− (a, b) -> case hfield (ordTable @a) field of
142+ (DB a, DB b) -> case hfield (ordTable @a) field of
115143 Dict -> Const [(a <. b, a ==. b)]
116144 where
117145 go (lt, eq) a = lt ||. (eq &&. a)
@@ -124,7 +152,7 @@ infix 4 <=:
124152(toColumns -> as) >: (toColumns -> bs) =
125153 foldr @[] go false $ getConst $ htabulateA $ \field ->
126154 case (hfield as field, hfield bs field) of
127− (a, b) -> case hfield (ordTable @a) field of
155+ (DB a, DB b) -> case hfield (ordTable @a) field of
128156 Dict -> Const [(a >. b, a ==. b)]
129157 where
130158 go (gt, eq) a = gt ||. (eq &&. a)
@@ -137,7 +165,7 @@ infix 4 >:
137165(toColumns -> as) >=: (toColumns -> bs) =
138166 foldr @[] go true $ getConst $ htabulateA $ \field ->
139167 case (hfield as field, hfield bs field) of
140− (a, b) -> case hfield (ordTable @a) field of
168+ (DB a, DB b) -> case hfield (ordTable @a) field of
141169 Dict -> Const [(a >. b, a ==. b)]
142170 where
143171 go (gt, eq) a = gt ||. (eq &&. a)
@@ -146,9 +174,9 @@ infix 4 >=:
146174
147175-- | Given two 'Table's, return the table that sorts before the other.
148176least :: OrdTable a => a -> a -> a
149−least a b = bool b a (a <: b)
177+least a b = bool a b (a <: b)
150178
151179
152180-- | Given two 'Table's, return the table that sorts after the other.
153181greatest :: OrdTable a => a -> a -> a
154−greatest a b = bool b a (a >: b)
182+greatest a b = bool a b (a >: b)
src/Rel8/Table/Order.hs+18−14
@@ -16,14 +16,16 @@ import Data.Functor.Contravariant ( (>$<), contramap )
1616import Prelude
1717
1818-- rel8
19+import Rel8.Expr ( unDB )
1920import Rel8.Expr.Order ( asc, desc, nullsFirst, nullsLast )
2021import Rel8.Order ( Order )
2122import Rel8.Schema.Dict ( Dict( Dict ) )
2223import Rel8.Schema.HTable (htabulateA, hfield, hspecs)
23−import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
24−import Rel8.Schema.Spec ( Spec( Spec, nullity ) )
25−import Rel8.Table ( Columns, toColumns )
26−import Rel8.Table.Ord ( OrdTable, ordTable )
24+import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
25+import Rel8.Schema.Spec ( SSpec( SSpec ) )
26+import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullability )
27+import Rel8.Table
28+import Rel8.Table.Ord
2729
2830
2931-- | Construct an 'Order' for a 'Table' by sorting all columns into ascending
@@ -31,11 +33,12 @@ import Rel8.Table.Ord ( OrdTable, ordTable )
3133ascTable :: forall a. OrdTable a => Order a
3234ascTable = contramap toColumns $ getConst $
3335 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
36+ SSpec {} -> case hfield (ordTable @a) field of
37+ dict@Dict -> case dbTypeDict dict of
38+ Dict -> Const $ unDB . (`hfield` field) >$<
39+ case dbTypeNullability dict of
40+ Nullable -> nullsFirst asc
41+ NonNullable -> asc
3942
4043
4144-- | Construct an 'Order' for a 'Table' by sorting all columns into descending
@@ -43,8 +46,9 @@ ascTable = contramap toColumns $ getConst $
4346descTable :: forall a. OrdTable a => Order a
4447descTable = contramap toColumns $ getConst $
4548 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
49+ SSpec {} -> case hfield (ordTable @a) field of
50+ dict@Dict -> case dbTypeDict dict of
51+ Dict -> Const $ unDB . (`hfield` field) >$<
52+ case dbTypeNullability dict of
53+ Nullable -> nullsLast desc
54+ NonNullable -> 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+133
@@ -0,0 +1,133 @@
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.Opaque ( Opaque )
21+import Rel8.Schema.Context ( Col )
22+import Rel8.Schema.Context.Label ( Labelable )
23+import Rel8.Schema.HTable ( HTable )
24+import qualified Rel8.Schema.Kind as K
25+import Rel8.Schema.Nullability ( Sql )
26+import Rel8.Schema.Spec ( KnownSpec )
27+import Rel8.Table ( Table, Congruent )
28+import Rel8.Type ( DBType )
29+
30+
31+type Recontextualize :: K.Context -> K.Context -> Type -> Type -> Constraint
32+class
33+ ( Table from a
34+ , Table to b
35+ , Congruent a b
36+ , Recontextualize from from a a
37+ , Recontextualize to to b b
38+ , Recontextualize to from b a
39+ ) => Recontextualize from to a b
40+ | a -> from
41+ , b -> to
42+ , a to -> b
43+ , b from -> a
44+
45+
46+instance KnownSpec spec =>
47+ Recontextualize from to (Col from spec) (Col to spec)
48+
49+
50+{-
51+instance Sql DBType a =>
52+ Recontextualize Aggregate Insertion (Aggregate (Expr a)) (Insertion a)
53+
54+
55+instance Sql DBType a => Recontextualize Expr Insertion (Expr a) (Insertion a)
56+-}
57+
58+
59+instance Sql DBType a => Recontextualize Identity Identity (Identity a) (Identity a)
60+
61+
62+{-
63+instance Sql DBType a =>
64+ Recontextualize Identity Insertion (Identity a) (Insertion a)
65+
66+
67+instance Sql DBType a =>
68+ Recontextualize Insertion Aggregate (Insertion a) (Aggregate (Expr a))
69+
70+
71+instance Sql DBType a => Recontextualize Insertion Expr (Insertion a) (Expr a)
72+
73+
74+instance Sql DBType a =>
75+ Recontextualize Insertion Identity (Insertion a) (Identity a)
76+
77+
78+instance Sql DBType a => Recontextualize Insertion Insertion (Insertion a) (Insertion a)
79+
80+
81+instance Sql DBType a => Recontextualize Insertion Name (Insertion a) (Name a)
82+
83+
84+instance Sql DBType a => Recontextualize Name Insertion (Name a) (Insertion a)
85+-}
86+
87+
88+instance Recontextualize from to (Opaque from a) (Opaque to a)
89+
90+
91+instance HTable t => Recontextualize from to (t (Col from)) (t (Col to))
92+
93+
94+instance
95+ ( Table from (t from)
96+ , Table to (t to)
97+ , Congruent (t from) (t to)
98+ ) => Recontextualize from to (t from) (t to)
99+
100+
101+instance
102+ ( Recontextualize from to a1 b1
103+ , Recontextualize from to a2 b2
104+ , Labelable from
105+ , Labelable to
106+ ) => Recontextualize from to (a1, a2) (b1, b2)
107+
108+
109+instance
110+ ( Recontextualize from to a1 b1
111+ , Recontextualize from to a2 b2
112+ , Recontextualize from to a3 b3
113+ , Labelable from, Labelable to
114+ ) => Recontextualize from to (a1, a2, a3) (b1, b2, b3)
115+
116+
117+instance
118+ ( Recontextualize from to a1 b1
119+ , Recontextualize from to a2 b2
120+ , Recontextualize from to a3 b3
121+ , Recontextualize from to a4 b4
122+ , Labelable from, Labelable to
123+ ) => Recontextualize from to (a1, a2, a3, a4) (b1, b2, b3, b4)
124+
125+
126+instance
127+ ( Recontextualize from to a1 b1
128+ , Recontextualize from to a2 b2
129+ , Recontextualize from to a3 b3
130+ , Recontextualize from to a4 b4
131+ , Recontextualize from to a5 b5
132+ , Labelable from, Labelable to
133+ ) => Recontextualize from to (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5)
src/Rel8/Table/Rel8able.hsdeleted−92
@@ -1,92 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language FlexibleInstances #-}
3−{-# language MultiParamTypeClasses #-}
4−{-# language ScopedTypeVariables #-}
5−{-# language StandaloneKindSignatures #-}
6−{-# language TypeApplications #-}
7−{-# language TypeFamilies #-}
8−{-# language UndecidableInstances #-}
9−
10−{-# options_ghc -fno-warn-orphans #-}
11−
12−module Rel8.Table.Rel8able
13− (
14− )
15−where
16−
17−-- base
18−import Prelude ()
19−
20−-- rel8
21−import Rel8.Expr ( Expr )
22−import qualified Rel8.Kind.Algebra as K
23−import Rel8.Kind.Context ( Reifiable, contextSing )
24−import Rel8.Generic.Rel8able
25− ( Rel8able, Algebra
26− , GColumns, gfromColumns, gtoColumns
27− , GFromExprs, gfromResult, gtoResult
28− )
29−import qualified Rel8.Schema.Kind as K
30−import Rel8.Schema.HTable ( HConstrainTable, hdicts )
31−import Rel8.Schema.Null ( Sql )
32−import Rel8.Schema.Result ( Result )
33−import Rel8.Table
34− ( Table, Columns, Context, fromColumns, toColumns
35− , FromExprs, fromResult, toResult
36− , Transpose
37− )
38−import Rel8.Table.ADT ( ADT )
39−import Rel8.Table.Eq ( EqTable, eqTable )
40−import Rel8.Table.Ord ( OrdTable, ordTable )
41−import Rel8.Table.Serialize ( ToExprs )
42−import Rel8.Type.Eq ( DBEq )
43−import Rel8.Type.Ord ( DBOrd )
44−
45−
46−instance (Rel8able t, Reifiable context, context ~ context') =>
47− Table context' (t context)
48− where
49− type Columns (t context) = GColumns t
50− type Context (t context) = context
51− type FromExprs (t context) = GFromExprs t
52− type Transpose to (t context) = t to
53−
54− fromColumns = gfromColumns contextSing
55− toColumns = gtoColumns contextSing
56− fromResult = gfromResult @t
57− toResult = gtoResult @t
58−
59−
60−instance
61− ( context ~ Expr
62− , Rel8able t
63− , HConstrainTable (Columns (t context)) (Sql DBEq)
64− )
65− => EqTable (t context)
66− where
67− eqTable = hdicts @(Columns (t context)) @(Sql DBEq)
68−
69−
70−instance
71− ( context ~ Expr
72− , Rel8able t
73− , HConstrainTable (Columns (t context)) (Sql DBEq)
74− , HConstrainTable (Columns (t context)) (Sql DBOrd)
75− )
76− => OrdTable (t context)
77− where
78− ordTable = hdicts @(Columns (t context)) @(Sql DBOrd)
79−
80−
81−instance
82− ( Rel8able t', t' ~ Choose (Algebra t) t
83− , x ~ t' Expr
84− , result ~ Result
85− )
86− => ToExprs x (t result)
87−
88−
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
src/Rel8/Table/Serialize.hs+270−69
@@ -1,4 +1,6 @@
11{-# language AllowAmbiguousTypes #-}
2+{-# language DataKinds #-}
3+{-# language DisambiguateRecordFields #-}
24{-# language FlexibleContexts #-}
35{-# language FlexibleInstances #-}
46{-# language FunctionalDependencies #-}
@@ -7,16 +9,18 @@
79{-# language StandaloneKindSignatures #-}
810{-# language TypeApplications #-}
911{-# language TypeFamilies #-}
12+{-# language ViewPatterns #-}
1013{-# language UndecidableInstances #-}
1114
1215module Rel8.Table.Serialize
13− ( Serializable, lit, litHTable, parse
14− , ToExprs
16+ ( Serializable, lit, parse
17+ , Encodes, litTable
1518 )
1619where
1720
1821-- base
19−import Data.Functor.Identity ( Identity( Identity ) )
22+import Data.Bifunctor ( bimap )
23+import Data.Functor.Identity ( Identity )
2024import Data.Kind ( Constraint, Type )
2125import Data.List.NonEmpty ( NonEmpty )
2226import Prelude
@@ -25,124 +29,321 @@ import Prelude
2529import qualified Hasql.Decoders as Hasql
2630
2731-- rel8
28−import Rel8.Expr ( Expr )
32+import Rel8.Expr ( Expr, Col(..) )
2933import Rel8.Expr.Serialize ( slitExpr, sparseValue )
34+import Rel8.Schema.Context ( Col(..) )
35+import Rel8.Schema.Context.Identity
36+ ( fromHEitherTable, toHEitherTable
37+ , fromHListTable, toHListTable
38+ , fromHMaybeTable, toHMaybeTable
39+ , fromHNonEmptyTable, toHNonEmptyTable
40+ , fromHTheseTable, toHTheseTable
41+ )
42+import Rel8.Schema.Context.Label ( labeler, unlabeler )
3043import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )
31−import 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 )
44+import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
45+import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
46+import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
47+import Rel8.Schema.HTable.Pair ( HPair(..) )
48+import Rel8.Schema.HTable.Trio ( HTrio(..) )
49+import Rel8.Schema.HTable.Type ( HType(..) )
50+import Rel8.Schema.Nullability ( NotNull, Sql )
51+import Rel8.Schema.Spec ( SSpec(..), KnownSpec )
52+import Rel8.Table ( Table, Columns, fromColumns, toColumns )
53+import Rel8.Table.Either ( EitherTable )
54+import Rel8.Table.List ( ListTable )
55+import Rel8.Table.Maybe ( MaybeTable )
56+import Rel8.Table.NonEmpty ( NonEmptyTable )
57+import Rel8.Table.Recontextualize ( Recontextualize )
58+import Rel8.Table.These ( TheseTable )
3559import Rel8.Type ( DBType )
3660
3761-- semigroupoids
3862import Data.Functor.Apply ( WrappedApplicative(..) )
3963
64+-- these
65+import Data.These ( These )
66+
67+
68+fromIdentity' :: forall exprs a. ToExprs a exprs => Columns exprs (Col Identity) -> a
69+fromIdentity' = fromIdentity @_ @exprs
70+
71+
72+toIdentity' :: forall exprs a. ToExprs a exprs => a -> Columns exprs (Col Identity)
73+toIdentity' = toIdentity @_ @exprs
74+
4075
41−-- | @ToExprs exprs a@ is evidence that the types @exprs@ and @a@ describe
42−-- essentially the same type, but @exprs@ is in the 'Expr' context, and @a@ is
43−-- a normal Haskell type.
4476type ToExprs :: Type -> Type -> Constraint
45−class Table Expr exprs => ToExprs exprs a
77+class Table Expr exprs => ToExprs a exprs where
78+ fromIdentity :: Columns exprs (Col Identity) -> a
79+ toIdentity :: a -> Columns exprs (Col Identity)
4680
4781
48−instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a
82+instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs a x where
83+ fromIdentity (HType (Result a)) = a
84+ toIdentity = HType . Result
4985
5086
51−instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a]
87+instance (Sql DBType a, x ~ [a]) => ToExprs [a] (Expr x) where
88+ fromIdentity (HType (Result a)) = a
89+ toIdentity = HType . Result
5290
5391
54−instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a)
92+instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Maybe a) (Expr x)
93+ where
94+ fromIdentity (HType (Result a)) = a
95+ toIdentity = HType . Result
5596
5697
57−instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a)
98+instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (NonEmpty a) (Expr x)
99+ where
100+ fromIdentity (HType (Result a)) = a
101+ toIdentity = HType . Result
58102
59103
60−instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>
61− ToExprs x (a, b)
104+instance (ToExprs a exprs1, ToExprs b exprs2, x ~ EitherTable exprs1 exprs2) =>
105+ ToExprs (Either a b) x
106+ where
107+ fromIdentity =
108+ bimap
109+ (fromIdentity' @exprs1 . hunlabel unlabeler)
110+ (fromIdentity' @exprs2 . hunlabel unlabeler) .
111+ fromHEitherTable
112+ toIdentity =
113+ toHEitherTable .
114+ bimap
115+ (hlabel labeler . toIdentity' @exprs1)
116+ (hlabel labeler . toIdentity' @exprs2)
62117
63118
64−instance
65− ( ToExprs exprs1 a
66− , ToExprs exprs2 b
67− , ToExprs exprs3 c
68− , x ~ (exprs1, exprs2, exprs3)
69− )
70− => ToExprs x (a, b, c)
119+instance ToExprs a exprs => ToExprs [a] (ListTable exprs) where
120+ fromIdentity = fmap (fromIdentity' @exprs) . fromHListTable
121+ toIdentity = toHListTable . fmap (toIdentity' @exprs)
71122
72123
73−instance
74− ( ToExprs exprs1 a
75− , ToExprs exprs2 b
76− , ToExprs exprs3 c
77− , ToExprs exprs4 d
78− , x ~ (exprs1, exprs2, exprs3, exprs4)
79− )
80− => ToExprs x (a, b, c, d)
124+instance ToExprs a exprs => ToExprs (Maybe a) (MaybeTable exprs) where
125+ fromIdentity =
126+ fmap (fromIdentity' @exprs . hunlabel unlabeler) .
127+ fromHMaybeTable
128+ toIdentity =
129+ toHMaybeTable .
130+ fmap (hlabel labeler . toIdentity' @exprs)
131+
132+
133+instance ToExprs a exprs => ToExprs (NonEmpty a) (NonEmptyTable exprs)
134+ where
135+ fromIdentity = fmap (fromIdentity' @exprs) . fromHNonEmptyTable
136+ toIdentity = toHNonEmptyTable . fmap (toIdentity' @exprs)
137+
138+
139+instance (ToExprs a exprs1, ToExprs b exprs2, x ~ TheseTable exprs1 exprs2) =>
140+ ToExprs (These a b) x
141+ where
142+ fromIdentity =
143+ bimap
144+ (fromIdentity' @exprs1 . hunlabel unlabeler)
145+ (fromIdentity' @exprs2 . hunlabel unlabeler) .
146+ fromHTheseTable
147+ toIdentity =
148+ toHTheseTable .
149+ bimap
150+ (hlabel labeler . toIdentity' @exprs1)
151+ (hlabel labeler . toIdentity' @exprs2)
152+
153+
154+instance (ToExprs a exprs1, ToExprs b exprs2, x ~ (exprs1, exprs2)) =>
155+ ToExprs (a, b) x
156+ where
157+ fromIdentity (HPair a b) =
158+ ( fromIdentity' @exprs1 $ hunlabel unlabeler a
159+ , fromIdentity' @exprs2 $ hunlabel unlabeler b
160+ )
161+ toIdentity (a, b) = HPair
162+ { hfst = hlabel labeler $ toIdentity' @exprs1 a
163+ , hsnd = hlabel labeler $ toIdentity' @exprs2 b
164+ }
81165
82166
83167instance
84− ( ToExprs exprs1 a
85− , ToExprs exprs2 b
86− , ToExprs exprs3 c
87− , ToExprs exprs4 d
88− , ToExprs exprs5 e
89− , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
90− )
91− => ToExprs x (a, b, c, d, e)
168+ ( ToExprs a exprs1
169+ , ToExprs b exprs2
170+ , ToExprs c exprs3
171+ , x ~ (exprs1, exprs2, exprs3)
172+ ) => ToExprs (a, b, c) x
173+ where
174+ fromIdentity (HTrio a b c) =
175+ ( fromIdentity' @exprs1 $ hunlabel unlabeler a
176+ , fromIdentity' @exprs2 $ hunlabel unlabeler b
177+ , fromIdentity' @exprs3 $ hunlabel unlabeler c
178+ )
179+ toIdentity (a, b, c) = HTrio
180+ { hfst = hlabel labeler $ toIdentity' @exprs1 a
181+ , hsnd = hlabel labeler $ toIdentity' @exprs2 b
182+ , htrd = hlabel labeler $ toIdentity' @exprs3 c
183+ }
92184
93185
94186instance
95− ( ToExprs exprs1 a
96− , ToExprs exprs2 b
97− , ToExprs exprs3 c
98− , ToExprs exprs4 d
99− , ToExprs exprs5 e
100− , ToExprs exprs6 f
101− , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6)
102− )
103− => ToExprs x (a, b, c, d, e, f)
187+ ( ToExprs a exprs1
188+ , ToExprs b exprs2
189+ , ToExprs c exprs3
190+ , ToExprs d exprs4
191+ , x ~ (exprs1, exprs2, exprs3, exprs4)
192+ ) => ToExprs (a, b, c, d) x
193+ where
194+ fromIdentity (HQuartet a b c d) =
195+ ( fromIdentity' @exprs1 $ hunlabel unlabeler a
196+ , fromIdentity' @exprs2 $ hunlabel unlabeler b
197+ , fromIdentity' @exprs3 $ hunlabel unlabeler c
198+ , fromIdentity' @exprs4 $ hunlabel unlabeler d
199+ )
200+ toIdentity (a, b, c, d) = HQuartet
201+ { hfst = hlabel labeler $ toIdentity' @exprs1 a
202+ , hsnd = hlabel labeler $ toIdentity' @exprs2 b
203+ , htrd = hlabel labeler $ toIdentity' @exprs3 c
204+ , hfrt = hlabel labeler $ toIdentity' @exprs4 d
205+ }
104206
105207
106208instance
107− ( ToExprs exprs1 a
108− , ToExprs exprs2 b
109− , ToExprs exprs3 c
110− , ToExprs exprs4 d
111− , ToExprs exprs5 e
112− , ToExprs exprs6 f
113− , ToExprs exprs7 g
114− , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6, exprs7)
115− )
116− => ToExprs x (a, b, c, d, e, f, g)
209+ ( ToExprs a exprs1
210+ , ToExprs b exprs2
211+ , ToExprs c exprs3
212+ , ToExprs d exprs4
213+ , ToExprs e exprs5
214+ , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
215+ ) => ToExprs (a, b, c, d, e) x
216+ where
217+ fromIdentity (HQuintet a b c d e) =
218+ ( fromIdentity' @exprs1 $ hunlabel unlabeler a
219+ , fromIdentity' @exprs2 $ hunlabel unlabeler b
220+ , fromIdentity' @exprs3 $ hunlabel unlabeler c
221+ , fromIdentity' @exprs4 $ hunlabel unlabeler d
222+ , fromIdentity' @exprs5 $ hunlabel unlabeler e
223+ )
224+ toIdentity (a, b, c, d, e) = HQuintet
225+ { hfst = hlabel labeler $ toIdentity' @exprs1 a
226+ , hsnd = hlabel labeler $ toIdentity' @exprs2 b
227+ , htrd = hlabel labeler $ toIdentity' @exprs3 c
228+ , hfrt = hlabel labeler $ toIdentity' @exprs4 d
229+ , hfft = hlabel labeler $ toIdentity' @exprs5 e
230+ }
231+
232+
233+instance (HTable t, result ~ Col Identity, x ~ t (Col Expr)) =>
234+ ToExprs (t result) x
235+ where
236+ fromIdentity = id
237+ toIdentity = id
238+
239+
240+instance (Recontextualize Identity Expr (t Identity) (t Expr), result ~ Identity, x ~ t Expr) =>
241+ ToExprs (t result) x
242+ where
243+ fromIdentity = fromColumns
244+ toIdentity = toColumns
245+
246+
247+instance (KnownSpec spec, x ~ Col Expr spec) =>
248+ ToExprs (Col Identity spec) x
249+ where
250+ fromIdentity = fromColumns
251+ toIdentity = toColumns
252+
253+
254+type FromExprs :: Type -> Type
255+type family FromExprs a where
256+ FromExprs (Expr a) = a
257+ FromExprs (Col Expr spec) = Col Identity spec
258+ FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
259+ FromExprs (ListTable a) = [FromExprs a]
260+ FromExprs (MaybeTable a) = Maybe (FromExprs a)
261+ FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)
262+ FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
263+ FromExprs (a, b) = (FromExprs a, FromExprs b)
264+ FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)
265+ FromExprs (a, b, c, d) =
266+ (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
267+ FromExprs (a, b, c, d, e) =
268+ (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
269+ FromExprs (t Expr) = t Identity
270+ FromExprs (t (Col Expr)) = t (Col Identity)
117271
118272
119273-- | @Serializable@ witnesses the one-to-one correspondence between the type
120274-- @sql@, which contains SQL expressions, and the type @haskell@, which
121275-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
122276type Serializable :: Type -> Type -> Constraint
123−class (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
124−instance (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a
277+class (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
278+instance (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a
125279instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a
126280
127281
128282-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is
129283-- capable of lifting single @Expr@s to full tables.
130284lit :: forall exprs a. Serializable exprs a => a -> exprs
131−lit = fromColumns . litHTable . toResult @_ @exprs
285+lit = fromColumns . litHTable . toIdentity' @exprs
132286
133287
134288parse :: forall exprs a. Serializable exprs a => Hasql.Row a
135−parse = fromResult @_ @exprs <$> parseHTable
289+parse = fromIdentity' @exprs <$> parseHTable
290+
291+
292+type Encodes :: Type -> Type -> Constraint
293+class Serializable exprs a => Encodes a exprs | a -> exprs, exprs -> a
294+
295+
296+instance KnownSpec spec => Encodes (Col Identity spec) (Col Expr spec)
297+
298+
299+instance Serializable (t Identity) (t Expr) => Encodes (t Expr) (t Identity)
300+
301+
302+instance HTable t => Encodes (t (Col Identity)) (t (Col Expr))
303+
304+
305+instance (Encodes a x, Encodes b y) => Encodes (Either a b) (EitherTable x y)
306+
307+
308+instance Encodes a x => Encodes [a] (ListTable x)
309+
310+
311+instance Encodes a x => Encodes (Maybe a) (MaybeTable x)
312+
313+
314+instance Encodes a x => Encodes (NonEmpty a) (NonEmptyTable x)
315+
316+
317+instance (Encodes a x, Encodes b y) => Encodes (These a b) (TheseTable x y)
318+
319+
320+instance (Encodes a x, Encodes b y) => Encodes (a, b) (x, y)
321+
322+
323+instance (Encodes a x, Encodes b y, Encodes c z) =>
324+ Encodes (a, b, c) (x, y, z)
325+
326+
327+instance (Encodes a w, Encodes b x, Encodes c y, Encodes d z) =>
328+ Encodes (a, b, c, d) (w, x, y, z)
329+
330+
331+instance (Encodes a v, Encodes b w, Encodes c x, Encodes d y, Encodes e z) =>
332+ Encodes (a, b, c, d, e) (v, w, x, y, z)
333+
334+
335+litTable :: Encodes a exprs => a -> exprs
336+litTable = lit
136337
137338
138−litHTable :: HTable t => t Result -> t Expr
339+litHTable :: HTable t => t (Col Identity) -> t (Col Expr)
139340litHTable as = htabulate $ \field ->
140341 case hfield hspecs field of
141− Spec {nullity, info} -> case hfield as field of
142− Identity value -> slitExpr nullity info value
342+ SSpec {nullability, info} -> case hfield as field of
343+ Result value -> DB (slitExpr nullability info value)
143344
144345
145−parseHTable :: HTable t => Hasql.Row (t Result)
346+parseHTable :: HTable t => Hasql.Row (t (Col Identity))
146347parseHTable = unwrapApplicative $ htabulateA $ \field ->
147348 WrapApplicative $ case hfield hspecs field of
148− Spec {nullity, info} -> Identity <$> sparseValue nullity info
349+ SSpec {nullability, info} -> Result <$> sparseValue nullability info
src/Rel8/Table/Tag.hsnew file+104
@@ -0,0 +1,104 @@
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.Dict ( Dict( Dict ) )
33+import Rel8.Schema.Name ( Name( Name ) )
34+import Rel8.Schema.Nullability ( Sql, mapSql )
35+import Rel8.Type.Monoid ( DBMonoid )
36+import Rel8.Type.Semigroup ( DBSemigroup )
37+
38+
39+type Tag :: Symbol -> Type -> Type
40+data Tag label a = Tag
41+ { expr :: Expr a
42+ , aggregator :: Maybe Aggregator
43+ , name :: Name a
44+ }
45+
46+
47+type Taggable :: Type -> Constraint
48+class Taggable a where
49+ tappend :: KnownSymbol label => Tag label a -> Tag label a -> Tag label a
50+ tempty :: KnownSymbol label => Tag label a
51+
52+
53+instance Sql DBMonoid a => Taggable a where
54+ tappend :: forall label. KnownSymbol label
55+ => Tag label a -> Tag label a -> Tag label a
56+ tappend a b = Tag
57+ { expr = case mapSql dbSemigroupFromDBMonoid (Dict @_ @a) of
58+ Dict -> expr a <> expr b
59+ , aggregator = aggregator a <|> aggregator b
60+ , name = case (name a, symbolVal (Proxy @label)) of
61+ (Name x, y)
62+ | x == y -> name b
63+ | otherwise -> name a
64+ }
65+ {-# INLINABLE tappend #-}
66+
67+ tempty :: forall label. KnownSymbol label => Tag label a
68+ tempty = Tag
69+ { expr = mempty
70+ , aggregator = empty
71+ , name = Name (symbolVal (Proxy @label))
72+ }
73+ {-# INLINABLE tempty #-}
74+
75+
76+instance (KnownSymbol label, Taggable a) => Semigroup (Tag label a) where
77+ (<>) = tappend
78+
79+
80+instance (KnownSymbol label, Taggable a) => Monoid (Tag label a) where
81+ mempty = tempty
82+
83+
84+fromAggregate :: forall a label. (KnownSymbol label, Taggable a)
85+ => Aggregate (Expr a) -> Tag label a
86+fromAggregate = fold . getFirst . foldInputs go
87+ where
88+ go aggregator primExpr = pure $ (tempty @a @label)
89+ { expr = fromPrimExpr primExpr
90+ , aggregator
91+ }
92+
93+
94+fromExpr :: forall label a. (KnownSymbol label, Taggable a)
95+ => Expr a -> Tag label a
96+fromExpr expr = (tempty @a @label) {expr}
97+
98+
99+fromName :: forall a label. Taggable a => Name a -> Tag label a
100+fromName name = (tempty @a @"") {name}
101+
102+
103+dbSemigroupFromDBMonoid :: Dict DBMonoid a -> Dict DBSemigroup a
104+dbSemigroupFromDBMonoid Dict = Dict
src/Rel8/Table/These.hs+133−211
@@ -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 #-}
@@ -12,115 +13,87 @@
1213{-# language TypeFamilies #-}
1314{-# language UndecidableInstances #-}
1415
15−{-# options_ghc -fno-warn-orphans #-}
16−
1716module Rel8.Table.These
1817 ( TheseTable(..)
1918 , theseTable, thisTable, thatTable, thoseTable
2019 , isThisTable, isThatTable, isThoseTable
2120 , hasHereTable, hasThereTable
2221 , justHereTable, justThereTable
23− , alignMaybeTable
24− , aggregateTheseTable
25− , nameTheseTable
22+ , aggregateTheseTable, nameTheseTable
2623 )
2724where
2825
2926-- base
3027import Data.Bifunctor ( Bifunctor, bimap )
28+import Data.Functor.Identity ( runIdentity )
3129import Data.Kind ( Type )
32−import Data.Maybe ( isJust )
33−import Prelude hiding ( null, undefined )
30+import Prelude hiding ( undefined )
3431
3532-- rel8
3633import Rel8.Aggregate ( Aggregate )
3734import 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 )
35+import Rel8.Expr.Bool ( (&&.), not_ )
36+import Rel8.Expr.Null ( isNonNull )
37+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler, hlabeler )
38+import Rel8.Schema.Context.Nullify
39+ ( Nullifiable, ConstrainTag
40+ , hencodeTag, hdecodeTag
41+ , hnullifier, hunnullifier
42+ )
43+import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
4444import Rel8.Schema.HTable.Identity ( HIdentity(..) )
45−import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
45+import Rel8.Schema.HTable.Maybe ( HMaybeNullifiable )
46+import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
4647import Rel8.Schema.HTable.These ( HTheseTable(..) )
47−import qualified Rel8.Schema.Kind as K
48−import Rel8.Schema.Name ( Name )
49−import Rel8.Table
50− ( Table, Columns, Context, fromColumns, toColumns
51− , FromExprs, fromResult, toResult
52− , Transpose
53− )
48+import Rel8.Schema.Name ( Name )
49+import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
5450import Rel8.Table.Eq ( EqTable, eqTable )
51+import Rel8.Table.Lifted
52+ ( Table2, Columns2, ConstrainHContext2, fromColumns2, toColumns2
53+ )
5554import Rel8.Table.Maybe
5655 ( MaybeTable(..)
5756 , maybeTable, justTable, nothingTable
5857 , isJustTable
59− , aggregateMaybeTable
60− , nameMaybeTable
58+ , aggregateMaybeTable, nameMaybeTable
6159 )
62−import Rel8.Table.Nullify ( Nullify, guard )
6360import Rel8.Table.Ord ( OrdTable, ordTable )
64−import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )
65−import Rel8.Table.Serialize ( ToExprs )
61+import Rel8.Table.Recontextualize ( Recontextualize )
62+import Rel8.Table.Tag ( Tag(..) )
6663import Rel8.Table.Undefined ( undefined )
6764import Rel8.Type.Tag ( MaybeTag )
6865
6966-- semigroupoids
70−import Data.Functor.Apply ( Apply, (<.>) )
67+import Data.Functor.Apply ( Apply, (<.>), liftF2 )
7168import Data.Functor.Bind ( Bind, (>>-) )
7269
73−-- these
74−import Data.These ( These( This, That, These ) )
75−import Data.These.Combinators ( justHere, justThere )
76−
77−
78−-- | @TheseTable a b@ is a Rel8 table that contains either the table @a@, the
79−-- table @b@, or both tables @a@ and @b@. You can construct @TheseTable@s using
80−-- 'thisTable', 'thatTable' and 'thoseTable'. @TheseTable@s can be
81−-- eliminated/pattern matched using 'theseTable'.
82−--
83−-- @TheseTable@ is operationally the same as Haskell's 'These' type, but
84−-- 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
70+
71+type TheseTable :: Type -> Type -> Type
72+data TheseTable a b = TheseTable
73+ { here :: MaybeTable a
74+ , there :: MaybeTable b
8975 }
9076 deriving stock Functor
9177
9278
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
79+instance Bifunctor TheseTable where
9880 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
9981
10082
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
83+instance (Table Expr a, Semigroup a) => Apply (TheseTable a) where
10884 fs <.> as = TheseTable
10985 { here = here fs <> here as
11086 , there = there fs <.> there as
11187 }
11288
11389
114−instance (context ~ Expr, Table Expr a, Semigroup a) =>
115− Applicative (TheseTable context a)
90+instance (Table Expr a, Semigroup a) => Applicative (TheseTable a)
11691 where
11792 pure = thatTable
11893 (<*>) = (<.>)
11994
12095
121−instance (context ~ Expr, Table Expr a, Semigroup a) =>
122− Bind (TheseTable context a)
123− where
96+instance (Table Expr a, Semigroup a) => Bind (TheseTable a) where
12497 TheseTable here1 ma >>- f = case ma >>- f' of
12598 mtb -> TheseTable
12699 { here = maybeTable here1 ((here1 <>) . fst) mtb
@@ -131,14 +104,12 @@ instance (context ~ Expr, Table Expr a, Semigroup a) =>
131104 TheseTable here2 mb -> (here2,) <$> mb
132105
133106
134−instance (context ~ Expr, Table Expr a, Semigroup a) =>
135− Monad (TheseTable context a)
136− where
107+instance (Table Expr a, Semigroup a) => Monad (TheseTable a) where
137108 (>>=) = (>>-)
138109
139110
140−instance (context ~ Expr, Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
141− Semigroup (TheseTable context a b)
111+instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
112+ Semigroup (TheseTable a b)
142113 where
143114 a <> b = TheseTable
144115 { here = here a <> here b
@@ -146,177 +117,139 @@ instance (context ~ Expr, Table Expr a, Table Expr b, Semigroup a, Semigroup b)
146117 }
147118
148119
149−instance
150− ( Table context a, Table context b
151− , Reifiable context, context ~ context'
152− )
153− => Table context' (TheseTable context a b)
154− 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
120+instance Table2 TheseTable where
121+ type Columns2 TheseTable = HTheseTable
122+ type ConstrainHContext2 TheseTable = HMaybeNullifiable
123+
124+ toColumns2 f g TheseTable {here, there} = HTheseTable
125+ { hhereTag = HIdentity $ hencodeTag (toHereTag (tag here))
164126 , hhere =
165− hlabel $ guard (tag here) isJust isNonNull $ toColumns $ just here
166− , hthereTag = hlabel $ HIdentity $ tag there
127+ hnullify (hnullifier (tag here) isNonNull) $ f (just here)
128+ , hthereTag = HIdentity $ hencodeTag (toThereTag (tag there))
167129 , hthere =
168− hlabel $ guard (tag there) isJust isNonNull $ toColumns $ just there
130+ hnullify (hnullifier (tag there) isNonNull) $ g (just there)
169131 }
170132
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− }
133+ fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} =
134+ TheseTable
135+ { here =
136+ let
137+ tag = hdecodeTag $ unHIdentity hhereTag
138+ in
139+ MaybeTable
140+ { tag
141+ , just = f $
142+ runIdentity $
143+ hunnullify (\a -> pure . hunnullifier a)
144+ hhere
145+ }
146+ , there =
147+ let
148+ tag = hdecodeTag $ unHIdentity hthereTag
149+ in
150+ MaybeTable
151+ { tag
152+ , just = g $
153+ runIdentity $
154+ hunnullify (\a -> pure . hunnullifier a)
155+ hthere
156+ }
157+ }
181158
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− }
159+ {-# INLINABLE fromColumns2 #-}
160+ {-# INLINABLE toColumns2 #-}
226161
227162
228−instance (OrdTable a, OrdTable b, context ~ Expr) =>
229− OrdTable (TheseTable context a b)
163+instance
164+ ( Table context a, Table context b
165+ , Labelable context, Nullifiable context, ConstrainTag context MaybeTag
166+ ) => Table context (TheseTable a b)
230167 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− }
168+ type Columns (TheseTable a b) =
169+ HTheseTable (HLabel "Here" (Columns a)) (HLabel "There" (Columns b))
170+ type Context (TheseTable a b) = Context a
171+
172+ toColumns =
173+ toColumns2
174+ (hlabel labeler . toColumns)
175+ (hlabel labeler . toColumns)
176+ fromColumns =
177+ fromColumns2
178+ (fromColumns . hunlabel unlabeler)
179+ (fromColumns . hunlabel unlabeler)
180+
181+
182+instance
183+ ( Labelable from, Nullifiable from, ConstrainTag from MaybeTag
184+ , Labelable to, Nullifiable to, ConstrainTag to MaybeTag
185+ , Recontextualize from to a1 b1
186+ , Recontextualize from to a2 b2
187+ ) =>
188+ Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2)
189+
190+
191+instance (EqTable a, EqTable b) => EqTable (TheseTable a b) where
192+ eqTable =
193+ toColumns2 (hlabel hlabeler) (hlabel hlabeler)
194+ (thoseTable (eqTable @a) (eqTable @b))
195+
196+
197+instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where
198+ ordTable =
199+ toColumns2 (hlabel hlabeler) (hlabel hlabeler)
200+ (thoseTable (ordTable @a) (ordTable @b))
237201
238202
239−instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable Expr exprs1 exprs2) =>
240− ToExprs x (These a b)
203+toHereTag :: Tag "isJust" a -> Tag "hasHere" a
204+toHereTag Tag {..} = Tag {..}
241205
242206
243−-- | Test if a 'TheseTable' was constructed with 'thisTable'.
244−--
245−-- Corresponds to 'Data.These.Combinators.isThis'.
246−isThisTable :: TheseTable Expr a b -> Expr Bool
207+toThereTag :: Tag "isJust" a -> Tag "hasThere" a
208+toThereTag Tag {..} = Tag {..}
209+
210+
211+isThisTable :: TheseTable a b -> Expr Bool
247212isThisTable a = hasHereTable a &&. not_ (hasThereTable a)
248213
249214
250−-- | Test if a 'TheseTable' was constructed with 'thatTable'.
251−--
252−-- Corresponds to 'Data.These.Combinators.isThat'.
253−isThatTable :: TheseTable Expr a b -> Expr Bool
215+isThatTable :: TheseTable a b -> Expr Bool
254216isThatTable a = not_ (hasHereTable a) &&. hasThereTable a
255217
256218
257−-- | Test if a 'TheseTable' was constructed with 'thoseTable'.
258−--
259−-- Corresponds to 'Data.These.Combinators.isThese'.
260−isThoseTable :: TheseTable Expr a b -> Expr Bool
219+isThoseTable :: TheseTable a b -> Expr Bool
261220isThoseTable a = hasHereTable a &&. hasThereTable a
262221
263222
264−-- | Test if the @a@ side of @TheseTable a b@ is present.
265−--
266−-- Corresponds to 'Data.These.Combinators.hasHere'.
267−hasHereTable :: TheseTable Expr a b -> Expr Bool
223+hasHereTable :: TheseTable a b -> Expr Bool
268224hasHereTable TheseTable {here} = isJustTable here
269225
270226
271−-- | Test if the @b@ table of @TheseTable a b@ is present.
272−--
273−-- Corresponds to 'Data.These.Combinators.hasThere'.
274−hasThereTable :: TheseTable Expr a b -> Expr Bool
227+hasThereTable :: TheseTable a b -> Expr Bool
275228hasThereTable TheseTable {there} = isJustTable there
276229
277230
278−-- | Attempt to project out the @a@ table of a @TheseTable a b@.
279−--
280−-- Corresponds to 'Data.These.Combinators.justHere'.
281−justHereTable :: TheseTable context a b -> MaybeTable context a
231+justHereTable :: TheseTable a b -> MaybeTable a
282232justHereTable = here
283233
284234
285−-- | Attempt to project out the @b@ table of a @TheseTable a b@.
286−--
287−-- Corresponds to 'Data.These.Combinators.justThere'.
288−justThereTable :: TheseTable context a b -> MaybeTable context b
235+justThereTable :: TheseTable a b -> MaybeTable b
289236justThereTable = there
290237
291238
292−-- | Construct a @TheseTable@ from two 'MaybeTable's.
293−alignMaybeTable :: ()
294− => MaybeTable Expr a
295− -> MaybeTable Expr b
296− -> MaybeTable Expr (TheseTable Expr a b)
297−alignMaybeTable a b = MaybeTable tag (pure (TheseTable a b))
298− where
299− tag = boolExpr null mempty (isJustTable a ||. isJustTable b)
300−
301−
302−-- | Construct a @TheseTable@. Corresponds to 'This'.
303−thisTable :: Table Expr b => a -> TheseTable Expr a b
239+thisTable :: Table Expr b => a -> TheseTable a b
304240thisTable a = TheseTable (justTable a) nothingTable
305241
306242
307−-- | Construct a @TheseTable@. Corresponds to 'That'.
308−thatTable :: Table Expr a => b -> TheseTable Expr a b
243+thatTable :: Table Expr a => b -> TheseTable a b
309244thatTable b = TheseTable nothingTable (justTable b)
310245
311246
312−-- | Construct a @TheseTable@. Corresponds to 'These'.
313−thoseTable :: a -> b -> TheseTable Expr a b
247+thoseTable :: a -> b -> TheseTable a b
314248thoseTable a b = TheseTable (justTable a) (justTable b)
315249
316250
317−-- | 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,32 +257,21 @@ 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.
329260aggregateTheseTable :: ()
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− }
261+ => (a -> Aggregate c)
262+ -> (b -> Aggregate d)
263+ -> TheseTable a b
264+ -> Aggregate (TheseTable c d)
265+aggregateTheseTable f g TheseTable {here, there} =
266+ liftF2 TheseTable (aggregateMaybeTable f here) (aggregateMaybeTable g there)
338267
339268
340−-- | Construct a 'TheseTable' in the 'Name' context. This can be useful if you
341−-- have a 'TheseTable' that you are storing in a table and need to construct a
342−-- 'TableSchema'.
343269nameTheseTable :: ()
344270 => Name (Maybe MaybeTag)
345− -- ^ The name of the column to track the presence of the @a@ table.
346271 -> Name (Maybe MaybeTag)
347− -- ^ The name of the column to track the presence of the @b@ table.
348272 -> a
349− -- ^ Names of the columns in the @a@ table.
350273 -> b
351− -- ^ Names of the columns in the @b@ table.
352− -> TheseTable Name a b
274+ -> TheseTable a b
353275nameTheseTable here there a b =
354276 TheseTable
355277 { here = nameMaybeTable here a
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+6−6
@@ -11,16 +11,16 @@ where
1111import Prelude hiding ( undefined )
1212
1313-- rel8
14−import Rel8.Expr ( Expr )
14+import Rel8.Expr ( Expr, Col(..) )
1515import Rel8.Expr.Null ( snull, unsafeUnnullify )
1616import Rel8.Schema.HTable ( htabulate, hfield, hspecs )
17−import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
18−import Rel8.Schema.Spec ( Spec(..) )
17+import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
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 {nullability, info} -> case nullability of
25+ Nullable -> DB (snull info)
26+ NonNullable -> DB (unsafeUnnullify (snull info))
src/Rel8/Table/Window.hsdeleted−43
@@ -1,43 +0,0 @@
1−{-# language MonoLocalBinds #-}
2−
3−module Rel8.Table.Window
4− ( cumulative
5− , cumulative_
6− , currentRow
7− )
8−where
9−
10−-- base
11−import Prelude
12−
13−-- opaleye
14−import qualified Opaleye.Window as Opaleye
15−
16−-- rel8
17−import Rel8.Aggregate ( Aggregates )
18−import qualified Rel8.Expr.Window as Expr
19−import Rel8.Schema.HTable ( hfield, htabulateA )
20−import Rel8.Table ( fromColumns, toColumns )
21−import Rel8.Window ( Window( Window ) )
22−
23−
24−-- | 'cumulative' allows the use of aggregation functions in 'Window'
25−-- expressions. In particular, @'cumulative' 'Rel8.sum'@
26−-- (when combined with 'Rel8.Window.orderPartitionBy') gives a running total,
27−-- also known as a \"cumulative sum\", hence the name @cumulative@.
28−cumulative :: Aggregates aggregates exprs => (a -> aggregates) -> Window a exprs
29−cumulative f =
30− fmap fromColumns $
31− htabulateA $ \field ->
32− Expr.cumulative ((`hfield` field) . toColumns . f)
33−
34−
35−-- | A version of 'cumulative' for use with nullary aggregators like
36−-- 'Rel8.Expr.Aggregate.countStar'.
37−cumulative_ :: Aggregates aggregates exprs => aggregates -> Window a exprs
38−cumulative_ = cumulative . const
39−
40−
41−-- | Return every column of the current row of a window query.
42−currentRow :: Window a a
43−currentRow = Window $ Opaleye.over (Opaleye.noWindowFunction id) mempty mempty
src/Rel8/Tabulate.hs+228−530
@@ -1,640 +1,338 @@
1+{-# language DeriveFunctor #-}
2+{-# language DerivingStrategies #-}
13{-# language FlexibleContexts #-}
2−{-# language MonoLocalBinds #-}
3−{-# language ScopedTypeVariables #-}
4−{-# language StandaloneKindSignatures #-}
5−{-# language TypeApplications #-}
64{-# 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').
115
126module Rel8.Tabulate
13− (
14− Tabulation
15−
16− -- * Interfacing with 'Query's
7+ ( Tabulation
8+ , runTabulation
9+ , tabulate
10+ , tabulateA
1711 , fromQuery
18− , toQuery
1912 , liftQuery
20− , through
13+ , prebind
14+ , postbind
15+ , indexed
16+ , ifilter
2117 , 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
3918 , align
4019 , alignWith
4120 , leftAlign
4221 , leftAlignWith
43− , rightAlign
44− , rightAlignWith
4522 , zip
4623 , zipWith
4724 , similarity
4825 , difference
26+ , aggregateTabulation
27+ , optionalTabulation
4928 )
5029where
5130
5231-- base
53−import Control.Applicative ( (<|>), empty, liftA2 )
54−import Control.Monad ( liftM2 )
55−import Data.Bifunctor ( Bifunctor, bimap, first, second )
32+import Control.Applicative ( liftA2 )
33+import Control.Monad ( join, liftM2 )
34+import Data.Bifunctor ( bimap, first )
5635import 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
36+import Data.Maybe ( fromMaybe )
37+import Prelude hiding ( filter, lookup, undefined, zip, zipWith )
8338
8439-- rel8
85−import Rel8.Aggregate ( Aggregates )
40+import Rel8.Aggregate ( Aggregate )
8641import Rel8.Expr ( Expr )
87−import Rel8.Expr.Aggregate ( countStar )
88−import Rel8.Expr.Bool ( true )
89−import Rel8.Order ( Order( Order ) )
42+import Rel8.Expr.Bool ( not_, true )
9043import 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 )
44+import Rel8.Query.Aggregate ( aggregate )
45+import Rel8.Query.Exists ( withBy, withoutBy )
46+import Rel8.Query.Filter ( filter, where_ )
47+import Rel8.Query.Maybe ( optional )
9748import 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 )
49+import Rel8.Table ( Table )
50+import Rel8.Table.Aggregate ( groupBy )
51+import Rel8.Table.Eq ( EqTable, (==:) )
52+import Rel8.Table.Maybe ( MaybeTable )
53+import Rel8.Table.These ( TheseTable, theseTable )
54+import Rel8.Table.Undefined ( undefined )
11855
11956-- semigroupoids
12057import 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)
58+import Data.Functor.Bind ( Bind )
59+import qualified Data.Functor.Bind
60+import Data.Semigroup.Traversable.Class ( bitraverse1 )
16761
16862
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'.
63+-- | @'Tabulation' k a@ is denotionally a @MultiMap k a@ — a @Map@ where each
64+-- key @k@ corresponds to potentially multiple @a@ (i.e., @'Query' a@). This
65+-- @MultiMap@ supports 'lookup' and other operations you would expect it to.
17466--
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
67+-- \"Identity\" 'Tabulation's are created using 'tabulate'. 'Tabulation's can
68+-- be composed with 'Query's with 'prebind' or 'postbind' to form new
69+-- 'Tabulation's.
70+newtype Tabulation k a = Tabulation (k -> Query (Maybe k, a))
71+ deriving stock Functor
20172
20273
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 (<*>))@
20974instance EqTable k => Apply (Tabulation k) where
21075 liftF2 = liftA2
21176
21277
213−-- | @pure = 'liftQuery' . pure@
21478instance EqTable k => Applicative (Tabulation k) where
21579 pure = liftQuery . pure
21680 liftA2 = liftM2
21781
21882
21983instance 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)
84+ join = join
22885
22986
23087instance 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:
88+ Tabulation as >>= f = Tabulation $ \i -> do
89+ (mk, a) <- as i
90+ case mk of
91+ Nothing -> case f a of
92+ Tabulation bs -> bs i
93+ Just k -> case f a of
94+ Tabulation bs -> do
95+ (mk', b) <- bs k
96+ case mk' of
97+ Nothing -> pure (mk, b)
98+ Just k' -> do
99+ where_ $ k ==: k'
100+ pure (mk', b)
101+
102+
103+-- | This "undoes" 'fromQuery'.
275104--
276105-- @
277−-- do
278−-- k <- keys
279−-- a <- lookup k tabulation
280−-- pure (k, a)
106+-- 'runTabulation' . 'fromQuery' = id
107+-- 'fromQuery' . 'runTabulation' = id
281108-- @
282109--
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@.
110+-- Note however that it produces nonsense when passed a 'Tabulation' that was
111+-- made with from 'liftQuery' or 'pure'. In such cases the returned 'Query'
112+-- will always produce zero rows.
113+runTabulation :: EqTable k => Tabulation k a -> Query (k, a)
114+runTabulation (Tabulation f) = do
115+ (mk, a) <- f i
116+ case mk of
117+ Nothing -> do
118+ -- Opaleye tries to be too clever optimising "WHERE FALSE" and generates
119+ -- invalid SQL, so we use "WHERE NOT TRUE" instead
120+ where_ $ not_ true
121+ pure (i, a)
122+ Just k -> pure (k, a)
123+ where
124+ i = undefined
125+
126+
304127liftQuery :: Query a -> Tabulation k a
305−liftQuery = Tabulation . const . fmap (empty,)
128+liftQuery query = Tabulation $ const $ fmap (Nothing,) query
306129
307130
308−-- | Run a Kleisli arrow in the the 'Query' monad \"through\" a 'Tabulation'.
309−-- Useful for 'Rel8.filter'ing a 'Tabulation'.
131+-- | 'tabulate' creates an \"identity\" @'Tabulation' k a@ that allows @a@ be
132+-- indexed by one or more of its columns @k@. Some examples:
310133--
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`
134+-- [Tabulation by primary key]:
135+-- @
136+-- projectsById :: Project 'Expr' -> 'Tabulation' ('Expr' ProjectId) (Project 'Expr')
137+-- projectsById = 'tabulate' projectId
138+-- @
139+--
140+-- Note: the nature of primary keys means that each key will be mapped to a
141+-- singleton value in this case.
142+--
143+-- [Tabulation by other unique key]:
144+-- @
145+-- projectsByName :: Project 'Expr' -> 'Tabulation' ('Expr' Text) (Project 'Expr')
146+-- projectsByName = 'tabulate' projectName
147+-- @
148+--
149+-- [Tabulation by foreign key (tabulate a child table by parent key)]:
150+-- @
151+-- revisionsByProjectId :: Revision 'Expr' -> 'Tabulation' ('Expr' ProjectId) (Revision 'Expr')
152+-- revisionsByProjectId = 'tabulate' revisionProjectId
153+-- @
154+tabulate :: (a -> k) -> a -> Tabulation k a
155+tabulate key a = fromQuery $ pure (key a, a)
320156
321157
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)
158+-- | Like 'tabulate' but takes a monadic 'Query' function instead of a pure
159+-- one. This means you can filter rows while calculating the key, which is
160+-- useful in conjunction with 'Rel8.Extra.catNulls'.
161+tabulateA :: (a -> Query k) -> a -> Tabulation k a
162+tabulateA key a = fromQuery $ (,a) <$> key a
330163
331164
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
165+-- | Analgous to 'Data.Map.Strict.fromList'.
166+fromQuery :: Query (k, a) -> Tabulation k a
167+fromQuery = Tabulation . const . fmap (first Just)
345168
346169
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
170+indexed :: Tabulation k a -> Tabulation k (k, a)
171+indexed (Tabulation query) = Tabulation $ \i ->
172+ (\(mk, a) -> (mk, (fromMaybe i mk, a))) <$> query i
354173
355174
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))
175+ifilter :: (k -> a -> Expr Bool) -> Tabulation k a -> Tabulation k a
176+ifilter f tabulation = snd <$> do
177+ filter (uncurry f) `postbind` indexed tabulation
365178
366179
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).
180+-- | Map a 'Query' over the input side of a 'Tabulation'.
181+prebind :: (a -> Tabulation k b) -> Query a -> Tabulation k b
182+prebind f as = Tabulation $ \k -> do
183+ a <- as
184+ case f a of
185+ Tabulation query -> query k
186+infixr 1 `prebind`
403187
404188
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, ())
189+-- | Map a 'Query' over the output side of a 'Tabulation'.
190+postbind :: (a -> Query b) -> Tabulation k a -> Tabulation k b
191+postbind f (Tabulation as) = Tabulation $ \i -> do
192+ (k, a) <- as i
193+ case f a of
194+ bs -> do
195+ b <- bs
196+ pure (k, b)
197+infixr 1 `postbind`
482198
483199
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, ())
200+-- | Note that because 'Tabulation' is a @MultiMap@, the 'Query' returned by
201+-- 'lookup' can and often does contain multiple results.
202+lookup :: EqTable k => k -> Tabulation k a -> Query a
203+lookup key (Tabulation query) = do
204+ (mk, a) <- query key
205+ traverse_ (where_ . (key ==:)) mk
206+ pure a
494207
495208
496−-- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns.
209+-- | Analagous to
210+-- [@align@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:align).
497211--
498−-- Analogous to 'Data.Semialign.align'.
499−align :: EqTable k
500− => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable Expr a b)
212+-- If 'zip' makes an @INNER JOIN@, then 'align' makes a @FULL OUTER JOIN@.
213+align :: (EqTable k, Table Expr a, Table Expr b)
214+ => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable a b)
501215align = alignWith id
502216
503217
504−-- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns.
218+-- | Analagous to
219+-- [@alignWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:alignWith).
505220--
506−-- Analogous to 'Data.Semialign.alignWith'.
507−alignWith :: EqTable k
508− => (TheseTable Expr a b -> c)
221+-- See 'zipWith' and 'align'.
222+alignWith :: (EqTable k, Table Expr a, Table Expr b)
223+ => (TheseTable a b -> c)
509224 -> 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.
225+alignWith f kas kbs = do
226+ as <- toQuery kas
227+ bs <- toQuery kbs
228+ fromQuery $ do
229+ tkab <- alignBy (\(l, _) (m, _) -> l ==: m) as bs
230+ let
231+ k' = theseTable fst fst (const fst) tkab
232+ tab = bimap snd snd tkab
233+ pure (k', f tab)
234+
235+
236+-- | If 'zip' makes an @INNER JOIN@, then 'leftAlign' makes a @LEFT JOIN@.
237+-- This means it will return at least one row for every row in the left
238+-- 'Tabulation', even if there is no corresponding row in the right (hence the
239+-- 'Rel8.MaybeTable').
240+--
241+-- Analagous to
242+-- [@rpadZip@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:rpadZip).
535243leftAlign :: EqTable k
536− => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable Expr b)
244+ => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable b)
537245leftAlign = leftAlignWith (,)
538246
539247
540−-- | Performs a @NATURAL LEFT OUTER JOIN@ based on the common key columns.
248+-- | See 'zipWith' and 'leftAlign'.
541249--
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.
250+-- Analagous to
251+-- [@rpadZipWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:rpadZipWith).
548252leftAlignWith :: EqTable k
549− => (a -> MaybeTable Expr b -> c)
253+ => (a -> MaybeTable b -> c)
550254 -> Tabulation k a -> Tabulation k b -> Tabulation k c
551−leftAlignWith f left right = liftA2 f left (optional right)
255+leftAlignWith f left right = liftA2 f left (optionalTabulation right)
552256
553257
554−-- | Performs a @NATURAL RIGHT OUTER JOIN@ based on the common key columns.
555−--
556−-- Analogous to 'Data.Semialign.lpadZip'.
258+-- | Analagous to
259+-- [@zip@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:zip).
557260--
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.
261+-- There are multiple correct ways of understanding what this does.
568262--
569−-- Analogous to 'Data.Semialign.lpadZipWith'.
263+-- You can think of it as @'Data.Map.Strict.intersectionWith'
264+-- ('Control.Applicative.liftA2' (,))@. That is, @intersect@ the two
265+-- `Tabulation`s by matching their keys together (with 'Rel8.==:'), and combine
266+-- their values (remembering that 'Tabulation' is a 'MultiMap' so that the
267+-- values are keys) by getting their cartesian product.
570268--
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.
269+-- You can think of it as performing a cross product of the underlying 'Query's
270+-- of the given 'Tabulation's and filtering the results for 'match'ing keys.
582271--
583−-- Analagous to 'Data.Semialign.zip'.
272+-- You can think of it as a natural join in SQL terms.
584273--
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.
274+-- The size of the resulting 'Tabulation' will be \(\sum_{k} min(n_k, m_k) \)
275+-- in terms of the number of keys, but \(\sum_{k} n_k \times m_k\) in terms of
276+-- the number of values.
588277zip :: EqTable k
589278 => Tabulation k a -> Tabulation k b -> Tabulation k (a, b)
590279zip = zipWith (,)
591280
592281
593−-- | Performs a @NATURAL INNER JOIN@ based on the common key columns.
282+-- | Analagous to
283+-- [@zipWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:zipWith).
594284--
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.
285+-- See 'zip'.
600286zipWith :: EqTable k
601287 => (a -> b -> c) -> Tabulation k a -> Tabulation k b -> Tabulation k c
602288zipWith = liftA2
603289
604290
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.
291+-- | 'similarity' returns all the entries in the left 'Tabulation' that have a
292+-- corresponding entry in the right 'Tabulation'. This corresponds to a
293+-- semijoin in relational algebra.
607294--
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.
295+-- This differs from @'zipWith' const x y@ when the right 'Tabulation' @y@
296+-- contains an entry with multiple rows. For 'similarity', the entries in the
297+-- resulting 'Tabulation' will contain the same number of rows as their
298+-- respective entries in the left 'Tabulation' @x@. With `zipWith const x y`,
299+-- each entry would contain the /product/ of the number of rows of their
300+-- respective entries in @x@ and @y@.
610301--
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.
302+-- See 'Rel8.with'.
615303similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
616−similarity a b = a <* present b
304+similarity kas kbs = do
305+ as <- toQuery kas
306+ bs <- toQuery kbs
307+ fromQuery $ as >>= withBy (\(k, _) (l, _) -> k ==: l) bs
617308
618309
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.
310+-- | 'difference' returns all the entries in the left 'Tabulation' that don't
311+-- exist in the right 'Tabulation'. This corresponds to an antijoin in
312+-- relational algebra.
624313--
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.
314+-- See 'Rel8.without'.
629315difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
630−difference a b = a <* absent b
316+difference kas kbs = do
317+ as <- toQuery kas
318+ bs <- toQuery kbs
319+ fromQuery $ as >>= withoutBy (\(k, _) (l, _) -> k ==: l) bs
320+
321+
322+aggregateTabulation :: EqTable k
323+ => Tabulation k (Aggregate a) -> Tabulation k a
324+aggregateTabulation kas = do
325+ as <- toQuery kas
326+ fromQuery $ aggregate $ bitraverse1 groupBy id <$> as
327+
328+
329+optionalTabulation :: EqTable k
330+ => Tabulation k a -> Tabulation k (MaybeTable a)
331+optionalTabulation as = Tabulation $ \k -> do
332+ ma <- optional $ lookup k as
333+ pure (Just k, ma)
631334
632335
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)
336+toQuery :: Tabulation k a -> Tabulation k (Query (k, a))
337+toQuery (Tabulation as) = Tabulation $ \k ->
338+ pure (Nothing, first (fromMaybe k) <$> as k)
src/Rel8/Type.hs+21−16
@@ -1,8 +1,8 @@
1−{-# language FlexibleContexts #-}
21{-# language FlexibleInstances #-}
3−{-# language MonoLocalBinds #-}
4−{-# language MultiWayIf #-}
2+{-# language MultiParamTypeClasses #-}
53{-# language StandaloneKindSignatures #-}
4+{-# language TypeApplications #-}
5+{-# language UndecidableInstances #-}
66{-# language UndecidableInstances #-}
77
88module Rel8.Type
@@ -37,7 +37,12 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
3737import qualified Opaleye.Internal.HaskellDB.Sql.Default as Opaleye ( quote )
3838
3939-- rel8
40−import Rel8.Schema.Null ( NotNull, Sql, nullable )
40+import Rel8.Opaque ( Opaque )
41+import Rel8.Schema.Nullability
42+ ( NotNull, Unnullify
43+ , HasNullability, nullabilization
44+ , Sql
45+ )
4146import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
4247import Rel8.Type.Information ( TypeInformation(..), mapTypeInformation )
4348
@@ -127,11 +132,7 @@ instance DBType Int64 where
127132-- | Corresponds to @float4@
128133instance DBType Float where
129134 typeInformation = TypeInformation
130− { 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
135+ { encode = Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac
135136 , decode = Hasql.float4
136137 , typeName = "float4"
137138 }
@@ -140,11 +141,7 @@ instance DBType Float where
140141-- | Corresponds to @float8@
141142instance DBType Double where
142143 typeInformation = TypeInformation
143− { 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
144+ { encode = Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac
148145 , decode = Hasql.float8
149146 , typeName = "float8"
150147 }
@@ -281,8 +278,16 @@ instance DBType Value where
281278
282279
283280instance Sql DBType a => DBType [a] where
284− typeInformation = listTypeInformation nullable typeInformation
281+ typeInformation = listTypeInformation nullabilization typeInformation
285282
286283
287284instance Sql DBType a => DBType (NonEmpty a) where
288− typeInformation = nonEmptyTypeInformation nullable typeInformation
285+ typeInformation = nonEmptyTypeInformation nullabilization typeInformation
286+
287+
288+instance {-# OVERLAPPING #-} DBType Opaque where
289+ typeInformation = error "opaque"
290+
291+
292+instance {-# INCOHERENT #-} (HasNullability a, DBType (Unnullify a)) =>
293+ Sql DBType a
src/Rel8/Type/Array.hs+31−52
@@ -1,13 +1,12 @@
11{-# language GADTs #-}
2−{-# language LambdaCase #-}
32{-# language NamedFieldPuns #-}
43{-# language OverloadedStrings #-}
5−{-# language ViewPatterns #-}
64
75module Rel8.Type.Array
8− ( array, encodeArrayElement, extractArrayElement
6+ ( array
97 , listTypeInformation
108 , nonEmptyTypeInformation
9+ , fromPrimArray, toPrimArray, zipPrimArraysWith
1110 )
1211where
1312
@@ -23,78 +22,58 @@ import qualified Hasql.Decoders as Hasql
2322import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
2423
2524-- rel8
26−import Rel8.Schema.Null ( Unnullify, Nullity( Null, NotNull ) )
25+import Rel8.Schema.Nullability ( Unnullify, Nullability( Nullable, NonNullable ) )
2726import Rel8.Type.Information ( TypeInformation(..), parseTypeInformation )
2827
2928
3029array :: Foldable f
3130 => TypeInformation a -> f Opaleye.PrimExpr -> Opaleye.PrimExpr
32−array info =
33− Opaleye.CastExpr (arrayType info <> "[]") .
34− Opaleye.ArrayExpr . map (encodeArrayElement info) . toList
35−{-# INLINABLE array #-}
31+array TypeInformation {typeName} =
32+ fromPrimArray .
33+ Opaleye.CastExpr (typeName <> "[]") .
34+ Opaleye.ArrayExpr . toList
3635
3736
3837listTypeInformation :: ()
39− => Nullity a
38+ => Nullability a
4039 -> TypeInformation (Unnullify a)
4140 -> TypeInformation [a]
42−listTypeInformation nullity info@TypeInformation {encode, decode} =
43− TypeInformation
44− { decode = case nullity of
45− Null ->
46− Hasql.listArray (decodeArrayElement info (Hasql.nullable decode))
47− NotNull ->
48− Hasql.listArray (decodeArrayElement info (Hasql.nonNullable decode))
49− , encode = case nullity of
50− Null ->
51− Opaleye.ArrayExpr .
52− fmap (encodeArrayElement info . maybe null encode)
53− NotNull ->
54− Opaleye.ArrayExpr .
55− fmap (encodeArrayElement info . encode)
56− , typeName = arrayType info <> "[]"
57− }
41+listTypeInformation nullability info =
42+ case info of
43+ TypeInformation{ encode, decode } -> TypeInformation
44+ { decode = row $ case nullability of
45+ Nullable -> Hasql.listArray (Hasql.nullable decode)
46+ NonNullable -> Hasql.listArray (Hasql.nonNullable decode)
47+ , encode = case nullability of
48+ Nullable -> array info . fmap (maybe null encode)
49+ NonNullable -> array info . fmap encode
50+ , typeName = "record"
51+ }
5852 where
53+ row = Hasql.composite . Hasql.field . Hasql.nonNullable
5954 null = Opaleye.ConstExpr Opaleye.NullLit
6055
6156
6257nonEmptyTypeInformation :: ()
63− => Nullity a
58+ => Nullability a
6459 -> TypeInformation (Unnullify a)
6560 -> TypeInformation (NonEmpty a)
66−nonEmptyTypeInformation nullity =
67− parseTypeInformation parse toList . listTypeInformation nullity
61+nonEmptyTypeInformation nullability =
62+ parseTypeInformation parse toList . listTypeInformation nullability
6863 where
6964 parse = maybe (Left message) Right . nonEmpty
7065 message = "failed to decode NonEmptyList: got empty list"
7166
7267
73−isArray :: TypeInformation a -> Bool
74−isArray = \case
75− (reverse . typeName -> ']' : '[' : _) -> True
76− _ -> False
68+fromPrimArray :: Opaleye.PrimExpr -> Opaleye.PrimExpr
69+fromPrimArray = Opaleye.UnExpr (Opaleye.UnOpOther "ROW")
7770
7871
79−arrayType :: TypeInformation a -> String
80−arrayType info
81− | isArray info = "record"
82− | otherwise = typeName info
72+toPrimArray :: Opaleye.PrimExpr -> Opaleye.PrimExpr
73+toPrimArray a = Opaleye.CompositeExpr a "f1"
8374
8475
85−decodeArrayElement :: TypeInformation a -> Hasql.NullableOrNot Hasql.Value x -> Hasql.NullableOrNot Hasql.Value x
86−decodeArrayElement info
87− | isArray info = Hasql.nonNullable . Hasql.composite . Hasql.field
88− | otherwise = id
89−
90−
91−encodeArrayElement :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr
92−encodeArrayElement info
93− | isArray info = Opaleye.UnExpr (Opaleye.UnOpOther "ROW")
94− | otherwise = id
95−
96−
97−extractArrayElement :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr
98−extractArrayElement info
99− | isArray info = flip Opaleye.CompositeExpr "f1"
100− | otherwise = id
76+zipPrimArraysWith :: ()
77+ => (Opaleye.PrimExpr -> Opaleye.PrimExpr -> Opaleye.PrimExpr)
78+ -> Opaleye.PrimExpr -> Opaleye.PrimExpr -> Opaleye.PrimExpr
79+zipPrimArraysWith f a b = fromPrimArray (f (toPrimArray a) (toPrimArray b))
src/Rel8/Type/Array1D.hsnew file+136
@@ -0,0 +1,136 @@
1+{-# language DataKinds #-}
2+{-# language DeriveTraversable #-}
3+{-# language DerivingStrategies #-}
4+{-# language GeneralizedNewtypeDeriving #-}
5+{-# language NamedFieldPuns #-}
6+{-# language StandaloneKindSignatures #-}
7+{-# language TypeFamilies #-}
8+{-# language UndecidableInstances #-}
9+
10+{-# options_ghc -fno-warn-redundant-constraints #-}
11+
12+module Rel8.Type.Array1D
13+ ( Array1D( Array1D )
14+ , getArray1D
15+ )
16+where
17+
18+-- aeson
19+import Data.Aeson
20+ ( ToJSON
21+ , ToJSON1
22+ , ToJSONKey
23+ , FromJSON
24+ , FromJSON1
25+ , FromJSONKey
26+ )
27+
28+-- base
29+import Control.Applicative ( Alternative, (<|>) )
30+import Control.Monad ( MonadPlus )
31+import Data.Functor.Classes ( Eq1, Ord1, Read1, Show1 )
32+import Data.Kind ( Type )
33+import GHC.Exts ( IsList )
34+import Prelude hiding ( null )
35+
36+-- hasql
37+import qualified Hasql.Decoders as Hasql
38+
39+-- opaleye
40+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
41+
42+-- rel8
43+import Rel8.Expr.Opaleye ( zipPrimExprsWith )
44+import Rel8.Expr.Serialize ( litExpr )
45+import Rel8.Schema.Nullability
46+ ( Unnullify
47+ , Nullability( Nullable, NonNullable )
48+ , Sql, nullabilization
49+ )
50+import Rel8.Type ( DBType, typeInformation )
51+import Rel8.Type.Eq ( DBEq )
52+import Rel8.Type.Information ( TypeInformation(..) )
53+import Rel8.Type.Monoid ( DBMonoid, memptyExpr )
54+import Rel8.Type.Ord ( DBMax, DBMin, DBOrd )
55+import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )
56+
57+-- semigroupoids
58+import Data.Functor.Alt ( Alt, (<!>) )
59+import Data.Functor.Apply ( Apply )
60+import Data.Functor.Bind ( Bind )
61+import Data.Functor.Plus ( Plus )
62+
63+-- semialign
64+import Data.Align ( Align )
65+import Data.Semialign ( Semialign )
66+import Data.Zip ( Repeat, Unzip, Zip )
67+
68+
69+-- | A one dimensional array.
70+newtype Array1D a = Array1D [a]
71+ deriving stock Traversable
72+ deriving newtype
73+ ( Eq, Ord, Read, Show, Semigroup, Monoid, IsList
74+ , Functor, Foldable
75+ , Eq1, Ord1, Read1, Show1
76+ , FromJSON1, ToJSON1, FromJSON, FromJSONKey, ToJSON, ToJSONKey
77+ , Apply, Applicative, Alternative, Plus, Bind, Monad, MonadPlus
78+ , Align, Semialign, Repeat, Unzip, Zip
79+ )
80+
81+
82+instance Alt Array1D where
83+ (<!>) = (<|>)
84+
85+
86+getArray1D :: Array1D a -> [a]
87+getArray1D (Array1D a) = a
88+
89+
90+type IsArray1D :: Type -> Bool
91+type family IsArray1D a where
92+ IsArray1D (Array1D _) = 'True
93+ IsArray1D _ = 'False
94+
95+
96+array1DTypeInformation :: IsArray1D (Unnullify a) ~ 'False
97+ => Nullability a
98+ -> TypeInformation (Unnullify a)
99+ -> TypeInformation (Array1D a)
100+array1DTypeInformation nullability info =
101+ case info of
102+ TypeInformation{ encode, decode, typeName } -> TypeInformation
103+ { decode = case nullability of
104+ Nullable -> Array1D <$> Hasql.listArray (Hasql.nullable decode)
105+ NonNullable -> Array1D <$> Hasql.listArray (Hasql.nonNullable decode)
106+ , encode = case nullability of
107+ Nullable -> Opaleye.ArrayExpr . fmap (maybe null encode) . getArray1D
108+ NonNullable -> Opaleye.ArrayExpr . fmap encode . getArray1D
109+ , typeName = typeName <> "[]"
110+ }
111+ where
112+ null = Opaleye.ConstExpr Opaleye.NullLit
113+
114+
115+instance (Sql DBType a, IsArray1D (Unnullify a) ~ 'False) => DBType (Array1D a) where
116+ typeInformation = array1DTypeInformation nullabilization typeInformation
117+
118+
119+instance (Sql DBEq a, IsArray1D (Unnullify a) ~ 'False) => DBEq (Array1D a)
120+
121+
122+instance (Sql DBOrd a, IsArray1D (Unnullify a) ~ 'False) => DBOrd (Array1D a)
123+
124+
125+instance (Sql DBMax a, IsArray1D (Unnullify a) ~ 'False) => DBMax (Array1D a)
126+
127+
128+instance (Sql DBMin a, IsArray1D (Unnullify a) ~ 'False) => DBMin (Array1D a)
129+
130+
131+instance (Sql DBType a, IsArray1D (Unnullify a) ~ 'False) => DBSemigroup (Array1D a) where
132+ (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
133+
134+
135+instance (Sql DBType a, IsArray1D (Unnullify a) ~ 'False) => DBMonoid (Array1D a) where
136+ memptyExpr = litExpr mempty
src/Rel8/Type/Composite.hsdeleted−135
@@ -1,135 +0,0 @@
1−{-# language AllowAmbiguousTypes #-}
2−{-# language BlockArguments #-}
3−{-# language DataKinds #-}
4−{-# language FlexibleContexts #-}
5−{-# language GADTs #-}
6−{-# language NamedFieldPuns #-}
7−{-# language ScopedTypeVariables #-}
8−{-# language StandaloneKindSignatures #-}
9−{-# language TypeApplications #-}
10−{-# language UndecidableInstances #-}
11−{-# language UndecidableSuperClasses #-}
12−{-# language ViewPatterns #-}
13−
14−module Rel8.Type.Composite
15− ( Composite( Composite )
16− , DBComposite( compositeFields, compositeTypeName )
17− , compose, decompose
18− )
19−where
20−
21−-- base
22−import Data.Functor.Const ( Const( Const ), getConst )
23−import Data.Functor.Identity ( Identity( Identity ) )
24−import Data.Kind ( Constraint, Type )
25−import Prelude
26−
27−-- hasql
28−import qualified Hasql.Decoders as Hasql
29−
30−-- opaleye
31−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
32−
33−-- rel8
34−import Rel8.Expr ( Expr )
35−import Rel8.Expr.Opaleye ( castExpr, fromPrimExpr, toPrimExpr )
36−import Rel8.Schema.HTable ( HTable, hfield, hspecs, htabulate, htabulateA )
37−import Rel8.Schema.Name ( Name( Name ) )
38−import 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 )
42−import Rel8.Table.Eq ( EqTable )
43−import Rel8.Table.HKD ( HKD, HKDable )
44−import Rel8.Table.Ord ( OrdTable )
45−import Rel8.Table.Rel8able ()
46−import Rel8.Table.Serialize ( litHTable )
47−import Rel8.Type ( DBType, typeInformation )
48−import Rel8.Type.Eq ( DBEq )
49−import Rel8.Type.Information ( TypeInformation(..) )
50−import Rel8.Type.Ord ( DBOrd, DBMax, DBMin )
51−
52−-- semigroupoids
53−import Data.Functor.Apply ( WrappedApplicative(..) )
54−
55−
56−-- | A deriving-via helper type for column types that store a Haskell product
57−-- type in a single Postgres column using a Postgres composite type.
58−--
59−-- Note that this must map to a specific extant type in your database's schema
60−-- (created with @CREATE TYPE@). Use 'DBComposite' to specify the name of this
61−-- Postgres type and the names of the individual fields (for projecting with
62−-- 'decompose').
63−type Composite :: Type -> Type
64−newtype Composite a = Composite
65− { unComposite :: a
66− }
67−
68−
69−instance DBComposite a => DBType (Composite a) where
70− typeInformation = TypeInformation
71− { decode = Hasql.composite (Composite . fromResult @_ @(HKD a Expr) <$> decoder)
72− , encode = encoder . litHTable . toResult @_ @(HKD a Expr) . unComposite
73− , typeName = compositeTypeName @a
74− }
75−
76−
77−instance (DBComposite a, EqTable (HKD a Expr)) => DBEq (Composite a)
78−
79−
80−instance (DBComposite a, OrdTable (HKD a Expr)) => DBOrd (Composite a)
81−
82−
83−instance (DBComposite a, OrdTable (HKD a Expr)) => DBMax (Composite a)
84−
85−
86−instance (DBComposite a, OrdTable (HKD a Expr)) => DBMin (Composite a)
87−
88−
89−-- | 'DBComposite' is used to associate composite type metadata with a Haskell
90−-- type.
91−type DBComposite :: Type -> Constraint
92−class (DBType a, HKDable a) => DBComposite a where
93− -- | The names of all fields in the composite type that @a@ maps to.
94− compositeFields :: HKD a Name
95−
96− -- | The name of the composite type that @a@ maps to.
97− compositeTypeName :: String
98−
99−
100−-- | Collapse a 'HKD' into a PostgreSQL composite type.
101−--
102−-- 'HKD' values are represented in queries by having a column for each field in
103−-- the corresponding Haskell type. 'compose' collapses these columns into a
104−-- single column expression, by combining them into a PostgreSQL composite
105−-- type.
106−compose :: DBComposite a => HKD a Expr -> Expr a
107−compose = castExpr . fromPrimExpr . encoder . toColumns
108−
109−
110−-- | Expand a composite type into a 'HKD'.
111−--
112−-- 'decompose' is the inverse of 'compose'.
113−decompose :: forall a. DBComposite a => Expr a -> HKD a Expr
114−decompose (toPrimExpr -> a) = fromColumns $ htabulate \field ->
115− case hfield names field of
116− Name name -> case hfield hspecs field of
117− Spec {} -> fromPrimExpr $ Opaleye.CompositeExpr a name
118− where
119− names = toColumns (compositeFields @a)
120−
121−
122−decoder :: HTable t => Hasql.Composite (t Result)
123−decoder = unwrapApplicative $ htabulateA \field ->
124− case hfield hspecs field of
125− Spec {nullity, info} -> WrapApplicative $ Identity <$>
126− case nullity of
127− Null -> Hasql.field $ Hasql.nullable $ decode info
128− NotNull -> Hasql.field $ Hasql.nonNullable $ decode info
129−
130−
131−encoder :: HTable t => t Expr -> Opaleye.PrimExpr
132−encoder a = Opaleye.FunExpr "ROW" exprs
133− where
134− exprs = getConst $ htabulateA \field -> case hfield a field of
135− expr -> Const [toPrimExpr expr]
src/Rel8/Type/Enum.hsdeleted−139
@@ -1,139 +0,0 @@
1−{-# language AllowAmbiguousTypes #-}
2−{-# language DataKinds #-}
3−{-# language FlexibleContexts #-}
4−{-# language FlexibleInstances #-}
5−{-# language LambdaCase #-}
6−{-# language RankNTypes #-}
7−{-# language ScopedTypeVariables #-}
8−{-# language StandaloneKindSignatures #-}
9−{-# language TypeApplications #-}
10−{-# language TypeFamilies #-}
11−{-# language TypeOperators #-}
12−{-# language UndecidableInstances #-}
13−
14−module Rel8.Type.Enum
15− ( Enum( Enum )
16− , DBEnum( enumValue, enumTypeName )
17− , Enumable
18− )
19−where
20−
21−-- base
22−import Control.Applicative ( (<|>) )
23−import Control.Arrow ( (&&&) )
24−import Data.Kind ( Constraint, Type )
25−import Data.Proxy ( Proxy( Proxy ) )
26−import GHC.Generics
27− ( Generic, Rep, from, to
28− , (:+:)( L1, R1 ), M1( M1 ), U1( U1 )
29− , D, C, Meta( MetaCons )
30− )
31−import GHC.TypeLits ( KnownSymbol, symbolVal )
32−import Prelude hiding ( Enum )
33−
34−-- hasql
35−import qualified Hasql.Decoders as Hasql
36−
37−-- opaleye
38−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
39−
40−-- rel8
41−import Rel8.Type ( DBType, typeInformation )
42−import Rel8.Type.Eq ( DBEq )
43−import Rel8.Type.Information ( TypeInformation(..) )
44−import Rel8.Type.Ord ( DBOrd, DBMax, DBMin )
45−
46−-- text
47−import Data.Text ( pack )
48−
49−
50−-- | A deriving-via helper type for column types that store an \"enum\" type
51−-- (in Haskell terms, a sum type where all constructors are nullary) using a
52−-- Postgres @enum@ type.
53−--
54−-- Note that this should map to a specific type in your database's schema
55−-- (explicitly created with @CREATE TYPE ... AS ENUM@). Use 'DBEnum' to
56−-- specify the name of this Postgres type and the names of the individual
57−-- values. If left unspecified, the names of the values of the Postgres
58−-- @enum@ are assumed to match exactly exactly the names of the constructors
59−-- of the Haskell type (up to and including case sensitivity).
60−type Enum :: Type -> Type
61−newtype Enum a = Enum
62− { unEnum :: a
63− }
64−
65−
66−instance DBEnum a => DBType (Enum a) where
67− typeInformation = TypeInformation
68− { decode =
69− Hasql.enum $
70− flip lookup $
71− map ((pack . enumValue &&& Enum) . to) $
72− genumerate @(Rep a)
73− , encode =
74− Opaleye.ConstExpr .
75− Opaleye.StringLit .
76− enumValue @a .
77− unEnum
78− , typeName = enumTypeName @a
79− }
80−
81−
82−instance DBEnum a => DBEq (Enum a)
83−
84−
85−instance DBEnum a => DBOrd (Enum a)
86−
87−
88−instance DBEnum a => DBMax (Enum a)
89−
90−
91−instance DBEnum a => DBMin (Enum a)
92−
93−
94−-- | @DBEnum@ contains the necessary metadata to describe a PostgreSQL @enum@ type.
95−type DBEnum :: Type -> Constraint
96−class (DBType a, Enumable a) => DBEnum a where
97− -- | Map Haskell values to the corresponding element of the @enum@ type. The
98− -- default implementation of this method will use the exact name of the
99− -- Haskell constructors.
100− enumValue :: a -> String
101− enumValue = gshow @(Rep a) . from
102−
103− -- | The name of the PostgreSQL @enum@ type that @a@ maps to.
104− enumTypeName :: String
105−
106−
107−-- | Types that are sum types, where each constructor is unary (that is, has no
108−-- fields).
109−type Enumable :: Type -> Constraint
110−class (Generic a, GEnumable (Rep a)) => Enumable a
111−instance (Generic a, GEnumable (Rep a)) => Enumable a
112−
113−
114−type GEnumable :: (Type -> Type) -> Constraint
115−class GEnumable rep where
116− genumerate :: [rep x]
117− gshow :: rep x -> String
118−
119−
120−instance GEnumable rep => GEnumable (M1 D meta rep) where
121− genumerate = M1 <$> genumerate
122− gshow (M1 rep) = gshow rep
123−
124−
125−instance (GEnumable a, GEnumable b) => GEnumable (a :+: b) where
126− genumerate = L1 <$> genumerate <|> R1 <$> genumerate
127− gshow = \case
128− L1 a -> gshow a
129− R1 a -> gshow a
130−
131−
132−instance
133− ( meta ~ 'MetaCons name _fixity _isRecord
134− , KnownSymbol name
135− )
136− => GEnumable (M1 C meta U1)
137− where
138− genumerate = [M1 U1]
139− gshow (M1 U1) = symbolVal (Proxy @name)
src/Rel8/Type/Eq.hs+7−2
@@ -1,6 +1,5 @@
11{-# language FlexibleContexts #-}
22{-# language FlexibleInstances #-}
3−{-# language MonoLocalBinds #-}
43{-# language MultiParamTypeClasses #-}
54{-# language StandaloneKindSignatures #-}
65{-# language UndecidableInstances #-}
@@ -27,7 +26,8 @@ import qualified Data.ByteString.Lazy as Lazy ( ByteString )
2726import Data.CaseInsensitive ( CI )
2827
2928-- rel8
30−import Rel8.Schema.Null ( Sql )
29+import Rel8.Opaque ( Opaque )
30+import Rel8.Schema.Nullability ( Unnullify, HasNullability, Sql )
3131import Rel8.Type ( DBType )
3232
3333-- scientific
@@ -76,3 +76,8 @@ instance DBEq UUID
7676instance DBEq Value
7777instance Sql DBEq a => DBEq [a]
7878instance Sql DBEq a => DBEq (NonEmpty a)
79+instance DBEq Opaque
80+
81+
82+instance {-# INCOHERENT #-} (HasNullability a, DBEq (Unnullify a)) =>
83+ Sql DBEq a
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/Monoid.hs+9−2
@@ -27,7 +27,10 @@ import Data.CaseInsensitive ( CI )
2727import {-# SOURCE #-} Rel8.Expr ( Expr )
2828import Rel8.Expr.Array ( sempty )
2929import Rel8.Expr.Serialize ( litExpr )
30−import Rel8.Schema.Null ( Sql )
30+import Rel8.Schema.Nullability
31+ ( Unnullify
32+ , Sql, HasNullability, nullabilization
33+ )
3134import Rel8.Type ( DBType, typeInformation )
3235import Rel8.Type.Semigroup ( DBSemigroup )
3336
@@ -48,7 +51,7 @@ class DBSemigroup a => DBMonoid a where
4851
4952
5053instance Sql DBType a => DBMonoid [a] where
51− memptyExpr = sempty typeInformation
54+ memptyExpr = sempty nullabilization typeInformation
5255
5356
5457instance DBMonoid CalendarDiffTime where
@@ -77,3 +80,7 @@ instance DBMonoid ByteString where
7780
7881instance DBMonoid Lazy.ByteString where
7982 memptyExpr = litExpr ""
83+
84+
85+instance {-# INCOHERENT #-} (HasNullability a, DBMonoid (Unnullify a)) =>
86+ Sql DBMonoid a
src/Rel8/Type/Num.hs+13−9
@@ -7,7 +7,7 @@
77{-# language UndecidableInstances #-}
88
99module Rel8.Type.Num
10− ( DBNum, DBIntegral, DBFractional, DBFloating
10+ ( DBNum, DBIntegral, DBFractional
1111 )
1212where
1313
@@ -17,8 +17,8 @@ import Data.Kind ( Constraint, Type )
1717import Prelude
1818
1919-- rel8
20+import Rel8.Schema.Nullability ( HasNullability, Unnullify, Sql )
2021import Rel8.Type ( DBType )
21−import Rel8.Type.Ord ( DBOrd )
2222
2323-- scientific
2424import Data.Scientific ( Scientific )
@@ -36,26 +36,30 @@ instance DBNum Double
3636instance DBNum Scientific
3737
3838
39+instance {-# INCOHERENT #-} (HasNullability a, DBNum (Unnullify a)) =>
40+ Sql DBNum a
41+
42+
3943-- | The class of database types that can be coerced to from integral
4044-- expressions. This is a Rel8 concept, and allows us to provide
4145-- 'fromIntegral'.
4246type DBIntegral :: Type -> Constraint
43−class (DBNum a, DBOrd a) => DBIntegral a
47+class DBNum a => DBIntegral a
4448instance DBIntegral Int16
4549instance DBIntegral Int32
4650instance DBIntegral Int64
4751
4852
53+instance {-# INCOHERENT #-} (HasNullability a, DBIntegral (Unnullify a)) =>
54+ Sql DBIntegral a
55+
56+
4957-- | The class of database types that support the @/@ operator.
50−type DBFractional :: Type -> Constraint
5158class DBNum a => DBFractional a
5259instance DBFractional Float
5360instance DBFractional Double
5461instance DBFractional Scientific
5562
5663
57−-- | The class of database types that support the @/@ operator.
58−type DBFloating :: Type -> Constraint
59−class DBFractional a => DBFloating a
60−instance DBFloating Float
61−instance DBFloating Double
64+instance {-# INCOHERENT #-} (HasNullability a, DBFractional (Unnullify a)) =>
65+ Sql DBFractional a
src/Rel8/Type/Ord.hs+17−2
@@ -1,6 +1,5 @@
11{-# language FlexibleContexts #-}
22{-# language FlexibleInstances #-}
3−{-# language MonoLocalBinds #-}
43{-# language MultiParamTypeClasses #-}
54{-# language StandaloneKindSignatures #-}
65{-# language UndecidableInstances #-}
@@ -25,7 +24,8 @@ import qualified Data.ByteString.Lazy as Lazy ( ByteString )
2524import Data.CaseInsensitive ( CI )
2625
2726-- rel8
28−import Rel8.Schema.Null ( Sql )
27+import Rel8.Opaque ( Opaque )
28+import Rel8.Schema.Nullability ( Unnullify, Sql, HasNullability )
2929import Rel8.Type.Eq ( DBEq )
3030
3131-- scientific
@@ -70,11 +70,17 @@ instance DBOrd Lazy.ByteString
7070instance DBOrd UUID
7171instance Sql DBOrd a => DBOrd [a]
7272instance Sql DBOrd a => DBOrd (NonEmpty a)
73+instance {-# OVERLAPPING #-} DBOrd Opaque
74+
75+
76+instance {-# INCOHERENT #-} (HasNullability a, DBOrd (Unnullify a)) =>
77+ Sql DBOrd a
7378
7479
7580-- | The class of database types that support the @max@ aggregation function.
7681type DBMax :: Type -> Constraint
7782class DBOrd a => DBMax a
83+instance DBMax Bool
7884instance DBMax Char
7985instance DBMax Int16
8086instance DBMax Int32
@@ -97,9 +103,14 @@ instance Sql DBMax a => DBMax [a]
97103instance Sql DBMax a => DBMax (NonEmpty a)
98104
99105
106+instance {-# INCOHERENT #-} (HasNullability a, DBMax (Unnullify a)) =>
107+ Sql DBMax a
108+
109+
100110-- | The class of database types that support the @min@ aggregation function.
101111type DBMin :: Type -> Constraint
102112class DBOrd a => DBMin a
113+instance DBMin Bool
103114instance DBMin Char
104115instance DBMin Int16
105116instance DBMin Int32
@@ -120,3 +131,7 @@ instance DBMin ByteString
120131instance DBMin Lazy.ByteString
121132instance Sql DBMin a => DBMin [a]
122133instance Sql DBMin a => DBMin (NonEmpty a)
134+
135+
136+instance {-# INCOHERENT #-} (HasNullability a, DBMin (Unnullify a)) =>
137+ Sql DBMin a
src/Rel8/Type/ReadShow.hs+3−14
@@ -1,16 +1,8 @@
1−{-# language ScopedTypeVariables #-}
2−{-# language StandaloneKindSignatures #-}
3−{-# language TypeApplications #-}
4−{-# language ViewPatterns #-}
5−
61module Rel8.Type.ReadShow ( ReadShow(..) ) where
72
83-- base
9−import Data.Kind ( Type )
10−import Data.Proxy ( Proxy( Proxy ) )
11−import Data.Typeable ( Typeable, typeRep )
124import Prelude
13−import Text.Read ( readMaybe )
5+import Text.Read ( readEither )
146
157-- rel8
168import Rel8.Type ( DBType( typeInformation ) )
@@ -22,14 +14,11 @@ import qualified Data.Text as Text
2214
2315-- | A deriving-via helper type for column types that store a Haskell value
2416-- using a Haskell's 'Read' and 'Show' type classes.
25−type ReadShow :: Type -> Type
2617newtype ReadShow a = ReadShow { fromReadShow :: a }
2718
2819
29−instance (Read a, Show a, Typeable a) => DBType (ReadShow a) where
20+instance (Read a, Show a) => DBType (ReadShow a) where
3021 typeInformation = parseTypeInformation parser printer typeInformation
3122 where
32− parser (Text.unpack -> t) = case readMaybe t of
33− Just ok -> Right $ ReadShow ok
34− Nothing -> Left $ "Could not read " <> t <> " as a " <> show (typeRep (Proxy @a))
23+ parser = fmap ReadShow . readEither . Text.unpack
3524 printer = Text.pack . show . fromReadShow
src/Rel8/Type/Semigroup.hs+9−5
@@ -1,9 +1,10 @@
1−{-# language BlockArguments #-}
21{-# language DataKinds #-}
32{-# language FlexibleContexts #-}
43{-# language FlexibleInstances #-}
54{-# language MultiParamTypeClasses #-}
5+{-# language ScopedTypeVariables #-}
66{-# language StandaloneKindSignatures #-}
7+{-# language TypeApplications #-}
78{-# language TypeFamilies #-}
89{-# language UndecidableInstances #-}
910
@@ -29,9 +30,8 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
2930
3031-- rel8
3132import {-# SOURCE #-} Rel8.Expr ( Expr )
32−import Rel8.Expr.Array ( sappend, sappend1 )
3333import Rel8.Expr.Opaleye ( zipPrimExprsWith )
34−import Rel8.Schema.Null ( Sql )
34+import Rel8.Schema.Nullability ( Unnullify, Sql, HasNullability )
3535import Rel8.Type ( DBType )
3636
3737-- text
@@ -52,11 +52,11 @@ class DBType a => DBSemigroup a where
5252
5353
5454instance Sql DBType a => DBSemigroup [a] where
55− (<>.) = sappend
55+ (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
5656
5757
5858instance Sql DBType a => DBSemigroup (NonEmpty a) where
59− (<>.) = sappend1
59+ (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
6060
6161
6262instance DBSemigroup CalendarDiffTime where
@@ -85,3 +85,7 @@ instance DBSemigroup ByteString where
8585
8686instance DBSemigroup Lazy.ByteString where
8787 (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
88+
89+
90+instance {-# INCOHERENT #-} (HasNullability a, DBSemigroup (Unnullify a)) =>
91+ Sql DBSemigroup a
src/Rel8/Type/String.hs+5
@@ -21,6 +21,7 @@ import qualified Data.ByteString.Lazy as Lazy ( ByteString )
2121import Data.CaseInsensitive ( CI )
2222
2323-- rel8
24+import Rel8.Schema.Nullability ( HasNullability, Unnullify, Sql )
2425import Rel8.Type ( DBType )
2526
2627-- text
@@ -38,3 +39,7 @@ instance DBString (CI Text)
3839instance DBString (CI Lazy.Text)
3940instance DBString ByteString
4041instance DBString Lazy.ByteString
42+
43+
44+instance {-# INCOHERENT #-} (HasNullability a, DBString (Unnullify a)) =>
45+ Sql DBString a
src/Rel8/Type/Sum.hs+5
@@ -17,6 +17,7 @@ import Data.Kind ( Constraint, Type )
1717import Prelude
1818
1919-- rel8
20+import Rel8.Schema.Nullability ( HasNullability, Unnullify, Sql )
2021import Rel8.Type ( DBType )
2122
2223-- scientific
@@ -36,3 +37,7 @@ instance DBSum Float
3637instance DBSum Double
3738instance DBSum Scientific
3839instance DBSum CalendarDiffTime
40+
41+
42+instance {-# INCOHERENT #-} (HasNullability a, DBSum (Unnullify a)) =>
43+ Sql DBSum a
src/Rel8/Type/Tag.hs−13
@@ -1,13 +1,11 @@
11{-# language DataKinds #-}
22{-# language DeriveAnyClass #-}
33{-# language DerivingVia #-}
4−{-# language GeneralizedNewtypeDeriving #-}
54{-# language StandaloneKindSignatures #-}
65
76module Rel8.Type.Tag
87 ( EitherTag( IsLeft, IsRight ), isLeft, isRight
98 , MaybeTag( IsJust )
10− , Tag( Tag )
119 )
1210where
1311
@@ -32,9 +30,6 @@ import Rel8.Type.Monoid ( DBMonoid, memptyExpr )
3230import Rel8.Type.Ord ( DBOrd )
3331import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )
3432
35−-- text
36−import Data.Text ( Text )
37−
3833
3934type EitherTag :: Type
4035data EitherTag = IsLeft | IsRight
@@ -88,11 +83,3 @@ instance DBSemigroup MaybeTag where
8883
8984instance DBMonoid MaybeTag where
9085 memptyExpr = litExpr mempty
91−
92−
93−type Tag :: Type
94−newtype Tag = Tag Text
95− deriving newtype
96− ( Eq, Ord, Read, Show
97− , DBType, DBEq, DBOrd
98− )
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+174−338
@@ -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,17 +14,20 @@
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_ )
30+import Data.Functor.Identity ( Identity )
2731import Data.Int ( Int32, Int64 )
2832import Data.List ( nub, sort )
2933import Data.Maybe ( catMaybes )
@@ -35,30 +39,27 @@ import GHC.Generics ( Generic )
3539import qualified Data.ByteString.Lazy
3640
3741-- case-insensitive
38−import Data.CaseInsensitive ( mk )
42+import Data.CaseInsensitive (mk)
3943
4044-- containers
41−import Data.Containers.ListUtils ( nubOrdOn )
4245import qualified Data.Map.Strict as Map
4346
4447-- hasql
45−import Hasql.Connection ( Connection, acquire, release )
48+import Hasql.Connection ( Connection, acquire, release )
4649import Hasql.Session ( sql, run )
4750
48−-- hasql-transaction
49−import Hasql.Transaction ( Transaction, condemn, statement )
50−import qualified Hasql.Transaction.Sessions as Hasql
51−
5251-- hedgehog
5352import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )
5453import qualified Hedgehog.Gen as Gen
5554import qualified Hedgehog.Range as Range
5655
57−-- mmorph
58−import Control.Monad.Morph ( hoist )
56+-- lifted-base
57+import Control.Exception.Lifted ( bracket, throwIO, bracket_ )
58+
59+-- monad-control
60+import Control.Monad.Trans.Control ( MonadBaseControl )
5961
6062-- rel8
61−import Rel8 ( Result )
6263import qualified Rel8
6364
6465-- scientific
@@ -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,17 +113,14 @@ 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
129− , testEvaluate getTestDatabase
130124 ]
131125
132126 where
@@ -138,29 +132,25 @@ tests =
138132 flip run conn do
139133 sql "CREATE EXTENSION citext"
140134 sql "CREATE TABLE test_table ( column1 text not null, column2 bool not null )"
141− sql "CREATE TABLE unique_table ( \"key\" text not null unique, \"value\" text not null )"
142− sql "CREATE SEQUENCE test_seq"
143135
144136 return db
145137
146138 stopTestDatabase = TmpPostgres.stop
147139
148140
149−connect :: TmpPostgres.DB -> IO Connection
150−connect = acquire . TmpPostgres.toConnectionString >=> either (maybe empty (fail . unpack . decodeUtf8)) pure
151−
152−
153141databasePropertyTest
154142 :: TestName
155− -> ((TestT Transaction () -> PropertyT IO ()) -> PropertyT IO ())
143+ -> (((Connection -> TestT IO ()) -> PropertyT IO ()) -> PropertyT IO ())
156144 -> IO TmpPostgres.DB -> TestTree
157145databasePropertyTest testName f getTestDatabase =
158− withResource (connect =<< getTestDatabase) release $ \c ->
146+ withResource connect release $ \c ->
159147 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
148+ connection <- liftIO c
149+ f \g -> test $ rollingBack connection $ g connection
150+
151+ where
152+
153+ connect = either (error . show) return =<< acquire . TmpPostgres.toConnectionString =<< getTestDatabase
164154
165155
166156data TestTable f = TestTable
@@ -171,9 +161,9 @@ data TestTable f = TestTable
171161 deriving anyclass Rel8.Rel8able
172162
173163
174−deriving stock instance Eq (TestTable Result)
175−deriving stock instance Ord (TestTable Result)
176−deriving stock instance Show (TestTable Result)
164+deriving stock instance Eq (TestTable Identity)
165+deriving stock instance Ord (TestTable Identity)
166+deriving stock instance Show (TestTable Identity)
177167
178168
179169testTableSchema :: Rel8.TableSchema (TestTable Rel8.Name)
@@ -192,17 +182,18 @@ testSelectTestTable :: IO TmpPostgres.DB -> TestTree
192182testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do
193183 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
194184
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− }
185+ transaction \connection -> do
186+ void do
187+ liftIO $ Rel8.insert connection
188+ Rel8.Insert
189+ { into = testTableSchema
190+ , rows = map (Rel8.toInsert . Rel8.lit) rows
191+ , onConflict = Rel8.DoNothing
192+ , returning = Rel8.NumberOfRowsAffected
193+ }
203194
204− statement () $ Rel8.select do
205− Rel8.each testTableSchema
195+ selected <- liftIO $ Rel8.select connection do
196+ Rel8.each testTableSchema
206197
207198 sort selected === sort rows
208199
@@ -219,12 +210,11 @@ testWhere_ = databasePropertyTest "WHERE (Rel8.where_)" \transaction -> do
219210
220211 let expected = filter (\t -> testTableColumn2 t == magicBool) rows
221212
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
213+ transaction \connection -> do
214+ selected <- liftIO $ Rel8.select connection do
215+ t <- Rel8.values $ Rel8.lit <$> rows
216+ Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool
217+ return t
228218
229219 sort selected === sort expected
230220
@@ -237,12 +227,11 @@ testFilter :: IO TmpPostgres.DB -> TestTree
237227testFilter = databasePropertyTest "filter" \transaction -> do
238228 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable
239229
240− transaction do
230+ transaction \connection -> do
241231 let expected = filter testTableColumn2 rows
242232
243− selected <- lift do
244− statement () $ Rel8.select do
245− Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)
233+ selected <- liftIO $ Rel8.select connection
234+ $ Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)
246235
247236 sort selected === sort expected
248237
@@ -257,10 +246,9 @@ testLimit = databasePropertyTest "LIMIT (Rel8.limit)" \transaction -> do
257246
258247 n <- forAll $ Gen.integral (Range.linear 0 10)
259248
260− transaction do
261− selected <- lift do
262− statement () $ Rel8.select do
263− Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)
249+ transaction \connection -> do
250+ selected <- liftIO $ Rel8.select connection do
251+ Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)
264252
265253 diff (length selected) (<=) (fromIntegral n)
266254
@@ -278,10 +266,9 @@ testUnion = databasePropertyTest "UNION (Rel8.union)" \transaction -> evalM do
278266 left <- forAll $ Gen.list (Range.linear 0 10) genTestTable
279267 right <- forAll $ Gen.list (Range.linear 0 10) genTestTable
280268
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)
269+ transaction \connection -> do
270+ selected <- liftIO $ Rel8.select connection do
271+ Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)
285272
286273 sort selected === sort (nub (left ++ right))
287274
@@ -290,11 +277,9 @@ testDistinct :: IO TmpPostgres.DB -> TestTree
290277testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do
291278 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
292279
293− transaction do
294− selected <- lift do
295− statement () $ Rel8.select do
296− Rel8.distinct do
297− Rel8.values (Rel8.lit <$> rows)
280+ transaction \connection -> do
281+ selected <- liftIO $ Rel8.select connection $ Rel8.distinct do
282+ Rel8.values (Rel8.lit <$> rows)
298283
299284 sort selected === nub (sort rows)
300285
@@ -307,10 +292,8 @@ testExists :: IO TmpPostgres.DB -> TestTree
307292testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do
308293 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
309294
310− transaction do
311− exists <- lift do
312− statement () $ Rel8.select do
313− Rel8.exists $ Rel8.values $ Rel8.lit <$> rows
295+ transaction \connection -> do
296+ exists <- liftIO $ Rel8.select connection $ Rel8.exists $ Rel8.values $ Rel8.lit <$> rows
314297
315298 case rows of
316299 [] -> exists === [False]
@@ -321,10 +304,9 @@ testOptional :: IO TmpPostgres.DB -> TestTree
321304testOptional = databasePropertyTest "Rel8.optional" \transaction -> do
322305 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
323306
324− transaction do
325− selected <- lift do
326− statement () $ Rel8.select do
327− Rel8.optional $ Rel8.values (Rel8.lit <$> rows)
307+ transaction \connection -> do
308+ selected <- liftIO $ Rel8.select connection do
309+ Rel8.optional $ Rel8.values (Rel8.lit <$> rows)
328310
329311 case rows of
330312 [] -> selected === [Nothing]
@@ -335,10 +317,9 @@ testAnd :: IO TmpPostgres.DB -> TestTree
335317testAnd = databasePropertyTest "AND (&&.)" \transaction -> do
336318 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
337319
338− transaction do
339− [result] <- lift do
340− statement () $ Rel8.select do
341− pure $ Rel8.lit x Rel8.&&. Rel8.lit y
320+ transaction \connection -> do
321+ [result] <- liftIO $ Rel8.select connection $ pure $
322+ Rel8.lit x Rel8.&&. Rel8.lit y
342323
343324 result === (x && y)
344325
@@ -347,10 +328,9 @@ testOr :: IO TmpPostgres.DB -> TestTree
347328testOr = databasePropertyTest "OR (||.)" \transaction -> do
348329 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
349330
350− transaction do
351− [result] <- lift do
352− statement () $ Rel8.select $ pure $
353− Rel8.lit x Rel8.||. Rel8.lit y
331+ transaction \connection -> do
332+ [result] <- liftIO $ Rel8.select connection $ pure $
333+ Rel8.lit x Rel8.||. Rel8.lit y
354334
355335 result === (x || y)
356336
@@ -359,10 +339,9 @@ testLogicalFixities :: IO TmpPostgres.DB -> TestTree
359339testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do
360340 (u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool
361341
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
342+ transaction \connection -> do
343+ [result] <- liftIO $ Rel8.select connection $ pure $
344+ Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x
366345
367346 result === (u || v && w == x)
368347
@@ -371,10 +350,9 @@ testNot :: IO TmpPostgres.DB -> TestTree
371350testNot = databasePropertyTest "NOT (not_)" \transaction -> do
372351 x <- forAll Gen.bool
373352
374− transaction do
375− [result] <- lift do
376− statement () $ Rel8.select do
377− pure $ Rel8.not_ $ Rel8.lit x
353+ transaction \connection -> do
354+ [result] <- liftIO $ Rel8.select connection $ pure $
355+ Rel8.not_ $ Rel8.lit x
378356
379357 result === not x
380358
@@ -383,10 +361,9 @@ testBool :: IO TmpPostgres.DB -> TestTree
383361testBool = databasePropertyTest "ifThenElse_" \transaction -> do
384362 (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool
385363
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)
364+ transaction \connection -> do
365+ [result] <- liftIO $ Rel8.select connection $ pure $
366+ Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)
390367
391368 result === if x then y else z
392369
@@ -398,10 +375,9 @@ testAp = databasePropertyTest "Cartesian product (<*>)" \transaction -> do
398375 (Gen.list (Range.linear 1 10) genTestTable)
399376 (Gen.list (Range.linear 1 10) genTestTable)
400377
401− transaction do
402− result <- lift do
403− statement () $ Rel8.select do
404− liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))
378+ transaction \connection -> do
379+ result <- liftIO $ Rel8.select connection $ do
380+ liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))
405381
406382 sort result === sort (liftA2 (,) rows1 rows2)
407383
@@ -430,22 +406,21 @@ testDBType getTestDatabase = testGroup "DBType instances"
430406 where
431407 dbTypeTest :: (Eq a, Show a, Rel8.DBType a) => TestName -> Gen a -> TestTree
432408 dbTypeTest name generator = testGroup name
433− [ databasePropertyTest name (t generator) getTestDatabase
434− , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase
409+ [ databasePropertyTest name (t (==) generator) getTestDatabase
410+ , databasePropertyTest ("Maybe " <> name) (t (==) (Gen.maybe generator)) getTestDatabase
435411 ]
436412
437− t :: forall a b. (Eq a, Show a, Rel8.Sql Rel8.DBType a)
438− => Gen a
439− -> (TestT Transaction () -> PropertyT IO b)
413+ t :: forall a b. (Show a, Rel8.Sql Rel8.DBType a)
414+ => (a -> a -> Bool)
415+ -> Gen a
416+ -> ((Connection -> TestT IO ()) -> PropertyT IO b)
440417 -> PropertyT IO b
441− t generator transaction = do
418+ t eq generator transaction = do
442419 x <- forAll generator
443420
444− transaction do
445− [res] <- lift do
446− statement () $ Rel8.select do
447− pure (Rel8.litExpr x)
448− diff res (==) x
421+ transaction \connection -> do
422+ [res] <- liftIO $ Rel8.select connection $ pure (Rel8.litExpr x)
423+ diff res eq x
449424
450425 genDay :: Gen Day
451426 genDay = do
@@ -487,38 +462,39 @@ testDBEq getTestDatabase = testGroup "DBEq instances"
487462
488463 t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBEq a)
489464 => Gen a
490− -> (TestT Transaction () -> PropertyT IO ())
465+ -> ((Connection -> TestT IO ()) -> PropertyT IO ())
491466 -> PropertyT IO ()
492467 t generator transaction = do
493468 (x, y) <- forAll (liftA2 (,) generator generator)
494469
495− transaction do
496− [res] <- lift do
497− statement () $ Rel8.select do
498− pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y
470+ transaction \connection -> do
471+ [res] <- liftIO $ Rel8.select connection $ pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y
499472 res === (x == y)
500473
474+ cover 1 "Equal" $ x == y
475+ cover 1 "Not Equal" $ x /= y
476+
501477
502478testTableEquality :: IO TmpPostgres.DB -> TestTree
503479testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do
504480 (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable
505481
506− transaction do
507− [eq] <- lift do
508− statement () $ Rel8.select do
509− pure $ Rel8.lit x Rel8.==: Rel8.lit y
482+ transaction \connection -> do
483+ [eq] <- liftIO $ Rel8.select connection do
484+ pure $ Rel8.lit x Rel8.==: Rel8.lit y
510485
511486 eq === (x == y)
512487
488+ cover 1 "Equal" $ x == y
489+ cover 1 "Not Equal" $ x /= y
490+
513491
514492testFromString :: IO TmpPostgres.DB -> TestTree
515493testFromString = databasePropertyTest "FromString" \transaction -> do
516494 str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode
517495
518− transaction do
519− [result] <- lift do
520− statement () $ Rel8.select do
521− pure $ fromString str
496+ transaction \connection -> do
497+ [result] <- liftIO $ Rel8.select connection $ pure $ fromString str
522498 result === pack str
523499
524500
@@ -526,11 +502,10 @@ testCatMaybeTable :: IO TmpPostgres.DB -> TestTree
526502testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do
527503 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
528504
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)
505+ transaction \connection -> do
506+ selected <- liftIO $ Rel8.select connection do
507+ testTable <- Rel8.values $ Rel8.lit <$> rows
508+ Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)
534509
535510 sort selected === sort (filter testTableColumn2 rows)
536511
@@ -539,10 +514,9 @@ testCatMaybe :: IO TmpPostgres.DB -> TestTree
539514testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do
540515 rows <- forAll $ Gen.list (Range.linear 0 10) $ Gen.maybe Gen.bool
541516
542− transaction do
543− selected <- lift do
544− statement () $ Rel8.select do
545− Rel8.catNull =<< Rel8.values (map Rel8.lit rows)
517+ transaction \connection -> do
518+ selected <- evalM $ liftIO $ Rel8.select connection do
519+ Rel8.catNullable =<< Rel8.values (map Rel8.lit rows)
546520
547521 sort selected === sort (catMaybes rows)
548522
@@ -551,50 +525,27 @@ testMaybeTable :: IO TmpPostgres.DB -> TestTree
551525testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do
552526 (rows, def) <- forAll $ liftA2 (,) (Gen.list (Range.linear 0 10) genTestTable) genTestTable
553527
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))
528+ transaction \connection -> do
529+ selected <- liftIO $ Rel8.select connection $
530+ Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))
558531
559532 case rows of
560533 [] -> selected === [def]
561534 _ -> sort selected === sort rows
562535
563536
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−
586537data TwoTestTables f =
587538 TwoTestTables
588539 { testTable1 :: TestTable f
589540 , testTable2 :: TestTable f
590541 }
591− deriving stock Generic
542+ deriving stock Generic
592543 deriving anyclass Rel8.Rel8able
593544
594545
595−deriving stock instance Eq (TwoTestTables Result)
596−deriving stock instance Ord (TwoTestTables Result)
597−deriving stock instance Show (TwoTestTables Result)
546+deriving stock instance Eq (TwoTestTables Identity)
547+deriving stock instance Ord (TwoTestTables Identity)
548+deriving stock instance Show (TwoTestTables Identity)
598549
599550
600551testNestedTables :: IO TmpPostgres.DB -> TestTree
@@ -603,10 +554,9 @@ testNestedTables = databasePropertyTest "Nested TestTables" \transaction -> eval
603554 Gen.list (Range.linear 0 10) $
604555 liftA2 TwoTestTables genTestTable genTestTable
605556
606− transaction do
607− selected <- lift do
608− statement () $ Rel8.select do
609− Rel8.values (Rel8.lit <$> rows)
557+ transaction \connection -> do
558+ selected <- liftIO $ Rel8.select connection do
559+ Rel8.values (Rel8.lit <$> rows)
610560
611561 sort selected === sort rows
612562
@@ -616,12 +566,11 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction
616566 rows1 <- genRows
617567 rows2 <- genRows
618568
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
569+ transaction \connection -> do
570+ selected <- liftIO $ Rel8.select connection do
571+ as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))
572+ bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))
573+ pure $ liftA2 (,) as bs
625574
626575 case (rows1, rows2) of
627576 ([], []) -> selected === [Nothing]
@@ -629,12 +578,20 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction
629578 (as, []) -> selected === (Nothing <$ as)
630579 (as, bs) -> sort selected === sort (Just <$> liftA2 (,) as bs)
631580 where
632− genRows :: PropertyT IO [TestTable Result]
581+ genRows :: PropertyT IO [TestTable Identity]
633582 genRows = forAll do
634583 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)
635584
585+rollingBack
586+ :: (MonadBaseControl IO m, MonadIO m)
587+ => Connection -> m a -> m a
588+rollingBack connection =
589+ bracket_
590+ (liftIO (run (sql "BEGIN") connection))
591+ (liftIO (run (sql "ROLLBACK") connection))
592+
636593
637−genTestTable :: Gen (TestTable Result)
594+genTestTable :: Gen (TestTable Identity)
638595genTestTable = do
639596 testTableColumn1 <- Gen.text (Range.linear 0 5) Gen.alphaNum
640597 testTableColumn2 <- Gen.bool
@@ -645,19 +602,19 @@ testUpdate :: IO TmpPostgres.DB -> TestTree
645602testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do
646603 rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable
647604
648− transaction do
649− selected <- lift do
650− statement () $ Rel8.insert Rel8.Insert
605+ transaction \connection -> do
606+ void $ liftIO $ Rel8.insert connection
607+ Rel8.Insert
651608 { into = testTableSchema
652− , rows = Rel8.values $ map Rel8.lit $ Map.keys rows
609+ , rows = map (Rel8.toInsert . Rel8.lit) $ Map.keys rows
653610 , onConflict = Rel8.DoNothing
654− , returning = pure ()
611+ , returning = Rel8.NumberOfRowsAffected
655612 }
656613
657− statement () $ Rel8.update Rel8.Update
614+ void $ liftIO $ Rel8.update connection
615+ Rel8.Update
658616 { target = testTableSchema
659− , from = pure ()
660− , set = \_ r ->
617+ , set = \r ->
661618 let updates = map (bimap Rel8.lit Rel8.lit) $ Map.toList rows
662619 in
663620 foldl
@@ -671,12 +628,12 @@ testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do
671628 )
672629 r
673630 updates
674− , updateWhere = \_ _ -> Rel8.lit True
675− , returning = pure ()
631+ , updateWhere = \_ -> Rel8.lit True
632+ , returning = Rel8.NumberOfRowsAffected
676633 }
677634
678− statement () $ Rel8.select do
679− Rel8.each testTableSchema
635+ selected <- liftIO $ Rel8.select connection do
636+ Rel8.each testTableSchema
680637
681638 sort selected === sort (Map.elems rows)
682639
@@ -689,113 +646,45 @@ testDelete :: IO TmpPostgres.DB -> TestTree
689646testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do
690647 rows <- forAll $ Gen.list (Range.linear 0 5) genTestTable
691648
692− transaction do
693− (deleted, selected) <- lift do
694− statement () $ Rel8.insert Rel8.Insert
649+ transaction \connection -> do
650+ void $ liftIO $ Rel8.insert connection
651+ Rel8.Insert
695652 { into = testTableSchema
696− , rows = Rel8.values $ map Rel8.lit rows
653+ , rows = map (Rel8.toInsert . Rel8.lit) rows
697654 , onConflict = Rel8.DoNothing
698− , returning = pure ()
655+ , returning = Rel8.NumberOfRowsAffected
699656 }
700657
701− deleted <- statement () $ Rel8.delete Rel8.Delete
658+ deleted <-
659+ liftIO $ Rel8.delete connection
660+ Rel8.Delete
702661 { from = testTableSchema
703− , using = pure ()
704− , deleteWhere = const testTableColumn2
662+ , deleteWhere = testTableColumn2
705663 , returning = Rel8.Projection id
706664 }
707665
708− selected <- statement () $ Rel8.select do
709− Rel8.each testTableSchema
710−
711− pure (deleted, selected)
666+ selected <- liftIO $ Rel8.select connection do
667+ Rel8.each testTableSchema
712668
713669 sort (deleted <> selected) === sort rows
714670
715671
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−
782672newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }
783673 deriving stock Generic
784674 deriving anyclass Rel8.Rel8able
785675
786−deriving stock instance Eq (HKNestedPair Result)
787−deriving stock instance Ord (HKNestedPair Result)
788−deriving stock instance Show (HKNestedPair Result)
676+deriving stock instance Eq (HKNestedPair Identity)
677+deriving stock instance Ord (HKNestedPair Identity)
678+deriving stock instance Show (HKNestedPair Identity)
789679
790680
791681testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree
792682testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do
793683 rows <- forAll $ Gen.list (Range.linear 0 10) $ HKNestedPair <$> liftA2 (,) genTestTable genTestTable
794684
795− transaction do
796− selected <- lift do
797− statement () $ Rel8.select do
798− Rel8.values $ map Rel8.lit rows
685+ transaction \connection -> do
686+ selected <- liftIO $ Rel8.select connection do
687+ Rel8.values $ map Rel8.lit rows
799688
800689 sort selected === sort rows
801690
@@ -804,23 +693,12 @@ testSelectArray :: IO TmpPostgres.DB -> TestTree
804693testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do
805694 rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool
806695
807− transaction do
808− selected <- lift do
809− statement () $ Rel8.select do
810− Rel8.many $ Rel8.values (map Rel8.lit rows)
696+ transaction \connection -> do
697+ selected <- liftIO $ Rel8.select connection $ Rel8.aggregate do
698+ Rel8.listAgg <$> Rel8.values (map Rel8.lit rows)
811699
812700 selected === [foldMap pure rows]
813701
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)
821−
822− selected' === liftA2 (,) rows rows
823−
824702
825703data NestedMaybeTable f = NestedMaybeTable
826704 { nmt1 :: Rel8.Column f Bool
@@ -830,60 +708,18 @@ data NestedMaybeTable f = NestedMaybeTable
830708 deriving anyclass Rel8.Rel8able
831709
832710
833−deriving stock instance Eq (NestedMaybeTable Result)
834−deriving stock instance Ord (NestedMaybeTable Result)
835−deriving stock instance Show (NestedMaybeTable Result)
711+deriving stock instance Eq (NestedMaybeTable Identity)
712+deriving stock instance Ord (NestedMaybeTable Identity)
713+deriving stock instance Show (NestedMaybeTable Identity)
836714
837715
838716testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree
839717testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do
840718 let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) }
841719
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)
720+ transaction \connection -> do
721+ selected <- liftIO $ Rel8.select connection do
722+ x <- Rel8.values [Rel8.lit example]
723+ pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)
847724
848725 selected === [True]
849−
850−
851−testEvaluate :: IO TmpPostgres.DB -> TestTree
852−testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect" \transaction -> do
853−
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))
860−
861− normalize selected ===
862− [ ('a', (0, 0))
863− , ('b', (1, 1))
864− , ('c', (2, 2))
865− ]
866−
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))
873−
874− normalize selected' ===
875− [ (('a', 'd'), (0, 0))
876− , (('a', 'e'), (1, 1))
877− , (('a', 'f'), (2, 2))
878− , (('b', 'd'), (3, 3))
879− , (('b', 'e'), (4, 4))
880− , (('b', 'f'), (5, 5))
881− , (('c', 'd'), (6, 6))
882− , (('c', 'e'), (7, 7))
883− , (('c', 'f'), (8, 8))
884− ]
885−
886− where
887− normalize :: [(x, (Int64, Int64))] -> [(x, (Int64, Int64))]
888− normalize [] = []
889− normalize xs@((_, (i, _)) : _) = map (fmap (\(a, b) -> (a - i, b - i))) xs
tests/Rel8/Generic/Rel8able/Test.hsdeleted−188
@@ -1,188 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language DeriveAnyClass #-}
3−{-# language DeriveGeneric #-}
4−{-# language DerivingStrategies #-}
5−{-# language DuplicateRecordFields #-}
6−{-# language FlexibleInstances #-}
7−{-# language MultiParamTypeClasses #-}
8−{-# language StandaloneKindSignatures #-}
9−{-# language TypeFamilies #-}
10−{-# language UndecidableInstances #-}
11−
12−{-# options_ghc -O0 #-}
13−
14−module Rel8.Generic.Rel8able.Test
15− ( module Rel8.Generic.Rel8able.Test
16− )
17−where
18−
19−-- base
20−import GHC.Generics ( Generic )
21−import Prelude
22−
23−-- rel8
24−import Rel8
25−
26−-- text
27−import Data.Text ( Text )
28−
29−
30−data TableTest f = TableTest
31− { foo :: Column f Bool
32− , bar :: Column f (Maybe Bool)
33− }
34− deriving stock Generic
35− deriving anyclass Rel8able
36−
37−
38−data TablePair f = TablePair
39− { foo :: Column f Bool
40− , bars :: (Column f Text, Column f Text)
41− }
42− deriving stock Generic
43− deriving anyclass Rel8able
44−
45−
46−data TableMaybe f = TableMaybe
47− { foo :: Column f [Maybe Bool]
48− , bars :: HMaybe f (TablePair f, TablePair f)
49− }
50− deriving stock Generic
51− deriving anyclass Rel8able
52−
53−
54−data TableEither f = TableEither
55− { foo :: Column f Bool
56− , bars :: HEither f (HMaybe f (TablePair f, TablePair f)) (Column f Char)
57− }
58− deriving stock Generic
59− deriving anyclass Rel8able
60−
61−
62−data TableThese f = TableThese
63− { foo :: Column f Bool
64− , bars :: HThese f (TableMaybe f) (TableEither f)
65− }
66− deriving stock Generic
67− deriving anyclass Rel8able
68−
69−
70−data TableList f = TableList
71− { foo :: Column f Bool
72− , bars :: HList f (TableThese f)
73− }
74− deriving stock Generic
75− deriving anyclass Rel8able
76−
77−
78−data TableNonEmpty f = TableNonEmpty
79− { foo :: Column f Bool
80− , bars :: HNonEmpty f (TableList f, TableMaybe f)
81− }
82− deriving stock Generic
83− deriving anyclass Rel8able
84−
85−
86−data TableNest f = TableNest
87− { foo :: Column f Bool
88− , bars :: HList f (HMaybe f (TablePair f))
89− }
90− deriving stock Generic
91− deriving anyclass Rel8able
92−
93−
94−data S3Object = S3Object
95− { bucketName :: Text
96− , objectKey :: Text
97− }
98− deriving stock Generic
99−
100−
101−instance x ~ HKD S3Object Expr => ToExprs x S3Object
102−
103−
104−data HKDSum = HKDSumA Text | HKDSumB Bool Char | HKDSumC
105− deriving stock Generic
106−
107−
108−instance x ~ HKD HKDSum Expr => ToExprs x HKDSum
109−
110−
111−data HKDTest f = HKDTest
112− { s3Object :: Lift f S3Object
113− , hkdSum :: Lift f HKDSum
114− }
115− deriving stock Generic
116− deriving anyclass Rel8able
117−
118−
119−data NonRecord f = NonRecord
120− (Column f Bool)
121− (Column f Char)
122− (Column f Char)
123− (Column f Char)
124− (Column f Char)
125− (Column f Char)
126− (Column f Char)
127− (Column f Char)
128− (Column f Char)
129− (Column f Char)
130− deriving stock Generic
131− deriving anyclass Rel8able
132−
133−
134−data TableSum f
135− = TableSumA (Column f Bool) (Column f Text)
136− | TableSumB
137− | TableSumC (Column f Text)
138− deriving stock Generic
139−
140−
141−data BarbieSum f
142− = BarbieSumA (f Bool) (f Text)
143− | BarbieSumB
144− | BarbieSumC (f Text)
145− deriving stock Generic
146−
147−
148−data TableProduct f = TableProduct
149− { sum :: HADT f BarbieSum
150− , list :: TableList f
151− , foos :: HList f (HADT f TableSum, Lift f HKDSum, HKDTest f)
152− }
153− deriving stock Generic
154− 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