git.iko.soy/rel8
on master help sign in
swap
6c038ec177 ahead, 0 behind
154 files changed+6852−6660
since splitsnapshots
unifiedsplit
.github/workflows/build.yaml+3−3 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+18−17 docs/concepts/expr.rst+2−2 docs/concepts/insert.rst+181 docs/concepts/queries.rst+9−9 docs/cookbook.rst+10−8 docs/index.rst+2−1 docs/tutorial.rst+64−47 nix/sources.json+9−9 nix/sources.nix+66−20 rel8.cabal+50−28 shell.nix+1−1 src/Rel8.hs+340−52 src/Rel8/Aggregate.hs+42−128 src/Rel8/Aggregate/Legacy.hs−129 src/Rel8/Column.hs+9−13 src/Rel8/Column/ADT.hs+3−70 src/Rel8/Column/Either.hs+7−153 src/Rel8/Column/Field.hs−110 src/Rel8/Column/Lift.hs+3−69 src/Rel8/Column/List.hs+8−131 src/Rel8/Column/Maybe.hs+7−111 src/Rel8/Column/NonEmpty.hs+9−132 src/Rel8/Column/Null.hs+26 src/Rel8/Column/These.hs+8−155 src/Rel8/Expr.hs+17−47 src/Rel8/Expr.hs-boot+6−8 src/Rel8/Expr/Aggregate.hs+53−115 src/Rel8/Expr/Array.hs+6−6 src/Rel8/Expr/Default.hs+35 src/Rel8/Expr/Eq.hs+1−1 src/Rel8/Expr/Num.hs+39−6 src/Rel8/Expr/Opaleye.hs+19−5 src/Rel8/Expr/Sequence.hs+22 src/Rel8/Expr/Text.hs+24−4 src/Rel8/Expr/Time.hs+2−2 src/Rel8/Expr/Window.hs+121 src/Rel8/FCF.hs+3−3 src/Rel8/Generic/Construction.hs+199−300 src/Rel8/Generic/Construction/ADT.hs+178−59 src/Rel8/Generic/Construction/Record.hs+30−30 src/Rel8/Generic/Map.hs+20−64 src/Rel8/Generic/Record.hs+2 src/Rel8/Generic/Reify.hs−24 src/Rel8/Generic/Rel8able.hs+188−81 src/Rel8/Generic/Table.hs+24−109 src/Rel8/Generic/Table/ADT.hs+61−203 src/Rel8/Generic/Table/Record.hs+74−99 src/Rel8/Kind/Context.hs+8−41 src/Rel8/Kind/Labels.hs−57 src/Rel8/Kind/Necessity.hs−38 src/Rel8/Order.hs+2−9 src/Rel8/Query.hs+181−7 src/Rel8/Query.hs-boot+3−1 src/Rel8/Query/Aggregate.hs+22−2 src/Rel8/Query/Distinct.hs+4−9 src/Rel8/Query/Each.hs+3−3 src/Rel8/Query/Either.hs+27−17 src/Rel8/Query/Evaluate.hs+49 src/Rel8/Query/Exists.hs+15−17 src/Rel8/Query/Indexed.hs+21 src/Rel8/Query/List.hs+93−14 src/Rel8/Query/Maybe.hs+26−45 src/Rel8/Query/Null.hs+15 src/Rel8/Query/Opaleye.hs+41−5 src/Rel8/Query/Rebind.hs+27 src/Rel8/Query/SQL.hs+6−59 src/Rel8/Query/Set.hs+6−6 src/Rel8/Query/These.hs+52−45 src/Rel8/Query/Window.hs+26 src/Rel8/Schema/Context.hs−20 src/Rel8/Schema/Context/Label.hs−60 src/Rel8/Schema/Context/Nullify.hs+105−149 src/Rel8/Schema/Field.hs+50 src/Rel8/Schema/HTable.hs+51−24 src/Rel8/Schema/HTable/Either.hs+2−4 src/Rel8/Schema/HTable/Identity.hs+16−29 src/Rel8/Schema/HTable/Label.hs+37−50 src/Rel8/Schema/HTable/MapTable.hs+22−12 src/Rel8/Schema/HTable/Maybe.hs+2−4 src/Rel8/Schema/HTable/Nullify.hs+47−33 src/Rel8/Schema/HTable/These.hs+2−4 src/Rel8/Schema/HTable/Vectorize.hs+39−47 src/Rel8/Schema/Insert.hs−167 src/Rel8/Schema/Kind.hs+6−15 src/Rel8/Schema/Name.hs+34−54 src/Rel8/Schema/Reify.hs−74 src/Rel8/Schema/Result.hs+20−41 src/Rel8/Schema/Spec.hs+17−45 src/Rel8/Schema/Spec/ConstrainDBType.hs−89 src/Rel8/Schema/Spec/ConstrainType.hs−31 src/Rel8/Schema/Table.hs+20 src/Rel8/Statement/Delete.hs+35−48 src/Rel8/Statement/Insert.hs+60−60 src/Rel8/Statement/OnConflict.hs+106 src/Rel8/Statement/Returning.hs+114−10 src/Rel8/Statement/SQL.hs+29 src/Rel8/Statement/Select.hs+120−35 src/Rel8/Statement/Set.hs+33 src/Rel8/Statement/Update.hs+38−60 src/Rel8/Statement/Using.hs+36 src/Rel8/Statement/View.hs+43−28 src/Rel8/Statement/Where.hs+31 src/Rel8/Table.hs+88−252 src/Rel8/Table/ADT.hs+64−84 src/Rel8/Table/Aggregate.hs+37−36 src/Rel8/Table/Bool.hs+5−6 src/Rel8/Table/Cols.hs+50 src/Rel8/Table/Either.hs+147−152 src/Rel8/Table/Eq.hs+12−39 src/Rel8/Table/HKD.hs+91−121 src/Rel8/Table/Insert.hs−51 src/Rel8/Table/List.hs+71−66 src/Rel8/Table/Maybe.hs+121−139 src/Rel8/Table/Name.hs+37−26 src/Rel8/Table/NonEmpty.hs+72−64 src/Rel8/Table/Null.hs+147 src/Rel8/Table/Nullify.hs+211 src/Rel8/Table/Opaleye.hs+84−75 src/Rel8/Table/Ord.hs+16−45 src/Rel8/Table/Order.hs+13−16 src/Rel8/Table/Projection.hs+73 src/Rel8/Table/Recontextualize.hs−87 src/Rel8/Table/Rel8able.hs+29−85 src/Rel8/Table/Serialize.hs+24−119 src/Rel8/Table/Tag.hs−97 src/Rel8/Table/These.hs+201−164 src/Rel8/Table/Transpose.hs+46 src/Rel8/Table/Undefined.hs+5−5 src/Rel8/Table/Unreify.hs−106 src/Rel8/Table/Window.hs+43 src/Rel8/Tabulate.hs+530−246 src/Rel8/Type.hs+9−8 src/Rel8/Type/Array.hs+46−26 src/Rel8/Type/Array1D.hs−139 src/Rel8/Type/Composite.hs+90−39 src/Rel8/Type/Enum.hs+86−33 src/Rel8/Type/JSONBEncoded.hs+4 src/Rel8/Type/JSONEncoded.hs+4 src/Rel8/Type/Monoid.hs+2−2 src/Rel8/Type/Num.hs+4−1 src/Rel8/Type/Ord.hs−2 src/Rel8/Type/ReadShow.hs+3 src/Rel8/Type/Semigroup.hs+4−2 src/Rel8/Type/Tag.hs+2−1 src/Rel8/Window.hs+97 tests/Main.hs+323−159 src/Rel8/Generic/Rel8able/Test.hs → tests/Rel8/Generic/Rel8able/Test.hs+49−18
.github/workflows/build.yaml+3−3
@@ -9,14 +9,14 @@ jobs:
99 persist-credentials: false
1010 submodules: true
1111
12− - uses: cachix/install-nix-action@v12
12+ - uses: cachix/install-nix-action@v14.1
1313 with:
1414 nix_path: nixpkgs=channel:nixos-unstable
1515 extra_nix_config: |
1616 trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ=
17− substituters = https://cache.nixos.org/ https://hydra.iohk.io
17+ substituters = https://cache.nixos.org/ https://cache.iog.io
1818
19− - uses: cachix/cachix-action@v8
19+ - uses: cachix/cachix-action@v10
2020 with:
2121 name: rel8
2222 authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}'
Changelog.mdnew file+159
@@ -0,0 +1,159 @@
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 2020 Oliver Charles
1+Copyright 2021 Oliver Charles
22
33All rights reserved.
44
README.md+4
@@ -10,4 +10,8 @@ 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+
1317For more details, check out the [official documentation](https://rel8.readthedocs.io/en/latest/).
cabal.project−5
@@ -1,6 +1 @@
11packages: .
2−
3−allow-newer: generic-monoid:base
4−allow-newer: cryptohash-sha1:base
5−allow-newer: cryptohash-md5:base
6−allow-newer: entropy:Cabal
cabal.project.haskell-nix−6
@@ -2,9 +2,3 @@
22-- will interpret them as local packages, and try to build them when we cabal
33-- build. The only reason we have to specify these is for Haskell.nix to know to
44-- override these packages by fetching them rather than using Hackage.
5−
6−source-repository-package
7− type: git
8− location: git://github.com/jcpetruzza/barbies
9− tag: f99b05454874192e3511bd133555dfb6cc6a6ecb
10− --sha256: 0yy2i2jbllwavv5d2176rf8lmm4l1ws90lxkmdlfgvfzqxidx0gi
default.nix+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-2009;
4+ nixpkgsSrc = haskellNix.sources.nixpkgs-unstable;
55
66 nixpkgsArgs = haskellNix.nixpkgsArgs;
77
8− compiler-nix-name = "ghc8104";
8+ compiler-nix-name = "ghc924";
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+18−17
@@ -11,18 +11,19 @@ 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 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::
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::
2627
2728 newtype UserId = UserId { getUserId :: Int64 }
2829 deriving newtype DBType
@@ -57,8 +58,8 @@ In our PostgreSQL we have a few choices, but for now we'll assume that they are
5758stored as ``text`` values.
5859
5960In order to use this type in Rel8 queries, we need to write an instance of
60−``DBType`` for ``OrderStatus``. One approach is to use ``parseTypeInformation``,
61−which allows you to refine an existing ``DBType``::
61+``DBType`` for ``OrderStatus``. One approach is to use
62+``parseTypeInformation``, which allows you to refine an existing ``DBType``::
6263
6364 instance DBType OrderStatus where
6465 typeInformation = parseTypeInformation parser printer typeInformation
@@ -100,9 +101,9 @@ There usage is very similar to ``ReadShow`` - simply derive ``DBType via
100101JSONEncoded``, and Rel8 will use ``ToJSON`` and ``FromJSON`` instances (from
101102``aeson``) to serialize the given type.
102103
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::
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::
106107
107108 data Event = UserCreated UserCreatedData | OrderCreated OrderCreatedData
108109 deriving stock Generic
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.rstnew file+181
@@ -0,0 +1,181 @@
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+9−9
@@ -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.
@@ -138,20 +138,20 @@ a query. The above query could thus be written as::
138138
139139``where_`` and ``filter`` allow you to filter rows based on an expression, but
140140sometimes we want to filter based on another query. For this, Rel8 offers
141−``whereExists`` and ``whereNotExists``. For example, if all blog posts have a
142−list of tags, we could use ``whereExists`` to find all blog posts that have been
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
143143tagged as "Haskell"::
144144
145145 blogPost <- each blogPostSchema
146− whereExists do
146+ present do
147147 filter (("Haskell" ==.) . tagName) =<< tagFromBlogPost blogPost
148148
149−Notice that this example uses ``whereExists`` with a query that itself uses
150−``filter``. For each blog post, ``whereExists`` causes that row to be selected
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
151151only if the associated query finds a tag for that blog post with the ``tagName``
152152"Haskell".
153153
154−Like ``filter`` there is also a chaining variant of ``whereExists`` - ``with``.
154+Like ``filter`` there is also a chaining variant of ``present`` - ``with``.
155155We could rewrite the above query using ``with`` as::
156156
157157 haskellBlogPost <-
@@ -194,11 +194,11 @@ and this query can be written in Rel8 as::
194194
195195 authorForBlogPost :: BlogPost Expr -> Query (Author Expr)
196196 authorForBlogPost blogPost =
197− filter ((blogPostAuthorId blogPost ==.) authorId author) =<<
197+ filter ((blogPostAuthorId blogPost ==.) . authorId) =<<
198198 each authorSchema
199199
200200 While this is a little more code over all, in our experience this style
201− dramatically increases the readabality of queries using joins.
201+ dramatically increases the readability of queries using joins.
202202
203203Left (outer) joins with ``optional``
204204------------------------------------
docs/cookbook.rst+10−8
@@ -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,23 +142,25 @@ rows, but can also return *tree*\s.
142142To understand what this means, we'll consider a small example query for blog
143143posts. We want our query to return:
144144
145−1. The latest 5 blog posts.
145+1. The latest 5 blog posts that have at least one tag each.
1461462. For each blog post, all tags.
147−3. For each blog post, the latest 3 comments.
147+3. For each blog post, the latest 3 comments if they exist.
148148
149149In Rel8, we can write this query as::
150150
151151 latestBlogPosts = do
152152 post <- each postSchema
153153
154− tags <- aggregate do
154+ -- Returns a `NonEmptyTable a` which ends up as a `Data.List.NonEmpty a` after the query is run
155+ tags <- some $ do
155156 tag <- each tagSchema
156157 where_ (tagPostId tag ==. postId post)
157− return (listAgg (tagName tag))
158+ return (tagName tag)
158159
159− latestComments <-
160− many $
161− limit 3 $
160+ -- Returns a `ListTable a` which ends up as a `[a]` after the query is run
161+ latestComments <-
162+ many $
163+ limit 3 $
162164 orderBy (commentCreatedAt >$< desc) do
163165 comment <- each commentSchema
164166 where_ (commentPostId comment ==. postId post)
docs/index.rst+2−1
@@ -30,6 +30,7 @@ The main objectives of Rel8 are:
3030 concepts/expr
3131 concepts/tables
3232 concepts/queries
33+ concepts/insert
3334
3435.. toctree::
3536 :caption: Tips and tricks
@@ -49,4 +50,4 @@ More Resources
4950
5051* If you think you've found a bug, confusing behavior, or have a feature
5152 request, please raise an issue at `Rel8's issue tracker
52− <https://github.com/circuithub/rel8>`_.
53+ <https://github.com/circuithub/rel8>`_.
docs/tutorial.rst+64−47
@@ -5,24 +5,25 @@ 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 -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 #-}
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 #-}
2424
2525 import Prelude
26+ import Rel8
2627
2728The Example Schema
2829------------------
@@ -70,7 +71,7 @@ Following these steps for ``author``, we have::
7071 { authorId :: Column f Int64
7172 , name :: Column f Text
7273 , url :: Column f (Maybe Text)
73− }
74+ }
7475 deriving stock (Generic)
7576 deriving anyclass (Rel8able)
7677
@@ -81,7 +82,7 @@ in our project, it would be too easy to accidentally mix them up and create
8182nonsensical joins. As Haskell programmers, we often solve this problem by
8283creating ``newtype`` wrappers, and we can also use this technique with Rel8::
8384
84− newtype AuthorId = AuthorId { toInt64 :: Int64 }
85+ newtype AuthorId = AuthorId { toInt64 :: Int64 }
8586 deriving newtype (DBEq, DBType, Eq, Show)
8687
8788Now we can write our final schema mapping. First, the ``author`` table::
@@ -90,7 +91,7 @@ Now we can write our final schema mapping. First, the ``author`` table::
9091 { authorId :: Column f AuthorId
9192 , authorName :: Column f Text
9293 , authorUrl :: Column f (Maybe Text)
93− }
94+ }
9495 deriving stock (Generic)
9596 deriving anyclass (Rel8able)
9697
@@ -99,16 +100,16 @@ And similarly, the ``project`` table::
99100 data Project f = Project
100101 { projectAuthorId :: Column f AuthorId
101102 , projectName :: Column f Text
102− }
103+ }
103104 deriving stock (Generic)
104− deriving anyclass (Rel8able
105+ deriving anyclass (Rel8able)
105106
106107To show query results in this documentation, we'll also need ``Show`` instances:
107108Unfortunately these definitions look a bit scary, but they are essentially just
108109``deriving (Show)``::
109110
110− deriving stock instance f ~ Identity => Show (Author f)
111− deriving stock instance f ~ Identity => Show (Project f)
111+ deriving stock instance f ~ Result => Show (Author f)
112+ deriving stock instance f ~ Result => Show (Project f)
112113
113114These data types describe the structural mapping of the tables, but we also
114115need to specify a ``TableSchema`` for each table. A ``TableSchema`` contains
@@ -125,9 +126,9 @@ associated with the ``Author`` type::
125126
126127 authorSchema :: TableSchema (Author Name)
127128 authorSchema = TableSchema
128− { tableName = "author"
129− , tableSchema = Nothing
130− , tableColumns = Author
129+ { name = "author"
130+ , schema = Nothing
131+ , columns = Author
131132 { authorId = "author_id"
132133 , authorName = "name"
133134 , authorUrl = "url"
@@ -138,14 +139,27 @@ And likewise for ``project`` and ``Project``::
138139
139140 projectSchema :: TableSchema (Project Name)
140141 projectSchema = TableSchema
141− { tableName = "project"
142− , tableSchema = Nothing
143− , tableColumns = Project
142+ { name = "project"
143+ , schema = Nothing
144+ , columns = Project
144145 { projectAuthorId = "author_id"
145146 , projectName = "name"
146147 }
147148 }
148149
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.
149163
150164.. note::
151165
@@ -169,7 +183,7 @@ database heavy applications.
169183
170184In Rel8, ``SELECT`` statements are built using the ``Query`` monad. You can
171185think of this monad like the ordinary ``[]`` (List) monad - but this isn't
172−required knowledge.
186+required knowledge.
173187
174188To start, we'll look at one of the simplest queries possible - a basic ``SELECT
175189* FROM`` statement. To select all rows from a table, we use ``each``, and
@@ -190,25 +204,28 @@ Recall we defined ``projectAuthorId`` as ``Column f AuthorId``. Now we have
190204We'll see more about ``Expr`` soon, but you can think of ``Expr a`` as "SQL
191205expressions of type ``a``\".
192206
193−To execute this ``Query``, we pass it to ``select``::
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::
194210
195− >>> :t select c (each projectSchema)
196− select c (each projectSchema) :: MonadIO m => m [Project Identity]
211+ >>> Right conn <- acquire "user=postgres"
212+ >>> :t select conn (each projectSchema)
213+ select conn (each projectSchema) :: MonadIO m => m [Project Result]
197214
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
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
200217Haskell values. Studying ``projectAuthorId`` again, we have::
201218
202− >>> let aProjectIdentity = undefined :: Project Identity
203− >>> :t projectAuthorId aProjectIdentity
204− projectAuthorId aProjectIdentity :: AuthorId
219+ >>> let aProjectResult = undefined :: Project Result
220+ >>> :t projectAuthorId aProjectResult
221+ projectAuthorId aProjectResult :: AuthorId
205222
206−Here ``Column Identity AuthorId`` reduces to just ``AuthorId``, with no
223+Here ``Column Result AuthorId`` reduces to just ``AuthorId``, with no
207224wrappping type at all.
208225
209226Putting this all together, we can run our first query::
210227
211− >>> select c (each projectSchema) >>= mapM_ print
228+ >>> select conn (each projectSchema) >>= mapM_ print
212229 Project {projectAuthorId = 1, projectName = "rel8"}
213230 Project {projectAuthorId = 2, projectName = "aeson"}
214231 Project {projectAuthorId = 2, projectName = "text"}
@@ -218,7 +235,7 @@ sometimes we're only interested in a subset of the columns of a table. To
218235restrict the returned columns, we can specify a projection by using ``Query``\s
219236``Functor`` instance::
220237
221− >>> select c $ projectName <$> each projectSchema
238+ >>> select conn $ projectName <$> each projectSchema
222239 ["rel8","aeson","text"]
223240
224241Joins
@@ -234,7 +251,7 @@ We can do this by simply calling ``each`` twice, and then returning a tuple of
234251their results::
235252
236253 >>> :{
237− mapM_ print =<< select c do
254+ mapM_ print =<< select conn do
238255 author <- each authorSchema
239256 project <- each projectSchema
240257 return (projectName project, authorName author)
@@ -253,7 +270,7 @@ This isn't quite right, though, as we have ended up pairing up the wrong
253270projects and authors. To fix this, we can use ``where_`` to restrict the
254271returned rows. We could write::
255272
256− select c $ do
273+ select conn $ do
257274 author <- each authorSchema
258275 project <- each projectSchema
259276 where_ $ projectAuthorId project ==. authorId author
@@ -270,7 +287,7 @@ for the particular joins in your database. In our case, this would be::
270287Our final query is then::
271288
272289 >>> :{
273− mapM_ print =<< select c do
290+ mapM_ print =<< select conn do
274291 author <- each authorSchema
275292 project <- projectsForAuthor author
276293 return (projectName project, authorName author)
@@ -289,7 +306,7 @@ transformer to allow for the possibility of the join to fail.
289306In our test database, we can see that there's another author who we haven't
290307seen yet::
291308
292− >>> select c $ authorName <$> each authorSchema
309+ >>> select conn $ authorName <$> each authorSchema
293310 ["Ollie","Bryan O'Sullivan","Emily Pillmore"]
294311
295312Emily wasn't returned in our earlier query because - in our database - she
@@ -297,7 +314,7 @@ doesn't have any registered projects. We can account for this partiality in our
297314original query by wrapping the ``projectsForAuthor`` call with ``optional``::
298315
299316 >>> :{
300− mapM_ print =<< select c do
317+ mapM_ print =<< select conn do
301318 author <- each authorSchema
302319 mproject <- optional $ projectsForAuthor author
303320 return (authorName author, projectName <$> mproject)
@@ -342,9 +359,9 @@ focus on the /type/ of that query::
342359 return (author, project)
343360 where
344361
345− >>> :t select c authorsAndProjects
346− select c authorsAndProjects
347− :: MonadIO m => m [(Author Identity, Project Identity)]
362+ >>> :t select conn authorsAndProjects
363+ select conn authorsAndProjects
364+ :: MonadIO m => m [(Author Result, Project Result)]
348365
349366
350367Our query gives us a single list of pairs of authors and projects. However,
@@ -352,7 +369,7 @@ with our domain knowledge of the schema, this isn't a great type - what we'd
352369rather have is a list of pairs of authors and /lists/ of projects. That is,
353370what we'd like is::
354371
355− [(Author Identity, [Project Identity])]
372+ [(Author Result, [Project Result])]
356373
357374This would be a much better type! Rel8 can produce a query with this type by
358375simply wrapping the call to ``projectsForAuthor`` with either ``some`` or
@@ -360,7 +377,7 @@ simply wrapping the call to ``projectsForAuthor`` with either ``some`` or
360377author to have no projects::
361378
362379 >>> :{
363− mapM_ print =<< select c do
380+ mapM_ print =<< select conn do
364381 author <- each authorSchema
365382 projectNames <- many $ projectName <$> projectsForAuthor author
366383 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": "5b5a18e442df6e27ad8549d69b8868b62adb08c3",
9− "sha256": "055mk7kmjppng66ppnb8kr96v4wwc8pcxfsls5gl77129hsz9aph",
8+ "rev": "0837156c56cb5350dd9bd84eb424187e00aa1e8a",
9+ "sha256": "1djmv5a0vfj78csw2cad6nicrs8iqrp928b9b3v4h7lwwhhzliwl",
1010 "type": "tarball",
11− "url": "https://github.com/input-output-hk/haskell.nix/archive/5b5a18e442df6e27ad8549d69b8868b62adb08c3.tar.gz",
11+ "url": "https://github.com/input-output-hk/haskell.nix/archive/0837156c56cb5350dd9bd84eb424187e00aa1e8a.tar.gz",
1212 "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
1313 },
1414 "niv": {
@@ -17,10 +17,10 @@
1717 "homepage": "https://github.com/nmattia/niv",
1818 "owner": "nmattia",
1919 "repo": "niv",
20− "rev": "af958e8057f345ee1aca714c1247ef3ba1c15f5e",
21− "sha256": "1qjavxabbrsh73yck5dcq8jggvh3r2jkbr6b5nlz5d9yrqm9255n",
20+ "rev": "acdb1726783637852c01e0ad639ac9cbec28d8c8",
21+ "sha256": "1wszl8q70z6wfgkh2dvgmhhry6qp9nar421qq2ifd17hq2jj9ck3",
2222 "type": "tarball",
23− "url": "https://github.com/nmattia/niv/archive/af958e8057f345ee1aca714c1247ef3ba1c15f5e.tar.gz",
23+ "url": "https://github.com/nmattia/niv/archive/acdb1726783637852c01e0ad639ac9cbec28d8c8.tar.gz",
2424 "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
2525 },
2626 "nixpkgs": {
@@ -29,10 +29,10 @@
2929 "homepage": null,
3030 "owner": "nixos",
3131 "repo": "nixpkgs",
32− "rev": "a6847cb5460b47241eb35d1a6588652411642066",
33− "sha256": "0wb5hwgffr4in66qng22sfvbascwnq078q81ziwwayvmnkn73rrm",
32+ "rev": "1c1f5649bb9c1b0d98637c8c365228f57126f361",
33+ "sha256": "0f2nvdijyxfgl5kwyb4465pppd5vkhqxddx6v40k2s0z9jfhj0xl",
3434 "type": "tarball",
35− "url": "https://github.com/nixos/nixpkgs/archive/a6847cb5460b47241eb35d1a6588652411642066.tar.gz",
35+ "url": "https://github.com/nixos/nixpkgs/archive/1c1f5649bb9c1b0d98637c8c365228f57126f361.tar.gz",
3636 "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
3737 }
3838}
nix/sources.nix+66−20
@@ -6,25 +6,53 @@ let
66 # The fetchers. fetch_<type> fetches specs of type <type>.
77 #
88
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; };
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'; };
1417
1518 fetch_tarball = pkgs: name: spec:
1619 let
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";
20+ name' = sanitizeName name + "-src";
2021 in
2122 if spec.builtin or true then
2223 builtins_fetchTarball { name = name'; inherit (spec) url sha256; }
2324 else
2425 pkgs.fetchzip { name = name'; inherit (spec) url sha256; };
2526
26− fetch_git = spec:
27− builtins.fetchGit { url = spec.repo; inherit (spec) rev ref; };
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);
2856
2957 fetch_local = spec: spec.path;
3058
@@ -40,11 +68,21 @@ let
4068 # Various helpers
4169 #
4270
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+
4381 # The set of packages used when specs are fetched using non-builtins.
44− mkPkgs = sources:
82+ mkPkgs = sources: system:
4583 let
4684 sourcesNixpkgs =
47− import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) {};
85+ import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; };
4886 hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath;
4987 hasThisAsNixpkgsPath = <nixpkgs> == ./.;
5088 in
@@ -64,9 +102,9 @@ let
64102
65103 if ! builtins.hasAttr "type" spec then
66104 abort "ERROR: niv spec ${name} does not have a 'type' attribute"
67− else if spec.type == "file" then fetch_file pkgs spec
105+ else if spec.type == "file" then fetch_file pkgs name spec
68106 else if spec.type == "tarball" then fetch_tarball pkgs name spec
69− else if spec.type == "git" then fetch_git spec
107+ else if spec.type == "git" then fetch_git name spec
70108 else if spec.type == "local" then fetch_local spec
71109 else if spec.type == "builtin-tarball" then fetch_builtin-tarball name
72110 else if spec.type == "builtin-url" then fetch_builtin-url name
@@ -80,7 +118,10 @@ let
80118 saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name;
81119 ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}";
82120 in
83− if ersatz == "" then drv else ersatz;
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}";
84125
85126 # Ports of functions for older nix versions
86127
@@ -98,25 +139,29 @@ let
98139
99140 # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269
100141 stringAsChars = f: s: concatStrings (map f (stringToCharacters s));
142+ concatMapStrings = f: list: concatStrings (map f list);
101143 concatStrings = builtins.concatStringsSep "";
102144
145+ # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331
146+ optionalAttrs = cond: as: if cond then as else {};
147+
103148 # fetchTarball version that is compatible between all the versions of Nix
104− builtins_fetchTarball = { url, name, sha256 }@attrs:
149+ builtins_fetchTarball = { url, name ? null, sha256 }@attrs:
105150 let
106151 inherit (builtins) lessThan nixVersion fetchTarball;
107152 in
108153 if lessThan nixVersion "1.12" then
109− fetchTarball { inherit name url; }
154+ fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; }))
110155 else
111156 fetchTarball attrs;
112157
113158 # fetchurl version that is compatible between all the versions of Nix
114− builtins_fetchurl = { url, sha256 }@attrs:
159+ builtins_fetchurl = { url, name ? null, sha256 }@attrs:
115160 let
116161 inherit (builtins) lessThan nixVersion fetchurl;
117162 in
118163 if lessThan nixVersion "1.12" then
119− fetchurl { inherit url; }
164+ fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; }))
120165 else
121166 fetchurl attrs;
122167
@@ -135,7 +180,8 @@ let
135180 mkConfig =
136181 { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null
137182 , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile)
138− , pkgs ? mkPkgs sources
183+ , system ? builtins.currentSystem
184+ , pkgs ? mkPkgs sources system
139185 }: rec {
140186 # The sources, i.e. the attribute set of spec name to spec
141187 inherit sources;
rel8.cabal+50−28
@@ -1,24 +1,36 @@
11cabal-version: 2.0
22name: rel8
3−version: 0.1.0.0
3+version: 1.4.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
911build-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
1019
1120library
1221 build-depends:
1322 aeson
14− , base ^>= 4.14 || ^>=4.15
23+ , base ^>= 4.14 || ^>=4.15 || ^>=4.16
24+ , bifunctors
1525 , bytestring
1626 , case-insensitive
17− , casing
27+ , comonad
1828 , contravariant
19− , hasql ^>= 1.4.5.1
20− , opaleye ^>= 0.7.1.0
29+ , hasql ^>= 1.4.5.1 || ^>= 1.5.0.0 || ^>= 1.6.0.0
30+ , opaleye ^>= 0.9.6.1
31+ , pretty
2132 , profunctors
33+ , product-profunctors
2234 , scientific
2335 , semialign
2436 , semigroupoids
@@ -29,10 +41,12 @@ library
2941 default-language:
3042 Haskell2010
3143 ghc-options:
44+ -Werror=missing-methods -Werror=incomplete-patterns -Werror=missing-fields
3245 -Weverything -Wno-unsafe -Wno-safe -Wno-missing-safe-haskell-mode
3346 -Wno-missing-import-lists -Wno-prepositive-qualified-module
3447 -Wno-monomorphism-restriction
35− -Wno-missing-local-signatures
48+ -Wno-missing-local-signatures
49+ -Wno-missing-kind-signatures
3650 hs-source-dirs:
3751 src
3852 exposed-modules:
@@ -42,49 +56,45 @@ library
4256 Rel8.Expr.Time
4357 Rel8.Tabulate
4458
45− -- deprecated
46− Rel8.Aggregate.Legacy
47−
4859 other-modules:
4960 Rel8.Aggregate
5061
5162 Rel8.Column
5263 Rel8.Column.ADT
5364 Rel8.Column.Either
54− Rel8.Column.Field
5565 Rel8.Column.Lift
5666 Rel8.Column.List
5767 Rel8.Column.Maybe
5868 Rel8.Column.NonEmpty
69+ Rel8.Column.Null
5970 Rel8.Column.These
6071
6172 Rel8.Expr
6273 Rel8.Expr.Aggregate
6374 Rel8.Expr.Array
6475 Rel8.Expr.Bool
76+ Rel8.Expr.Default
6577 Rel8.Expr.Eq
6678 Rel8.Expr.Function
6779 Rel8.Expr.Null
6880 Rel8.Expr.Opaleye
6981 Rel8.Expr.Ord
7082 Rel8.Expr.Order
83+ Rel8.Expr.Sequence
7184 Rel8.Expr.Serialize
85+ Rel8.Expr.Window
7286
7387 Rel8.FCF
7488
7589 Rel8.Kind.Algebra
7690 Rel8.Kind.Context
77− Rel8.Kind.Labels
78− Rel8.Kind.Necessity
7991
8092 Rel8.Generic.Construction
8193 Rel8.Generic.Construction.ADT
8294 Rel8.Generic.Construction.Record
8395 Rel8.Generic.Map
8496 Rel8.Generic.Record
85− Rel8.Generic.Reify
8697 Rel8.Generic.Rel8able
87− Rel8.Generic.Rel8able.Test
8898 Rel8.Generic.Table
8999 Rel8.Generic.Table.ADT
90100 Rel8.Generic.Table.Record
@@ -96,23 +106,26 @@ library
96106 Rel8.Query.Distinct
97107 Rel8.Query.Each
98108 Rel8.Query.Either
109+ Rel8.Query.Evaluate
99110 Rel8.Query.Exists
100111 Rel8.Query.Filter
112+ Rel8.Query.Indexed
101113 Rel8.Query.Limit
102114 Rel8.Query.List
103115 Rel8.Query.Maybe
104116 Rel8.Query.Null
105117 Rel8.Query.Opaleye
106118 Rel8.Query.Order
119+ Rel8.Query.Rebind
107120 Rel8.Query.Set
108121 Rel8.Query.SQL
109122 Rel8.Query.These
110123 Rel8.Query.Values
124+ Rel8.Query.Window
111125
112− Rel8.Schema.Context
113− Rel8.Schema.Context.Label
114126 Rel8.Schema.Context.Nullify
115127 Rel8.Schema.Dict
128+ Rel8.Schema.Field
116129 Rel8.Schema.HTable
117130 Rel8.Schema.HTable.Either
118131 Rel8.Schema.HTable.Identity
@@ -125,51 +138,53 @@ library
125138 Rel8.Schema.HTable.Product
126139 Rel8.Schema.HTable.These
127140 Rel8.Schema.HTable.Vectorize
128− Rel8.Schema.Insert
129141 Rel8.Schema.Kind
130142 Rel8.Schema.Name
131143 Rel8.Schema.Null
132− Rel8.Schema.Reify
133144 Rel8.Schema.Result
134145 Rel8.Schema.Spec
135− Rel8.Schema.Spec.ConstrainDBType
136− Rel8.Schema.Spec.ConstrainType
137146 Rel8.Schema.Table
138147
139148 Rel8.Statement.Delete
140149 Rel8.Statement.Insert
150+ Rel8.Statement.OnConflict
141151 Rel8.Statement.Returning
142152 Rel8.Statement.Select
153+ Rel8.Statement.Set
154+ Rel8.Statement.SQL
143155 Rel8.Statement.Update
156+ Rel8.Statement.Using
144157 Rel8.Statement.View
158+ Rel8.Statement.Where
145159
146160 Rel8.Table
147161 Rel8.Table.ADT
148162 Rel8.Table.Aggregate
149163 Rel8.Table.Alternative
150164 Rel8.Table.Bool
165+ Rel8.Table.Cols
151166 Rel8.Table.Either
152167 Rel8.Table.Eq
153168 Rel8.Table.HKD
154− Rel8.Table.Insert
155169 Rel8.Table.List
156170 Rel8.Table.Maybe
157171 Rel8.Table.Name
158172 Rel8.Table.NonEmpty
173+ Rel8.Table.Null
174+ Rel8.Table.Nullify
159175 Rel8.Table.Opaleye
160176 Rel8.Table.Ord
161177 Rel8.Table.Order
162− Rel8.Table.Recontextualize
178+ Rel8.Table.Projection
163179 Rel8.Table.Rel8able
164180 Rel8.Table.Serialize
165− Rel8.Table.Tag
166181 Rel8.Table.These
182+ Rel8.Table.Transpose
167183 Rel8.Table.Undefined
168− Rel8.Table.Unreify
184+ Rel8.Table.Window
169185
170186 Rel8.Type
171187 Rel8.Type.Array
172− Rel8.Type.Array1D
173188 Rel8.Type.Composite
174189 Rel8.Type.Eq
175190 Rel8.Type.Enum
@@ -185,6 +200,9 @@ library
185200 Rel8.Type.Sum
186201 Rel8.Type.Tag
187202
203+ Rel8.Window
204+
205+
188206test-suite tests
189207 type: exitcode-stdio-1.0
190208 build-depends:
@@ -193,9 +211,9 @@ test-suite tests
193211 , case-insensitive
194212 , containers
195213 , hasql
196− , hedgehog ^>=1.0.2
197− , lifted-base ^>=0.2.3.12
198− , monad-control ^>=1.0.2.3
214+ , hasql-transaction
215+ , hedgehog ^>= 1.0 || ^>= 1.1
216+ , mmorph
199217 , rel8
200218 , scientific
201219 , tasty
@@ -203,8 +221,12 @@ test-suite tests
203221 , text
204222 , time
205223 , tmp-postgres ^>=1.34.1.0
224+ , transformers
206225 , uuid
207226
227+ other-modules:
228+ Rel8.Generic.Rel8able.Test
229+
208230 main-is: Main.hs
209231 hs-source-dirs: tests
210232 default-language: Haskell2010
shell.nix+1−1
@@ -1,6 +1,6 @@
11let
22 sources = import ./nix/sources.nix;
3− pkgs = import sources.nixpkgs {};
3+ pkgs = import sources.nixpkgs {overlays = [];};
44 hsPkgs = import ./default.nix;
55in
66 hsPkgs.shellFor {
src/Rel8.hs+340−52
@@ -14,8 +14,8 @@ module Rel8
1414 , ReadShow(..)
1515
1616 -- **** Generic
17− , Composite(..)
18− , Enum(..)
17+ , Composite(..), DBComposite(..), compose, decompose
18+ , Enum(..), DBEnum(..), Enumable
1919
2020 -- *** @TypeInformation@
2121 , TypeInformation(..)
@@ -32,34 +32,37 @@ module Rel8
3232
3333 -- * Tables and higher-kinded tables
3434 , Rel8able, KRel8able
35− , Column, Field, Necessity( Required, Optional )
36− , Default
35+ , Column
3736 , HADT
3837 , HEither
3938 , HMaybe
4039 , HList
4140 , HNonEmpty
41+ , HNull
4242 , HThese
4343 , Lift
4444
4545 , Table(..)
46+ , HTable
47+ , Transposes
4648 , AltTable((<|>:))
47− , EqTable, (==:), (/=:)
48− , OrdTable, ascTable, descTable
49+ , AlternativeTable( emptyTable )
50+ , EqTable(..), (==:), (/=:)
51+ , OrdTable(..), (<:), (<=:), (>:), (>=:), ascTable, descTable, greatest, least
4952 , lit
5053 , bool
5154 , case_
55+ , castTable
5256
5357 -- ** @MaybeTable@
5458 , MaybeTable
5559 , maybeTable, ($?), nothingTable, justTable
5660 , isNothingTable, isJustTable
61+ , fromMaybeTable
5762 , optional
5863 , catMaybeTable
59− , bindMaybeTable
6064 , traverseMaybeTable
6165 , aggregateMaybeTable
62− , insertMaybeTable
6366 , nameMaybeTable
6467
6568 -- ** @EitherTable@
@@ -68,10 +71,8 @@ module Rel8
6871 , isLeftTable, isRightTable
6972 , keepLeftTable
7073 , keepRightTable
71− , bindEitherTable
7274 , bitraverseEitherTable
7375 , aggregateEitherTable
74− , insertEitherTable
7576 , nameEitherTable
7677
7778 -- ** @TheseTable@
@@ -80,45 +81,71 @@ module Rel8
8081 , isThisTable, isThatTable, isThoseTable
8182 , hasHereTable, hasThereTable
8283 , justHereTable, justThereTable
84+ , alignMaybeTable
8385 , alignBy
8486 , keepHereTable, loseHereTable
8587 , keepThereTable, loseThereTable
8688 , keepThisTable, loseThisTable
8789 , keepThatTable, loseThatTable
8890 , keepThoseTable, loseThoseTable
89− , bindTheseTable
9091 , bitraverseTheseTable
9192 , aggregateTheseTable
92− , insertTheseTable
9393 , nameTheseTable
9494
9595 -- ** @ListTable@
9696 , ListTable
97− , listTable
98− , insertListTable
97+ , listTable, ($*)
9998 , nameListTable
10099 , many
100+ , manyExpr
101+ , catListTable
102+ , catList
101103
102104 -- ** @NonEmptyTable@
103105 , NonEmptyTable
104− , nonEmptyTable
105− , insertNonEmptyTable
106+ , nonEmptyTable, ($+)
106107 , nameNonEmptyTable
107108 , 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
108128
109− -- ** @ADT@
110− , ADT, ADTable, fromADT, toADT
111− , ConstructADT, constructADT
129+ -- *** Deconstruction of ADTs
130+ -- $deconstruction
112131 , DeconstructADT, deconstructADT
113− , InsertADT, insertADT
114− , NameADT, nameADT
132+
133+ -- *** Construction of ADTs
134+ -- $construction
135+ , BuildADT, buildADT
136+ , ConstructADT, constructADT
137+
138+ -- *** Other ADT operations
115139 , AggregateADT, aggregateADT
116140
141+ -- *** Miscellaneous notes
142+ -- $misc-notes
143+
117144 -- ** @HKD@
118− , HKD, HKDable, fromHKD, toHKD
145+ , HKD, HKDable
146+ , BuildHKD, buildHKD
119147 , ConstructHKD, constructHKD
120148 , DeconstructHKD, deconstructHKD
121− , InsertHKD, insertHKD
122149 , NameHKD, nameHKD
123150 , AggregateHKD, aggregateHKD
124151
@@ -133,8 +160,12 @@ module Rel8
133160 , Sql
134161 , litExpr
135162 , unsafeCastExpr
163+ , unsafeLiteral
136164
137165 -- ** @null@
166+ , NotNull
167+ , Nullable
168+ , Homonullable
138169 , null
139170 , nullify
140171 , nullable
@@ -153,6 +184,7 @@ module Rel8
153184 , (==.), (/=.), (==?), (/=?)
154185 , in_
155186 , boolExpr, caseExpr
187+ , like, ilike
156188
157189 -- ** Ordering
158190 , DBOrd
@@ -170,6 +202,13 @@ module Rel8
170202 , Query
171203 , showQuery
172204
205+ -- ** Projection
206+ , Projection
207+ , Projectable( project )
208+ , Biprojectable( biproject )
209+ , Projecting
210+ , Field
211+
173212 -- ** Selecting rows
174213 , Selects
175214 , each
@@ -178,8 +217,8 @@ module Rel8
178217 -- ** Filtering
179218 , filter
180219 , where_
181− , whereExists
182− , whereNotExists
220+ , present
221+ , absent
183222 , distinct
184223 , distinctOn
185224 , distinctOnBy
@@ -209,15 +248,16 @@ module Rel8
209248
210249 -- ** Aggregation
211250 , Aggregate
251+ , Aggregates
212252 , aggregate
213253 , countRows
214− , array1DAggExpr
215− , listAgg, listAggWithOrder, listAggExpr
216− , nonEmptyAgg, nonEmptyAggWithOrder, nonEmptyAggExpr
217254 , groupBy
255+ , listAgg, listAggExpr
256+ , mode
257+ , nonEmptyAgg, nonEmptyAggExpr
218258 , DBMax, max
219259 , DBMin, min
220− , DBSum, sum, sumWhere
260+ , DBSum, sum, sumWhere, avg
221261 , DBString, stringAgg
222262 , count
223263 , countStar
@@ -234,48 +274,71 @@ module Rel8
234274 , nullsFirst
235275 , nullsLast
236276
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+
237303 -- * IO
238304 , Serializable
305+ , ToExprs
306+ , Result
239307
240308 -- * Running statements
309+ -- $running
310+
241311 -- ** @SELECT@
242312 , select
243313
244314 -- ** @INSERT@
245315 , Insert(..)
246316 , OnConflict(..)
317+ , Upsert(..)
247318 , insert
248− , toInsert
249− , toInsertDefaults
319+ , unsafeDefault
320+ , showInsert
250321
251322 -- ** @DELETE@
252323 , Delete(..)
253324 , delete
325+ , showDelete
254326
255327 -- ** @UPDATE@
256− , update
257328 , Update(..)
329+ , update
330+ , showUpdate
258331
259332 -- ** @.. RETURNING@
260333 , Returning(..)
261334
262335 -- ** @CREATE VIEW@
263336 , createView
337+ , createOrReplaceView
264338
265− -- * TODO
266− -- TODO
267− -- These need organizing, but are reachable from Rel8's documentation so we
268− -- do need to export and document them.
269− , Array1D( Array1D )
270− , NotArray
271− , Nullable
272− , NotNull
273− , HTable
274− , Labelable
275− , ToExprs(..)
276− , FromExprs
277− , Result
278− , HKDT(..)
339+ -- ** Sequences
340+ , nextval
341+ , evaluate
279342 ) where
280343
281344-- base
@@ -286,42 +349,49 @@ import Rel8.Aggregate
286349import Rel8.Column
287350import Rel8.Column.ADT
288351import Rel8.Column.Either
289−import Rel8.Column.Field
290352import Rel8.Column.Lift
291353import Rel8.Column.List
292354import Rel8.Column.Maybe
293355import Rel8.Column.NonEmpty
356+import Rel8.Column.Null
294357import Rel8.Column.These
295358import Rel8.Expr
296359import Rel8.Expr.Aggregate
297360import Rel8.Expr.Bool
361+import Rel8.Expr.Default
298362import Rel8.Expr.Eq
299363import Rel8.Expr.Function
300364import Rel8.Expr.Null
301−import Rel8.Expr.Opaleye (unsafeCastExpr)
365+import Rel8.Expr.Opaleye (unsafeCastExpr, unsafeLiteral)
302366import Rel8.Expr.Ord
303367import Rel8.Expr.Order
304368import Rel8.Expr.Serialize
369+import Rel8.Expr.Sequence
370+import Rel8.Expr.Text ( like, ilike )
371+import Rel8.Expr.Window hiding ( cumulative )
305372import Rel8.Generic.Rel8able ( KRel8able, Rel8able )
306−import Rel8.Kind.Necessity
307373import Rel8.Order
308374import Rel8.Query
309375import Rel8.Query.Aggregate
310376import Rel8.Query.Distinct
311377import Rel8.Query.Each
312378import Rel8.Query.Either
379+import Rel8.Query.Evaluate
313380import Rel8.Query.Exists
314381import Rel8.Query.Filter
382+import Rel8.Query.Indexed
315383import Rel8.Query.Limit
316384import Rel8.Query.List
317385import Rel8.Query.Maybe
318386import Rel8.Query.Null
319387import Rel8.Query.Order
388+import Rel8.Query.Rebind
320389import Rel8.Query.SQL (showQuery)
321390import Rel8.Query.Set
322391import Rel8.Query.These
323392import Rel8.Query.Values
324−import Rel8.Schema.Context.Label
393+import Rel8.Query.Window
394+import Rel8.Schema.Field
325395import Rel8.Schema.HTable
326396import Rel8.Schema.Name
327397import Rel8.Schema.Null hiding ( nullable )
@@ -329,8 +399,10 @@ import Rel8.Schema.Result ( Result )
329399import Rel8.Schema.Table
330400import Rel8.Statement.Delete
331401import Rel8.Statement.Insert
402+import Rel8.Statement.OnConflict
332403import Rel8.Statement.Returning
333404import Rel8.Statement.Select
405+import Rel8.Statement.SQL
334406import Rel8.Statement.Update
335407import Rel8.Statement.View
336408import Rel8.Table
@@ -341,18 +413,21 @@ import Rel8.Table.Bool
341413import Rel8.Table.Either
342414import Rel8.Table.Eq
343415import Rel8.Table.HKD
344−import Rel8.Table.Insert
345416import Rel8.Table.List
346417import Rel8.Table.Maybe
347418import Rel8.Table.Name
348419import Rel8.Table.NonEmpty
420+import Rel8.Table.Null
421+import Rel8.Table.Opaleye ( castTable )
349422import Rel8.Table.Ord
350423import Rel8.Table.Order
424+import Rel8.Table.Projection
351425import Rel8.Table.Rel8able ()
352426import Rel8.Table.Serialize
353427import Rel8.Table.These
428+import Rel8.Table.Transpose
429+import Rel8.Table.Window
354430import Rel8.Type
355−import Rel8.Type.Array1D
356431import Rel8.Type.Composite
357432import Rel8.Type.Eq
358433import Rel8.Type.Enum
@@ -366,3 +441,216 @@ import Rel8.Type.ReadShow
366441import Rel8.Type.Semigroup
367442import Rel8.Type.String
368443import 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.
src/Rel8/Aggregate.hs+42−128
@@ -1,169 +1,83 @@
11{-# language DataKinds #-}
2−{-# language DerivingVia #-}
32{-# language FlexibleContexts #-}
43{-# language FlexibleInstances #-}
5−{-# language GADTs #-}
64{-# language MultiParamTypeClasses #-}
7−{-# language NamedFieldPuns #-}
8−{-# language PolyKinds #-}
5+{-# language RankNTypes #-}
96{-# language StandaloneKindSignatures #-}
107{-# language TypeFamilies #-}
118{-# language UndecidableInstances #-}
12−{-# language UndecidableSuperClasses #-}
139
1410module Rel8.Aggregate
15− ( Aggregate(..), foldInputs, mapInputs
16− , Aggregator(..), unsafeMakeAggregate
11+ ( Aggregate(..), zipOutputs
12+ , unsafeMakeAggregate
1713 , Aggregates
18− , Col( Aggregation )
1914 )
2015where
2116
2217-- base
23−import Data.Functor.Const ( Const( Const ), getConst )
24−import Data.Functor.Identity ( Identity )
18+import Control.Applicative ( liftA2 )
19+import Data.Functor.Identity ( Identity( Identity ) )
2520import Data.Kind ( Constraint, Type )
2621import Prelude
2722
23+-- profunctors
24+import Data.Profunctor ( dimap )
25+
2826-- opaleye
29−import qualified Opaleye.Internal.Aggregate as Opaleye
27+import qualified Opaleye.Aggregate as Opaleye
3028import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
31−import qualified Opaleye.Internal.PackMap as Opaleye
29+import qualified Opaleye.Internal.Column as Opaleye
3230
3331-- rel8
34−import Rel8.Expr ( Expr, Col(..) )
35−import Rel8.Schema.Context ( Interpretation(..) )
36−import Rel8.Schema.Context.Label ( Labelable(..) )
37−import Rel8.Schema.HTable ( hfield, htabulate, htabulateA, hspecs )
38−import Rel8.Schema.Name ( Name )
32+import Rel8.Expr ( Expr )
33+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
34+import qualified Rel8.Schema.Kind as K
3935import Rel8.Schema.Null ( Sql )
40−import Rel8.Schema.Reify ( notReify )
41−import Rel8.Schema.Result ( Result )
42−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
4336import Rel8.Table
4437 ( Table, Columns, Context, fromColumns, toColumns
45− , reify, unreify
38+ , FromExprs, fromResult, toResult
39+ , Transpose
4640 )
47−import Rel8.Table.Recontextualize ( Recontextualize )
41+import Rel8.Table.Transpose ( Transposes )
4842import Rel8.Type ( DBType )
4943
50−-- semigroupoids
51−import Data.Functor.Apply ( Apply, (<.>) )
52−
53−
54−-- | An @Aggregate a@ describes how to aggregate @Table@s of type @a@. You can
55−-- unpack an @Aggregate@ back to @a@ by running it with 'Rel8.aggregate'. As
56−-- @Aggregate@ is almost an 'Applicative' functor - but there is no 'pure'
57−-- operation. This means 'Aggregate' is an instance of 'Apply', and you can
58−-- combine @Aggregate@s using the @<.>@ combinator.
59−type Aggregate :: k -> Type
60−data Aggregate a where
61− Aggregate :: !(Opaleye.Aggregator () a) -> Aggregate a
62−
63−
64−instance Functor Aggregate where
65− fmap f (Aggregate a) = Aggregate (fmap f a)
66−
67−
68−instance Apply Aggregate where
69− Aggregate f <.> Aggregate a = Aggregate (f <*> a)
70−
7144
72−instance Interpretation Aggregate where
73− data Col Aggregate _spec where
74− Aggregation :: ()
75− => Aggregate (Expr a)
76− -> Col Aggregate ('Spec labels necessity a)
45+-- | 'Aggregate' is a special context used by 'Rel8.aggregate'.
46+type Aggregate :: K.Context
47+newtype Aggregate a = Aggregate (Opaleye.Aggregator () (Expr a))
7748
7849
79−instance Table Expr a => Table Aggregate (Aggregate a) where
80− type Columns (Aggregate a) = Columns a
50+instance Sql DBType a => Table Aggregate (Aggregate a) where
51+ type Columns (Aggregate a) = HIdentity a
8152 type Context (Aggregate a) = Aggregate
53+ type FromExprs (Aggregate a) = a
54+ type Transpose to (Aggregate a) = to a
8255
83− toColumns a = htabulate $ \field -> case hfield hspecs field of
84− SSpec {} -> Aggregation $ unDB . (`hfield` field) . toColumns <$> a
85− fromColumns as = fmap fromColumns $ htabulateA $ \field ->
86− case hfield as field of
87− Aggregation a -> DB <$> a
88−
89− reify = notReify
90− unreify = notReify
91−
92−
93−instance Sql DBType a =>
94− Recontextualize Aggregate Aggregate (Aggregate (Expr a)) (Aggregate (Expr a))
95−
96−
97−instance Sql DBType a =>
98− Recontextualize Aggregate Expr (Aggregate (Expr a)) (Expr a)
99−
100−
101−instance Sql DBType a =>
102− Recontextualize Aggregate Result (Aggregate (Expr a)) (Identity a)
56+ toColumns = HIdentity
57+ fromColumns (HIdentity a) = a
58+ toResult = HIdentity . Identity
59+ fromResult (HIdentity (Identity a)) = a
10360
10461
105−instance Sql DBType a =>
106− Recontextualize Aggregate Name (Aggregate (Expr a)) (Name a)
107−
108−
109−instance Sql DBType a =>
110− Recontextualize Expr Aggregate (Expr a) (Aggregate (Expr a))
111−
112−
113−instance Sql DBType a =>
114− Recontextualize Result Aggregate (Identity a) (Aggregate (Expr a))
115−
116−
117−instance Sql DBType a =>
118− Recontextualize Name Aggregate (Name a) (Aggregate (Expr a))
119−
120−
121−instance Labelable Aggregate where
122− labeler (Aggregation aggregate) = Aggregation aggregate
123− unlabeler (Aggregation aggregate) = Aggregation aggregate
124−
125−
126−-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate' 'Expr's
127−-- for the columns in @b@.
62+-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate's
63+-- for the 'Expr' columns in @b@.
12864type Aggregates :: Type -> Type -> Constraint
129−class Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs
130−instance Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs
131−
132−
133−foldInputs :: Monoid b
134− => (Maybe Aggregator -> Opaleye.PrimExpr -> b) -> Aggregate a -> b
135−foldInputs f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =
136− getConst $ flip agg () $ \(aggregator, a) ->
137− Const $ f (detuplize <$> aggregator) a
138− where
139− detuplize (operation, ordering, distinction) =
140− Aggregator {operation, ordering, distinction}
141−
142−
143−mapInputs :: ()
144− => (Opaleye.PrimExpr -> Opaleye.PrimExpr) -> Aggregate a -> Aggregate a
145−mapInputs transform (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =
146− Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ agg . \f input ->
147− f (fmap transform input)
65+class Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs
66+instance Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs
14867
14968
150−type Aggregator :: Type
151−data Aggregator = Aggregator
152− { operation :: Opaleye.AggrOp
153− , ordering :: [Opaleye.OrderExpr]
154− , distinction :: Opaleye.AggrDistinct
155− }
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)
15672
15773
158−unsafeMakeAggregate :: ()
159− => (input -> Opaleye.PrimExpr)
160− -> (Opaleye.PrimExpr -> output)
161− -> Maybe Aggregator
162− -> input
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
16379 -> Aggregate output
16480unsafeMakeAggregate input output aggregator expr =
165− Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ \f _ ->
166− output <$> f (tuplize <$> aggregator, input expr)
167− where
168− tuplize Aggregator {operation, ordering, distinction} =
169− (operation, ordering, distinction)
81+ Aggregate $ dimap in_ out aggregator
82+ where out = output . Opaleye.unColumn
83+ in_ = Opaleye.Column . input . const expr
src/Rel8/Aggregate/Legacy.hsdeleted−129
@@ -1,129 +0,0 @@
1−{-# language AllowAmbiguousTypes #-}
2−{-# language DataKinds #-}
3−{-# language FlexibleContexts #-}
4−{-# language RankNTypes #-}
5−{-# language ScopedTypeVariables #-}
6−{-# language StandaloneKindSignatures #-}
7−{-# language TypeApplications #-}
8−{-# language TypeFamilies #-}
9−{-# language ViewPatterns #-}
10−
11−module Rel8.Aggregate.Legacy
12− ( Aggregates
13− , aggregate
14− , aggregateTabulation
15− , groupBy
16− , listAgg
17− , nonEmptyAgg
18−
19− , AggregateADT, aggregateADT
20− , AggregateHKD, aggregateHKD
21− )
22−where
23−
24−-- base
25−import Data.Functor.Identity ( Identity( Identity ) )
26−import Data.Kind ( Type )
27−import GHC.Generics ( Rep )
28−import Prelude
29−
30−-- opaleye
31−import qualified Opaleye.Aggregate as Opaleye
32−
33−-- rel8
34−import Rel8.Aggregate ( Aggregate, Aggregates, Col(..) )
35−import Rel8.Expr ( Col(..), Expr )
36−import Rel8.Expr.Aggregate ( groupByExpr, listAggExpr, nonEmptyAggExpr )
37−import Rel8.Generic.Construction ( GGAggregate', ggaggregate' )
38−import Rel8.Generic.Table ( GAlgebra )
39−import Rel8.Kind.Algebra ( Algebra( Sum ) )
40−import Rel8.Query ( Query )
41−import Rel8.Query.Opaleye ( mapOpaleye )
42−import Rel8.Schema.Dict ( Dict( Dict ) )
43−import Rel8.Schema.HTable ( htabulate, hfield )
44−import Rel8.Schema.HTable.Vectorize ( hvectorize )
45−import Rel8.Schema.Kind ( Rel8able )
46−import Rel8.Table ( toColumns, fromColumns )
47−import Rel8.Table.ADT ( ConstructableADT, ADT( ADT ), ADTRep )
48−import Rel8.Table.Eq ( EqTable, eqTable )
49−import Rel8.Table.HKD ( ConstructableHKD, HKD( HKD ), HKDRep )
50−import Rel8.Table.List ( ListTable )
51−import Rel8.Table.NonEmpty ( NonEmptyTable )
52−import Rel8.Table.Opaleye ( aggregator )
53−import Rel8.Tabulate ( Tabulation )
54−import qualified Rel8.Tabulate
55−
56−
57−-- | Apply an aggregation to all rows returned by a 'Query'.
58−aggregate :: Aggregates aggregates exprs => Query aggregates -> Query exprs
59−aggregate = mapOpaleye (Opaleye.aggregate aggregator) . fmap (fromColumns . toColumns)
60−
61−
62−aggregateTabulation
63− :: (EqTable k, Aggregates aggregates exprs)
64− => (t -> aggregates) -> Tabulation k t -> Tabulation k exprs
65−aggregateTabulation f =
66− Rel8.Tabulate.aggregateTabulation . fmap (fromColumns . toColumns . f)
67−
68−
69−-- | Group equal tables together. This works by aggregating each column in the
70−-- given table with 'groupByExpr'.
71−groupBy :: forall exprs aggregates. (EqTable exprs, Aggregates aggregates exprs)
72− => exprs -> aggregates
73−groupBy (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
74− case hfield (eqTable @exprs) field of
75− Dict -> case hfield exprs field of
76− DB expr -> Aggregation $ groupByExpr expr
77−
78−
79−-- | Aggregate rows into a single row containing an array of all aggregated
80−-- rows. This can be used to associate multiple rows with a single row, without
81−-- changing the over cardinality of the query. This allows you to essentially
82−-- return a tree-like structure from queries.
83−--
84−-- For example, if we have a table of orders and each orders contains multiple
85−-- items, we could aggregate the table of orders, pairing each order with its
86−-- items:
87−--
88−-- @
89−-- ordersWithItems :: Query (Order Expr, ListTable (Item Expr))
90−-- ordersWithItems = do
91−-- order <- each orderSchema
92−-- items <- aggregate $ listAgg <$> itemsFromOrder order
93−-- return (order, items)
94−-- @
95−listAgg :: Aggregates aggregates exprs => exprs -> ListTable aggregates
96−listAgg (toColumns -> exprs) = fromColumns $
97− hvectorize
98− (\_ (Identity (DB a)) -> Aggregation $ listAggExpr a)
99− (pure exprs)
100−
101−
102−-- | Like 'listAgg', but the result is guaranteed to be a non-empty list.
103−nonEmptyAgg :: Aggregates aggregates exprs => exprs -> NonEmptyTable aggregates
104−nonEmptyAgg (toColumns -> exprs) = fromColumns $
105− hvectorize
106− (\_ (Identity (DB a)) -> Aggregation $ nonEmptyAggExpr a)
107− (pure exprs)
108−
109−
110−type AggregateADT :: Rel8able -> Type
111−type AggregateADT t = forall r. GGAggregate' 'Sum (ADTRep t) r
112−
113−
114−aggregateADT :: forall t. ConstructableADT t
115− => AggregateADT t -> ADT t Expr -> ADT t Aggregate
116−aggregateADT f =
117− ggaggregate' @'Sum @(ADTRep t) @(ADT t Expr) @(ADT t Aggregate) ADT (\(ADT a) -> a)
118− (f @(ADT t Aggregate))
119−
120−
121−type AggregateHKD :: Type -> Type
122−type AggregateHKD a = forall r. GGAggregate' (GAlgebra (Rep a)) (HKDRep a) r
123−
124−
125−aggregateHKD :: forall a. ConstructableHKD a
126− => AggregateHKD a -> HKD a Expr -> HKD a Aggregate
127−aggregateHKD f =
128− ggaggregate' @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) @(HKD a Aggregate) HKD (\(HKD a) -> a)
129− (f @(HKD a Aggregate))
src/Rel8/Column.hs+9−13
@@ -1,9 +1,9 @@
11{-# language DataKinds #-}
2−{-# language TypeFamilies #-}
32{-# language StandaloneKindSignatures #-}
3+{-# language TypeFamilies #-}
44
55module Rel8.Column
6− ( Column, Default
6+ ( Column
77 , TColumn
88 )
99where
@@ -13,22 +13,18 @@ import Data.Kind ( Type )
1313import Prelude ()
1414
1515-- rel8
16−import Rel8.Column.Field ( Field )
1716import Rel8.FCF ( Eval, Exp )
18−import Rel8.Kind.Necessity ( Necessity( Required, Optional ) )
1917import qualified Rel8.Schema.Kind as K
18+import Rel8.Schema.Result ( Result )
2019
2120
22−-- | The @Column@ type family should be used to indicate which fields of your
23−-- data types are single columns in queries. This type family has special
24−-- support when a query is executed, allowing you to use a single data type for
25−-- both query data and rows decoded to Haskell.
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.
2624type Column :: K.Context -> Type -> Type
27−type Column context a = Field context 'Required a
28−
29−
30−type Default :: K.Context -> Type -> Type
31−type Default context a = Field context 'Optional a
25+type family Column context a where
26+ Column Result a = a
27+ Column context a = context a
3228
3329
3430data TColumn :: K.Context -> Type -> Exp Type
src/Rel8/Column/ADT.hs+3−70
@@ -1,90 +1,23 @@
11{-# language DataKinds #-}
2−{-# language LambdaCase #-}
3−{-# language MultiParamTypeClasses #-}
42{-# language StandaloneKindSignatures #-}
53{-# language TypeFamilies #-}
6−{-# language UndecidableInstances #-}
74
85module Rel8.Column.ADT
9− ( HADT, AHADT(..)
6+ ( HADT
107 )
118where
129
1310-- base
1411import Data.Kind ( Type )
15−import Prelude
12+import Prelude ()
1613
1714-- rel8
18−import Rel8.Generic.Rel8able ( GColumns )
19−import Rel8.Kind.Context ( SContext(..), Reifiable, contextSing )
20−import Rel8.Schema.Context ( Col )
2115import qualified Rel8.Schema.Kind as K
22−import Rel8.Schema.Reify ( Reify, hreify, hunreify )
2316import Rel8.Schema.Result ( Result )
24−import Rel8.Table
25− ( Table, Columns, Context, fromColumns, toColumns
26− , Unreify, reify, unreify
27− )
28−import Rel8.Table.ADT ( ADT( ADT ), ADTable, fromADT, toADT )
29−import Rel8.Table.Recontextualize ( Recontextualize )
17+import Rel8.Table.ADT ( ADT )
3018
3119
3220type HADT :: K.Context -> K.Rel8able -> Type
3321type family HADT context t where
34− HADT (Reify context) t = AHADT context t
3522 HADT Result t = t Result
3623 HADT context t = ADT t context
37−
38−
39−type AHADT :: K.Context -> K.Rel8able -> Type
40−newtype AHADT context t = AHADT (HADT context t)
41−
42−
43−instance (ADTable t, Reifiable context) =>
44− Table (Reify context) (AHADT context t)
45− where
46− type Context (AHADT context t) = Reify context
47− type Columns (AHADT context t) = GColumns (ADT t)
48− type Unreify (AHADT context t) = HADT context t
49−
50− fromColumns = sfromColumnsADT contextSing
51− toColumns = stoColumnsADT contextSing
52− reify _ = AHADT
53− unreify _ (AHADT a) = a
54−
55−
56−instance
57− ( Reifiable context, Reifiable context'
58− , ADTable t, t ~ t'
59− )
60− => Recontextualize
61− (Reify context)
62− (Reify context')
63− (AHADT context t)
64− (AHADT context' t')
65−
66−
67−sfromColumnsADT :: ADTable t
68− => SContext context
69− -> GColumns (ADT t) (Col (Reify context))
70− -> AHADT context t
71−sfromColumnsADT = \case
72− SAggregate -> AHADT . ADT . hunreify
73− SExpr -> AHADT . ADT . hunreify
74− SInsert -> AHADT . ADT . hunreify
75− SName -> AHADT . ADT . hunreify
76− SResult -> AHADT . fromADT . ADT . hunreify
77− SReify context -> AHADT . sfromColumnsADT context . hunreify
78−
79−
80−stoColumnsADT :: ADTable t
81− => SContext context
82− -> AHADT context t
83− -> GColumns (ADT t) (Col (Reify context))
84−stoColumnsADT = \case
85− SAggregate -> hreify . (\(AHADT (ADT a)) -> a)
86− SExpr -> hreify . (\(AHADT (ADT a)) -> a)
87− SInsert -> hreify . (\(AHADT (ADT a)) -> a)
88− SName -> hreify . (\(AHADT (ADT a)) -> a)
89− SResult -> hreify . (\(ADT a) -> a) . toADT . (\(AHADT a) -> a)
90− SReify context -> hreify . stoColumnsADT context . (\(AHADT a) -> a)
src/Rel8/Column/Either.hs+7−153
@@ -1,172 +1,26 @@
11{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
3−{-# language LambdaCase #-}
4−{-# language MultiParamTypeClasses #-}
52{-# language StandaloneKindSignatures #-}
6−{-# language TypeFamilies #-}
7−{-# language UndecidableInstances #-}
3+{-# language TypeFamilyDependencies #-}
84
95module Rel8.Column.Either
10− ( HEither, AHEither(..)
6+ ( HEither
117 )
128where
139
1410-- base
15−import Control.Applicative ( liftA2 )
16−import Data.Bifunctor ( Bifunctor, bimap )
1711import Data.Kind ( Type )
1812import Prelude
1913
2014-- rel8
21−import Rel8.Aggregate ( Aggregate )
22−import Rel8.Expr ( Expr )
23−import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )
24−import Rel8.Schema.Context ( Col )
25−import Rel8.Schema.HTable.Either ( HEitherTable )
26−import Rel8.Schema.Insert ( Insert )
2715import qualified Rel8.Schema.Kind as K
28−import Rel8.Schema.Name ( Name(..) )
29−import Rel8.Schema.Reify ( Reify, hreify, hunreify )
3016import Rel8.Schema.Result ( Result )
31−import Rel8.Table
32− ( Table, Columns, Context, fromColumns, toColumns
33− , Unreify, reify, unreify
34− )
3517import Rel8.Table.Either ( EitherTable )
36−import Rel8.Table.Recontextualize ( Recontextualize )
3718
3819
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.
3923type HEither :: K.Context -> Type -> Type -> Type
40−type family HEither context where
41− HEither (Reify context) = AHEither context
42− HEither Aggregate = EitherTable
43− HEither Expr = EitherTable
44− HEither Insert = EitherTable
45− HEither Name = EitherTable
24+type family HEither context = either | either -> context where
4625 HEither Result = Either
47−
48−
49−type AHEither :: K.Context -> Type -> Type -> Type
50−newtype AHEither context a b = AHEither (HEither context a b)
51−
52−
53−instance Reifiable context => Bifunctor (AHEither context) where
54− bimap = sbimapEither contextSing
55−
56−
57−instance Reifiable context => Functor (AHEither context a) where
58− fmap = bimap id
59−
60−
61−instance (Reifiable context, Table (Reify context) a, Table (Reify context) b)
62− => Table (Reify context) (AHEither context a b)
63− where
64− type Context (AHEither context a b) = Reify context
65− type Columns (AHEither context a b) = HEitherTable (Columns a) (Columns b)
66− type Unreify (AHEither context a b) = HEither context (Unreify a) (Unreify b)
67−
68− fromColumns = sfromColumnsEither contextSing
69− toColumns = stoColumnsEither contextSing
70− reify proof = liftA2 bimap reify reify proof . AHEither
71− unreify proof = (\(AHEither a) -> a) . liftA2 bimap unreify unreify proof
72−
73−
74−instance
75− ( Reifiable context, Reifiable context'
76− , Recontextualize (Reify context) (Reify context') a a'
77− , Recontextualize (Reify context) (Reify context') b b'
78− ) =>
79− Recontextualize
80− (Reify context)
81− (Reify context')
82− (AHEither context a b)
83− (AHEither context' a' b')
84−
85−
86−sbimapEither :: ()
87− => SContext context
88− -> (a -> c)
89− -> (b -> d)
90− -> AHEither context a b
91− -> AHEither context c d
92−sbimapEither = \case
93− SAggregate -> \f g (AHEither a) -> AHEither (bimap f g a)
94− SExpr -> \f g (AHEither a) -> AHEither (bimap f g a)
95− SResult -> \f g (AHEither a) -> AHEither (bimap f g a)
96− SInsert -> \f g (AHEither a) -> AHEither (bimap f g a)
97− SName -> \f g (AHEither a) -> AHEither (bimap f g a)
98− SReify context -> \f g (AHEither a) -> AHEither (sbimapEither context f g a)
99−
100−
101−sfromColumnsEither :: (Table (Reify context) a, Table (Reify context) b)
102− => SContext context
103− -> HEitherTable (Columns a) (Columns b) (Col (Reify context))
104− -> AHEither context a b
105−sfromColumnsEither = \case
106− SAggregate ->
107− AHEither .
108− bimap (fromColumns . hreify) (fromColumns . hreify) .
109− fromColumns .
110− hunreify
111− SExpr ->
112− AHEither .
113− bimap (fromColumns . hreify) (fromColumns . hreify) .
114− fromColumns .
115− hunreify
116− SResult ->
117− AHEither .
118− bimap (fromColumns . hreify) (fromColumns . hreify) .
119− fromColumns .
120− hunreify
121− SInsert ->
122− AHEither .
123− bimap (fromColumns . hreify) (fromColumns . hreify) .
124− fromColumns .
125− hunreify
126− SName ->
127− AHEither .
128− bimap (fromColumns . hreify) (fromColumns . hreify) .
129− fromColumns .
130− hunreify
131− SReify context ->
132− AHEither .
133− sbimapEither context (fromColumns . hreify) (fromColumns . hreify) .
134− sfromColumnsEither context .
135− hunreify
136−
137−
138−stoColumnsEither :: (Table (Reify context) a, Table (Reify context) b)
139− => SContext context
140− -> AHEither context a b
141− -> HEitherTable (Columns a) (Columns b) (Col (Reify context))
142−stoColumnsEither = \case
143− SAggregate ->
144− hreify .
145− toColumns .
146− bimap (hunreify . toColumns) (hunreify . toColumns) .
147− (\(AHEither a) -> a)
148− SExpr ->
149− hreify .
150− toColumns .
151− bimap (hunreify . toColumns) (hunreify . toColumns) .
152− (\(AHEither a) -> a)
153− SResult ->
154− hreify .
155− toColumns .
156− bimap (hunreify . toColumns) (hunreify . toColumns) .
157− (\(AHEither a) -> a)
158− SInsert ->
159− hreify .
160− toColumns .
161− bimap (hunreify . toColumns) (hunreify . toColumns) .
162− (\(AHEither a) -> a)
163− SName ->
164− hreify .
165− toColumns .
166− bimap (hunreify . toColumns) (hunreify . toColumns) .
167− (\(AHEither a) -> a)
168− SReify context ->
169− hreify .
170− stoColumnsEither context .
171− sbimapEither context (hunreify . toColumns) (hunreify . toColumns) .
172− (\(AHEither a) -> a)
26+ HEither context = EitherTable context
src/Rel8/Column/Field.hsdeleted−110
@@ -1,110 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
3−{-# language LambdaCase #-}
4−{-# language MultiParamTypeClasses #-}
5−{-# language StandaloneKindSignatures #-}
6−{-# language TypeFamilies #-}
7−
8−module Rel8.Column.Field
9− ( Field, AField(..)
10− )
11−where
12−
13−-- base
14−import Data.Kind ( Type )
15−import Prelude
16−
17−-- rel8
18−import Rel8.Aggregate ( Aggregate, Col(..) )
19−import Rel8.Expr ( Expr, Col(..) )
20−import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )
21−import Rel8.Kind.Necessity
22− ( Necessity( Required, Optional )
23− , SNecessity( SRequired, SOptional )
24− , KnownNecessity, necessitySing
25− )
26−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
27−import Rel8.Schema.Insert ( Insert, Col(..) )
28−import qualified Rel8.Schema.Kind as K
29−import Rel8.Schema.Name ( Name(..), Col(..) )
30−import Rel8.Schema.Null ( Sql )
31−import Rel8.Schema.Reify ( Reify, Col(..) )
32−import Rel8.Schema.Result ( Col( Result ), Result )
33−import Rel8.Schema.Spec ( Spec( Spec ) )
34−import Rel8.Table
35− ( Table, Columns, Context, fromColumns, toColumns
36− , Unreify, reify, unreify
37− )
38−import Rel8.Table.Recontextualize ( Recontextualize )
39−import Rel8.Type ( DBType )
40−
41−
42−type Field :: K.Context -> Necessity -> Type -> Type
43−type family Field context necessity a where
44− Field (Reify context) necessity a = AField context necessity a
45− Field Aggregate _necessity a = Aggregate (Expr a)
46− Field Expr _necessity a = Expr a
47− Field Insert 'Required a = Expr a
48− Field Insert 'Optional a = Maybe (Expr a)
49− Field Name _necessity a = Name a
50− Field Result _necessity a = a
51−
52−
53−type AField :: K.Context -> Necessity -> Type -> Type
54−newtype AField context necessity a = AField (Field context necessity a)
55−
56−
57−instance (Reifiable context, KnownNecessity necessity, Sql DBType a) =>
58− Table (Reify context) (AField context necessity a)
59− where
60− type Context (AField context necessity a) = Reify context
61− type Columns (AField context necessity a) = HIdentity ('Spec '[] necessity a)
62− type Unreify (AField context necessity a) = Field context necessity a
63−
64− fromColumns (HIdentity (Reify a)) = sfromColumn contextSing a
65− toColumns = HIdentity . Reify . stoColumn contextSing necessitySing
66− reify _ = AField
67− unreify _ (AField a) = a
68−
69−
70−instance
71− ( Reifiable context, Reifiable context'
72− , KnownNecessity necessity, Sql DBType a
73− ) =>
74− Recontextualize
75− (Reify context)
76− (Reify context')
77− (AField context necessity a)
78− (AField context' necessity a)
79−
80−
81−sfromColumn :: ()
82− => SContext context
83− -> Col context ('Spec labels necessity a)
84− -> AField context necessity a
85−sfromColumn = \case
86− SAggregate -> \(Aggregation a) -> AField a
87− SExpr -> \(DB a) -> AField a
88− SResult -> \(Result a) -> AField a
89− SInsert -> \case
90− RequiredInsert a -> AField a
91− OptionalInsert a -> AField a
92− SName -> \(NameCol a) -> AField (Name a)
93− SReify context -> \(Reify a) -> AField (sfromColumn context a)
94−
95−
96−stoColumn :: ()
97− => SContext context
98− -> SNecessity necessity
99− -> AField context necessity a
100− -> Col context ('Spec labels necessity a)
101−stoColumn = \case
102− SAggregate -> \_ (AField a) -> Aggregation a
103− SExpr -> \_ (AField a) -> DB a
104− SResult -> \_ (AField a) -> Result a
105− SInsert -> \case
106− SRequired -> \(AField a) -> RequiredInsert a
107− SOptional -> \(AField a) -> OptionalInsert a
108− SName -> \_ (AField (Name a)) -> NameCol a
109− SReify context ->
110− \necessity (AField a) -> Reify (stoColumn context necessity a)
src/Rel8/Column/Lift.hs+3−69
@@ -1,89 +1,23 @@
11{-# language DataKinds #-}
2−{-# language LambdaCase #-}
3−{-# language MultiParamTypeClasses #-}
42{-# language StandaloneKindSignatures #-}
53{-# language TypeFamilies #-}
64
75module Rel8.Column.Lift
8− ( Lift, ALift(..)
6+ ( Lift
97 )
108where
119
1210-- base
1311import Data.Kind ( Type )
14−import Prelude
12+import Prelude ()
1513
1614-- rel8
17−import Rel8.Generic.Rel8able ( GColumns )
18−import Rel8.Kind.Context ( Reifiable(..), SContext(..) )
19−import Rel8.Schema.Context ( Col )
2015import qualified Rel8.Schema.Kind as K
21−import Rel8.Schema.Reify ( Reify, hreify, hunreify )
2216import Rel8.Schema.Result ( Result )
23−import Rel8.Table
24− ( Table, Columns, Context, fromColumns, toColumns
25− , Unreify, reify, unreify
26− )
27−import Rel8.Table.Rel8able ()
28−import Rel8.Table.HKD ( HKD( HKD ), HKDable, fromHKD, toHKD )
29−import Rel8.Table.Recontextualize ( Recontextualize )
17+import Rel8.Table.HKD ( HKD )
3018
3119
3220type Lift :: K.Context -> Type -> Type
3321type family Lift context a where
34− Lift (Reify context) a = ALift context a
3522 Lift Result a = a
3623 Lift context a = HKD a context
37−
38−
39−type ALift :: K.Context -> Type -> Type
40−newtype ALift context a = ALift
41− { unALift :: Lift context a
42− }
43−
44−
45−instance (Reifiable context, HKDable a) =>
46− Table (Reify context) (ALift context a)
47− where
48− type Context (ALift context a) = Reify context
49− type Columns (ALift context a) = GColumns (HKD a)
50− type Unreify (ALift context a) = Lift context a
51−
52− fromColumns = sfromColumnsLift contextSing
53− toColumns = stoColumnsLift contextSing
54− reify _ = ALift
55− unreify _ (ALift a) = a
56−
57−
58−instance (Reifiable context, Reifiable context', HKDable a) =>
59− Recontextualize
60− (Reify context)
61− (Reify context')
62− (ALift context a)
63− (ALift context' a)
64−
65−
66−sfromColumnsLift :: HKDable a
67− => SContext context
68− -> GColumns (HKD a) (Col (Reify context))
69− -> ALift context a
70−sfromColumnsLift = \case
71− SAggregate -> ALift . fromColumns . hunreify
72− SExpr -> ALift . fromColumns . hunreify
73− SInsert -> ALift . fromColumns . hunreify
74− SName -> ALift . fromColumns . hunreify
75− SResult -> ALift . fromHKD . HKD . hunreify
76− SReify context -> ALift . sfromColumnsLift context . hunreify
77−
78−
79−stoColumnsLift :: HKDable a
80− => SContext context
81− -> ALift context a
82− -> GColumns (HKD a) (Col (Reify context))
83−stoColumnsLift = \case
84− SAggregate -> hreify . toColumns . unALift
85− SExpr -> hreify . toColumns . unALift
86− SInsert -> hreify . toColumns . unALift
87− SName -> hreify . toColumns . unALift
88− SResult -> hreify . (\(HKD a) -> a) . toHKD . unALift
89− SReify context -> hreify . stoColumnsLift context . unALift
src/Rel8/Column/List.hs+8−131
@@ -1,148 +1,25 @@
11{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
3−{-# language LambdaCase #-}
4−{-# language MultiParamTypeClasses #-}
52{-# language StandaloneKindSignatures #-}
6−{-# language TypeFamilies #-}
7−{-# language UndecidableInstances #-}
3+{-# language TypeFamilyDependencies #-}
84
95module Rel8.Column.List
10− ( HList, AHList(..)
6+ ( HList
117 )
128where
139
1410-- base
1511import Data.Kind ( Type )
16−import Data.Type.Equality ( (:~:)( Refl ) )
17−import Prelude
12+import Prelude ()
1813
1914-- rel8
20−import Rel8.Aggregate ( Aggregate )
21−import Rel8.Expr ( Expr )
22−import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )
23−import Rel8.Schema.Context ( Col )
24−import Rel8.Schema.HTable.List ( HListTable )
25−import Rel8.Schema.Insert ( Insert )
2615import qualified Rel8.Schema.Kind as K
27−import Rel8.Schema.Name ( Name )
28−import Rel8.Schema.Reify ( Reify, hreify, hunreify )
2916import Rel8.Schema.Result ( Result )
30−import Rel8.Table
31− ( Table, Columns, Congruent, Context, fromColumns, toColumns
32− , Unreify, reify, unreify
33− )
34−import Rel8.Table.List ( ListTable( ListTable ) )
35−import Rel8.Table.Recontextualize ( Recontextualize )
36−import Rel8.Table.Unreify ( Unreifiability(..), Unreifiable, unreifiability )
17+import Rel8.Table.List ( ListTable )
3718
3819
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.
3922type HList :: K.Context -> Type -> Type
40−type family HList context where
41− HList (Reify context) = AHList context
42− HList Aggregate = ListTable
43− HList Expr = ListTable
44− HList Insert = ListTable
45− HList Name = ListTable
23+type family HList context = list | list -> context where
4624 HList Result = []
47−
48−
49−type AHList :: K.Context -> Type -> Type
50−newtype AHList context a = AHList (HList context a)
51−
52−
53−instance (Reifiable context, Unreifiable a, Table (Reify context) a) =>
54− Table (Reify context) (AHList context a)
55− where
56− type Context (AHList context a) = Reify context
57− type Columns (AHList context a) = HListTable (Columns a)
58− type Unreify (AHList context a) = HList context (Unreify a)
59−
60− fromColumns = sfromColumnsList contextSing
61− toColumns = stoColumnsList contextSing
62−
63− reify _ = sreifyList (unreifiability contextSing)
64− unreify _ = sunreifyList (unreifiability contextSing)
65−
66−
67−instance
68− ( Reifiable context, Reifiable context'
69− , Unreifiable a, Unreifiable a'
70− , Recontextualize (Reify context) (Reify context') a a'
71− )
72− => Recontextualize
73− (Reify context)
74− (Reify context')
75− (AHList context a)
76− (AHList context' a')
77−
78−
79−smapList :: Congruent a b
80− => SContext context
81− -> (a -> b)
82− -> (HListTable (Columns a) (Col (Context a)) -> HListTable (Columns b) (Col (Context b)))
83− -> AHList context a
84− -> AHList context b
85−smapList = \case
86− SAggregate -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
87− SExpr -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
88− SResult -> \f _ (AHList as) -> AHList (fmap f as)
89− SInsert -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
90− SName -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
91− SReify context -> \f g (AHList as) -> AHList (smapList context f g as)
92−
93−
94−sfromColumnsList :: Table (Reify context) a
95− => SContext context
96− -> HListTable (Columns a) (Col (Reify context))
97− -> AHList context a
98−sfromColumnsList = \case
99− SAggregate -> AHList . ListTable
100− SExpr -> AHList . ListTable
101− SResult -> AHList . fmap (fromColumns . hreify) . fromColumns . hunreify
102− SInsert -> AHList . ListTable
103− SName -> AHList . ListTable
104− SReify context ->
105− AHList .
106− smapList context (fromColumns . hreify) hreify .
107− sfromColumnsList context .
108− hunreify
109−
110−
111−stoColumnsList :: Table (Reify context) a
112− => SContext context
113− -> AHList context a
114− -> HListTable (Columns a) (Col (Reify context))
115−stoColumnsList = \case
116− SAggregate -> \(AHList (ListTable a)) -> a
117− SExpr -> \(AHList (ListTable a)) -> a
118− SResult ->
119− hreify . toColumns . fmap (hunreify . toColumns) . (\(AHList a) -> a)
120− SInsert -> \(AHList (ListTable a)) -> a
121− SName -> \(AHList (ListTable a)) -> a
122− SReify context ->
123− hreify .
124− stoColumnsList context .
125− smapList context (hunreify . toColumns) hunreify .
126− (\(AHList a) -> a)
127−
128−
129−sreifyList :: Table (Reify context) a
130− => Unreifiability context a
131− -> HList context (Unreify a)
132− -> AHList context a
133−sreifyList = \case
134− UResult -> AHList . fmap (reify Refl)
135− Unreifiability context ->
136− smapList context (reify Refl) hreify .
137− AHList
138−
139−
140−sunreifyList :: Table (Reify context) a
141− => Unreifiability context a
142− -> AHList context a
143− -> HList context (Unreify a)
144−sunreifyList = \case
145− UResult -> fmap (unreify Refl) . (\(AHList a) -> a)
146− Unreifiability context ->
147− (\(AHList a) -> a) .
148− smapList context (unreify Refl) hunreify
25+ HList context = ListTable context
src/Rel8/Column/Maybe.hs+7−111
@@ -1,14 +1,9 @@
11{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
3−{-# language GADTs #-}
4−{-# language LambdaCase #-}
5−{-# language MultiParamTypeClasses #-}
62{-# language StandaloneKindSignatures #-}
7−{-# language TypeFamilies #-}
8−{-# language UndecidableInstances #-}
3+{-# language TypeFamilyDependencies #-}
94
105module Rel8.Column.Maybe
11− ( HMaybe, AHMaybe(..)
6+ ( HMaybe
127 )
138where
149
@@ -17,114 +12,15 @@ import Data.Kind ( Type )
1712import Prelude
1813
1914-- rel8
20−import Rel8.Aggregate ( Aggregate )
21−import Rel8.Expr ( Expr )
22−import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )
23−import Rel8.Schema.Context ( Col )
24−import Rel8.Schema.HTable.Maybe ( HMaybeTable )
25−import Rel8.Schema.Insert ( Insert )
2615import qualified Rel8.Schema.Kind as K
27−import Rel8.Schema.Name ( Name )
28−import Rel8.Schema.Reify ( Reify, hreify, hunreify )
2916import Rel8.Schema.Result ( Result )
30−import Rel8.Table
31− ( Table, Columns, Context, fromColumns, toColumns
32− , Unreify, reify, unreify
33− )
3417import Rel8.Table.Maybe ( MaybeTable )
35−import Rel8.Table.Recontextualize ( Recontextualize )
3618
3719
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.
3823type HMaybe :: K.Context -> Type -> Type
39−type family HMaybe context where
40− HMaybe (Reify context) = AHMaybe context
41− HMaybe Aggregate = MaybeTable
42− HMaybe Expr = MaybeTable
43− HMaybe Insert = MaybeTable
44− HMaybe Name = MaybeTable
24+type family HMaybe context = maybe | maybe -> context where
4525 HMaybe Result = Maybe
46−
47−
48−type AHMaybe :: K.Context -> Type -> Type
49−newtype AHMaybe context a = AHMaybe (HMaybe context a)
50−
51−
52−instance Reifiable context => Functor (AHMaybe context) where
53− fmap = smapMaybe contextSing
54−
55−
56−instance (Reifiable context, Table (Reify context) a) =>
57− Table (Reify context) (AHMaybe context a)
58− where
59− type Context (AHMaybe context a) = Reify context
60− type Columns (AHMaybe context a) = HMaybeTable (Columns a)
61− type Unreify (AHMaybe context a) = HMaybe context (Unreify a)
62−
63− fromColumns = sfromColumnsMaybe contextSing
64− toColumns = stoColumnsMaybe contextSing
65− reify proof = fmap fmap reify proof . AHMaybe
66− unreify proof = (\(AHMaybe a) -> a) . fmap fmap unreify proof
67−
68−
69−instance
70− ( Reifiable context, Reifiable context'
71− , Recontextualize (Reify context) (Reify context') a a'
72− ) =>
73− Recontextualize
74− (Reify context)
75− (Reify context')
76− (AHMaybe context a)
77− (AHMaybe context' a')
78−
79−
80−smapMaybe :: ()
81− => SContext context
82− -> (a -> b)
83− -> AHMaybe context a
84− -> AHMaybe context b
85−smapMaybe = \case
86− SAggregate -> \f (AHMaybe a) -> AHMaybe (fmap f a)
87− SExpr -> \f (AHMaybe a) -> AHMaybe (fmap f a)
88− SResult -> \f (AHMaybe a) -> AHMaybe (fmap f a)
89− SInsert -> \f (AHMaybe a) -> AHMaybe (fmap f a)
90− SName -> \f (AHMaybe a) -> AHMaybe (fmap f a)
91− SReify context -> \f (AHMaybe a) -> AHMaybe (smapMaybe context f a)
92−
93−
94−sfromColumnsMaybe :: Table (Reify context) a
95− => SContext context
96− -> HMaybeTable (Columns a) (Col (Reify context))
97− -> AHMaybe context a
98−sfromColumnsMaybe = \case
99− SAggregate -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
100− SExpr -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
101− SResult -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
102− SInsert -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
103− SName -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
104− SReify context ->
105− AHMaybe .
106− smapMaybe context (fromColumns . hreify) .
107− sfromColumnsMaybe context .
108− hunreify
109−
110−
111−stoColumnsMaybe :: Table (Reify context) a
112− => SContext context
113− -> AHMaybe context a
114− -> HMaybeTable (Columns a) (Col (Reify context))
115−stoColumnsMaybe = \case
116− SAggregate ->
117− hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
118− SExpr ->
119− hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
120− SResult ->
121− hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
122− SInsert ->
123− hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
124− SName ->
125− hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
126− SReify context ->
127− hreify .
128− stoColumnsMaybe context .
129− smapMaybe context (hunreify . toColumns) .
130− (\(AHMaybe a) -> a)
26+ HMaybe context = MaybeTable context
src/Rel8/Column/NonEmpty.hs+9−132
@@ -1,150 +1,27 @@
11{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
3−{-# language LambdaCase #-}
4−{-# language MultiParamTypeClasses #-}
52{-# language StandaloneKindSignatures #-}
6−{-# language TypeFamilies #-}
7−{-# language UndecidableInstances #-}
3+{-# language TypeFamilyDependencies #-}
84
95module Rel8.Column.NonEmpty
10− ( HNonEmpty, AHNonEmpty(..)
6+ ( HNonEmpty
117 )
128where
139
1410-- base
1511import Data.Kind ( Type )
1612import Data.List.NonEmpty ( NonEmpty )
17−import Data.Type.Equality ( (:~:)( Refl ) )
18−import Prelude
13+import Prelude ()
1914
2015-- rel8
21−import Rel8.Aggregate ( Aggregate )
22−import Rel8.Expr ( Expr )
23−import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )
24−import Rel8.Schema.Context ( Col )
25−import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
26−import Rel8.Schema.Insert ( Insert )
2716import qualified Rel8.Schema.Kind as K
28−import Rel8.Schema.Name ( Name )
29−import Rel8.Schema.Reify ( Reify, hreify, hunreify )
3017import Rel8.Schema.Result ( Result )
31−import Rel8.Table
32− ( Table, Columns, Congruent, Context, fromColumns, toColumns
33− , Unreify, reify, unreify
34− )
35−import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )
36−import Rel8.Table.Recontextualize ( Recontextualize )
37−import Rel8.Table.Unreify ( Unreifiability(..), Unreifiable, unreifiability )
18+import Rel8.Table.NonEmpty ( NonEmptyTable )
3819
3920
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.
4024type HNonEmpty :: K.Context -> Type -> Type
41−type family HNonEmpty context where
42− HNonEmpty (Reify context) = AHNonEmpty context
43− HNonEmpty Aggregate = NonEmptyTable
44− HNonEmpty Expr = NonEmptyTable
45− HNonEmpty Insert = NonEmptyTable
46− HNonEmpty Name = NonEmptyTable
25+type family HNonEmpty context = nonEmpty | nonEmpty -> context where
4726 HNonEmpty Result = NonEmpty
48−
49−
50−type AHNonEmpty :: K.Context -> Type -> Type
51−newtype AHNonEmpty context a = AHNonEmpty (HNonEmpty context a)
52−
53−
54−instance (Reifiable context, Unreifiable a, Table (Reify context) a) =>
55− Table (Reify context) (AHNonEmpty context a)
56− where
57− type Context (AHNonEmpty context a) = Reify context
58− type Columns (AHNonEmpty context a) = HNonEmptyTable (Columns a)
59− type Unreify (AHNonEmpty context a) = HNonEmpty context (Unreify a)
60−
61− fromColumns = sfromColumnsNonEmpty contextSing
62− toColumns = stoColumnsNonEmpty contextSing
63−
64− reify _ = sreifyNonEmpty (unreifiability contextSing)
65− unreify _ = sunreifyNonEmpty (unreifiability contextSing)
66−
67−
68−instance
69− ( Reifiable context, Reifiable context'
70− , Unreifiable a, Unreifiable a'
71− , Recontextualize (Reify context) (Reify context') a a'
72− )
73− => Recontextualize
74− (Reify context)
75− (Reify context')
76− (AHNonEmpty context a)
77− (AHNonEmpty context' a')
78−
79−
80−smapNonEmpty :: Congruent a b
81− => SContext context
82− -> (a -> b)
83− -> (HNonEmptyTable (Columns a) (Col (Context a)) -> HNonEmptyTable (Columns b) (Col (Context b)))
84− -> AHNonEmpty context a
85− -> AHNonEmpty context b
86−smapNonEmpty = \case
87− SAggregate -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
88− SExpr -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
89− SResult -> \f _ (AHNonEmpty as) -> AHNonEmpty (fmap f as)
90− SInsert -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
91− SName -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
92− SReify context -> \f g (AHNonEmpty as) -> AHNonEmpty (smapNonEmpty context f g as)
93−
94−
95−sfromColumnsNonEmpty :: Table (Reify context) a
96− => SContext context
97− -> HNonEmptyTable (Columns a) (Col (Reify context))
98− -> AHNonEmpty context a
99−sfromColumnsNonEmpty = \case
100− SAggregate -> AHNonEmpty . NonEmptyTable
101− SExpr -> AHNonEmpty . NonEmptyTable
102− SResult ->
103− AHNonEmpty . fmap (fromColumns . hreify) . fromColumns . hunreify
104− SInsert -> AHNonEmpty . NonEmptyTable
105− SName -> AHNonEmpty . NonEmptyTable
106− SReify context ->
107− AHNonEmpty .
108− smapNonEmpty context (fromColumns . hreify) hreify .
109− sfromColumnsNonEmpty context .
110− hunreify
111−
112−
113−stoColumnsNonEmpty :: Table (Reify context) a
114− => SContext context
115− -> AHNonEmpty context a
116− -> HNonEmptyTable (Columns a) (Col (Reify context))
117−stoColumnsNonEmpty = \case
118− SAggregate -> \(AHNonEmpty (NonEmptyTable a)) -> a
119− SExpr -> \(AHNonEmpty (NonEmptyTable a)) -> a
120− SResult ->
121− hreify . toColumns . fmap (hunreify . toColumns) . (\(AHNonEmpty a) -> a)
122− SInsert -> \(AHNonEmpty (NonEmptyTable a)) -> a
123− SName -> \(AHNonEmpty (NonEmptyTable a)) -> a
124− SReify context ->
125− hreify .
126− stoColumnsNonEmpty context .
127− smapNonEmpty context (hunreify . toColumns) hunreify .
128− (\(AHNonEmpty a) -> a)
129−
130−
131−sreifyNonEmpty :: Table (Reify context) a
132− => Unreifiability context a
133− -> HNonEmpty context (Unreify a)
134− -> AHNonEmpty context a
135−sreifyNonEmpty = \case
136− UResult -> AHNonEmpty . fmap (reify Refl)
137− Unreifiability context ->
138− smapNonEmpty context (reify Refl) hreify .
139− AHNonEmpty
140−
141−
142−sunreifyNonEmpty :: Table (Reify context) a
143− => Unreifiability context a
144− -> AHNonEmpty context a
145− -> HNonEmpty context (Unreify a)
146−sunreifyNonEmpty = \case
147− UResult -> fmap (unreify Refl) . (\(AHNonEmpty a) -> a)
148− Unreifiability context ->
149− (\(AHNonEmpty a) -> a) .
150− smapNonEmpty context (unreify Refl) hunreify
27+ HNonEmpty context = NonEmptyTable context
src/Rel8/Column/Null.hsnew file+26
@@ -0,0 +1,26 @@
1+{-# language DataKinds #-}
2+{-# language StandaloneKindSignatures #-}
3+{-# language TypeFamilyDependencies #-}
4+
5+module Rel8.Column.Null
6+ ( HNull
7+ )
8+where
9+
10+-- base
11+import Data.Kind ( Type )
12+import Prelude
13+
14+-- rel8
15+import qualified Rel8.Schema.Kind as K
16+import Rel8.Schema.Result ( Result )
17+import Rel8.Table.Null ( NullTable )
18+
19+
20+-- | Nest a 'Null' value within a 'Rel8able'. @HNull f a@ will produce a
21+-- 'NullTable' @a@ in the 'Expr' context, and a @'Maybe' a@ in the 'Result'
22+-- context.
23+type HNull :: K.Context -> Type -> Type
24+type family HNull context = maybe | maybe -> context where
25+ HNull Result = Maybe
26+ HNull context = NullTable context
src/Rel8/Column/These.hs+8−155
@@ -1,176 +1,29 @@
11{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
3−{-# language GADTs #-}
4−{-# language LambdaCase #-}
5−{-# language MultiParamTypeClasses #-}
62{-# language StandaloneKindSignatures #-}
7−{-# language TypeFamilies #-}
8−{-# language UndecidableInstances #-}
3+{-# language TypeFamilyDependencies #-}
94
105module Rel8.Column.These
11− ( HThese, AHThese(..)
6+ ( HThese
127 )
138where
149
1510-- base
16−import Control.Applicative ( liftA2 )
17−import Data.Bifunctor ( Bifunctor, bimap )
1811import Data.Kind ( Type )
19−import Prelude
12+import Prelude ()
2013
2114-- rel8
22−import Rel8.Aggregate ( Aggregate )
23−import Rel8.Expr ( Expr )
24−import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )
25−import Rel8.Schema.Context ( Col )
26−import Rel8.Schema.HTable.These ( HTheseTable )
27−import Rel8.Schema.Insert ( Insert )
2815import qualified Rel8.Schema.Kind as K
29−import Rel8.Schema.Name ( Name )
30−import Rel8.Schema.Reify ( Reify, hreify, hunreify )
3116import Rel8.Schema.Result ( Result )
32−import Rel8.Table
33− ( Table, Columns, Context, fromColumns, toColumns
34− , Unreify, reify, unreify
35− )
36−import Rel8.Table.Recontextualize ( Recontextualize )
3717import Rel8.Table.These ( TheseTable )
3818
3919-- these
4020import Data.These ( These )
4121
4222
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.
4326type HThese :: K.Context -> Type -> Type -> Type
44−type family HThese context where
45− HThese (Reify context) = AHThese context
46− HThese Aggregate = TheseTable
47− HThese Expr = TheseTable
48− HThese Insert = TheseTable
49− HThese Name = TheseTable
27+type family HThese context = these | these -> context where
5028 HThese Result = These
51−
52−
53−type AHThese :: K.Context -> Type -> Type -> Type
54−newtype AHThese context a b = AHThese (HThese context a b)
55−
56−
57−instance Reifiable context => Bifunctor (AHThese context) where
58− bimap = sbimapThese contextSing
59−
60−
61−instance Reifiable context => Functor (AHThese context a) where
62− fmap = bimap id
63−
64−
65−instance (Reifiable context, Table (Reify context) a, Table (Reify context) b)
66− => Table (Reify context) (AHThese context a b)
67− where
68− type Context (AHThese context a b) = Reify context
69− type Columns (AHThese context a b) = HTheseTable (Columns a) (Columns b)
70− type Unreify (AHThese context a b) = HThese context (Unreify a) (Unreify b)
71−
72− fromColumns = sfromColumnsThese contextSing
73− toColumns = stoColumnsThese contextSing
74− reify proof = liftA2 bimap reify reify proof . AHThese
75− unreify proof = (\(AHThese a) -> a) . liftA2 bimap unreify unreify proof
76−
77−
78−instance
79− ( Reifiable context, Reifiable context'
80− , Recontextualize (Reify context) (Reify context') a a'
81− , Recontextualize (Reify context) (Reify context') b b'
82− ) =>
83− Recontextualize
84− (Reify context)
85− (Reify context')
86− (AHThese context a b)
87− (AHThese context' a' b')
88−
89−
90−sbimapThese :: ()
91− => SContext context
92− -> (a -> c)
93− -> (b -> d)
94− -> AHThese context a b
95− -> AHThese context c d
96−sbimapThese = \case
97− SAggregate -> \f g (AHThese a) -> AHThese (bimap f g a)
98− SExpr -> \f g (AHThese a) -> AHThese (bimap f g a)
99− SResult -> \f g (AHThese a) -> AHThese (bimap f g a)
100− SInsert -> \f g (AHThese a) -> AHThese (bimap f g a)
101− SName -> \f g (AHThese a) -> AHThese (bimap f g a)
102− SReify context -> \f g (AHThese a) -> AHThese (sbimapThese context f g a)
103−
104−
105−sfromColumnsThese :: (Table (Reify context) a, Table (Reify context) b)
106− => SContext context
107− -> HTheseTable (Columns a) (Columns b) (Col (Reify context))
108− -> AHThese context a b
109−sfromColumnsThese = \case
110− SAggregate ->
111− AHThese .
112− bimap (fromColumns . hreify) (fromColumns . hreify) .
113− fromColumns .
114− hunreify
115− SExpr ->
116− AHThese .
117− bimap (fromColumns . hreify) (fromColumns . hreify) .
118− fromColumns .
119− hunreify
120− SResult ->
121− AHThese .
122− bimap (fromColumns . hreify) (fromColumns . hreify) .
123− fromColumns .
124− hunreify
125− SInsert ->
126− AHThese .
127− bimap (fromColumns . hreify) (fromColumns . hreify) .
128− fromColumns .
129− hunreify
130− SName ->
131− AHThese .
132− bimap (fromColumns . hreify) (fromColumns . hreify) .
133− fromColumns .
134− hunreify
135− SReify context ->
136− AHThese .
137− sbimapThese context (fromColumns . hreify) (fromColumns . hreify) .
138− sfromColumnsThese context .
139− hunreify
140−
141−
142−stoColumnsThese :: (Table (Reify context) a, Table (Reify context) b)
143− => SContext context
144− -> AHThese context a b
145− -> HTheseTable (Columns a) (Columns b) (Col (Reify context))
146−stoColumnsThese = \case
147− SAggregate ->
148− hreify .
149− toColumns .
150− bimap (hunreify . toColumns) (hunreify . toColumns) .
151− (\(AHThese a) -> a)
152− SExpr ->
153− hreify .
154− toColumns .
155− bimap (hunreify . toColumns) (hunreify . toColumns) .
156− (\(AHThese a) -> a)
157− SResult ->
158− hreify .
159− toColumns .
160− bimap (hunreify . toColumns) (hunreify . toColumns) .
161− (\(AHThese a) -> a)
162− SInsert ->
163− hreify .
164− toColumns .
165− bimap (hunreify . toColumns) (hunreify . toColumns) .
166− (\(AHThese a) -> a)
167− SName ->
168− hreify .
169− toColumns .
170− bimap (hunreify . toColumns) (hunreify . toColumns) .
171− (\(AHThese a) -> a)
172− SReify context ->
173− hreify .
174− stoColumnsThese context .
175− sbimapThese context (hunreify . toColumns) (hunreify . toColumns) .
176− (\(AHThese a) -> a)
29+ HThese context = TheseTable context
src/Rel8/Expr.hs+17−47
@@ -1,27 +1,21 @@
11{-# language DataKinds #-}
22{-# language DerivingStrategies #-}
3+{-# language FlexibleContexts #-}
34{-# language FlexibleInstances #-}
4−{-# language GADTs #-}
55{-# language MultiParamTypeClasses #-}
6−{-# language PolyKinds #-}
7−{-# language RoleAnnotations #-}
86{-# language ScopedTypeVariables #-}
9−{-# language StandaloneDeriving #-}
107{-# language StandaloneKindSignatures #-}
118{-# language TypeApplications #-}
129{-# language TypeFamilies #-}
1310{-# language UndecidableInstances #-}
14−{-# language UndecidableSuperClasses #-}
1511
1612module Rel8.Expr
1713 ( Expr(..)
18− , Col( DB, unDB )
1914 )
2015where
2116
2217-- base
23−import Data.Functor.Identity ( Identity )
24−import Data.Kind ( Type )
18+import Data.Functor.Identity ( Identity( Identity ) )
2519import Data.String ( IsString, fromString )
2620import Prelude hiding ( null )
2721
@@ -38,17 +32,14 @@ import Rel8.Expr.Opaleye
3832 , zipPrimExprsWith
3933 )
4034import Rel8.Expr.Serialize ( litExpr )
41−import Rel8.Schema.Context ( Interpretation, Col )
42−import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
43−import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )
35+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
36+import qualified Rel8.Schema.Kind as K
4437import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
45−import Rel8.Schema.Reify ( notReify )
46−import Rel8.Schema.Result ( Result )
47−import Rel8.Schema.Spec ( Spec( Spec ) )
4838import Rel8.Table
49− ( Table, Columns, Context, fromColumns, toColumns, reify, unreify
39+ ( Table, Columns, Context, fromColumns, toColumns
40+ , FromExprs, fromResult, toResult
41+ , Transpose
5042 )
51−import Rel8.Table.Recontextualize ( Recontextualize )
5243import Rel8.Type ( DBType )
5344import Rel8.Type.Monoid ( DBMonoid, memptyExpr )
5445import Rel8.Type.Num ( DBFloating, DBFractional, DBNum )
@@ -56,13 +47,9 @@ import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )
5647
5748
5849-- | Typed SQL expressions.
59−type role Expr representational
60−type Expr :: k -> Type
61−data Expr a where
62− Expr :: k ~ Type => !Opaleye.PrimExpr -> Expr (a :: k)
63−
64−
65−deriving stock instance Show (Expr a)
50+type Expr :: K.Context
51+newtype Expr a = Expr Opaleye.PrimExpr
52+ deriving stock Show
6653
6754
6855instance Sql DBSemigroup a => Semigroup (Expr a) where
@@ -126,30 +113,13 @@ instance Sql DBFloating a => Floating (Expr a) where
126113 atanh = function "atanh"
127114
128115
129−instance Interpretation Expr where
130− data Col Expr _spec where
131− DB :: {unDB :: Expr a} -> Col Expr ('Spec labels necessity a)
132−
133−
134116instance Sql DBType a => Table Expr (Expr a) where
135− type Columns (Expr a) = HType a
117+ type Columns (Expr a) = HIdentity a
136118 type Context (Expr a) = Expr
119+ type FromExprs (Expr a) = a
120+ type Transpose to (Expr a) = to a
137121
138− toColumns a = HType (DB a)
139− fromColumns (HType (DB a)) = a
140− reify = notReify
141− unreify = notReify
142−
143−
144−instance Sql DBType a => Recontextualize Expr Expr (Expr a) (Expr a)
145−
146−
147−instance Sql DBType a => Recontextualize Expr Result (Expr a) (Identity a)
148−
149−
150−instance Sql DBType a => Recontextualize Result Expr (Identity a) (Expr a)
151−
152−
153−instance Labelable Expr where
154− labeler (DB a) = DB a
155− unlabeler (DB a) = DB a
122+ toColumns a = HIdentity a
123+ fromColumns (HIdentity a) = a
124+ toResult a = HIdentity (Identity a)
125+ fromResult (HIdentity (Identity a)) = a
src/Rel8/Expr.hs-boot+6−8
@@ -1,6 +1,4 @@
1−{-# language GADTs #-}
2−{-# language PolyKinds #-}
3−{-# language RoleAnnotations #-}
1+{-# language DataKinds #-}
42{-# language StandaloneKindSignatures #-}
53
64module Rel8.Expr
@@ -9,14 +7,14 @@ module Rel8.Expr
97where
108
119-- base
12−import Data.Kind ( Type )
1310import Prelude ()
1411
1512-- opaleye
1613import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
1714
15+-- rel8
16+import Rel8.Schema.Kind ( Context )
1817
19−type role Expr representational
20−type Expr :: k -> Type
21−data Expr a where
22− Expr :: k ~ Type => !Opaleye.PrimExpr -> Expr (a :: k)
18+
19+type Expr :: Context
20+newtype Expr a = Expr Opaleye.PrimExpr
src/Rel8/Expr/Aggregate.hs+53−115
@@ -10,10 +10,11 @@ module Rel8.Expr.Aggregate
1010 , and, or
1111 , min, max
1212 , sum, sumWhere
13+ , avg
1314 , stringAgg
1415 , groupByExpr
15− , array1DAggExpr, listAggExpr, nonEmptyAggExpr
16− , listAggExprWithOrder, nonEmptyAggExprWithOrder
16+ , listAggExpr, nonEmptyAggExpr
17+ , slistAggExpr, snonEmptyAggExpr
1718 )
1819where
1920
@@ -23,10 +24,12 @@ import Data.List.NonEmpty ( NonEmpty )
2324import Prelude hiding ( and, max, min, null, or, sum )
2425
2526-- opaleye
26−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
27+import qualified Opaleye.Internal.Aggregate as Opaleye
28+import Opaleye.Internal.Column ( Field_( Column ) )
29+import qualified Opaleye.Aggregate as Opaleye
2730
2831-- rel8
29−import Rel8.Aggregate ( Aggregate, Aggregator(..), unsafeMakeAggregate )
32+import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )
3033import Rel8.Expr ( Expr )
3134import Rel8.Expr.Bool ( caseExpr )
3235import Rel8.Expr.Opaleye
@@ -37,11 +40,11 @@ import Rel8.Expr.Opaleye
3740 )
3841import Rel8.Expr.Null ( null )
3942import Rel8.Expr.Serialize ( litExpr )
40−import Rel8.Order ( Order, toOrderExprs )
41−import Rel8.Schema.Null ( Sql )
42−import Rel8.Type.Array ( fromPrimArray )
43−import Rel8.Type.Array1D ( Array1D, NotArray )
43+import Rel8.Schema.Null ( Sql, Unnullify )
44+import Rel8.Type ( DBType, typeInformation )
45+import Rel8.Type.Array ( encodeArrayElement )
4446import Rel8.Type.Eq ( DBEq )
47+import Rel8.Type.Information ( TypeInformation )
4548import Rel8.Type.Num ( DBNum )
4649import Rel8.Type.Ord ( DBMax, DBMin )
4750import Rel8.Type.String ( DBString )
@@ -49,164 +52,99 @@ import Rel8.Type.Sum ( DBSum )
4952
5053
5154-- | Count the occurances of a single column. Corresponds to @COUNT(a)@
52−count :: Expr a -> Aggregate (Expr Int64)
53−count = unsafeMakeAggregate toPrimExpr fromPrimExpr $
54− Just Aggregator
55− { operation = Opaleye.AggrCount
56− , ordering = []
57− , distinction = Opaleye.AggrAll
58− }
59−
55+count :: Expr a -> Aggregate Int64
56+count = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.count
6057
6158-- | Count the number of distinct occurances of a single column. Corresponds to
6259-- @COUNT(DISTINCT a)@
63−countDistinct :: Sql DBEq a => Expr a -> Aggregate (Expr Int64)
60+countDistinct :: Sql DBEq a => Expr a -> Aggregate Int64
6461countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $
65− Just Aggregator
66− { operation = Opaleye.AggrCount
67− , ordering = []
68− , distinction = Opaleye.AggrDistinct
69− }
62+ Opaleye.distinctAggregator Opaleye.count
7063
7164
7265-- | Corresponds to @COUNT(*)@.
73−countStar :: Aggregate (Expr Int64)
66+countStar :: Aggregate Int64
7467countStar = count (litExpr True)
7568
7669
7770-- | A count of the number of times a given expression is @true@.
78−countWhere :: Expr Bool -> Aggregate (Expr Int64)
71+countWhere :: Expr Bool -> Aggregate Int64
7972countWhere condition = count (caseExpr [(condition, litExpr (Just True))] null)
8073
8174
8275-- | Corresponds to @bool_and@.
83−and :: Expr Bool -> Aggregate (Expr Bool)
84−and = unsafeMakeAggregate toPrimExpr fromPrimExpr $
85− Just Aggregator
86− { operation = Opaleye.AggrBoolAnd
87− , ordering = []
88− , distinction = Opaleye.AggrAll
89− }
76+and :: Expr Bool -> Aggregate Bool
77+and = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolAnd
9078
9179
9280-- | Corresponds to @bool_or@.
93−or :: Expr Bool -> Aggregate (Expr Bool)
94−or = unsafeMakeAggregate toPrimExpr fromPrimExpr $
95− Just Aggregator
96− { operation = Opaleye.AggrBoolOr
97− , ordering = []
98− , distinction = Opaleye.AggrAll
99− }
81+or :: Expr Bool -> Aggregate Bool
82+or = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolOr
10083
10184
10285-- | Produce an aggregation for @Expr a@ using the @max@ function.
103−max :: Sql DBMax a => Expr a -> Aggregate (Expr a)
104−max = unsafeMakeAggregate toPrimExpr fromPrimExpr $
105− Just Aggregator
106− { operation = Opaleye.AggrMax
107− , ordering = []
108− , distinction = Opaleye.AggrAll
109− }
86+max :: Sql DBMax a => Expr a -> Aggregate a
87+max = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMax
11088
11189
11290-- | Produce an aggregation for @Expr a@ using the @max@ function.
113−min :: Sql DBMin a => Expr a -> Aggregate (Expr a)
114−min = unsafeMakeAggregate toPrimExpr fromPrimExpr $
115− Just Aggregator
116− { operation = Opaleye.AggrMin
117− , ordering = []
118− , distinction = Opaleye.AggrAll
119− }
91+min :: Sql DBMin a => Expr a -> Aggregate a
92+min = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMin
12093
12194-- | Corresponds to @sum@. Note that in SQL, @sum@ is type changing - for
12295-- example the @sum@ of @integer@ returns a @bigint@. Rel8 doesn't support
123−-- this, and will add explicit cast back to the original input type. This can
96+-- this, and will add explicit casts back to the original input type. This can
12497-- lead to overflows, and if you anticipate very large sums, you should upcast
12598-- your input.
126−sum :: Sql DBSum a => Expr a -> Aggregate (Expr a)
127−sum = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $
128− Just Aggregator
129− { operation = Opaleye.AggrSum
130− , ordering = []
131− , distinction = Opaleye.AggrAll
132− }
99+sum :: Sql DBSum a => Expr a -> Aggregate a
100+sum = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) Opaleye.unsafeSum
101+
133102
103+-- | Corresponds to @avg@. Note that in SQL, @avg@ is type changing - for
104+-- example, the @avg@ of @integer@ returns a @numeric@. Rel8 doesn't support
105+-- this, and will add explicit casts back to the original input type. If you
106+-- need a fractional result on an integral column, you should cast your input
107+-- to 'Double' or 'Data.Scientific.Scientific' before calling 'avg'.
108+avg :: Sql DBSum a => Expr a -> Aggregate a
109+avg = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) Opaleye.unsafeAvg
134110
135111-- | Take the sum of all expressions that satisfy a predicate.
136112sumWhere :: (Sql DBNum a, Sql DBSum a)
137− => Expr Bool -> Expr a -> Aggregate (Expr a)
113+ => Expr Bool -> Expr a -> Aggregate a
138114sumWhere condition a = sum (caseExpr [(condition, a)] 0)
139115
140116
141117-- | Corresponds to @string_agg()@.
142118stringAgg :: Sql DBString a
143− => Expr db -> Expr a -> Aggregate (Expr a)
119+ => Expr db -> Expr a -> Aggregate a
144120stringAgg delimiter =
145− unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $
146− Just Aggregator
147− { operation = Opaleye.AggrStringAggr (toPrimExpr delimiter)
148− , ordering = []
149− , distinction = Opaleye.AggrAll
150− }
121+ unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) (Opaleye.stringAgg (Column (toPrimExpr delimiter)))
151122
152123
153124-- | Aggregate a value by grouping by it.
154−groupByExpr :: Sql DBEq a => Expr a -> Aggregate (Expr a)
155−groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Nothing
156−
157−
158−-- | Collect expressions values as an array.
159−array1DAggExpr :: NotArray a => Expr a -> Aggregate (Expr (Array1D a))
160−array1DAggExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr $ Just
161− Aggregator
162− { operation = Opaleye.AggrArr
163− , ordering = []
164− , distinction = Opaleye.AggrAll
165− }
125+groupByExpr :: Sql DBEq a => Expr a -> Aggregate a
126+groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.groupBy
166127
167128
168129-- | Collect expressions values as a list.
169−listAggExpr :: Expr a -> Aggregate (Expr [a])
170−listAggExpr = unsafeMakeAggregate toPrimExpr from $ Just
171− Aggregator
172− { operation = Opaleye.AggrArr
173− , ordering = []
174− , distinction = Opaleye.AggrAll
175− }
176− where
177− from = fromPrimExpr . fromPrimArray
130+listAggExpr :: Sql DBType a => Expr a -> Aggregate [a]
131+listAggExpr = slistAggExpr typeInformation
178132
179133
180134-- | Collect expressions values as a non-empty list.
181−nonEmptyAggExpr :: Expr a -> Aggregate (Expr (NonEmpty a))
182−nonEmptyAggExpr = unsafeMakeAggregate toPrimExpr from $ Just
183− Aggregator
184− { operation = Opaleye.AggrArr
185− , ordering = []
186− , distinction = Opaleye.AggrAll
187− }
188− where
189− from = fromPrimExpr . fromPrimArray
135+nonEmptyAggExpr :: Sql DBType a => Expr a -> Aggregate (NonEmpty a)
136+nonEmptyAggExpr = snonEmptyAggExpr typeInformation
190137
191138
192−listAggExprWithOrder :: Order o -> o -> Expr a -> Aggregate (Expr [a])
193−listAggExprWithOrder order o = unsafeMakeAggregate toPrimExpr from $ Just
194− Aggregator
195− { operation = Opaleye.AggrArr
196− , ordering = toOrderExprs order o
197− , distinction = Opaleye.AggrAll
198− }
139+slistAggExpr :: ()
140+ => TypeInformation (Unnullify a) -> Expr a -> Aggregate [a]
141+slistAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg
199142 where
200− from = fromPrimExpr . fromPrimArray
143+ to = encodeArrayElement info . toPrimExpr
201144
202145
203−nonEmptyAggExprWithOrder :: ()
204− => Order o -> o -> Expr a -> Aggregate (Expr (NonEmpty a))
205−nonEmptyAggExprWithOrder order o = unsafeMakeAggregate toPrimExpr from $ Just
206− Aggregator
207− { operation = Opaleye.AggrArr
208− , ordering = toOrderExprs order o
209− , distinction = Opaleye.AggrAll
210− }
146+snonEmptyAggExpr :: ()
147+ => TypeInformation (Unnullify a) -> Expr a -> Aggregate (NonEmpty a)
148+snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg
211149 where
212− from = fromPrimExpr . fromPrimArray
150+ to = encodeArrayElement info . toPrimExpr
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, zipPrimArraysWith )
28+import Rel8.Type.Array ( array )
2929import Rel8.Type.Information ( TypeInformation(..) )
30−import Rel8.Schema.Null ( Unnullify, Nullity, Sql )
30+import Rel8.Schema.Null ( Unnullify, Sql )
3131
3232
3333sappend :: Expr [a] -> Expr [a] -> Expr [a]
34−sappend = zipPrimExprsWith (zipPrimArraysWith (Opaleye.BinExpr (Opaleye.:||)))
34+sappend = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
3535
3636
3737sappend1 :: Expr (NonEmpty a) -> Expr (NonEmpty a) -> Expr (NonEmpty a)
38−sappend1 = zipPrimExprsWith (zipPrimArraysWith (Opaleye.BinExpr (Opaleye.:||)))
38+sappend1 = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
3939
4040
41−sempty :: Nullity a -> TypeInformation (Unnullify a) -> Expr [a]
42−sempty _ info = fromPrimExpr $ array info []
41+sempty :: TypeInformation (Unnullify a) -> Expr [a]
42+sempty info = fromPrimExpr $ array info []
4343
4444
4545slistOf :: TypeInformation (Unnullify a) -> [Expr a] -> Expr [a]
src/Rel8/Expr/Default.hsnew file+35
@@ -0,0 +1,35 @@
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+1−1
@@ -22,7 +22,7 @@ import Prelude
2222import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
2323
2424-- rel8
25−import {-# SOURCE #-} Rel8.Expr ( Expr )
25+import Rel8.Expr ( Expr )
2626import Rel8.Expr.Bool ( (&&.), (||.), false, or_, coalesce )
2727import Rel8.Expr.Null ( isNull, unsafeLiftOpNull )
2828import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr, zipPrimExprsWith )
src/Rel8/Expr/Num.hs+39−6
@@ -4,18 +4,24 @@
44{-# options_ghc -fno-warn-redundant-constraints #-}
55
66module Rel8.Expr.Num
7− ( fromIntegral, realToFrac, div, mod, ceiling, floor, round, truncate
7+ ( fromIntegral
8+ , realToFrac
9+ , div, mod, divMod
10+ , quot, rem, quotRem
11+ , ceiling, floor, round, truncate
812 )
913where
1014
1115-- base
12−import Prelude ()
16+import Prelude ( (+), (-), fst, negate, signum, snd )
1317
1418-- rel
1519import Rel8.Expr ( Expr( Expr ) )
20+import Rel8.Expr.Eq ( (==.) )
1621import Rel8.Expr.Function ( function )
1722import Rel8.Expr.Opaleye ( castExpr )
1823import Rel8.Schema.Null ( Homonullable, Sql )
24+import Rel8.Table.Bool ( bool )
1925import Rel8.Type.Num ( DBFractional, DBIntegral, DBNum )
2026
2127
@@ -42,14 +48,41 @@ ceiling :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)
4248ceiling = function "ceiling"
4349
4450
45−-- | Perform integral division. Corresponds to the @div()@ function.
51+-- | Emulates the behaviour of the Haskell function 'Prelude.div' in
52+-- PostgreSQL.
4653div :: Sql DBIntegral a => Expr a -> Expr a -> Expr a
47−div = function "div"
54+div n d = fst (divMod n d)
4855
4956
50−-- | Corresponds to the @mod()@ function.
57+-- | Emulates the behaviour of the Haskell function 'Prelude.mod' in
58+-- PostgreSQL.
5159mod :: Sql DBIntegral a => Expr a -> Expr a -> Expr a
52−mod = function "mod"
60+mod n d = snd (divMod n d)
61+
62+
63+-- | Simultaneous 'div' and 'mod'.
64+divMod :: Sql DBIntegral a => Expr a -> Expr a -> (Expr a, Expr a)
65+divMod n d = bool qr (q - 1, r + d) (signum r ==. negate (signum d))
66+ where
67+ qr@(q, r) = quotRem n d
68+
69+
70+-- | Perform integral division. Corresponds to the @div()@ function in
71+-- PostgreSQL, which behaves like Haskell's 'Prelude.quot' rather than
72+-- 'Prelude.div'.
73+quot :: Sql DBIntegral a => Expr a -> Expr a -> Expr a
74+quot = function "div"
75+
76+
77+-- | Corresponds to the @mod()@ function in PostgreSQL, which behaves like
78+-- Haskell's 'Prelude.rem' rather than 'Prelude.mod'.
79+rem :: Sql DBIntegral a => Expr a -> Expr a -> Expr a
80+rem = function "mod"
81+
82+
83+-- | Simultaneous 'quot' and 'rem'.
84+quotRem :: Sql DBIntegral a => Expr a -> Expr a -> (Expr a, Expr a)
85+quotRem n d = (quot n d, rem n d)
5386
5487
5588-- | Round a 'DFractional' to a 'DBIntegral' by rounding to the nearest smaller
src/Rel8/Expr/Opaleye.hs+19−5
@@ -10,7 +10,7 @@ module Rel8.Expr.Opaleye
1010 , scastExpr, sunsafeCastExpr
1111 , unsafeLiteral
1212 , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith, traversePrimExpr
13− , toColumn, fromColumn
13+ , toColumn, fromColumn, traverseFieldP
1414 )
1515where
1616
@@ -27,6 +27,9 @@ import Rel8.Schema.Null ( Unnullify, Sql )
2727import Rel8.Type ( DBType, typeInformation )
2828import Rel8.Type.Information ( TypeInformation(..) )
2929
30+-- profunctors
31+import Data.Profunctor ( Profunctor, dimap )
32+
3033
3134castExpr :: Sql DBType a => Expr a -> Expr a
3235castExpr = scastExpr typeInformation
@@ -48,8 +51,13 @@ sunsafeCastExpr TypeInformation {typeName} =
4851 fromPrimExpr . Opaleye.CastExpr typeName . toPrimExpr
4952
5053
51−unsafeLiteral :: Sql DBType a => String -> Expr a
52−unsafeLiteral = castExpr . Expr . Opaleye.ConstExpr . Opaleye.OtherLit
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
5361
5462
5563fromPrimExpr :: Opaleye.PrimExpr -> Expr a
@@ -75,9 +83,15 @@ traversePrimExpr :: Functor f
7583traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr
7684
7785
78−toColumn :: Opaleye.PrimExpr -> Opaleye.Column b
86+traverseFieldP :: Profunctor p
87+ => p (Opaleye.Field_ n x) (Opaleye.Field_ m y)
88+ -> p (Expr a) (Expr b)
89+traverseFieldP = dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn)
90+
91+
92+toColumn :: Opaleye.PrimExpr -> Opaleye.Field_ n b
7993toColumn = Opaleye.Column
8094
8195
82−fromColumn :: Opaleye.Column b -> Opaleye.PrimExpr
96+fromColumn :: Opaleye.Field_ n b -> Opaleye.PrimExpr
8397fromColumn (Opaleye.Column a) = a
src/Rel8/Expr/Sequence.hsnew file+22
@@ -0,0 +1,22 @@
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/Text.hs+24−4
@@ -17,6 +17,9 @@ module Rel8.Expr.Text
1717 , pgClientEncoding, quoteIdent, quoteLiteral, quoteNullable, regexpReplace
1818 , regexpSplitToArray, repeat, replace, reverse, right, rpad, rtrim
1919 , splitPart, strpos, substr, translate
20+
21+ -- * @LIKE@ and @ILIKE@
22+ , like, ilike
2023 )
2124where
2225
@@ -24,7 +27,7 @@ where
2427import Data.Bool ( Bool )
2528import Data.Int ( Int32 )
2629import Data.Maybe ( Maybe( Nothing, Just ) )
27−import Prelude ()
30+import Prelude ( flip )
2831
2932-- bytestring
3033import Data.ByteString ( ByteString )
@@ -32,7 +35,6 @@ import Data.ByteString ( ByteString )
3235-- rel8
3336import Rel8.Expr ( Expr )
3437import Rel8.Expr.Function ( binaryOperator, function, nullaryFunction )
35−import Rel8.Type.Array1D ( Array1D )
3638
3739-- text
3840import Data.Text (Text)
@@ -50,7 +52,7 @@ infixr 6 ++.
5052
5153
5254-- | Matches regular expression, case sensitive
53−--
55+--
5456-- Corresponds to the @~.@ operator.
5557(~.) :: Expr Text -> Expr Text -> Expr Bool
5658(~.) = binaryOperator "~."
@@ -218,7 +220,7 @@ regexpReplace a b c Nothing = function "regexp_replace" a b c
218220
219221-- | Corresponds to the @regexp_split_to_array@ function.
220222regexpSplitToArray :: ()
221− => Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr (Array1D Text)
223+ => Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr [Text]
222224regexpSplitToArray a b (Just c) = function "regexp_split_to_array" a b c
223225regexpSplitToArray a b Nothing = function "regexp_split_to_array" a b
224226
@@ -274,3 +276,21 @@ substr a b Nothing = function "substr" a b
274276-- | Corresponds to the @translate@ function.
275277translate :: Expr Text -> Expr Text -> Expr Text -> Expr Text
276278translate = 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 ( unsafeCastExpr, unsafeLiteral )
34+import Rel8.Expr.Opaleye ( castExpr, 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 = unsafeLiteral $ "'1 " ++ unit ++ "'"
167+singleton unit = castExpr $ unsafeLiteral $ "'1 " ++ unit ++ "'"
src/Rel8/Expr/Window.hsnew file+121
@@ -0,0 +1,121 @@
1+module Rel8.Expr.Window
2+ ( cumulative
3+ , rowNumber
4+ , rank
5+ , denseRank
6+ , percentRank
7+ , cumeDist
8+ , ntile
9+ , lag
10+ , lead
11+ , firstValue
12+ , lastValue
13+ , nthValue
14+ )
15+where
16+
17+-- base
18+import Data.Int ( Int32, Int64 )
19+import Prelude
20+
21+-- opaleye
22+import qualified Opaleye.Internal.Aggregate as Opaleye
23+import qualified Opaleye.Internal.PackMap as Opaleye
24+import qualified Opaleye.Internal.Window as Opaleye
25+import qualified Opaleye.Window as Opaleye
26+
27+-- profunctors
28+import Data.Profunctor (dimap)
29+
30+-- rel8
31+import Rel8.Aggregate ( Aggregate( Aggregate ) )
32+import Rel8.Expr ( Expr )
33+import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr, toColumn, toPrimExpr )
34+import Rel8.Schema.Null ( Nullify )
35+import Rel8.Window ( Window( Window ) )
36+
37+
38+cumulative :: (a -> Aggregate b) -> Window a (Expr b)
39+cumulative f =
40+ fromWindowFunction $ Opaleye.aggregatorWindowFunction (fromAggregate f) id
41+
42+
43+-- | [@row_number()@](https://www.postgresql.org/docs/current/functions-window.html)
44+rowNumber :: Window a (Expr Int64)
45+rowNumber = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.rowNumber
46+
47+
48+-- | [@rank()@](https://www.postgresql.org/docs/current/functions-window.html)
49+rank :: Window a (Expr Int64)
50+rank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.rank
51+
52+
53+-- | [@dense_rank()@](https://www.postgresql.org/docs/current/functions-window.html)
54+denseRank :: Window a (Expr Int64)
55+denseRank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.denseRank
56+
57+
58+-- | [@percent_rank()@](https://www.postgresql.org/docs/current/functions-window.html)
59+percentRank :: Window a (Expr Double)
60+percentRank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.percentRank
61+
62+
63+-- | [@cume_dist()@](https://www.postgresql.org/docs/current/functions-window.html)
64+cumeDist :: Window a (Expr Double)
65+cumeDist = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.cumeDist
66+
67+
68+-- | [@ntile(num_buckets)@](https://www.postgresql.org/docs/current/functions-window.html)
69+ntile :: Expr Int32 -> Window a (Expr Int32)
70+ntile buckets = fromWindowFunction $ fromPrimExpr . fromColumn <$>
71+ Opaleye.ntile (toColumn (toPrimExpr buckets))
72+
73+
74+-- | [@lag(value, offset, default)@](https://www.postgresql.org/docs/current/functions-window.html)
75+lag :: Expr Int32 -> Expr a -> Window (Expr a) (Expr a)
76+lag offset def =
77+ fromWindowFunction $
78+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $
79+ Opaleye.lag (toColumn (toPrimExpr offset)) (toColumn (toPrimExpr def))
80+
81+
82+-- | [@lead(value, offset, default)@](https://www.postgresql.org/docs/current/functions-window.html)
83+lead :: Expr Int32 -> Expr a -> Window (Expr a) (Expr a)
84+lead offset def =
85+ fromWindowFunction $
86+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $
87+ Opaleye.lead (toColumn (toPrimExpr offset)) (toColumn (toPrimExpr def))
88+
89+
90+-- | [@first_value(value)@](https://www.postgresql.org/docs/current/functions-window.html)
91+firstValue :: Window (Expr a) (Expr a)
92+firstValue =
93+ fromWindowFunction $
94+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn)
95+ Opaleye.firstValue
96+
97+
98+-- | [@last_value(value)@](https://www.postgresql.org/docs/current/functions-window.html)
99+lastValue :: Window (Expr a) (Expr a)
100+lastValue =
101+ fromWindowFunction $
102+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn)
103+ Opaleye.lastValue
104+
105+
106+-- | [@nth_value(value, n)@](https://www.postgresql.org/docs/current/functions-window.html)
107+nthValue :: Expr Int32 -> Window (Expr a) (Expr (Nullify a))
108+nthValue n =
109+ fromWindowFunction $
110+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $
111+ Opaleye.nthValue (toColumn (toPrimExpr n))
112+
113+
114+fromAggregate :: (a -> Aggregate b) -> Opaleye.Aggregator a (Expr b)
115+fromAggregate f = Opaleye.Aggregator $ Opaleye.PackMap $ \w a -> case f a of
116+ Aggregate (Opaleye.Aggregator (Opaleye.PackMap x)) -> x w ()
117+
118+
119+fromWindowFunction :: Opaleye.WindowFunction a b -> Window a b
120+fromWindowFunction (Opaleye.WindowFunction (Opaleye.PackMap w)) =
121+ Window $ Opaleye.Windows $ Opaleye.PackMap $ \f -> w $ \o -> f (o, mempty)
src/Rel8/FCF.hs+3−3
@@ -5,7 +5,7 @@
55
66module Rel8.FCF
77 ( Exp, Eval
8− , Compose
8+ , Id
99 )
1010where
1111
@@ -22,5 +22,5 @@ type Eval :: Exp e -> e
2222type family Eval a
2323
2424
25−data Compose :: (Type -> Type) -> (Type -> Exp Type) -> Type -> Exp Type
26−type instance Eval (Compose f g a) = f (Eval (g a))
25+data Id :: a -> Exp a
26+type instance Eval (Id a) = a
src/Rel8/Generic/Construction.hs+199−300
@@ -2,9 +2,6 @@
22{-# language ConstraintKinds #-}
33{-# language DataKinds #-}
44{-# language FlexibleContexts #-}
5−{-# language FlexibleInstances #-}
6−{-# language LambdaCase #-}
7−{-# language MultiParamTypeClasses #-}
85{-# language NamedFieldPuns #-}
96{-# language ScopedTypeVariables #-}
107{-# language StandaloneKindSignatures #-}
@@ -14,13 +11,13 @@
1411{-# language ViewPatterns #-}
1512
1613module Rel8.Generic.Construction
17− ( GGConstructable
14+ ( GGBuildable
15+ , GGBuild, ggbuild
16+ , GGConstructable
1817 , GGConstruct, ggconstruct
1918 , GGDeconstruct, ggdeconstruct
20− , GGInsert, gginsert
2119 , GGName, ggname
2220 , GGAggregate, ggaggregate
23− , GGAggregate', ggaggregate'
2421 )
2522where
2623
@@ -28,27 +25,29 @@ where
2825import Data.Bifunctor ( first )
2926import Data.Kind ( Constraint, Type )
3027import Data.List.NonEmpty ( NonEmpty( (:|) ) )
31−import Data.Type.Equality ( (:~:)( Refl ) )
28+import GHC.TypeLits ( Symbol )
3229import Prelude
3330
3431-- rel8
35−import Rel8.Aggregate ( Col( Aggregation ), Aggregate )
36−import Rel8.Expr ( Col( DB ), Expr )
32+import Rel8.Aggregate ( Aggregate( Aggregate ) )
33+import Rel8.Expr ( Expr )
3734import Rel8.Expr.Aggregate ( groupByExpr )
3835import Rel8.Expr.Eq ( (==.) )
3936import Rel8.Expr.Null ( nullify, snull, unsafeUnnullify )
4037import Rel8.Expr.Serialize ( litExpr )
41−import Rel8.FCF ( Compose, Eval, Exp )
38+import Rel8.FCF ( Eval, Exp, Id )
4239import Rel8.Generic.Construction.ADT
43− ( GConstructableADT
40+ ( GConstructorADT, GMakeableADT, gmakeADT
41+ , GConstructableADT
4442 , GBuildADT, gbuildADT, gunbuildADT
4543 , GConstructADT, gconstructADT, gdeconstructADT
46− , CorepConstructors, GConstructors, gcindex, gctabulate
47− , CorepFields, gfindex, gftabulate, gftraverse
44+ , RepresentableConstructors, GConstructors, gcindex, gctabulate
45+ , RepresentableFields, gfindex, gftabulate
4846 )
4947import Rel8.Generic.Construction.Record
50− ( GConstructable, GConstruct, gconstruct, gdeconstruct
51− , Corep, gindex, gtabulate, gtraverse
48+ ( GConstructor
49+ , GConstructable, GConstruct, gconstruct, gdeconstruct
50+ , Representable, gindex, gtabulate
5251 )
5352import Rel8.Generic.Table ( GGColumns )
5453import Rel8.Kind.Algebra
@@ -56,36 +55,92 @@ import Rel8.Kind.Algebra
5655 , KnownAlgebra, algebraSing
5756 )
5857import qualified Rel8.Kind.Algebra as K
59−import Rel8.Kind.Necessity ( SNecessity( SOptional, SRequired ) )
60−import Rel8.Schema.Context.Nullify ( runTag )
58+import Rel8.Schema.Context.Nullify ( sguard, snullify )
6159import Rel8.Schema.HTable ( HTable )
62−import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )
63−import Rel8.Schema.Insert ( Col( OptionalInsert, RequiredInsert ), Insert )
60+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
6461import qualified Rel8.Schema.Kind as K
65−import Rel8.Schema.Name ( Col( NameCol ), Name( Name ) )
62+import Rel8.Schema.Name ( Name( Name ) )
6663import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
67−import Rel8.Schema.Spec ( SSpec( SSpec, necessity, nullity, info ) )
68−import Rel8.Schema.Reify ( Col( Reify ), Reify, hreify, hunreify )
69−import Rel8.Schema.Result ( Result )
64+import Rel8.Schema.Spec ( Spec( Spec, nullity, info ) )
7065import Rel8.Table
71− ( TTable, TColumns, TUnreify
72− , Table, fromColumns, toColumns, reify, unreify
66+ ( TTable, TColumns
67+ , Table, fromColumns, toColumns
7368 )
7469import Rel8.Table.Bool ( case_ )
7570import Rel8.Type.Tag ( Tag )
7671
77−-- semigroupoids
78−import Data.Functor.Apply ( Apply, MaybeApply( MaybeApply ), liftF2 )
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)
79135
80136
81137type GGConstructable :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint
82138type GGConstructable algebra rep =
83139 ( KnownAlgebra algebra
84− , Eval (GGColumns algebra TColumns (Eval (rep (Reify Aggregate)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))
85− , Eval (GGColumns algebra TColumns (Eval (rep (Reify Expr)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))
86− , Eval (GGColumns algebra TColumns (Eval (rep (Reify Insert)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))
87− , Eval (GGColumns algebra TColumns (Eval (rep (Reify Name)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))
88− , HTable (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))))
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))))
89144 , GGConstructable' algebra rep
90145 )
91146
@@ -93,112 +148,100 @@ type GGConstructable algebra rep =
93148type GGConstructable' :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint
94149type family GGConstructable' algebra rep where
95150 GGConstructable' 'K.Product rep =
96− ( Corep (Compose Aggregate TUnreify) (Eval (rep (Reify Expr)))
97− , Corep TUnreify (Eval (rep (Reify Aggregate)))
98− , Corep TUnreify (Eval (rep (Reify Expr)))
99− , Corep TUnreify (Eval (rep (Reify Insert)))
100− , Corep TUnreify (Eval (rep (Reify Name)))
101− , GConstructable (TTable (Reify Aggregate)) TColumns TUnreify (Col (Reify Aggregate)) (Eval (rep (Reify Aggregate)))
102− , GConstructable (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) (Eval (rep (Reify Expr)))
103− , GConstructable (TTable (Reify Insert)) TColumns TUnreify (Col (Reify Insert)) (Eval (rep (Reify Insert)))
104− , GConstructable (TTable (Reify Name)) TColumns TUnreify (Col (Reify Name)) (Eval (rep (Reify Name)))
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))
105157 )
106158 GGConstructable' 'K.Sum rep =
107− ( CorepConstructors TUnreify (Eval (rep (Reify Expr)))
108− , CorepConstructors TUnreify (Eval (rep (Reify Insert)))
109− , CorepFields (Compose Aggregate TUnreify) (Eval (rep (Reify Expr)))
110− , CorepFields TUnreify (Eval (rep (Reify Aggregate)))
111− , CorepFields TUnreify (Eval (rep (Reify Expr)))
112− , CorepFields TUnreify (Eval (rep (Reify Name)))
113− , Functor (GConstructors TUnreify (Eval (rep (Reify Expr))))
114− , Functor (GConstructors TUnreify (Eval (rep (Reify Insert))))
115− , GConstructableADT (TTable (Reify Aggregate)) TColumns TUnreify (Col (Reify Aggregate)) (Eval (rep (Reify Aggregate)))
116− , GConstructableADT (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) (Eval (rep (Reify Expr)))
117− , GConstructableADT (TTable (Reify Insert)) TColumns TUnreify (Col (Reify Insert)) (Eval (rep (Reify Insert)))
118− , GConstructableADT (TTable (Reify Name)) TColumns TUnreify (Col (Reify Name)) (Eval (rep (Reify Name)))
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))
119167 )
120168
121169
122170type GGConstruct :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type
123−type family GGConstruct algebra rep a where
124− GGConstruct 'K.Product rep a = GConstruct TUnreify (Eval (rep (Reify Expr))) a
125− GGConstruct 'K.Sum rep a =
126− -- Ideally this would be as follows, but GHC complains about "illegal polymorphic type"
127− -- (forall r. GConstructADT TUnreify (Eval (rep (Reify Expr))) r r) -> a
128− GConstructADT TUnreify (Eval (rep (Reify Expr))) a a -> a
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
129174
130175
131176ggconstruct :: forall algebra rep a. GGConstructable algebra rep
132− => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr) -> a)
133− -> GGConstruct algebra rep a
134−ggconstruct gfromColumns = case algebraSing @algebra of
177+ => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a)
178+ -> GGConstruct algebra rep a -> a
179+ggconstruct gfromColumns f = case algebraSing @algebra of
135180 SProduct ->
136− gtabulate @TUnreify @(Eval (rep (Reify Expr))) @a $
181+ f $
182+ gtabulate @Id @(Eval (rep Expr)) @a $
137183 gfromColumns .
138− hunreify .
139184 gconstruct
140− @(TTable (Reify Expr))
185+ @(TTable Expr)
141186 @TColumns
142− @TUnreify
143− @(Col (Reify Expr))
144− @(Eval (rep (Reify Expr)))
145− (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
146− SSum -> \f ->
147− gcindex @TUnreify @(Eval (rep (Reify Expr))) @a f $
148− fmap (gfromColumns . hunreify) $
187+ @Id
188+ @Expr
189+ @(Eval (rep Expr))
190+ (const toColumns)
191+ SSum ->
192+ gcindex @Id @(Eval (rep Expr)) @a f $
193+ fmap gfromColumns $
149194 gconstructADT
150− @(TTable (Reify Expr))
195+ @(TTable Expr)
151196 @TColumns
152− @TUnreify
153− @(Col (Reify Expr))
154− @(Eval (rep (Reify Expr)))
155− (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
156− (\SSpec {info} -> Reify (DB (snull info)))
157− (\SSpec {nullity} -> case nullity of
197+ @Id
198+ @Expr
199+ @(Eval (rep Expr))
200+ (const toColumns)
201+ (\Spec {info} -> snull info)
202+ (\Spec {nullity} -> case nullity of
158203 Null -> id
159− NotNull -> \(Reify (DB a)) -> Reify (DB (nullify a)))
160− (HType . Reify . DB . litExpr)
204+ NotNull -> nullify)
205+ (HIdentity . litExpr)
161206
162207
163208type GGDeconstruct :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type -> Type
164209type family GGDeconstruct algebra rep a r where
165210 GGDeconstruct 'K.Product rep a r =
166− GConstruct TUnreify (Eval (rep (Reify Expr))) r -> a -> r
211+ GConstruct Id (Eval (rep Expr)) r -> a -> r
167212 GGDeconstruct 'K.Sum rep a r =
168− GConstructADT TUnreify (Eval (rep (Reify Expr))) r (a -> r)
213+ GConstructADT Id (Eval (rep Expr)) r (a -> r)
169214
170215
171216ggdeconstruct :: forall algebra rep a r. (GGConstructable algebra rep, Table Expr r)
172− => (a -> Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr))
217+ => (a -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)
173218 -> GGDeconstruct algebra rep a r
174219ggdeconstruct gtoColumns = case algebraSing @algebra of
175220 SProduct -> \build ->
176− gindex @TUnreify @(Eval (rep (Reify Expr))) @r build .
221+ gindex @Id @(Eval (rep Expr)) @r build .
177222 gdeconstruct
178− @(TTable (Reify Expr))
223+ @(TTable Expr)
179224 @TColumns
180− @TUnreify
181− @(Col (Reify Expr))
182− @(Eval (rep (Reify Expr)))
183− (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns) .
184− hreify .
225+ @Id
226+ @Expr
227+ @(Eval (rep Expr))
228+ (const fromColumns) .
185229 gtoColumns
186230 SSum ->
187− gctabulate @TUnreify @(Eval (rep (Reify Expr))) @r @(a -> r) $ \constructors as ->
231+ gctabulate @Id @(Eval (rep Expr)) @r @(a -> r) $ \constructors as ->
188232 let
189− (HType (Reify (DB tag)), cases) =
233+ (HIdentity tag, cases) =
190234 gdeconstructADT
191− @(TTable (Reify Expr))
235+ @(TTable Expr)
192236 @TColumns
193− @TUnreify
194− @(Col (Reify Expr))
195− @(Eval (rep (Reify Expr)))
196− (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns)
197− (\SSpec {nullity} -> case nullity of
237+ @Id
238+ @Expr
239+ @(Eval (rep Expr))
240+ (const fromColumns)
241+ (\Spec {nullity} -> case nullity of
198242 Null -> id
199− NotNull -> \(Reify (DB a)) -> Reify (DB (unsafeUnnullify a)))
243+ NotNull -> unsafeUnnullify)
200244 constructors $
201− hreify $
202245 gtoColumns as
203246 in
204247 case cases of
@@ -206,248 +249,104 @@ ggdeconstruct gtoColumns = case algebraSing @algebra of
206249 case_ cases' r
207250
208251
209−type GGInsert :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type
210−type family GGInsert algebra rep a where
211− GGInsert 'K.Product rep a = GConstruct TUnreify (Eval (rep (Reify Insert))) a
212− GGInsert 'K.Sum rep a =
213− -- Ideally this would be as follows, but GHC complains about "illegal polymorphic type"
214− -- (forall r. GConstructADT TUnreify (Eval (rep (Reify Insert))) r r) -> a
215− GConstructADT TUnreify (Eval (rep (Reify Insert))) a a -> a
216−
217−
218−gginsert :: forall algebra rep a. GGConstructable algebra rep
219− => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Insert) -> a)
220− -> GGInsert algebra rep a
221−gginsert gfromColumns = case algebraSing @algebra of
222− SProduct ->
223− gtabulate @TUnreify @(Eval (rep (Reify Insert))) @a $
224− gfromColumns .
225− hunreify .
226− gconstruct
227− @(TTable (Reify Insert))
228− @TColumns
229− @TUnreify
230− @(Col (Reify Insert))
231− @(Eval (rep (Reify Insert)))
232− (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
233− SSum -> \f ->
234− gcindex @TUnreify @(Eval (rep (Reify Insert))) @a f $
235− fmap (gfromColumns . hunreify) $
236− gconstructADT
237− @(TTable (Reify Insert))
238− @TColumns
239− @TUnreify
240− @(Col (Reify Insert))
241− @(Eval (rep (Reify Insert)))
242− (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
243− (\SSpec {necessity, info} -> Reify $ case necessity of
244− SRequired -> RequiredInsert (snull info)
245− SOptional -> OptionalInsert (Just (snull info)))
246− (\SSpec {nullity} -> case nullity of
247− Null -> id
248− NotNull -> \case
249− Reify (RequiredInsert a) -> Reify (RequiredInsert (nullify a))
250− Reify (OptionalInsert a) -> Reify (OptionalInsert (nullify <$> a)))
251− (HType . Reify . RequiredInsert . litExpr)
252−
253−
254252type GGName :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type
255253type family GGName algebra rep a where
256− GGName 'K.Product rep a = GConstruct TUnreify (Eval (rep (Reify Name))) a
257− GGName 'K.Sum rep a = Name Tag -> GBuildADT TUnreify (Eval (rep (Reify Name))) a
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
258256
259257
260258ggname :: forall algebra rep a. GGConstructable algebra rep
261− => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Name) -> a)
259+ => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Name -> a)
262260 -> GGName algebra rep a
263261ggname gfromColumns = case algebraSing @algebra of
264262 SProduct ->
265− gtabulate @TUnreify @(Eval (rep (Reify Name))) @a $
263+ gtabulate @Id @(Eval (rep Name)) @a $
266264 gfromColumns .
267− hunreify .
268265 gconstruct
269− @(TTable (Reify Name))
266+ @(TTable Name)
270267 @TColumns
271− @TUnreify
272− @(Col (Reify Name))
273− @(Eval (rep (Reify Name)))
274− (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
268+ @Id
269+ @Name
270+ @(Eval (rep Name))
271+ (const toColumns)
275272 SSum -> \tag ->
276− gftabulate @TUnreify @(Eval (rep (Reify Name))) @a $
273+ gftabulate @Id @(Eval (rep Name)) @a $
277274 gfromColumns .
278− hunreify .
279275 gbuildADT
280− @(TTable (Reify Name))
276+ @(TTable Name)
281277 @TColumns
282− @TUnreify
283− @(Col (Reify Name))
284− @(Eval (rep (Reify Name)))
285− (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
286− (\_ _ (Reify (NameCol a)) -> Reify (NameCol a))
287− (HType ((\(Name a) -> Reify (NameCol a)) tag))
278+ @Id
279+ @Name
280+ @(Eval (rep Name))
281+ (const toColumns)
282+ (\_ _ (Name a) -> Name a)
283+ (HIdentity tag)
288284
289285
290286type GGAggregate :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type
291287type family GGAggregate algebra rep r where
292288 GGAggregate 'K.Product rep r =
293− GConstruct (Compose Aggregate TUnreify) (Eval (rep (Reify Expr))) r ->
294− GConstruct TUnreify (Eval (rep (Reify Expr))) r
289+ GConstruct Id (Eval (rep Aggregate)) r ->
290+ GConstruct Id (Eval (rep Expr)) r
295291 GGAggregate 'K.Sum rep r =
296− GBuildADT (Compose Aggregate TUnreify) (Eval (rep (Reify Expr))) r ->
297− GBuildADT TUnreify (Eval (rep (Reify Expr))) r
292+ GBuildADT Id (Eval (rep Aggregate)) r ->
293+ GBuildADT Id (Eval (rep Expr)) r
298294
299295
300−ggaggregate :: forall algebra rep a. GGConstructable algebra rep
301− => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr) -> a)
302− -> (a -> Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr))
303− -> GGAggregate algebra rep (Aggregate a) -> a -> Aggregate a
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
304300ggaggregate gfromColumns gtoColumns agg es = case algebraSing @algebra of
305− SProduct -> flip f exprs $
306− fmap
307− ( gfromColumns
308− . hunreify
309− . gconstruct
310− @(TTable (Reify Expr))
311− @TColumns
312− @TUnreify
313− @(Col (Reify Expr))
314− @(Eval (rep (Reify Expr)))
315− (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
316− ) .
317− liftF½ .
318− gtraverse @TUnreify @(Eval (rep (Reify Expr))) @_ @Aggregate (MaybeApply . Left)
319− where
320− f =
321− gindex @TUnreify @(Eval (rep (Reify Expr))) @(Aggregate a) .
322− agg .
323− gtabulate @(Compose Aggregate TUnreify) @(Eval (rep (Reify Expr))) @(Aggregate a)
324− exprs =
325− gdeconstruct
326− @(TTable (Reify Expr))
327− @TColumns
328− @TUnreify
329− @(Col (Reify Expr))
330− @(Eval (rep (Reify Expr)))
331− (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns) $
332− hreify $
333− gtoColumns es
334− SSum -> flip f exprs $
335− liftF1½
336− (\tag' ->
337− gfromColumns .
338− hunreify .
339− gbuildADT
340− @(TTable (Reify Expr))
341− @TColumns
342− @TUnreify
343− @(Col (Reify Expr))
344− @(Eval (rep (Reify Expr)))
345− (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
346− (\tag'' SSpec {nullity} (Reify (DB a)) ->
347− Reify $ DB $ runTag nullity (tag ==. litExpr tag'') a)
348− (HType (Reify (DB tag'))))
349− (groupByExpr tag) .
350− gftraverse @TUnreify @(Eval (rep (Reify Expr))) @_ @Aggregate (MaybeApply . Left)
351− where
352− f =
353− gfindex @TUnreify @(Eval (rep (Reify Expr))) @(Aggregate a) .
354− agg .
355− gftabulate @(Compose Aggregate TUnreify) @(Eval (rep (Reify Expr))) @(Aggregate a)
356− (HType (Reify (DB tag)), exprs) =
357− gunbuildADT
358− @(TTable (Reify Expr))
359− @TColumns
360− @TUnreify
361− @(Col (Reify Expr))
362− @(Eval (rep (Reify Expr)))
363− (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns)
364− (\SSpec {nullity} -> case nullity of
365− Null -> id
366− NotNull -> \(Reify (DB a)) -> Reify (DB (unsafeUnnullify a))) $
367− hreify $
368− gtoColumns es
369−
370−
371−type GGAggregate' :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type
372−type family GGAggregate' algebra rep r where
373− GGAggregate' 'K.Product rep r =
374− GConstruct TUnreify (Eval (rep (Reify Aggregate))) r ->
375− GConstruct TUnreify (Eval (rep (Reify Expr))) r
376− GGAggregate' 'K.Sum rep r =
377− GBuildADT TUnreify (Eval (rep (Reify Aggregate))) r ->
378− GBuildADT TUnreify (Eval (rep (Reify Expr))) r
379−
380−
381−ggaggregate' :: forall algebra rep exprs agg. GGConstructable algebra rep
382− => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Aggregate) -> agg)
383− -> (exprs -> Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr))
384− -> GGAggregate' algebra rep agg -> exprs -> agg
385−ggaggregate' gfromColumns gtoColumns agg es = case algebraSing @algebra of
386301 SProduct -> flip f exprs $
387302 gfromColumns .
388− hunreify .
389303 gconstruct
390− @(TTable (Reify Aggregate))
304+ @(TTable Aggregate)
391305 @TColumns
392− @TUnreify
393− @(Col (Reify Aggregate))
394− @(Eval (rep (Reify Aggregate)))
395− (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
306+ @Id
307+ @Aggregate
308+ @(Eval (rep Aggregate))
309+ (const toColumns)
396310 where
397311 f =
398− gindex @TUnreify @(Eval (rep (Reify Expr))) @agg .
312+ gindex @Id @(Eval (rep Expr)) @agg .
399313 agg .
400− gtabulate @TUnreify @(Eval (rep (Reify Aggregate))) @agg
314+ gtabulate @Id @(Eval (rep Aggregate)) @agg
401315 exprs =
402316 gdeconstruct
403− @(TTable (Reify Expr))
317+ @(TTable Expr)
404318 @TColumns
405− @TUnreify
406− @(Col (Reify Expr))
407− @(Eval (rep (Reify Expr)))
408− (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns) $
409− hreify $
319+ @Id
320+ @Expr
321+ @(Eval (rep Expr))
322+ (const fromColumns) $
410323 gtoColumns es
411324 SSum -> flip f exprs $
412325 gfromColumns .
413− hunreify .
414326 gbuildADT
415− @(TTable (Reify Aggregate))
327+ @(TTable Aggregate)
416328 @TColumns
417− @TUnreify
418− @(Col (Reify Aggregate))
419− @(Eval (rep (Reify Aggregate)))
420− (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
421− (\tag' SSpec {nullity} (Reify (Aggregation a)) ->
422− Reify $ Aggregation $ runTag nullity (tag ==. litExpr tag') <$> a)
423− (HType (Reify (Aggregation (groupByExpr tag))))
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))
424336 where
425337 f =
426− gfindex @TUnreify @(Eval (rep (Reify Expr))) @agg .
338+ gfindex @Id @(Eval (rep Expr)) @agg .
427339 agg .
428− gftabulate @TUnreify @(Eval (rep (Reify Aggregate))) @agg
429− (HType (Reify (DB tag)), exprs) =
340+ gftabulate @Id @(Eval (rep Aggregate)) @agg
341+ (HIdentity tag, exprs) =
430342 gunbuildADT
431− @(TTable (Reify Expr))
343+ @(TTable Expr)
432344 @TColumns
433− @TUnreify
434− @(Col (Reify Expr))
435− @(Eval (rep (Reify Expr)))
436− (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns)
437− (\SSpec {nullity} -> case nullity of
345+ @Id
346+ @Expr
347+ @(Eval (rep Expr))
348+ (const fromColumns)
349+ (\Spec {nullity} -> case nullity of
438350 Null -> id
439− NotNull -> \(Reify (DB a)) -> Reify (DB (unsafeUnnullify a))) $
440− hreify $
351+ NotNull -> unsafeUnnullify) $
441352 gtoColumns es
442−
443−
444−liftF½ :: MaybeApply Aggregate a -> Aggregate a
445−liftF½ (MaybeApply ma) = case ma of
446− Left a -> a
447− Right a -> a <$ groupByExpr (litExpr False)
448−
449−
450−liftF1½ :: Apply v => (a -> b -> c) -> v a -> MaybeApply v b -> v c
451−liftF1½ f a (MaybeApply eb) = case eb of
452− Left b -> liftF2 f a b
453− Right b -> fmap (`f` b) a
src/Rel8/Generic/Construction/ADT.hs+178−59
@@ -1,6 +1,7 @@
11{-# language AllowAmbiguousTypes #-}
22{-# language BlockArguments #-}
33{-# language DataKinds #-}
4+{-# language FlexibleContexts #-}
45{-# language FlexibleInstances #-}
56{-# language MultiParamTypeClasses #-}
67{-# language RankNTypes #-}
@@ -16,13 +17,13 @@ module Rel8.Generic.Construction.ADT
1617 ( GConstructableADT
1718 , GBuildADT, gbuildADT, gunbuildADT
1819 , GConstructADT, gconstructADT, gdeconstructADT
19− , GFields, CorepFields, gftabulate, gfindex, gftraverse
20− , GConstructors, CorepConstructors, gctabulate, gcindex
20+ , GFields, RepresentableFields, gftabulate, gfindex
21+ , GConstructors, RepresentableConstructors, gctabulate, gcindex
22+ , GConstructorADT, GMakeableADT, gmakeADT
2123 )
2224where
2325
2426-- base
25−import Control.Applicative ( liftA2 )
2627import Data.Bifunctor ( first )
2728import Data.Functor.Identity ( runIdentity )
2829import Data.Kind ( Constraint, Type )
@@ -31,28 +32,30 @@ import Data.Proxy ( Proxy( Proxy ) )
3132import GHC.Generics
3233 ( (:+:), (:*:)( (:*:) ), M1, U1
3334 , C, D
34− , Meta( MetaCons )
35+ , Meta( MetaData, MetaCons )
36+ )
37+import GHC.TypeLits
38+ ( ErrorMessage( (:<>:), Text ), TypeError
39+ , Symbol, KnownSymbol, symbolVal
3540 )
36−import GHC.TypeLits ( KnownSymbol, symbolVal )
3741import Prelude hiding ( null )
3842
3943-- rel8
40−import Rel8.FCF ( Compose, Exp )
44+import Rel8.FCF ( Exp )
4145import Rel8.Generic.Construction.Record
4246 ( GConstruct, GConstructable, gconstruct, gdeconstruct
43− , GFields, Corep, gtabulate, gindex, gtraverse
47+ , GFields, Representable, gtabulate, gindex
4448 , FromColumns, ToColumns
4549 )
4650import Rel8.Generic.Table.ADT ( GColumnsADT, GColumnsADT' )
4751import Rel8.Generic.Table.Record ( GColumns )
48−import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )
4952import Rel8.Schema.HTable ( HTable )
50−import Rel8.Schema.HTable.Identity ( HType )
53+import Rel8.Schema.HTable.Identity ( HIdentity )
5154import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
5255import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify )
5356import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
5457import Rel8.Schema.Null ( Nullify )
55−import Rel8.Schema.Spec ( Spec( Spec ), SSpec )
58+import Rel8.Schema.Spec ( Spec )
5659import qualified Rel8.Schema.Kind as K
5760import Rel8.Type.Tag ( Tag( Tag ) )
5861
@@ -60,24 +63,42 @@ import Rel8.Type.Tag ( Tag( Tag ) )
6063import Data.Text ( pack )
6164
6265
63−type Null :: K.HContext -> Type
64−type Null context = forall labels necessity a. ()
65− => SSpec ('Spec labels necessity a)
66− -> context ('Spec labels necessity (Nullify a))
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+ )
6786
6887
69−type Nullifier :: K.HContext -> Type
70−type Nullifier context = forall labels necessity a. ()
71− => SSpec ('Spec labels necessity a)
72− -> context ('Spec labels necessity a)
73− -> context ('Spec labels necessity (Nullify a))
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))
7492
7593
76−type Unnullifier :: K.HContext -> Type
77−type Unnullifier context = forall labels necessity a. ()
78− => SSpec ('Spec labels necessity a)
79− -> context ('Spec labels necessity (Nullify a))
80− -> context ('Spec labels necessity a)
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
81102
82103
83104type GConstructADT
@@ -96,26 +117,26 @@ type family GConstructors f rep where
96117 GConstructors f (M1 C _ rep) = (->) (GFields f rep)
97118
98119
99−type CorepConstructors :: (Type -> Exp Type) -> (Type -> Type) -> Constraint
100−class CorepConstructors f rep where
120+type RepresentableConstructors :: (Type -> Exp Type) -> (Type -> Type) -> Constraint
121+class RepresentableConstructors f rep where
101122 gctabulate :: (GConstructors f rep r -> a) -> GConstructADT f rep r a
102123 gcindex :: GConstructADT f rep r a -> GConstructors f rep r -> a
103124
104125
105−instance CorepConstructors f rep => CorepConstructors f (M1 D meta rep) where
126+instance RepresentableConstructors f rep => RepresentableConstructors f (M1 D meta rep) where
106127 gctabulate = gctabulate @f @rep
107128 gcindex = gcindex @f @rep
108129
109130
110−instance (CorepConstructors f a, CorepConstructors f b) =>
111− CorepConstructors f (a :+: b)
131+instance (RepresentableConstructors f a, RepresentableConstructors f b) =>
132+ RepresentableConstructors f (a :+: b)
112133 where
113134 gctabulate f =
114135 gctabulate @f @a \a -> gctabulate @f @b \b -> f (a :*: b)
115136 gcindex f (a :*: b) = gcindex @f @b (gcindex @f @a f a) b
116137
117138
118−instance Corep f rep => CorepConstructors f (M1 C meta rep) where
139+instance Representable f rep => RepresentableConstructors f (M1 C meta rep) where
119140 gctabulate f = f . gindex @f @rep
120141 gcindex f = f . gtabulate @f @rep
121142
@@ -134,44 +155,38 @@ type family GFieldsADT f rep where
134155 GFieldsADT f (M1 C _ rep) = GFields f rep
135156
136157
137−type CorepFields :: (Type -> Exp Type) -> (Type -> Type) -> Constraint
138−class CorepFields f rep where
158+type RepresentableFields :: (Type -> Exp Type) -> (Type -> Type) -> Constraint
159+class RepresentableFields f rep where
139160 gftabulate :: (GFieldsADT f rep -> a) -> GBuildADT f rep a
140161 gfindex :: GBuildADT f rep a -> GFieldsADT f rep -> a
141− gftraverse :: Applicative m
142− => (forall a. g a -> m a)
143− -> GFieldsADT (Compose g f) rep -> m (GFieldsADT f rep)
144162
145163
146−instance CorepFields f rep => CorepFields f (M1 D meta rep) where
164+instance RepresentableFields f rep => RepresentableFields f (M1 D meta rep) where
147165 gftabulate = gftabulate @f @rep
148166 gfindex = gfindex @f @rep
149− gftraverse = gftraverse @f @rep
150167
151168
152−instance (CorepFields f a, CorepFields f b) => CorepFields f (a :+: b) where
169+instance (RepresentableFields f a, RepresentableFields f b) => RepresentableFields f (a :+: b) where
153170 gftabulate f =
154171 gftabulate @f @a \a -> gftabulate @f @b \b -> f (a, b)
155172 gfindex f (a, b) = gfindex @f @b (gfindex @f @a f a) b
156− gftraverse f (a, b) = liftA2 (,) (gftraverse @f @a f a) (gftraverse @f @b f b)
157173
158174
159−instance Corep f rep => CorepFields f (M1 C meta rep) where
175+instance Representable f rep => RepresentableFields f (M1 C meta rep) where
160176 gftabulate = gtabulate @f @rep
161177 gfindex = gindex @f @rep
162− gftraverse = gtraverse @f @rep
163178
164179
165180type GConstructableADT
166181 :: (Type -> Exp Constraint)
167182 -> (Type -> Exp K.HTable)
168183 -> (Type -> Exp Type)
169− -> K.HContext -> (Type -> Type) -> Constraint
184+ -> K.Context -> (Type -> Type) -> Constraint
170185class GConstructableADT _Table _Columns f context rep where
171186 gbuildADT :: ()
172187 => ToColumns _Table _Columns f context
173188 -> (Tag -> Nullifier context)
174− -> HType Tag context
189+ -> HIdentity Tag context
175190 -> GFieldsADT f rep
176191 -> GColumnsADT _Columns rep context
177192
@@ -179,13 +194,13 @@ class GConstructableADT _Table _Columns f context rep where
179194 => FromColumns _Table _Columns f context
180195 -> Unnullifier context
181196 -> GColumnsADT _Columns rep context
182− -> (HType Tag context, GFieldsADT f rep)
197+ -> (HIdentity Tag context, GFieldsADT f rep)
183198
184199 gconstructADT :: ()
185200 => ToColumns _Table _Columns f context
186201 -> Null context
187202 -> Nullifier context
188− -> (Tag -> HType Tag context)
203+ -> (Tag -> HIdentity Tag context)
189204 -> GConstructors f rep (GColumnsADT _Columns rep context)
190205
191206 gdeconstructADT :: ()
@@ -193,30 +208,29 @@ class GConstructableADT _Table _Columns f context rep where
193208 -> Unnullifier context
194209 -> GConstructors f rep r
195210 -> GColumnsADT _Columns rep context
196− -> (HType Tag context, NonEmpty (Tag, r))
211+ -> (HIdentity Tag context, NonEmpty (Tag, r))
197212
198213
199214instance
200− ( htable ~ HLabel "tag" (HType Tag)
215+ ( htable ~ HLabel "tag" (HIdentity Tag)
201216 , GConstructableADT' _Table _Columns f context htable rep
202− , HLabelable context
203217 )
204218 => GConstructableADT _Table _Columns f context (M1 D meta rep)
205219 where
206220 gbuildADT toColumns nullifier =
207221 gbuildADT' @_Table @_Columns @f @context @htable @rep toColumns nullifier .
208− hlabel hlabeler
222+ hlabel
209223
210224 gunbuildADT fromColumns unnullifier =
211− first (hunlabel hunlabeler) .
225+ first hunlabel .
212226 gunbuildADT' @_Table @_Columns @f @context @htable @rep fromColumns unnullifier
213227
214228 gconstructADT toColumns null nullifier mk =
215229 gconstructADT' @_Table @_Columns @f @context @htable @rep toColumns null nullifier
216− (hlabel hlabeler . mk)
230+ (hlabel . mk)
217231
218232 gdeconstructADT fromColumns unnullifier cases =
219− first (hunlabel hunlabeler) .
233+ first hunlabel .
220234 gdeconstructADT' @_Table @_Columns @f @context @htable @rep fromColumns unnullifier cases
221235
222236
@@ -224,7 +238,7 @@ type GConstructableADT'
224238 :: (Type -> Exp Constraint)
225239 -> (Type -> Exp K.HTable)
226240 -> (Type -> Exp Type)
227− -> K.HContext -> K.HTable -> (Type -> Type) -> Constraint
241+ -> K.Context -> K.HTable -> (Type -> Type) -> Constraint
228242class GConstructableADT' _Table _Columns f context htable rep where
229243 gbuildADT' :: ()
230244 => ToColumns _Table _Columns f context
@@ -311,7 +325,6 @@ instance {-# OVERLAPPABLE #-}
311325 ( HTable (GColumns _Columns rep)
312326 , KnownSymbol label
313327 , meta ~ 'MetaCons label _fixity _isRecord
314− , HLabelable context
315328 , GConstructable _Table _Columns f context rep
316329 , GColumnsADT' _Columns htable (M1 C meta rep) ~
317330 HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))
@@ -320,7 +333,7 @@ instance {-# OVERLAPPABLE #-}
320333 where
321334 gbuildADT' toColumns nullifier htable =
322335 HProduct htable .
323− hlabel hlabeler .
336+ hlabel .
324337 hnullify (nullifier tag) .
325338 gconstruct @_Table @_Columns @f @context @rep toColumns
326339 where
@@ -331,13 +344,13 @@ instance {-# OVERLAPPABLE #-}
331344 , gdeconstruct @_Table @_Columns @f @context @rep fromColumns $
332345 runIdentity $
333346 hunnullify (\spec -> pure . unnullifier spec) $
334− hunlabel hunlabeler
347+ hunlabel
335348 a
336349 )
337350
338351 gconstructADT' toColumns _ nullifier mk =
339352 HProduct htable .
340− hlabel hlabeler .
353+ hlabel .
341354 hnullify nullifier .
342355 gconstruct @_Table @_Columns @f @context @rep toColumns
343356 where
@@ -352,8 +365,114 @@ instance {-# OVERLAPPABLE #-}
352365 a = gdeconstruct @_Table @_Columns @f @context @rep fromColumns $
353366 runIdentity $
354367 hunnullify (\spec -> pure . unnullifier spec) $
355− hunlabel hunlabeler
368+ hunlabel
356369 columns
357370 tag = Tag $ pack $ symbolVal (Proxy @label)
358371
359− gfill null htable = HProduct htable (hlabel hlabeler (hnulls null))
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.hs+30−30
@@ -12,28 +12,28 @@
1212{-# language UndecidableInstances #-}
1313
1414module Rel8.Generic.Construction.Record
15− ( GConstruct, GConstructable, gconstruct, gdeconstruct
16− , GFields, Corep, gtabulate, gindex, gtraverse
15+ ( GConstructor, GConstruct, GConstructable, gconstruct, gdeconstruct
16+ , GFields, Representable, gtabulate, gindex
1717 , FromColumns, ToColumns
1818 )
1919where
2020
2121-- base
22−import Control.Applicative ( liftA2 )
2322import Data.Kind ( Constraint, Type )
2423import Data.Proxy ( Proxy( Proxy ) )
2524import GHC.Generics
2625 ( (:*:), K1, M1, U1
27− , D, C, S, Meta( MetaSel )
26+ , D, C, S, Meta( MetaData, MetaCons, MetaSel )
27+ )
28+import GHC.TypeLits
29+ ( ErrorMessage( (:<>:), Text ), TypeError
30+ , Symbol
2831 )
29−import GHC.TypeLits ( KnownSymbol )
3032import Prelude
3133
3234-- rel8
33−import Rel8.FCF ( Compose, Eval, Exp )
35+import Rel8.FCF ( Eval, Exp )
3436import Rel8.Generic.Table.Record ( GColumns )
35−import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )
36−import Rel8.Schema.HTable ( HTable )
3737import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
3838import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
3939import qualified Rel8.Schema.Kind as K
@@ -43,7 +43,7 @@ type FromColumns
4343 :: (Type -> Exp Constraint)
4444 -> (Type -> Exp K.HTable)
4545 -> (Type -> Exp Type)
46− -> K.HContext
46+ -> K.Context
4747 -> Type
4848type FromColumns _Table _Columns f context = forall proxy x.
4949 Eval (_Table x) => proxy x -> Eval (_Columns x) context -> Eval (f x)
@@ -53,12 +53,22 @@ type ToColumns
5353 :: (Type -> Exp Constraint)
5454 -> (Type -> Exp K.HTable)
5555 -> (Type -> Exp Type)
56− -> K.HContext
56+ -> K.Context
5757 -> Type
5858type ToColumns _Table _Columns f context = forall proxy x.
5959 Eval (_Table x) => proxy x -> Eval (f x) -> Eval (_Columns x) context
6060
6161
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+
6272type GConstruct :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type
6373type family GConstruct f rep r where
6474 GConstruct f (M1 _ _ rep) r = GConstruct f rep r
@@ -75,46 +85,39 @@ type family GFields f rep where
7585 GFields f (K1 _ a) = Eval (f a)
7686
7787
78−type Corep :: (Type -> Exp Type) -> (Type -> Type) -> Constraint
79−class Corep f rep where
88+type Representable :: (Type -> Exp Type) -> (Type -> Type) -> Constraint
89+class Representable f rep where
8090 gtabulate :: (GFields f rep -> a) -> GConstruct f rep a
8191 gindex :: GConstruct f rep a -> GFields f rep -> a
82− gtraverse :: Applicative m
83− => (forall a. g a -> m a)
84− -> GFields (Compose g f) rep -> m (GFields f rep)
8592
8693
87−instance Corep f rep => Corep f (M1 i meta rep) where
94+instance Representable f rep => Representable f (M1 i meta rep) where
8895 gtabulate = gtabulate @f @rep
8996 gindex = gindex @f @rep
90− gtraverse = gtraverse @f @rep
9197
9298
93−instance (Corep f a, Corep f b) =>
94− Corep f (a :*: b)
99+instance (Representable f a, Representable f b) =>
100+ Representable f (a :*: b)
95101 where
96102 gtabulate f = gtabulate @f @a \a -> gtabulate @f @b \b -> f (a, b)
97103 gindex f (a, b) = gindex @f @b (gindex @f @a f a) b
98− gtraverse f (a, b) = liftA2 (,) (gtraverse @f @a f a) (gtraverse @f @b f b)
99104
100105
101−instance Corep f U1 where
106+instance Representable f U1 where
102107 gtabulate = ($ ())
103108 gindex = const
104− gtraverse = const pure
105109
106110
107−instance Corep f (K1 i a) where
111+instance Representable f (K1 i a) where
108112 gtabulate = id
109113 gindex = id
110− gtraverse = id
111114
112115
113116type GConstructable
114117 :: (Type -> Exp Constraint)
115118 -> (Type -> Exp K.HTable)
116119 -> (Type -> Exp Type)
117− -> K.HContext -> (Type -> Type) -> Constraint
120+ -> K.Context -> (Type -> Type) -> Constraint
118121class GConstructable _Table _Columns f context rep where
119122 gconstruct :: ()
120123 => ToColumns _Table _Columns f context
@@ -157,12 +160,9 @@ instance
157160
158161instance
159162 ( Eval (_Table a)
160− , HTable (Eval (_Columns a))
161− , HLabelable context
162− , KnownSymbol label
163163 , meta ~ 'MetaSel ('Just label) _su _ss _ds
164164 )
165165 => GConstructable _Table _Columns f context (M1 S meta (K1 i a))
166166 where
167− gconstruct toColumns = hlabel hlabeler . toColumns (Proxy @a)
168− gdeconstruct fromColumns = fromColumns (Proxy @a) . hunlabel hunlabeler
167+ gconstruct toColumns = hlabel . toColumns (Proxy @a)
168+ gdeconstruct fromColumns = fromColumns (Proxy @a) . hunlabel
src/Rel8/Generic/Map.hs+20−64
@@ -1,26 +1,19 @@
1−{-# language AllowAmbiguousTypes #-}
21{-# language DataKinds #-}
3−{-# language EmptyCase #-}
4−{-# language FlexibleInstances #-}
5−{-# language LambdaCase #-}
6−{-# language MultiParamTypeClasses #-}
7−{-# language RankNTypes #-}
8−{-# language ScopedTypeVariables #-}
92{-# language StandaloneKindSignatures #-}
10−{-# language TypeApplications #-}
113{-# language TypeFamilies #-}
124{-# language TypeOperators #-}
135{-# language UndecidableInstances #-}
146
157module Rel8.Generic.Map
16− ( GMap, GMappable (gmap, gunmap)
8+ ( GMap
9+ , Map
1710 )
1811where
1912
2013-- base
21−import Data.Kind ( Constraint, Type )
14+import Data.Kind ( Type )
2215import GHC.Generics
23− ( (:+:)( L1, R1 ), (:*:)( (:*:) ), K1( K1 ), M1( M1 ), U1( U1 ), V1
16+ ( (:+:), (:*:), K1, M1, U1, V1
2417 )
2518import Prelude ()
2619
@@ -38,56 +31,19 @@ type family GMap f rep where
3831 GMap f (K1 i a) = K1 i (Eval (f a))
3932
4033
41−type GMappable :: (Type -> Exp Constraint) -> (Type -> Type) -> Constraint
42−class GMappable constraint rep where
43− gmap :: ()
44− => proxy f
45− -> (forall a. Eval (constraint a) => a -> Eval (f a))
46− -> rep x
47− -> GMap f rep x
48−
49− gunmap :: ()
50− => proxy f
51− -> (forall a. Eval (constraint a) => Eval (f a) -> a)
52− -> GMap f rep x
53− -> rep x
54−
55−
56−instance GMappable constraint rep => GMappable constraint (M1 i c rep) where
57− gmap proxy f (M1 a) = M1 (gmap @constraint proxy f a)
58− gunmap proxy f (M1 a) = M1 (gunmap @constraint proxy f a)
59−
60−
61−instance GMappable constraint V1 where
62− gmap _ _ = \case
63− gunmap _ _ = \case
64−
65−
66−instance (GMappable constraint rep1, GMappable constraint rep2) =>
67− GMappable constraint (rep1 :+: rep2)
68− where
69− gmap proxy f = \case
70− L1 a -> L1 (gmap @constraint proxy f a)
71− R1 a -> R1 (gmap @constraint proxy f a)
72− gunmap proxy f = \case
73− L1 a -> L1 (gunmap @constraint proxy f a)
74− R1 a -> R1 (gunmap @constraint proxy f a)
75−
76−
77−instance GMappable constraint U1 where
78− gmap _ _ U1 = U1
79− gunmap _ _ U1 = U1
80−
81−
82−instance (GMappable constraint rep1, GMappable constraint rep2) =>
83− GMappable constraint (rep1 :*: rep2)
84− where
85− gmap proxy f (a :*: b) =
86− gmap @constraint proxy f a :*: gmap @constraint proxy f b
87− gunmap proxy f (a :*: b) =
88− gunmap @constraint proxy f a :*: gunmap @constraint proxy f b
89−
90−
91−instance Eval (constraint a) => GMappable constraint (K1 i a) where
92− gmap _ f (K1 a) = K1 (f a)
93− gunmap _ f (K1 a) = K1 (f a)
34+-- | Map a @Type -> Type@ function over the @Type@-kinded type variables in
35+-- of a type constructor.
36+type Map :: (Type -> Exp Type) -> Type -> Type
37+type family Map f a where
38+ Map p (t a b c d e f g) =
39+ t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e))
40+ (Eval (p f)) (Eval (p g))
41+ Map p (t a b c d e f) =
42+ t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e))
43+ (Eval (p f))
44+ Map p (t a b c d e) =
45+ t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e))
46+ Map p (t a b c d) = t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d))
47+ Map p (t a b c) = t (Eval (p a)) (Eval (p b)) (Eval (p c))
48+ Map p (t a b) = t (Eval (p a)) (Eval (p b))
49+ Map p (t a) = t (Eval (p a))
src/Rel8/Generic/Record.hs+2
@@ -1,5 +1,6 @@
11{-# language AllowAmbiguousTypes #-}
22{-# language DataKinds #-}
3+{-# language FlexibleContexts #-}
34{-# language FlexibleInstances #-}
45{-# language MultiParamTypeClasses #-}
56{-# language PolyKinds #-}
@@ -141,6 +142,7 @@ instance {-# OVERLAPPABLE #-} Snd (Count n rep) ~ rep => Countable n rep where
141142 uncount = id
142143
143144
145+type Record :: Type -> Type
144146newtype Record a = Record
145147 { unrecord :: a
146148 }
src/Rel8/Generic/Reify.hsdeleted−24
@@ -1,24 +0,0 @@
1−{-# language StandaloneKindSignatures #-}
2−{-# language TypeFamilies #-}
3−
4−module Rel8.Generic.Reify
5− ( ARep
6− )
7−where
8−
9−-- base
10−import Data.Functor.Contravariant ( Contravariant, contramap )
11−import Data.Kind ( Type )
12−import Data.Void ( Void, absurd )
13−import GHC.Generics ( Generic, Rep, from, to )
14−import Prelude
15−
16−
17−type ARep :: (Type -> Type) -> Type
18−newtype ARep rep = ARep (rep Void)
19−
20−
21−instance (Contravariant rep, Functor rep) => Generic (ARep rep) where
22− type Rep (ARep rep) = rep
23− from (ARep a) = fmap absurd a
24− to = ARep . contramap absurd
src/Rel8/Generic/Rel8able.hs+188−81
@@ -1,13 +1,18 @@
11{-# language AllowAmbiguousTypes #-}
2+{-# language ConstraintKinds #-}
23{-# language DataKinds #-}
34{-# language DefaultSignatures #-}
45{-# language FlexibleContexts #-}
56{-# language FlexibleInstances #-}
7+{-# language LambdaCase #-}
68{-# language MultiParamTypeClasses #-}
9+{-# language PolyKinds #-}
10+{-# language QuantifiedConstraints #-}
711{-# language ScopedTypeVariables #-}
812{-# language StandaloneKindSignatures #-}
913{-# language TypeApplications #-}
10−{-# language TypeFamilies #-}
14+{-# language TypeFamilyDependencies #-}
15+{-# language TypeOperators #-}
1116{-# language UndecidableInstances #-}
1217
1318module Rel8.Generic.Rel8able
@@ -15,42 +20,99 @@ module Rel8.Generic.Rel8able
1520 , Algebra
1621 , GRep
1722 , GColumns, gfromColumns, gtoColumns
18− , greify, gunreify
19− , TUnreifyContext
23+ , GFromExprs, gfromResult, gtoResult
24+ , TSerialize, serialize, deserialize
2025 )
2126where
2227
2328-- base
29+import Data.Functor.Identity ( Identity )
2430import Data.Kind ( Constraint, Type )
25−import Data.Proxy ( Proxy( Proxy ) )
26−import Data.Type.Equality ( (:~:)( Refl ) )
31+import Data.Type.Bool ( type (&&) )
2732import GHC.Generics ( Generic, Rep, from, to )
2833import Prelude
2934
3035-- rel8
31−import Rel8.Kind.Context ( Reifiable )
32−import Rel8.FCF ( Eval, Exp )
33−import Rel8.Generic.Map ( GMap, GMappable, gmap, gunmap )
36+import Rel8.Aggregate ( Aggregate )
37+import Rel8.Expr ( Expr )
38+import Rel8.FCF ( Exp, Eval )
3439import Rel8.Generic.Record ( Record(..) )
3540import Rel8.Generic.Table ( GAlgebra )
3641import qualified Rel8.Generic.Table.Record as G
3742import qualified Rel8.Kind.Algebra as K ( Algebra(..) )
38−import Rel8.Schema.Context ( Col )
39−import Rel8.Schema.Context.Label ( Labelable )
43+import Rel8.Kind.Context ( SContext(..) )
44+import Rel8.Schema.Field ( Field )
4045import Rel8.Schema.HTable ( HTable )
4146import qualified Rel8.Schema.Kind as K
42−import Rel8.Schema.Reify ( Reify, UnwrapReify )
47+import Rel8.Schema.Name ( Name )
4348import Rel8.Schema.Result ( Result )
4449import Rel8.Table
45− ( fromColumns, toColumns, reify, unreify
46− , TTable, TColumns, TContext, TUnreify
50+ ( Table, Columns, Context, fromColumns, toColumns
51+ , FromExprs, fromResult, toResult
52+ , Transpose
53+ , TTable, TColumns
4754 )
55+import Rel8.Table.Transpose ( Transposes )
4856
4957
58+-- | The kind of 'Rel8able' types
5059type KRel8able :: Type
5160type KRel8able = K.Rel8able
5261
5362
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+
54116-- | This type class allows you to define custom 'Table's using higher-kinded
55117-- data types. Higher-kinded data types are data types of the pattern:
56118--
@@ -62,113 +124,158 @@ type KRel8able = K.Rel8able
62124-- , fieldN :: Column f Tn OR HKn f
63125-- }
64126-- @
65−--
127+--
66128-- where @Tn@ is any Haskell type, and @HKn@ is any higher-kinded type.
67−--
129+--
68130-- That is, higher-kinded data are records where all fields in the record are
69131-- all either of the type @Column f T@ (for any @T@), or are themselves
70132-- higher-kinded data:
71−--
133+--
72134-- [Nested]
73−--
135+--
74136-- @
75137-- data Nested f =
76138-- Nested { nested1 :: MyType f
77139-- , nested2 :: MyType f
78140-- }
79141-- @
80−--
142+--
81143-- The @Rel8able@ type class is used to give us a special mapping operation
82144-- that lets us change the type parameter @f@.
83−--
145+--
84146-- [Supplying @Rel8able@ instances]
85−--
147+--
86148-- This type class should be derived generically for all table types in your
87−-- project. To do this, enable the @DeriveAnyType@ and @DeriveGeneric@ language
149+-- project. To do this, enable the @DeriveAnyClass@ and @DeriveGeneric@ language
88150-- extensions:
89−--
151+--
90152-- @
91153-- \{\-\# LANGUAGE DeriveAnyClass, DeriveGeneric #-\}
92−--
154+--
93155-- data MyType f = MyType { fieldA :: Column f T }
94156-- deriving ( GHC.Generics.Generic, Rel8able )
95157-- @
96158type Rel8able :: K.Rel8able -> Constraint
97159class HTable (GColumns t) => Rel8able t where
98160 type GColumns t :: K.HTable
161+ type GFromExprs t :: Type
99162
100− gfromColumns :: (Labelable context, Reifiable context)
101− => GColumns t (Col (Reify context)) -> t (Reify context)
102−
103− gtoColumns :: (Labelable context, Reifiable context)
104− => t (Reify context) -> GColumns t (Col (Reify context))
105−
106− greify :: (Labelable context, Reifiable context)
107− => t context -> t (Reify context)
163+ gfromColumns :: SContext context -> GColumns t context -> t context
164+ gtoColumns :: SContext context -> t context -> GColumns t context
108165
109− gunreify :: (Labelable context, Reifiable context)
110− => t (Reify context) -> t context
166+ gfromResult :: GColumns t Result -> GFromExprs t
167+ gtoResult :: GFromExprs t -> GColumns t Result
111168
112− type GColumns t = G.GColumns TColumns (GRep t (Reify Result))
169+ type GColumns t = G.GColumns TColumns (GRep t Expr)
170+ type GFromExprs t = t Result
113171
114172 default gfromColumns :: forall context.
115− ( Generic (Record (t (Reify context)))
116− , G.GTable (TTable (Reify context)) TColumns (Col (Reify context)) (GRep t (Reify context))
117− , G.GColumns TColumns (GRep t (Reify context)) ~ GColumns t
173+ ( SRel8able t Aggregate
174+ , SRel8able t Expr
175+ , forall table. SRel8able t (Field table)
176+ , SRel8able t Name
177+ , SSerialize t
118178 )
119− => GColumns t (Col (Reify context)) -> t (Reify context)
120− gfromColumns =
121− unrecord .
122− to .
123− G.gfromColumns @(TTable (Reify context)) @TColumns fromColumns
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
124186
125187 default gtoColumns :: forall context.
126− ( Generic (Record (t (Reify context)))
127− , G.GTable (TTable (Reify context)) TColumns (Col (Reify context)) (GRep t (Reify context))
128− , G.GColumns TColumns (GRep t (Reify context)) ~ GColumns t
129− )
130− => t (Reify context) -> GColumns t (Col (Reify context))
131− gtoColumns =
132− G.gtoColumns @(TTable (Reify context)) @TColumns toColumns .
133− from .
134− Record
135−
136− default greify :: forall context.
137− ( Generic (Record (t context))
138− , Generic (Record (t (Reify context)))
139− , GMappable (TTable (Reify context)) (GRep t (Reify context))
140− , GRep t context ~ GMap TUnreify (GRep t (Reify context))
141− )
142− => t context -> t (Reify context)
143− greify =
144− unrecord .
145− to .
146− gunmap @(TTable (Reify context)) (Proxy @TUnreify) (reify Refl) .
147− from .
148− Record
149−
150− default gunreify :: forall context.
151− ( Generic (Record (t context))
152− , Generic (Record (t (Reify context)))
153− , GMappable (TTable (Reify context)) (GRep t (Reify context))
154− , GRep t context ~ GMap TUnreify (GRep t (Reify context))
188+ ( SRel8able t Aggregate
189+ , SRel8able t Expr
190+ , forall table. SRel8able t (Field table)
191+ , SRel8able t Name
192+ , SSerialize t
155193 )
156− => t (Reify context) -> t context
157− gunreify =
158− unrecord .
159− to .
160− gmap @(TTable (Reify context)) (Proxy @TUnreify) (unreify Refl) .
161− from .
162− Record
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
163209
164210
165211type Algebra :: K.Rel8able -> K.Algebra
166−type Algebra t = GAlgebra (GRep t (Reify Result))
212+type Algebra t = GAlgebra (GRep t Expr)
167213
168214
169215type GRep :: K.Rel8able -> K.Context -> Type -> Type
170216type GRep t context = Rep (Record (t context))
171217
172218
173−data TUnreifyContext :: Type -> Exp K.Context
174−type instance Eval (TUnreifyContext a) = UnwrapReify (Eval (TContext a))
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.hs+24−109
@@ -12,8 +12,7 @@
1212{-# language UndecidableInstances #-}
1313
1414module Rel8.Generic.Table
15− ( GGTable, GGColumns, GGContext, ggfromColumns, ggtoColumns, ggtable
16− , GGToExprs, ggfromResult, ggtoResult
15+ ( GGSerialize, GGColumns, ggfromResult, ggtoResult
1716 , GAlgebra
1817 )
1918where
@@ -26,43 +25,19 @@ import Prelude ()
2625-- rel8
2726import Rel8.FCF ( Eval, Exp )
2827import Rel8.Generic.Table.ADT
29− ( GTableADT, GColumnsADT, gfromColumnsADT, gtoColumnsADT, gtableADT
30− , GToExprsADT, gtoResultADT, gfromResultADT
31− )
32−import Rel8.Generic.Table.Record
33− ( GTable, GColumns, GContext, gfromColumns, gtoColumns, gtable
34− , GToExprs, gtoResult, gfromResult
28+ ( GSerializeADT, GColumnsADT, gtoResultADT, gfromResultADT
3529 )
30+import Rel8.Generic.Table.Record ( GSerialize, GColumns, gtoResult, gfromResult )
3631import Rel8.Kind.Algebra
3732 ( Algebra( Product, Sum )
3833 , SAlgebra( SProduct, SSum )
3934 , KnownAlgebra, algebraSing
4035 )
41−import Rel8.Schema.Context ( Col )
4236import qualified Rel8.Schema.Kind as K
43−import Rel8.Schema.Null ( Nullify )
44−import Rel8.Schema.Spec ( Spec( Spec ), SSpec )
4537import Rel8.Schema.Result ( Result )
4638
4739
48−data GGTable
49− :: Algebra
50− -> (Type -> Exp Constraint)
51− -> (Type -> Exp K.HTable)
52− -> K.HContext
53− -> (Type -> Type)
54− -> Exp Constraint
55−
56−
57−type instance Eval (GGTable 'Product _Table _Columns context rep) =
58− GTable _Table _Columns context rep
59−
60−
61−type instance Eval (GGTable 'Sum _Table _Columns context rep) =
62− GTableADT _Table _Columns context rep
63−
64−
65−data GGToExprs
40+data GGSerialize
6641 :: Algebra
6742 -> (Type -> Type -> Exp Constraint)
6843 -> (Type -> Exp K.HTable)
@@ -71,12 +46,12 @@ data GGToExprs
7146 -> Exp Constraint
7247
7348
74−type instance Eval (GGToExprs 'Product _ToExprs _Columns exprs rep) =
75− GToExprs _ToExprs _Columns exprs rep
49+type instance Eval (GGSerialize 'Product _Serialize _Columns exprs rep) =
50+ GSerialize _Serialize _Columns exprs rep
7651
7752
78−type instance Eval (GGToExprs 'Sum _ToExprs _Columns exprs rep) =
79− GToExprsADT _ToExprs _Columns exprs rep
53+type instance Eval (GGSerialize 'Sum _Serialize _Columns exprs rep) =
54+ GSerializeADT _Serialize _Columns exprs rep
8055
8156
8257data GGColumns
@@ -92,19 +67,6 @@ type instance Eval (GGColumns 'Product _Columns rep) = GColumns _Columns rep
9267type instance Eval (GGColumns 'Sum _Columns rep) = GColumnsADT _Columns rep
9368
9469
95−data GGContext
96− :: Algebra
97− -> (Type -> Exp K.Context)
98− -> (Type -> Type)
99− -> Exp K.Context
100−
101−
102−type instance Eval (GGContext 'Product _Context rep) = GContext _Context rep
103−
104−
105−type instance Eval (GGContext 'Sum _Context _rep) = Result
106−
107−
10870type GAlgebra :: (Type -> Type) -> Algebra
10971type family GAlgebra rep where
11072 GAlgebra (M1 _ _ rep) = GAlgebra rep
@@ -115,74 +77,27 @@ type family GAlgebra rep where
11577 GAlgebra (K1 _ _) = 'Product
11678
11779
118−ggfromColumns :: forall algebra _Table _Columns rep context x.
119− ( KnownAlgebra algebra
120− , Eval (GGTable algebra _Table _Columns context rep)
121− )
122− => (forall spec. algebra ~ 'Sum => context spec -> Col Result spec)
123− -> (forall spec. algebra ~ 'Sum => Col Result spec -> context spec)
124− -> (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)
125− -> Eval (GGColumns algebra _Columns rep) context
126− -> rep x
127−ggfromColumns = case algebraSing @algebra of
128− SProduct -> \_ _ -> gfromColumns @_Table @_Columns
129− SSum -> gfromColumnsADT @_Table @_Columns
130−
131−
132−ggtoColumns :: forall algebra _Table _Columns rep context x.
133− ( KnownAlgebra algebra
134− , Eval (GGTable algebra _Table _Columns context rep)
135− )
136− => (forall spec. algebra ~ 'Sum => context spec -> Col Result spec)
137− -> (forall spec. algebra ~ 'Sum => Col Result spec -> context spec)
138− -> (forall a. Eval (_Table a) => a -> Eval (_Columns a) context)
139− -> rep x
140− -> Eval (GGColumns algebra _Columns rep) context
141−ggtoColumns = case algebraSing @algebra of
142− SProduct -> \_ _ -> gtoColumns @_Table @_Columns
143− SSum -> gtoColumnsADT @_Table @_Columns
144−
145−
146−ggtable :: forall algebra _Table _Columns rep context.
147− ( KnownAlgebra algebra
148− , Eval (GGTable algebra _Table _Columns context rep)
149− )
150− => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)
151− -> (forall a labels necessity. ()
152− => SSpec ('Spec labels necessity a)
153− -> context ('Spec labels necessity a)
154− -> context ('Spec labels necessity (Nullify a)))
155− -> Eval (GGColumns algebra _Columns rep) context
156−ggtable = case algebraSing @algebra of
157− SProduct -> \table _ -> gtable @_Table @_Columns @_ @rep table
158− SSum -> gtableADT @_Table @_Columns @_ @rep
159−
160−
161−ggfromResult :: forall algebra _ToExprs _Columns exprs rep x.
80+ggfromResult :: forall algebra _Serialize _Columns exprs rep x.
16281 ( KnownAlgebra algebra
163− , Eval (GGToExprs algebra _ToExprs _Columns exprs rep)
82+ , Eval (GGSerialize algebra _Serialize _Columns exprs rep)
16483 )
165− => (forall expr a proxy. Eval (_ToExprs expr a)
166− => proxy expr
167− -> Eval (_Columns expr) (Col Result)
168− -> a)
169− -> Eval (GGColumns algebra _Columns exprs) (Col Result)
84+ => (forall expr a proxy. Eval (_Serialize expr a)
85+ => proxy expr -> Eval (_Columns expr) Result -> a)
86+ -> Eval (GGColumns algebra _Columns exprs) Result
17087 -> rep x
171−ggfromResult = case algebraSing @algebra of
172− SProduct -> gfromResult @_ToExprs @_Columns @exprs
173− SSum -> gfromResultADT @_ToExprs @_Columns @exprs
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
17491
17592
176−ggtoResult :: forall algebra _ToExprs _Columns exprs rep x.
93+ggtoResult :: forall algebra _Serialize _Columns exprs rep x.
17794 ( KnownAlgebra algebra
178− , Eval (GGToExprs algebra _ToExprs _Columns exprs rep)
95+ , Eval (GGSerialize algebra _Serialize _Columns exprs rep)
17996 )
180− => (forall expr a proxy. Eval (_ToExprs expr a)
181− => proxy expr
182− -> a
183− -> Eval (_Columns expr) (Col Result))
97+ => (forall expr a proxy. Eval (_Serialize expr a)
98+ => proxy expr -> a -> Eval (_Columns expr) Result)
18499 -> rep x
185− -> Eval (GGColumns algebra _Columns exprs) (Col Result)
186−ggtoResult = case algebraSing @algebra of
187− SProduct -> gtoResult @_ToExprs @_Columns @exprs
188− SSum -> gtoResultADT @_ToExprs @_Columns @exprs
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.hs+61−203
@@ -4,7 +4,6 @@
44{-# language FlexibleInstances #-}
55{-# language LambdaCase #-}
66{-# language MultiParamTypeClasses #-}
7−{-# language PolyKinds #-}
87{-# language RankNTypes #-}
98{-# language ScopedTypeVariables #-}
109{-# language StandaloneKindSignatures #-}
@@ -14,13 +13,13 @@
1413{-# language UndecidableInstances #-}
1514
1615module Rel8.Generic.Table.ADT
17− ( GTableADT, GColumnsADT, gfromColumnsADT, gtoColumnsADT, gtableADT
18− , GTableADT', GColumnsADT'
19− , GToExprsADT, gfromResultADT, gtoResultADT
16+ ( GSerializeADT, GColumnsADT, gfromResultADT, gtoResultADT
17+ , GSerializeADT', GColumnsADT'
2018 )
2119where
2220
2321-- base
22+import Data.Functor.Identity ( Identity( Identity ) )
2423import Data.Kind ( Constraint, Type )
2524import Data.Proxy ( Proxy( Proxy ) )
2625import GHC.Generics
@@ -33,23 +32,14 @@ import Prelude hiding ( null )
3332
3433-- rel8
3534import Rel8.FCF ( Eval, Exp )
36−import Rel8.Generic.Table.Record
37− ( GTable, GColumns, gtable
38− , GToExprs, gfromResult, gtoResult
39− )
40−import Rel8.Schema.Context.Label ( HLabelable, hlabeler, labeler, unlabeler )
41−import Rel8.Schema.HTable ( HTable, hmap )
42−import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )
35+import Rel8.Generic.Table.Record ( GSerialize, GColumns, gfromResult, gtoResult )
36+import Rel8.Schema.HTable ( HTable )
37+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
4338import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
4439import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify )
4540import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
4641import qualified Rel8.Schema.Kind as K
47−import Rel8.Schema.Null ( Nullify )
48−import Rel8.Schema.Spec ( Spec( Spec ), SSpec )
49−import Rel8.Schema.Result
50− ( Col( Result ), Result
51− , null, nullifier, unnullifier
52− )
42+import Rel8.Schema.Result ( Result, null, nullifier, unnullifier )
5343import Rel8.Type.Tag ( Tag( Tag ) )
5444
5545-- text
@@ -61,7 +51,7 @@ type GColumnsADT
6151 -> (Type -> Type) -> K.HTable
6252type family GColumnsADT _Columns rep where
6353 GColumnsADT _Columns (M1 D _ rep) =
64− GColumnsADT' _Columns (HLabel "tag" (HType Tag)) rep
54+ GColumnsADT' _Columns (HLabel "tag" (HIdentity Tag)) rep
6555
6656
6757type GColumnsADT'
@@ -75,246 +65,118 @@ type family GColumnsADT' _Columns htable rep where
7565 HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))
7666
7767
78−type GTableADT
79− :: (Type -> Exp Constraint)
80− -> (Type -> Exp K.HTable)
81− -> K.HContext -> (Type -> Type) -> Constraint
82−class GTableADT _Table _Columns context rep where
83− gfromColumnsADT :: ()
84− => (forall spec. context spec -> Col Result spec)
85− -> (forall spec. Col Result spec -> context spec)
86− -> (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)
87− -> GColumnsADT _Columns rep context
88− -> rep x
89−
90− gtoColumnsADT :: ()
91− => (forall spec. context spec -> Col Result spec)
92− -> (forall spec. Col Result spec -> context spec)
93− -> (forall a. Eval (_Table a) => a -> Eval (_Columns a) context)
94− -> rep x
95− -> GColumnsADT _Columns rep context
96−
97− gtableADT :: ()
98− => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)
99− -> (forall a labels necessity. ()
100− => SSpec ('Spec labels necessity a)
101− -> context ('Spec labels necessity a)
102− -> context ('Spec labels necessity (Nullify a)))
103− -> GColumnsADT _Columns rep context
104−
105−
106−instance
107− ( htable ~ HLabel "tag" (HType Tag)
108− , HTable (GColumnsADT _Columns (M1 D meta rep))
109− , Eval (_Table (htable context))
110− , Eval (_Columns (htable context)) ~ htable
111− , GTableADT' _Table _Columns htable context rep
112− , GToExprsADT' (Const _Table) _Columns htable rep rep
113− )
114− => GTableADT _Table _Columns context (M1 D meta rep)
115− where
116− gfromColumnsADT fromContext toContext fromColumns =
117− gfromResultADT @(Const _Table) @_Columns @(M1 D meta rep) @(M1 D meta rep)
118− (const (fromColumns . hmap toContext)) .
119− hmap fromContext
120−
121− gtoColumnsADT fromContext toContext toColumns =
122− hmap toContext .
123− gtoResultADT @(Const _Table) @_Columns @(M1 D meta rep) @(M1 D meta rep)
124− (const (hmap fromContext . toColumns))
125−
126− gtableADT table hnullifier =
127− gtableADT' @_Table @_Columns @htable @context @rep table hnullifier htable
128− where
129− htable = table (Proxy @(htable context))
130−
131−
132−type GTableADT'
133− :: (Type -> Exp Constraint)
134− -> (Type -> Exp K.HTable)
135− -> K.HTable -> K.HContext -> (Type -> Type) -> Constraint
136−class GTableADT' _Table _Columns htable context rep where
137− gtableADT' :: ()
138− => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)
139− -> (forall a labels necessity. ()
140− => SSpec ('Spec labels necessity a)
141− -> context ('Spec labels necessity a)
142− -> context ('Spec labels necessity (Nullify a)))
143− -> htable context
144− -> GColumnsADT' _Columns htable rep context
145−
146−
147−instance
148− ( htable' ~ GColumnsADT' _Columns htable a
149− , GTableADT' _Table _Columns htable context a
150− , GTableADT' _Table _Columns htable' context b
151− )
152− => GTableADT' _Table _Columns htable context (a :+: b)
153− where
154− gtableADT' table hnullifier =
155− gtableADT' @_Table @_Columns @_ @_ @b table hnullifier .
156− gtableADT' @_Table @_Columns @_ @_ @a table hnullifier
157−
158−
159−instance meta ~ 'MetaCons label _fixity _isRecord =>
160− GTableADT' _Table _Columns htable context (M1 C meta U1)
161− where
162− gtableADT' _ _ = id
163−
164−
165−instance {-# OVERLAPPABLE #-}
166− ( HTable (GColumns _Columns rep)
167− , GTable _Table _Columns context rep
168− , HLabelable context
169− , meta ~ 'MetaCons label _fixity _isRecord
170− , KnownSymbol label
171− , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) rep) ~
172− HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))
173− )
174− => GTableADT' _Table _Columns htable context (M1 C meta rep)
175− where
176− gtableADT' table hnullifier htable =
177− HProduct htable $
178− hlabel hlabeler $
179− hnullify hnullifier $
180− gtable @_Table @_Columns @_ @rep table
181−
182−
183−type GToExprsADT
68+type GSerializeADT
18469 :: (Type -> Type -> Exp Constraint)
18570 -> (Type -> Exp K.HTable)
18671 -> (Type -> Type) -> (Type -> Type) -> Constraint
187−class GToExprsADT _ToExprs _Columns exprs rep where
72+class GSerializeADT _Serialize _Columns exprs rep where
18873 gfromResultADT :: ()
189− => (forall expr a proxy.
190− ( Eval (_ToExprs expr a)
191− , HTable (Eval (_Columns expr))
192− )
193− => proxy expr
194− -> Eval (_Columns expr) (Col Result)
195− -> a)
196− -> GColumnsADT _Columns exprs (Col Result)
74+ => (forall expr a proxy. Eval (_Serialize expr a)
75+ => proxy expr -> Eval (_Columns expr) Result -> a)
76+ -> GColumnsADT _Columns exprs Result
19777 -> rep x
19878
19979 gtoResultADT :: ()
200− => (forall expr a proxy.
201− ( Eval (_ToExprs expr a)
202− , HTable (Eval (_Columns expr))
203− )
204− => proxy expr
205− -> a
206− -> Eval (_Columns expr) (Col Result))
80+ => (forall expr a proxy. Eval (_Serialize expr a)
81+ => proxy expr -> a -> Eval (_Columns expr) Result)
20782 -> rep x
208− -> GColumnsADT _Columns exprs (Col Result)
83+ -> GColumnsADT _Columns exprs Result
20984
21085
21186instance
212− ( htable ~ HLabel "tag" (HType Tag)
213− , GToExprsADT' _ToExprs _Columns htable exprs rep
87+ ( htable ~ HLabel "tag" (HIdentity Tag)
88+ , GSerializeADT' _Serialize _Columns htable exprs rep
21489 )
215− => GToExprsADT _ToExprs _Columns (M1 D meta exprs) (M1 D meta rep)
90+ => GSerializeADT _Serialize _Columns (M1 D meta exprs) (M1 D meta rep)
21691 where
21792 gfromResultADT fromResult columns =
218− case gfromResultADT' @_ToExprs @_Columns @_ @exprs fromResult tag columns of
93+ case gfromResultADT' @_Serialize @_Columns @htable @exprs @rep fromResult tag columns of
21994 Just rep -> M1 rep
22095 _ -> error "ADT.fromColumns: mismatch between tag and data"
22196 where
222− tag = (\(HType (Result a)) -> a) . hunlabel @_ @"tag" unlabeler
97+ tag = (\(HIdentity (Identity a)) -> a) . hunlabel @"tag"
22398
22499 gtoResultADT toResult (M1 rep) =
225− gtoResultADT' @_ToExprs @_Columns @_ @exprs toResult tag (Just rep)
100+ gtoResultADT' @_Serialize @_Columns @htable @exprs @rep toResult tag (Just rep)
226101 where
227− tag = hlabel @_ @"tag" labeler . HType . Result
102+ tag = hlabel @"tag" . HIdentity . Identity
228103
229104
230−type GToExprsADT'
105+type GSerializeADT'
231106 :: (Type -> Type -> Exp Constraint)
232107 -> (Type -> Exp K.HTable)
233108 -> K.HTable -> (Type -> Type) -> (Type -> Type) -> Constraint
234−class GToExprsADT' _ToExprs _Columns htable exprs rep where
235− gfromResultADT' :: ()
236− => (forall expr a proxy.
237− ( Eval (_ToExprs expr a)
238− , HTable (Eval (_Columns expr))
239− )
240− => proxy expr
241− -> Eval (_Columns expr) (Col Result)
242− -> a)
243− -> (htable (Col Result) -> Tag)
244− -> GColumnsADT' _Columns htable exprs (Col Result)
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
245115 -> Maybe (rep x)
246116
247− gtoResultADT' :: ()
248− => (forall expr a proxy.
249− ( Eval (_ToExprs expr a)
250− , HTable (Eval (_Columns expr))
251− )
252− => proxy expr
253− -> a
254− -> Eval (_Columns expr) (Col Result))
255− -> (Tag -> htable (Col Result))
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)
256121 -> Maybe (rep x)
257− -> GColumnsADT' _Columns htable exprs (Col Result)
122+ -> GColumnsADT' _Columns htable exprs context
258123
259124 extract :: GColumnsADT' _Columns htable exprs context -> htable context
260125
261126
262127instance
263− ( htable' ~ GColumnsADT' _Columns htable a
264− , GToExprsADT' _ToExprs _Columns htable a rep1
265− , GToExprsADT' _ToExprs _Columns htable' b rep2
128+ ( htable' ~ GColumnsADT' _Columns htable exprs1
129+ , GSerializeADT' _Serialize _Columns htable exprs1 a
130+ , GSerializeADT' _Serialize _Columns htable' exprs2 b
266131 )
267− => GToExprsADT' _ToExprs _Columns htable (a :+: b) (rep1 :+: rep2)
132+ => GSerializeADT' _Serialize _Columns htable (exprs1 :+: exprs2) (a :+: b)
268133 where
269134 gfromResultADT' fromResult f columns =
270135 case ma of
271136 Just a -> Just (L1 a)
272137 Nothing -> R1 <$>
273− gfromResultADT' @_ToExprs @_Columns @_ @b @rep2
138+ gfromResultADT' @_Serialize @_Columns @_ @exprs2 @b
274139 fromResult
275− (f . extract @_ToExprs @_Columns @_ @a @rep1)
140+ (f . extract @_Serialize @_Columns @_ @exprs1 @a)
276141 columns
277142 where
278143 ma =
279− gfromResultADT' @_ToExprs @_Columns @_ @a @rep1
144+ gfromResultADT' @_Serialize @_Columns @_ @exprs1 @a
280145 fromResult
281146 f
282− (extract @_ToExprs @_Columns @_ @b @rep2 columns)
147+ (extract @_Serialize @_Columns @_ @exprs2 @b columns)
283148
284149 gtoResultADT' toResult tag = \case
285150 Just (L1 a) ->
286− gtoResultADT' @_ToExprs @_Columns @_ @b @rep2
151+ gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b
287152 toResult
288− (\_ -> gtoResultADT' @_ToExprs @_Columns @_ @a @rep1
153+ (\_ -> gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a
289154 toResult
290155 tag
291156 (Just a))
292157 Nothing
293158 Just (R1 b) ->
294− gtoResultADT' @_ToExprs @_Columns @_ @b @rep2
159+ gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b
295160 toResult
296161 (\tag' ->
297− gtoResultADT' @_ToExprs @_Columns @_ @a @rep1
162+ gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a
298163 toResult
299164 (\_ -> tag tag')
300165 Nothing)
301166 (Just b)
302167 Nothing ->
303− gtoResultADT' @_ToExprs @_Columns @_ @b @rep2
168+ gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b
304169 toResult
305− (\_ -> gtoResultADT' @_ToExprs @_Columns @_ @a @rep1 toResult tag Nothing)
170+ (\_ -> gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a toResult tag Nothing)
306171 Nothing
307172
308173 extract =
309− extract @_ToExprs @_Columns @_ @a @rep1 .
310− extract @_ToExprs @_Columns @_ @b @rep2
174+ extract @_Serialize @_Columns @_ @exprs1 @a .
175+ extract @_Serialize @_Columns @_ @exprs2 @b
311176
312177
313−instance
314− ( meta ~ 'MetaCons label _fixity _isRecord
315− , KnownSymbol label
316− )
317− => GToExprsADT' _ToExprs _Columns htable (M1 C meta U1) (M1 C meta U1)
178+instance (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) =>
179+ GSerializeADT' _Serialize _Columns _htable (M1 C meta U1) (M1 C meta U1)
318180 where
319181 gfromResultADT' _ tag columns
320182 | tag columns == tag' = Just (M1 U1)
@@ -331,33 +193,29 @@ instance
331193
332194instance {-# OVERLAPPABLE #-}
333195 ( HTable (GColumns _Columns exprs)
334− , GToExprs _ToExprs _Columns exprs rep
196+ , GSerialize _Serialize _Columns exprs rep
335197 , meta ~ 'MetaCons label _fixity _isRecord
336198 , KnownSymbol label
337− , GColumnsADT' _Columns htable (M1 C meta exprs) ~
199+ , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) exprs) ~
338200 HProduct htable (HLabel label (HNullify (GColumns _Columns exprs)))
339201 )
340− => GToExprsADT' _ToExprs _Columns htable (M1 C meta exprs) (M1 C meta rep)
202+ => GSerializeADT' _Serialize _Columns htable (M1 C meta exprs) (M1 C meta rep)
341203 where
342204 gfromResultADT' fromResult tag (HProduct a b)
343205 | tag a == tag' =
344− M1 . gfromResult @_ToExprs @_Columns @exprs fromResult <$>
345− hunnullify unnullifier (hunlabel unlabeler b)
206+ M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult <$>
207+ hunnullify unnullifier (hunlabel b)
346208 | otherwise = Nothing
347209 where
348210 tag' = Tag $ pack $ symbolVal (Proxy @label)
349211
350212 gtoResultADT' toResult tag = \case
351− Nothing -> HProduct (tag tag') (hlabel labeler (hnulls (const null)))
213+ Nothing -> HProduct (tag tag') (hlabel (hnulls (const null)))
352214 Just (M1 rep) -> HProduct (tag tag') $
353− hlabel labeler $
215+ hlabel $
354216 hnullify nullifier $
355− gtoResult @_ToExprs @_Columns @exprs toResult rep
217+ gtoResult @_Serialize @_Columns @exprs @rep toResult rep
356218 where
357219 tag' = Tag $ pack $ symbolVal (Proxy @label)
358220
359221 extract (HProduct a _) = a
360−
361−
362−data Const :: (a -> Exp Constraint) -> a -> a -> Exp Constraint
363−type instance Eval (Const f x a) = (Eval (f a), x ~ a)
src/Rel8/Generic/Table/Record.hs+74−99
@@ -14,7 +14,7 @@
1414
1515module Rel8.Generic.Table.Record
1616 ( GTable, GColumns, GContext, gfromColumns, gtoColumns, gtable
17− , GToExprs, gfromResult, gtoResult
17+ , GSerialize, gfromResult, gtoResult
1818 )
1919where
2020
@@ -26,18 +26,13 @@ import GHC.Generics
2626 , C, D, S
2727 , Meta( MetaSel )
2828 )
29−import GHC.TypeLits ( KnownSymbol )
3029import Prelude hiding ( null )
3130
3231-- rel8
3332import Rel8.FCF ( Eval, Exp )
34−import Rel8.Schema.Context ( Col )
35−import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )
36−import Rel8.Schema.HTable ( HTable )
3733import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
3834import Rel8.Schema.HTable.Product ( HProduct(..) )
3935import qualified Rel8.Schema.Kind as K
40−import Rel8.Schema.Result ( Result )
4136
4237
4338type GColumns :: (Type -> Exp K.HTable) -> (Type -> Type) -> K.HTable
@@ -60,8 +55,8 @@ type family GContext _Context rep where
6055type GTable
6156 :: (Type -> Exp Constraint)
6257 -> (Type -> Exp K.HTable)
63− -> K.HContext -> (Type -> Type) -> Constraint
64−class GTable _Table _Columns context rep
58+ -> (Type -> Type) -> Constraint
59+class GTable _Table _Columns rep
6560 where
6661 gfromColumns :: ()
6762 => (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)
@@ -78,129 +73,109 @@ class GTable _Table _Columns context rep
7873 -> GColumns _Columns rep context
7974
8075
81−instance GTable _Table _Columns context rep =>
82− GTable _Table _Columns context (M1 D c rep)
76+type GSerialize
77+ :: (Type -> Type -> Exp Constraint)
78+ -> (Type -> Exp K.HTable)
79+ -> (Type -> Type) -> (Type -> Type) -> Constraint
80+class GSerialize _Serialize _Columns exprs rep
8381 where
84− gfromColumns fromColumns =
85− M1 . gfromColumns @_Table @_Columns @context @rep fromColumns
86− gtoColumns toColumns (M1 a) =
87− gtoColumns @_Table @_Columns @context @rep toColumns a
88− gtable = gtable @_Table @_Columns @context @rep
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
8993
9094
91−instance GTable _Table _Columns context rep =>
92− GTable _Table _Columns context (M1 C c rep)
95+instance GTable _Table _Columns rep => GTable _Table _Columns (M1 D c rep)
9396 where
9497 gfromColumns fromColumns =
95− M1 . gfromColumns @_Table @_Columns @context @rep fromColumns
98+ M1 . gfromColumns @_Table @_Columns @rep fromColumns
9699 gtoColumns toColumns (M1 a) =
97− gtoColumns @_Table @_Columns @context @rep toColumns a
98− gtable = gtable @_Table @_Columns @context @rep
100+ gtoColumns @_Table @_Columns @rep toColumns a
101+ gtable = gtable @_Table @_Columns @rep
99102
100103
101−instance
102− ( GTable _Table _Columns context rep1
103− , GTable _Table _Columns context rep2
104− )
105− => GTable _Table _Columns context (rep1 :*: rep2)
104+instance GSerialize _Serialize _Columns exprs rep =>
105+ GSerialize _Serialize _Columns (M1 D c exprs) (M1 D c rep)
106106 where
107− gfromColumns fromColumns (HProduct a b) =
108− gfromColumns @_Table @_Columns @context @rep1 fromColumns a :*:
109− gfromColumns @_Table @_Columns @context @rep2 fromColumns b
110− gtoColumns toColumns (a :*: b) = HProduct
111− (gtoColumns @_Table @_Columns @context @rep1 toColumns a)
112− (gtoColumns @_Table @_Columns @context @rep2 toColumns b)
113− gtable table = HProduct
114− (gtable @_Table @_Columns @context @rep1 table)
115− (gtable @_Table @_Columns @context @rep2 table)
107+ gfromResult fromResult =
108+ M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult
109+ gtoResult toResult (M1 a) =
110+ gtoResult @_Serialize @_Columns @exprs @rep toResult a
116111
117112
118−instance
119− ( HTable (Eval (_Columns a))
120− , Eval (_Table a)
121− , HLabelable context
122− , KnownSymbol label
123− , meta ~ 'MetaSel ('Just label) _su _ss _ds
124− , k1 ~ K1 i a
125− )
126− => GTable _Table _Columns context (M1 S meta k1)
113+instance GTable _Table _Columns rep => GTable _Table _Columns (M1 C c rep)
127114 where
128− gfromColumns fromColumns = M1 . K1 . fromColumns . hunlabel hunlabeler
129− gtoColumns toColumns (M1 (K1 a)) = hlabel hlabeler (toColumns a)
130− gtable table = hlabel hlabeler (table (Proxy @a))
131−
132−
133−type GToExprs
134− :: (Type -> Type -> Exp Constraint)
135− -> (Type -> Exp K.HTable)
136− -> (Type -> Type) -> (Type -> Type) -> Constraint
137−class GToExprs _ToExprs _Columns exprs rep where
138− gfromResult :: ()
139− => (forall expr a proxy.
140− ( Eval (_ToExprs expr a)
141− , HTable (Eval (_Columns expr))
142− )
143− => proxy expr
144− -> Eval (_Columns expr) (Col Result)
145− -> a)
146− -> GColumns _Columns exprs (Col Result)
147− -> rep x
148− gtoResult :: ()
149− => (forall expr a proxy.
150− ( Eval (_ToExprs expr a)
151− , HTable (Eval (_Columns expr))
152− )
153− => proxy expr
154− -> a
155− -> Eval (_Columns expr) (Col Result))
156− -> rep x
157− -> GColumns _Columns exprs (Col Result)
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
158120
159121
160−instance GToExprs _ToExprs _Columns exprs rep =>
161− GToExprs _ToExprs _Columns (M1 D c exprs) (M1 D c rep)
122+instance GSerialize _Serialize _Columns exprs rep =>
123+ GSerialize _Serialize _Columns (M1 C c exprs) (M1 C c rep)
162124 where
163125 gfromResult fromResult =
164− M1 . gfromResult @_ToExprs @_Columns @exprs fromResult
126+ M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult
165127 gtoResult toResult (M1 a) =
166− gtoResult @_ToExprs @_Columns @exprs toResult a
128+ gtoResult @_Serialize @_Columns @exprs @rep toResult a
167129
168130
169−instance GToExprs _ToExprs _Columns exprs rep =>
170− GToExprs _ToExprs _Columns (M1 C c exprs) (M1 C c rep)
131+instance (GTable _Table _Columns rep1, GTable _Table _Columns rep2) =>
132+ GTable _Table _Columns (rep1 :*: rep2)
171133 where
172− gfromResult fromResult =
173− M1 . gfromResult @_ToExprs @_Columns @exprs fromResult
174− gtoResult toResult (M1 a) =
175− gtoResult @_ToExprs @_Columns @exprs toResult a
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)
176143
177144
178145instance
179− ( GToExprs _ToExprs _Columns exprs1 rep1
180− , GToExprs _ToExprs _Columns exprs2 rep2
146+ ( GSerialize _Serialize _Columns expr1 rep1
147+ , GSerialize _Serialize _Columns expr2 rep2
181148 )
182− => GToExprs _ToExprs _Columns (exprs1 :*: exprs2) (rep1 :*: rep2)
149+ => GSerialize _Serialize _Columns (expr1 :*: expr2) (rep1 :*: rep2)
183150 where
184151 gfromResult fromResult (HProduct a b) =
185− gfromResult @_ToExprs @_Columns @exprs1 fromResult a :*:
186− gfromResult @_ToExprs @_Columns @exprs2 fromResult b
152+ gfromResult @_Serialize @_Columns @expr1 @rep1 fromResult a :*:
153+ gfromResult @_Serialize @_Columns @expr2 @rep2 fromResult b
187154 gtoResult toResult (a :*: b) =
188155 HProduct
189− (gtoResult @_ToExprs @_Columns @exprs1 toResult a)
190− (gtoResult @_ToExprs @_Columns @exprs2 toResult b)
156+ (gtoResult @_Serialize @_Columns @expr1 @rep1 toResult a)
157+ (gtoResult @_Serialize @_Columns @expr2 @rep2 toResult b)
191158
192159
193160instance
194− ( Eval (_ToExprs exprs a)
195− , HTable (Eval (_Columns exprs))
196− , KnownSymbol label
161+ ( Eval (_Table a)
197162 , meta ~ 'MetaSel ('Just label) _su _ss _ds
198− , k1 ~ K1 i exprs
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
199176 , k1' ~ K1 i a
200177 )
201− => GToExprs _ToExprs _Columns (M1 S meta k1) (M1 S meta k1')
178+ => GSerialize _Serialize _Columns (M1 S meta k1) (M1 S meta k1')
202179 where
203− gfromResult fromResult =
204− M1 . K1 . fromResult (Proxy @exprs) . hunlabel hunlabeler
205− gtoResult toResult (M1 (K1 a)) =
206− hlabel hlabeler (toResult (Proxy @exprs) a)
180+ gfromResult fromResult = M1 . K1 . fromResult (Proxy @expr) . hunlabel
181+ gtoResult toResult (M1 (K1 a)) = hlabel (toResult (Proxy @expr) a)
src/Rel8/Kind/Context.hs+8−41
@@ -1,13 +1,11 @@
11{-# language DataKinds #-}
22{-# language GADTs #-}
3−{-# language LambdaCase #-}
43{-# language StandaloneKindSignatures #-}
4+{-# language TypeSynonymInstances #-}
55
66module Rel8.Kind.Context
77 ( Reifiable( contextSing )
88 , SContext(..)
9− , sReifiable
10− , sLabelable
119 )
1210where
1311
@@ -18,13 +16,9 @@ import Prelude ()
1816-- rel8
1917import Rel8.Aggregate ( Aggregate )
2018import Rel8.Expr ( Expr )
21−import Rel8.Schema.Dict ( Dict( Dict ) )
22−import Rel8.Schema.Context ( Interpretation )
23−import Rel8.Schema.Context.Label ( Labelable )
24−import Rel8.Schema.Insert ( Insert )
19+import Rel8.Schema.Field ( Field )
2520import Rel8.Schema.Kind ( Context )
2621import Rel8.Schema.Name ( Name )
27−import Rel8.Schema.Reify ( Reify )
2822import Rel8.Schema.Result ( Result )
2923
3024
@@ -32,14 +26,13 @@ type SContext :: Context -> Type
3226data SContext context where
3327 SAggregate :: SContext Aggregate
3428 SExpr :: SContext Expr
35− SInsert :: SContext Insert
29+ SField :: SContext (Field table)
3630 SName :: SContext Name
3731 SResult :: SContext Result
38− SReify :: SContext context -> SContext (Reify context)
3932
4033
4134type Reifiable :: Context -> Constraint
42−class Interpretation context => Reifiable context where
35+class Reifiable context where
4336 contextSing :: SContext context
4437
4538
@@ -51,39 +44,13 @@ instance Reifiable Expr where
5144 contextSing = SExpr
5245
5346
54−instance Reifiable Result where
55− contextSing = SResult
47+instance Reifiable (Field table) where
48+ contextSing = SField
5649
5750
58−instance Reifiable Insert where
59− contextSing = SInsert
51+instance Reifiable Result where
52+ contextSing = SResult
6053
6154
6255instance Reifiable Name where
6356 contextSing = SName
64−
65−
66−instance Reifiable context => Reifiable (Reify context) where
67− contextSing = SReify contextSing
68−
69−
70−sReifiable :: SContext context -> Dict Reifiable context
71−sReifiable = \case
72− SAggregate -> Dict
73− SExpr -> Dict
74− SInsert -> Dict
75− SName -> Dict
76− SResult -> Dict
77− SReify context -> case sReifiable context of
78− Dict -> Dict
79−
80−
81−sLabelable :: SContext context -> Dict Labelable context
82−sLabelable = \case
83− SAggregate -> Dict
84− SExpr -> Dict
85− SInsert -> Dict
86− SName -> Dict
87− SResult -> Dict
88− SReify context -> case sLabelable context of
89− Dict -> Dict
src/Rel8/Kind/Labels.hsdeleted−57
@@ -1,57 +0,0 @@
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( SNil, SCons )
12− , KnownLabels( labelsSing )
13− , renderLabels
14− )
15−where
16−
17−-- base
18−import Data.Kind ( Constraint, Type )
19−import Data.List.NonEmpty ( NonEmpty, nonEmpty )
20−import Data.Maybe ( fromMaybe )
21−import Data.Proxy ( Proxy( Proxy ) )
22−import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
23−import Prelude
24−
25−
26−type Labels :: Type
27−type Labels = [Symbol]
28−
29−
30−type SLabels :: Labels -> Type
31−data SLabels labels where
32− SNil :: SLabels '[]
33− SCons :: KnownSymbol label => Proxy label -> SLabels labels -> SLabels (label ': labels)
34−
35−
36−type KnownLabels :: Labels -> Constraint
37−class KnownLabels labels where
38− labelsSing :: SLabels labels
39−
40−
41−instance KnownLabels '[] where
42− labelsSing = SNil
43−
44−
45−instance (KnownSymbol label, KnownLabels labels) =>
46− KnownLabels (label ': labels)
47− where
48− labelsSing = SCons Proxy labelsSing
49−
50−
51−renderLabels :: SLabels labels -> NonEmpty String
52−renderLabels = fromMaybe (pure "anon") . nonEmpty . go
53− where
54− go :: SLabels labels -> [String]
55− go = \case
56− SNil -> []
57− SCons label labels -> symbolVal label : go labels
src/Rel8/Kind/Necessity.hsdeleted−38
@@ -1,38 +0,0 @@
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/Order.hs+2−9
@@ -4,7 +4,6 @@
44
55module Rel8.Order
66 ( Order(..)
7− , toOrderExprs
87 )
98where
109
@@ -17,8 +16,7 @@ import Prelude
1716import Data.Functor.Contravariant.Divisible ( Decidable, Divisible )
1817
1918-- opaleye
20−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
21−import qualified Opaleye.Internal.Order as Opaleye
19+import qualified Opaleye.Order as Opaleye
2220
2321
2422-- | An ordering expression for @a@. Primitive orderings are defined with
@@ -26,12 +24,7 @@ import qualified Opaleye.Internal.Order as Opaleye
2624-- instances.
2725--
2826-- A common pattern is to use '<>' to combine multiple orderings in sequence,
29−-- and '>$<' (from 'Contravariant') to select individual columns.
27+-- and 'Data.Functor.Contravariant.>$<' to select individual columns.
3028type Order :: Type -> Type
3129newtype Order a = Order (Opaleye.Order a)
3230 deriving newtype (Contravariant, Divisible, Decidable, Semigroup, Monoid)
33−
34−
35−toOrderExprs :: Order a -> a -> [Opaleye.OrderExpr]
36−toOrderExprs (Order (Opaleye.Order order)) a =
37− uncurry Opaleye.OrderExpr <$> order a
src/Rel8/Query.hs+181−7
@@ -1,6 +1,6 @@
1−{-# language DerivingVia #-}
2−{-# language GeneralizedNewtypeDeriving #-}
1+{-# language FlexibleContexts #-}
32{-# language StandaloneKindSignatures #-}
3+{-# language UndecidableInstances #-}
44
55module Rel8.Query
66 ( Query( Query )
@@ -8,37 +8,201 @@ module Rel8.Query
88where
99
1010-- base
11+import Control.Applicative ( liftA2 )
12+import Control.Monad ( liftM2 )
1113import Data.Kind ( Type )
14+import Data.Monoid ( Any( Any ) )
1215import Prelude
1316
1417-- opaleye
15−import qualified Opaleye.Select as 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
1623
1724-- rel8
25+import Rel8.Expr ( Expr )
1826import Rel8.Query.Set ( unionAll )
27+import Rel8.Query.Opaleye ( fromOpaleye )
1928import Rel8.Query.Values ( values )
29+import Rel8.Table ( Table, fromColumns, toColumns )
2030import Rel8.Table.Alternative
2131 ( AltTable, (<|>:)
2232 , AlternativeTable, emptyTable
2333 )
34+import Rel8.Table.Projection ( Projectable, apply, project )
2435
2536-- semigroupoids
26−import Data.Functor.Apply ( Apply, WrappedApplicative(..) )
37+import Data.Functor.Apply ( Apply, (<.>) )
2738import Data.Functor.Bind ( Bind, (>>-) )
2839
2940
3041-- | The @Query@ monad allows you to compose a @SELECT@ query. This monad has
3142-- semantics similar to the list (@[]@) monad.
3243type Query :: Type -> Type
33−newtype Query a = Query (Opaleye.Select a)
34− deriving newtype (Functor, Applicative, Monad)
35− deriving Apply via (WrappedApplicative Opaleye.Select)
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
36174
37175
38176instance Bind Query where
39177 (>>-) = (>>=)
40178
41179
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+
42206-- | '<|>:' = 'unionAll'.
43207instance AltTable Query where
44208 (<|>:) = unionAll
@@ -47,3 +211,13 @@ instance AltTable Query where
47211-- | 'emptyTable' = 'values' @[]@.
48212instance AlternativeTable Query where
49213 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+3−1
@@ -7,11 +7,13 @@ where
77
88-- base
99import Data.Kind ( Type )
10+import Data.Monoid ( Any )
1011import Prelude ()
1112
1213-- opaleye
14+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
1315import qualified Opaleye.Select as Opaleye
1416
1517
1618type Query :: Type -> Type
17−newtype Query a = Query (Opaleye.Select a)
19+newtype Query a = Query ([Opaleye.PrimExpr] -> Opaleye.Select (Any, a))
src/Rel8/Query/Aggregate.hs+22−2
@@ -1,12 +1,17 @@
11{-# language FlexibleContexts #-}
2+{-# language MonoLocalBinds #-}
3+{-# language ScopedTypeVariables #-}
4+{-# language TypeApplications #-}
25
36module Rel8.Query.Aggregate
47 ( aggregate
58 , countRows
9+ , mode
610 )
711where
812
913-- base
14+import Data.Functor.Contravariant ( (>$<) )
1015import Data.Int ( Int64 )
1116import Prelude
1217
@@ -14,18 +19,25 @@ import Prelude
1419import qualified Opaleye.Aggregate as Opaleye
1520
1621-- rel8
17−import Rel8.Aggregate ( Aggregate )
22+import Rel8.Aggregate ( Aggregates )
1823import Rel8.Expr ( Expr )
1924import Rel8.Expr.Aggregate ( countStar )
25+import Rel8.Expr.Order ( desc )
2026import Rel8.Query ( Query )
27+import Rel8.Query.Limit ( limit )
2128import Rel8.Query.Maybe ( optional )
2229import 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 )
2335import Rel8.Table.Opaleye ( aggregator )
2436import Rel8.Table.Maybe ( maybeTable )
2537
2638
2739-- | Apply an aggregation to all rows returned by a 'Query'.
28−aggregate :: Query (Aggregate exprs) -> Query exprs
40+aggregate :: Aggregates aggregates exprs => Query aggregates -> Query exprs
2941aggregate = mapOpaleye (Opaleye.aggregate aggregator)
3042
3143
@@ -34,3 +46,11 @@ aggregate = mapOpaleye (Opaleye.aggregate aggregator)
3446-- will return @0@.
3547countRows :: Query a -> Query (Expr Int64)
3648countRows = fmap (maybeTable 0 id) . optional . aggregate . fmap (const countStar)
49+
50+
51+-- | Return the most common row in a query.
52+mode :: forall a. EqTable a => Query a -> Query a
53+mode rows = limit 1 $ fmap (fromCols . snd) $ orderBy (fst >$< desc) $ do
54+ aggregate $ do
55+ row <- toColumns <$> rows
56+ pure (countStar, Cols $ hgroupBy (eqTable @a) row)
src/Rel8/Query/Distinct.hs+4−9
@@ -1,5 +1,3 @@
1−{-# options_ghc -fno-warn-redundant-constraints #-}
2−
31module Rel8.Query.Distinct
42 ( distinct
53 , distinctOn
@@ -8,12 +6,11 @@ module Rel8.Query.Distinct
86where
97
108-- base
11−import Prelude
9+import Prelude ()
1210
1311-- opaleye
1412import qualified Opaleye.Distinct as Opaleye
15−import qualified Opaleye.Internal.Order as Opaleye
16−import qualified Opaleye.Internal.QueryArr as Opaleye
13+import qualified Opaleye.Order as Opaleye
1714
1815-- rel8
1916import Rel8.Order ( Order( Order ) )
@@ -33,13 +30,11 @@ distinct = mapOpaleye (Opaleye.distinctExplicit distinctspec)
3330-- to a projection. If multiple rows have the same projection, it is
3431-- unspecified which row will be returned. If this matters, use 'distinctOnBy'.
3532distinctOn :: EqTable b => (a -> b) -> Query a -> Query a
36−distinctOn proj =
37− mapOpaleye (\q -> Opaleye.productQueryArr (Opaleye.distinctOn unpackspec proj . Opaleye.runSimpleQueryArr q))
33+distinctOn proj = mapOpaleye (Opaleye.distinctOnExplicit unpackspec proj)
3834
3935
4036-- | Select all distinct rows from a query, where rows are equivalent according
4137-- to a projection. If there are multiple rows with the same projection, the
4238-- first row according to the specified 'Order' will be returned.
4339distinctOnBy :: EqTable b => (a -> b) -> Order a -> Query a -> Query a
44−distinctOnBy proj (Order order) =
45− mapOpaleye (\q -> Opaleye.productQueryArr (Opaleye.distinctOnBy unpackspec proj order . Opaleye.runSimpleQueryArr q))
40+distinctOnBy proj (Order order) = mapOpaleye (Opaleye.distinctOnByExplicit unpackspec proj order)
src/Rel8/Query/Each.hs+3−3
@@ -17,7 +17,7 @@ import Rel8.Query ( Query )
1717import Rel8.Query.Opaleye ( fromOpaleye )
1818import Rel8.Schema.Name ( Selects )
1919import Rel8.Schema.Table ( TableSchema )
20−import Rel8.Table ( fromColumns, toColumns )
20+import Rel8.Table.Cols ( fromCols, toCols )
2121import Rel8.Table.Opaleye ( table, unpackspec )
2222
2323
@@ -25,8 +25,8 @@ import Rel8.Table.Opaleye ( table, unpackspec )
2525-- table@.
2626each :: Selects names exprs => TableSchema names -> Query exprs
2727each =
28− fmap fromColumns .
28+ fmap fromCols .
2929 fromOpaleye .
3030 Opaleye.selectTableExplicit unpackspec .
3131 table .
32− fmap toColumns
32+ fmap toCols
src/Rel8/Query/Either.hs+27−17
@@ -3,23 +3,22 @@
33module Rel8.Query.Either
44 ( keepLeftTable
55 , keepRightTable
6− , bindEitherTable
76 , bitraverseEitherTable
87 )
98where
109
1110-- base
12−import Data.Functor ( (<&>) )
1311import Prelude
1412
13+-- comonad
14+import Control.Comonad ( extract )
15+
1516-- rel8
1617import Rel8.Expr ( Expr )
1718import Rel8.Expr.Eq ( (==.) )
1819import Rel8.Query ( Query )
1920import Rel8.Query.Filter ( where_ )
2021import Rel8.Query.Maybe ( optional )
21−import Rel8.Table ( Table )
22−import Rel8.Table.Bool ( bool )
2322import Rel8.Table.Either
2423 ( EitherTable( EitherTable )
2524 , isLeftTable, isRightTable
@@ -27,30 +26,41 @@ import Rel8.Table.Either
2726import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
2827
2928
30−keepLeftTable :: EitherTable a b -> Query a
29+-- | Filter 'EitherTable's, keeping only 'leftTable's.
30+keepLeftTable :: EitherTable Expr a b -> Query a
3131keepLeftTable e@(EitherTable _ a _) = do
3232 where_ $ isLeftTable e
33− pure a
33+ pure (extract a)
3434
3535
36−keepRightTable :: EitherTable a b -> Query b
36+-- | Filter 'EitherTable's, keeping only 'rightTable's.
37+keepRightTable :: EitherTable Expr a b -> Query b
3738keepRightTable e@(EitherTable _ _ b) = do
3839 where_ $ isRightTable e
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
40+ pure (extract b)
4741
4842
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+-- ]
4959bitraverseEitherTable :: ()
5060 => (a -> Query c)
5161 -> (b -> Query d)
52− -> EitherTable a b
53− -> Query (EitherTable c d)
62+ -> EitherTable Expr a b
63+ -> Query (EitherTable Expr c d)
5464bitraverseEitherTable f g e@(EitherTable tag _ _) = do
5565 mc@(MaybeTable _ c) <- optional (f =<< keepLeftTable e)
5666 md@(MaybeTable _ d) <- optional (g =<< keepRightTable e)
src/Rel8/Query/Evaluate.hsnew file+49
@@ -0,0 +1,49 @@
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+15−17
@@ -2,8 +2,8 @@
22
33module Rel8.Query.Exists
44 ( exists, inQuery
5− , whereExists, with, withBy
6− , whereNotExists, without, withoutBy
5+ , present, with, withBy
6+ , absent, without, withoutBy
77 )
88where
99
@@ -11,56 +11,54 @@ where
1111import Prelude hiding ( filter )
1212
1313-- opaleye
14+import qualified Opaleye.Exists as Opaleye
1415import qualified Opaleye.Operators as Opaleye
1516
1617-- rel8
1718import Rel8.Expr ( Expr )
19+import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )
1820import Rel8.Query ( Query )
1921import Rel8.Query.Filter ( filter )
20−import Rel8.Query.Maybe ( optional )
2122import Rel8.Query.Opaleye ( mapOpaleye )
2223import 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 isJustTable . optional . whereExists
29−-- FIXME: change this when b7aacc07c6392654cae439fc3b997620c3aa7a87 makes it
30−-- into a release of Opaleye
28+exists = fmap (fromPrimExpr . fromColumn) . mapOpaleye Opaleye.exists
3129
3230
3331inQuery :: EqTable a => a -> Query a -> Query (Expr Bool)
3432inQuery a = exists . (>>= filter (a ==:))
3533
3634
37−-- | Produce the empty query if the given query returns no rows. @whereExists@
35+-- | Produce the empty query if the given query returns no rows. @present@
3836-- is equivalent to @WHERE EXISTS@ in SQL.
39−whereExists :: Query a -> Query ()
40−whereExists = mapOpaleye Opaleye.restrictExists
37+present :: Query a -> Query ()
38+present = mapOpaleye Opaleye.restrictExists
4139
4240
43−-- | Produce the empty query if the given query returns rows. @whereNotExists@
41+-- | Produce the empty query if the given query returns rows. @absent@
4442-- is equivalent to @WHERE NOT EXISTS@ in SQL.
45−whereNotExists :: Query a -> Query ()
46−whereNotExists = mapOpaleye Opaleye.restrictNotExists
43+absent :: Query a -> Query ()
44+absent = mapOpaleye Opaleye.restrictNotExists
4745
4846
4947-- | @with@ is similar to 'filter', but allows the predicate to be a full query.
5048--
51−-- @with f a = a <$ whereExists (f a)@, but this form matches 'filter'.
49+-- @with f a = a <$ present (f a)@, but this form matches 'filter'.
5250with :: (a -> Query b) -> a -> Query a
53−with f a = a <$ whereExists (f a)
51+with f a = a <$ present (f a)
5452
5553
5654-- | Like @with@, but with a custom membership test.
57−withBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a
55+withBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a
5856withBy predicate bs = with $ \a -> bs >>= filter (predicate a)
5957
6058
6159-- | Filter rows where @a -> Query b@ yields no rows.
6260without :: (a -> Query b) -> a -> Query a
63−without f a = a <$ whereNotExists (f a)
61+without f a = a <$ absent (f a)
6462
6563
6664-- | Like @without@, but with a custom membership test.
src/Rel8/Query/Indexed.hsnew file+21
@@ -0,0 +1,21 @@
1+module Rel8.Query.Indexed
2+ ( indexed
3+ )
4+where
5+
6+-- base
7+import Control.Applicative ( liftA2 )
8+import Data.Int ( Int64 )
9+import Prelude
10+
11+-- rel8
12+import Rel8.Expr ( Expr )
13+import Rel8.Expr.Window ( rowNumber )
14+import Rel8.Query ( Query )
15+import Rel8.Query.Window ( window )
16+import Rel8.Table.Window ( currentRow )
17+
18+
19+-- | Pair each row of a query with its index within the query.
20+indexed :: Query a -> Query (Expr Int64, a)
21+indexed = window (liftA2 (,) (subtract 1 <$> rowNumber) currentRow)
src/Rel8/Query/List.hs+93−14
@@ -1,23 +1,58 @@
11{-# language FlexibleContexts #-}
2+{-# language GADTs #-}
3+{-# language NamedFieldPuns #-}
24
35module Rel8.Query.List
46 ( many, some
7+ , manyExpr, someExpr
8+ , catListTable, catNonEmptyTable
9+ , catList, catNonEmpty
510 )
611where
712
813-- base
14+import Data.Functor.Identity ( runIdentity )
15+import Data.List.NonEmpty ( NonEmpty )
916import Prelude
1017
18+-- opaleye
19+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
20+
1121-- rel8
1222import Rel8.Expr ( Expr )
23+import Rel8.Expr.Aggregate ( listAggExpr, nonEmptyAggExpr )
24+import Rel8.Expr.Opaleye ( mapPrimExpr )
1325import Rel8.Query ( Query )
1426import Rel8.Query.Aggregate ( aggregate )
1527import Rel8.Query.Maybe ( optional )
16−import Rel8.Table ( Table )
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 )
1734import Rel8.Table.Aggregate ( listAgg, nonEmptyAgg )
18−import Rel8.Table.List ( ListTable )
35+import Rel8.Table.List ( ListTable( ListTable ) )
1936import Rel8.Table.Maybe ( maybeTable )
20−import Rel8.Table.NonEmpty ( NonEmptyTable )
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)
2156
2257
2358-- | Aggregate a 'Query' into a 'NonEmptyTable'. If the supplied query returns
@@ -28,16 +63,60 @@ import Rel8.Table.NonEmpty ( NonEmptyTable )
2863--
2964-- @some@ is analogous to 'Control.Applicative.some' from
3065-- @Control.Applicative@.
31−some :: Table Expr a => Query a -> Query (NonEmptyTable a)
32−some = aggregate . fmap nonEmptyAgg
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)
3371
3472
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
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
117+
118+
119+sunnest :: TypeInformation (Unnullify a) -> Expr (list a) -> Expr a
120+sunnest info = mapPrimExpr $
121+ extractArrayElement info .
122+ Opaleye.UnExpr (Opaleye.UnOpOther "UNNEST")
src/Rel8/Query/Maybe.hs+26−45
@@ -1,7 +1,10 @@
1+{-# language GADTs #-}
2+{-# language LambdaCase #-}
3+{-# language NamedFieldPuns #-}
4+
15module Rel8.Query.Maybe
26 ( optional
37 , catMaybeTable
4− , bindMaybeTable
58 , traverseMaybeTable
69 )
710where
@@ -9,23 +12,20 @@ where
912-- base
1013import Prelude
1114
15+-- comonad
16+import Control.Comonad ( extract )
17+
1218-- 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
19+import qualified Opaleye.Internal.MaybeFields as Opaleye
1820
1921-- rel8
20−import Rel8.Expr.Bool ( true )
22+import Rel8.Expr ( Expr )
2123import Rel8.Expr.Eq ( (==.) )
22−import Rel8.Expr.Opaleye ( toPrimExpr )
24+import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )
2325import Rel8.Query ( Query )
2426import Rel8.Query.Filter ( where_ )
2527import Rel8.Query.Opaleye ( mapOpaleye )
26−import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
27−import Rel8.Table.Opaleye ( unpackspec )
28−import Rel8.Table.Tag ( Tag(..), fromExpr )
28+import Rel8.Table.Maybe ( MaybeTable(..), isJustTable )
2929
3030
3131-- | Convert a query that might return zero rows to a query that always returns
@@ -33,18 +33,11 @@ import Rel8.Table.Tag ( Tag(..), fromExpr )
3333--
3434-- To speak in more concrete terms, 'optional' is most useful to write @LEFT
3535-- JOIN@s.
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
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+ }
4841
4942
5043-- | Filter out 'MaybeTable's, returning only the tables that are not-null.
@@ -52,36 +45,24 @@ optional = mapOpaleye $ Opaleye.QueryArr . go
5245-- This operation can be used to "undo" the effect of 'optional', which
5346-- operationally is like turning a @LEFT JOIN@ back into a full @JOIN@. You
5447-- can think of this as analogous to 'Data.Maybe.catMaybes'.
55−catMaybeTable :: MaybeTable a -> Query a
48+catMaybeTable :: MaybeTable Expr a -> Query a
5649catMaybeTable ma@(MaybeTable _ a) = do
5750 where_ $ isJustTable ma
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
51+ pure (extract a)
7352
7453
7554-- | Extend an optional query with another query. This is useful if you want
7655-- to step through multiple @LEFT JOINs@.
7756--
7857-- Note that @traverseMaybeTable@ takes a @a -> Query b@ function, which means
79−-- you also have the ability to "expand" one row into multiple rows. If the
58+-- you also have the ability to "expand" one row into multiple rows. If the
8059-- @a -> Query b@ function returns no rows, then the resulting query will also
8160-- have no rows. However, regardless of the given @a -> Query b@ function, if
82−-- the input is @noTable@, you will always get exactly one @noTable@ back.
83−traverseMaybeTable :: (a -> Query b) -> MaybeTable a -> Query (MaybeTable b)
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)
8464traverseMaybeTable query ma@(MaybeTable input _) = do
85− MaybeTable output b <- optional (query =<< catMaybeTable ma)
86− where_ $ expr output ==. expr input
87− pure $ MaybeTable input b
65+ optional (query =<< catMaybeTable ma) >>= \case
66+ MaybeTable output b -> do
67+ where_ $ output ==. input
68+ pure $ MaybeTable input b
src/Rel8/Query/Null.hs+15
@@ -1,5 +1,8 @@
1+{-# language FlexibleContexts #-}
2+
13module Rel8.Query.Null
24 ( catNull
5+ , catNullTable
36 )
47where
58
@@ -9,6 +12,8 @@ import Prelude
912-- rel8
1013import Rel8.Expr ( Expr )
1114import Rel8.Expr.Null ( isNonNull, unsafeUnnullify )
15+import Rel8.Table ( Table )
16+import Rel8.Table.Null ( NullTable, isNonNullTable, unsafeUnnullifyTable )
1217import Rel8.Query ( Query )
1318import Rel8.Query.Filter ( where_ )
1419
@@ -21,3 +26,13 @@ catNull :: Expr (Maybe a) -> Query (Expr a)
2126catNull a = do
2227 where_ $ isNonNull a
2328 pure $ unsafeUnnullify a
29+
30+
31+-- | Filter a 'Query' that might return @nullTable@ to a 'Query' without any
32+-- @nullTable@s.
33+--
34+-- Corresponds to 'Data.Maybe.catMaybes'.
35+catNullTable :: Table Expr a => NullTable Expr a -> Query a
36+catNullTable a = do
37+ where_ $ isNonNullTable a
38+ pure $ unsafeUnnullifyTable a
src/Rel8/Query/Opaleye.hs+41−5
@@ -1,34 +1,70 @@
1+{-# language TupleSections #-}
2+
13module Rel8.Query.Opaleye
24 ( fromOpaleye
35 , toOpaleye
46 , mapOpaleye
57 , zipOpaleyeWith
8+ , unsafePeekQuery
69 )
710where
811
912-- base
13+import Control.Applicative ( liftA2 )
1014import Prelude
1115
1216-- opaleye
13−import qualified Opaleye.Select as Opaleye
17+import qualified Opaleye.Internal.QueryArr as Opaleye
18+import qualified Opaleye.Internal.Tag as Opaleye
1419
1520-- rel8
1621import {-# SOURCE #-} Rel8.Query ( Query( Query ) )
1722
1823
1924fromOpaleye :: Opaleye.Select a -> Query a
20−fromOpaleye = Query
25+fromOpaleye = Query . pure . fmap pure
2126
2227
2328toOpaleye :: Query a -> Opaleye.Select a
24−toOpaleye (Query a) = a
29+toOpaleye (Query a) = snd <$> a mempty
2530
2631
2732mapOpaleye :: (Opaleye.Select a -> Opaleye.Select b) -> Query a -> Query b
28−mapOpaleye f = fromOpaleye . f . toOpaleye
33+mapOpaleye f (Query a) = Query (fmap (mapping f) a)
2934
3035
3136zipOpaleyeWith :: ()
3237 => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)
3338 -> Query a -> Query b -> Query c
34−zipOpaleyeWith f a b = fromOpaleye $ f (toOpaleye a) (toOpaleye b)
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
src/Rel8/Query/Rebind.hsnew file+27
@@ -0,0 +1,27 @@
1+{-# language FlexibleContexts #-}
2+
3+module Rel8.Query.Rebind
4+ ( rebind
5+ )
6+where
7+
8+-- base
9+import Prelude
10+import Control.Arrow ((<<<))
11+
12+-- opaleye
13+import qualified Opaleye.Internal.Rebind as Opaleye
14+
15+-- rel8
16+import Rel8.Expr ( Expr )
17+import Rel8.Query ( Query )
18+import Rel8.Table ( Table )
19+import Rel8.Table.Opaleye ( unpackspec )
20+import Rel8.Query.Opaleye (fromOpaleye)
21+
22+
23+-- | 'rebind' takes a variable name, some expressions, and binds each of them
24+-- to a new variable in the SQL. The @a@ returned consists only of these
25+-- variables. It's essentially a @let@ binding for Postgres expressions.
26+rebind :: Table Expr a => String -> a -> Query a
27+rebind prefix a = fromOpaleye (Opaleye.rebindExplicitPrefix prefix unpackspec <<< pure a)
src/Rel8/Query/SQL.hs+6−59
@@ -1,74 +1,21 @@
11{-# language FlexibleContexts #-}
2−{-# language TypeFamilies #-}
3−{-# language ViewPatterns #-}
2+{-# language MonoLocalBinds #-}
43
54module Rel8.Query.SQL
65 ( showQuery
7− , sqlForQuery, sqlForQueryWithNames
86 )
97where
108
119-- base
12−import Data.Foldable ( fold )
13−import Data.Functor.Const ( Const( Const ), getConst )
14−import Data.Void ( Void )
1510import Prelude
1611
17−-- opaleye
18−import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye
19−import qualified Opaleye.Internal.PrimQuery as Opaleye
20−import qualified Opaleye.Internal.Print as Opaleye
21−import qualified Opaleye.Internal.Optimize as Opaleye
22−import qualified Opaleye.Internal.QueryArr as Opaleye hiding ( Select )
23−import qualified Opaleye.Internal.Sql as Opaleye
24−
2512-- rel8
26−import Rel8.Expr ( Expr, Col(..) )
27−import Rel8.Expr.Opaleye ( toPrimExpr )
13+import Rel8.Expr ( Expr )
2814import Rel8.Query ( Query )
29−import Rel8.Query.Opaleye ( toOpaleye )
30−import Rel8.Schema.Name ( Selects, Col(..) )
31−import Rel8.Schema.HTable ( htabulateA, hfield )
32−import Rel8.Table ( Table, toColumns )
33−import Rel8.Table.Name ( namesFromLabels )
34−import Rel8.Table.Opaleye ( castTable )
15+import Rel8.Statement.Select ( ppSelect )
16+import Rel8.Table ( Table )
3517
3618
37−-- | Convert a query to a 'String' containing the query as a @SELECT@
38−-- statement.
19+-- | Convert a 'Query' to a 'String' containing a @SELECT@ statement.
3920showQuery :: Table Expr a => Query a -> String
40−showQuery = fold . sqlForQuery
41−
42−
43−sqlForQuery :: Table Expr a
44− => Query a -> Maybe String
45−sqlForQuery = sqlForQueryWithNames namesFromLabels . fmap toColumns
46−
47−
48−sqlForQueryWithNames :: Selects names exprs
49− => names -> Query exprs -> Maybe String
50−sqlForQueryWithNames names query =
51− show . Opaleye.ppSql . selectFrom names exprs <$> optimize primQuery
52− where
53− (exprs, primQuery, _) =
54− Opaleye.runSimpleQueryArrStart (toOpaleye query) ()
55−
56−
57−optimize :: Opaleye.PrimQuery' a -> Maybe (Opaleye.PrimQuery' Void)
58−optimize = Opaleye.removeEmpty . Opaleye.optimize
59−
60−
61−selectFrom :: Selects names exprs
62− => names -> exprs -> Opaleye.PrimQuery' Void -> Opaleye.Select
63−selectFrom (toColumns -> names) (toColumns . castTable -> exprs) query =
64− Opaleye.SelectFrom $ Opaleye.newSelect
65− { Opaleye.attrs = Opaleye.SelectAttrs attributes
66− , Opaleye.tables = Opaleye.oneTable select
67− }
68− where
69− select = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator query
70− attributes = getConst $ htabulateA $ \field -> case hfield names field of
71− NameCol name -> case hfield exprs field of
72− DB (toPrimExpr -> expr) -> Const (pure (makeAttr name expr))
73− makeAttr label expr =
74− (Opaleye.sqlExpr expr, Just (Opaleye.SqlColumn label))
21+showQuery = show . ppSelect
src/Rel8/Query/Set.hs+6−6
@@ -23,36 +23,36 @@ import Rel8.Table.Opaleye ( binaryspec )
2323
2424
2525-- | Combine the results of two queries of the same type, collapsing
26−-- duplicates. @union a b@ is the same as the SQL statement @x UNION b@.
26+-- duplicates. @union a b@ is the same as the SQL statement @a UNION b@.
2727union :: EqTable a => Query a -> Query a -> Query a
2828union = zipOpaleyeWith (Opaleye.unionExplicit binaryspec)
2929
3030
3131-- | Combine the results of two queries of the same type, retaining duplicates.
32−-- @unionAll a b@ is the same as the SQL statement @x UNION ALL b@.
32+-- @unionAll a b@ is the same as the SQL statement @a UNION ALL b@.
3333unionAll :: Table Expr a => Query a -> Query a -> Query a
3434unionAll = zipOpaleyeWith (Opaleye.unionAllExplicit binaryspec)
3535
3636
3737-- | Find the intersection of two queries, collapsing duplicates. @intersect a
38−-- b@ is the same as the SQL statement @x INTERSECT b@.
38+-- b@ is the same as the SQL statement @a INTERSECT b@.
3939intersect :: EqTable a => Query a -> Query a -> Query a
4040intersect = zipOpaleyeWith (Opaleye.intersectExplicit binaryspec)
4141
4242
4343-- | Find the intersection of two queries, retaining duplicates. @intersectAll
44−-- a b@ is the same as the SQL statement @x INTERSECT ALL b@.
44+-- a b@ is the same as the SQL statement @a INTERSECT ALL b@.
4545intersectAll :: EqTable a => Query a -> Query a -> Query a
4646intersectAll = zipOpaleyeWith (Opaleye.intersectAllExplicit binaryspec)
4747
4848
4949-- | Find the difference of two queries, collapsing duplicates @except a b@ is
50−-- the same as the SQL statement @x INTERSECT b@.
50+-- the same as the SQL statement @a EXCEPT b@.
5151except :: EqTable a => Query a -> Query a -> Query a
5252except = zipOpaleyeWith (Opaleye.exceptExplicit binaryspec)
5353
5454
5555-- | Find the difference of two queries, retaining duplicates. @exceptAll a b@
56−-- is the same as the SQL statement @x EXCEPT ALL b@.
56+-- is the same as the SQL statement @a EXCEPT ALL b@.
5757exceptAll :: EqTable a => Query a -> Query a -> Query a
5858exceptAll = zipOpaleyeWith (Opaleye.exceptAllExplicit binaryspec)
src/Rel8/Query/These.hs+52−45
@@ -1,4 +1,5 @@
11{-# language FlexibleContexts #-}
2+{-# language GADTs #-}
23
34module Rel8.Query.These
45 ( alignBy
@@ -7,7 +8,6 @@ module Rel8.Query.These
78 , keepThisTable, loseThisTable
89 , keepThatTable, loseThatTable
910 , keepThoseTable, loseThoseTable
10− , bindTheseTable
1111 , bitraverseTheseTable
1212 )
1313where
@@ -15,27 +15,29 @@ where
1515-- base
1616import Prelude
1717
18+-- comonad
19+import Control.Comonad ( extract )
20+
1821-- opaleye
19−import qualified Opaleye.Internal.Join as Opaleye
22+import qualified Opaleye.Internal.PackMap as Opaleye
2023import qualified Opaleye.Internal.PrimQuery as Opaleye
24+import qualified Opaleye.Internal.QueryArr as Opaleye
25+import qualified Opaleye.Internal.Tag as Opaleye
2126
2227-- rel8
2328import Rel8.Expr ( Expr )
2429import Rel8.Expr.Bool ( boolExpr, not_ )
2530import Rel8.Expr.Eq ( (==.) )
26−import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
31+import Rel8.Expr.Opaleye ( toPrimExpr, traversePrimExpr )
2732import Rel8.Expr.Serialize ( litExpr )
2833import Rel8.Query ( Query )
2934import Rel8.Query.Filter ( where_ )
3035import Rel8.Query.Maybe ( optional )
3136import Rel8.Query.Opaleye ( zipOpaleyeWith )
32−import Rel8.Table ( Table )
3337import Rel8.Table.Either ( EitherTable( EitherTable ) )
3438import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
35−import Rel8.Table.Opaleye ( unpackspec )
36−import Rel8.Table.Tag ( Tag(..) )
3739import Rel8.Table.These
38− ( TheseTable( TheseTable )
40+ ( TheseTable( TheseTable, here, there )
3941 , hasHereTable, hasThereTable
4042 , isThisTable, isThatTable, isThoseTable
4143 )
@@ -43,86 +45,91 @@ import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) )
4345
4446
4547-- | Corresponds to a @FULL OUTER JOIN@ between two queries.
46−alignBy :: (Table Expr a, Table Expr b)
48+alignBy :: ()
4749 => (a -> b -> Expr Bool)
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)
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)
6075keepHereTable = loseThatTable
6176
6277
63−loseHereTable :: TheseTable a b -> Query b
78+loseHereTable :: TheseTable Expr a b -> Query b
6479loseHereTable = keepThatTable
6580
6681
67−keepThereTable :: TheseTable a b -> Query (MaybeTable a, b)
82+keepThereTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)
6883keepThereTable = loseThisTable
6984
7085
71−loseThereTable :: TheseTable a b -> Query a
86+loseThereTable :: TheseTable Expr a b -> Query a
7287loseThereTable = keepThisTable
7388
7489
75−keepThisTable :: TheseTable a b -> Query a
90+keepThisTable :: TheseTable Expr a b -> Query a
7691keepThisTable t@(TheseTable (MaybeTable _ a) _) = do
7792 where_ $ isThisTable t
78− pure a
93+ pure (extract a)
7994
8095
81−loseThisTable :: TheseTable a b -> Query (MaybeTable a, b)
96+loseThisTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)
8297loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do
8398 where_ $ not_ $ isThisTable t
84− pure (ma, b)
99+ pure (ma, extract b)
85100
86101
87−keepThatTable :: TheseTable a b -> Query b
102+keepThatTable :: TheseTable Expr a b -> Query b
88103keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do
89104 where_ $ isThatTable t
90− pure b
105+ pure (extract b)
91106
92107
93−loseThatTable :: TheseTable a b -> Query (a, MaybeTable b)
108+loseThatTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)
94109loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do
95110 where_ $ not_ $ isThatTable t
96− pure (a, mb)
111+ pure (extract a, mb)
97112
98113
99−keepThoseTable :: TheseTable a b -> Query (a, b)
114+keepThoseTable :: TheseTable Expr a b -> Query (a, b)
100115keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
101116 where_ $ isThoseTable t
102− pure (a, b)
117+ pure (extract a, extract b)
103118
104119
105−loseThoseTable :: TheseTable a b -> Query (EitherTable a b)
120+loseThoseTable :: TheseTable Expr a b -> Query (EitherTable Expr a b)
106121loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
107122 where_ $ not_ $ isThoseTable t
108− pure $ EitherTable result a b
123+ pure $ EitherTable tag a b
109124 where
110125 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)
119126
120127
121128bitraverseTheseTable :: ()
122129 => (a -> Query c)
123130 -> (b -> Query d)
124− -> TheseTable a b
125− -> Query (TheseTable c d)
131+ -> TheseTable Expr a b
132+ -> Query (TheseTable Expr c d)
126133bitraverseTheseTable f g t = do
127134 mc <- optional (f . fst =<< keepHereTable t)
128135 md <- optional (g . snd =<< keepThereTable t)
src/Rel8/Query/Window.hsnew file+26
@@ -0,0 +1,26 @@
1+module Rel8.Query.Window
2+ ( window
3+ )
4+where
5+
6+-- base
7+import Prelude ()
8+
9+-- opaleye
10+import qualified Opaleye.Window as Opaleye
11+
12+-- rel8
13+import Rel8.Query ( Query )
14+import Rel8.Query.Opaleye ( mapOpaleye )
15+import Rel8.Window ( Window( Window ) )
16+
17+
18+-- | 'window' runs a query composed of expressions containing
19+-- [window functions](https://www.postgresql.org/docs/current/tutorial-window.html).
20+-- 'window' is similar to 'Rel8.aggregate', with the main difference being
21+-- that in a window query, each input row corresponds to one output row,
22+-- whereas aggregation queries fold the entire input query down into a single
23+-- row. To put this into a Haskell context, 'Rel8.aggregate' is to 'foldl' as
24+-- 'window' is to 'scanl'.
25+window :: Window a b -> Query a -> Query b
26+window (Window a) = mapOpaleye (Opaleye.runWindows a)
src/Rel8/Schema/Context.hsdeleted−20
@@ -1,20 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language StandaloneKindSignatures #-}
3−{-# language TypeFamilies #-}
4−
5−module Rel8.Schema.Context
6− ( Interpretation( Col )
7− )
8−where
9−
10−-- base
11−import Data.Kind ( Constraint )
12−import Prelude ()
13−
14−-- rel8
15−import Rel8.Schema.Kind ( Context, HContext )
16−
17−
18−type Interpretation :: Context -> Constraint
19−class Interpretation context where
20− data Col context :: HContext
src/Rel8/Schema/Context/Label.hsdeleted−60
@@ -1,60 +0,0 @@
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.Kind ( Constraint )
15−import Prelude hiding ( null )
16−
17−-- rel8
18−import Rel8.Schema.Context ( Interpretation )
19−import Rel8.Schema.Dict ( Dict( Dict ) )
20−import Rel8.Schema.Kind ( Context, HContext )
21−import Rel8.Schema.Spec ( Spec( Spec ) )
22−import Rel8.Schema.Result ( Col( Result ), Result )
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 Result 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+105−149
@@ -1,188 +1,144 @@
11{-# language DataKinds #-}
2+{-# language EmptyCase #-}
23{-# language FlexibleContexts #-}
3−{-# language FlexibleInstances #-}
4−{-# language InstanceSigs #-}
5−{-# language MultiParamTypeClasses #-}
4+{-# language GADTs #-}
5+{-# language LambdaCase #-}
66{-# language NamedFieldPuns #-}
7−{-# language ScopedTypeVariables #-}
87{-# language StandaloneKindSignatures #-}
9−{-# language TypeFamilies #-}
108
119module Rel8.Schema.Context.Nullify
12− ( Nullifiable( ConstrainTag, encodeTag, decodeTag, nullifier, unnullifier )
13− , HNullifiable( HConstrainTag, hencodeTag, hdecodeTag, hnullifier, hunnullifier )
14− , runTag, unnull
10+ ( Nullifiability(..), NonNullifiability(..), nullifiableOrNot, absurd
11+ , Nullifiable, nullifiability
12+ , guarder, nullifier, unnullifier
13+ , sguard, snullify
1514 )
1615where
1716
1817-- base
18+import Data.Bool ( bool )
19+import Data.Functor.Identity ( Identity( Identity ) )
1920import Data.Kind ( Constraint, Type )
20−import GHC.TypeLits ( KnownSymbol )
2121import Prelude hiding ( null )
2222
2323-- opaleye
2424import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
2525
2626-- rel8
27−import Rel8.Aggregate
28− ( Aggregate, Col(..)
29− , mapInputs
30− , unsafeMakeAggregate
31− )
32−import Rel8.Expr ( Expr, Col(..) )
27+import Rel8.Aggregate ( Aggregate(..), zipOutputs )
28+import Rel8.Expr ( Expr )
3329import Rel8.Expr.Bool ( boolExpr )
3430import Rel8.Expr.Null ( nullify, unsafeUnnullify )
35−import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
36−import Rel8.Kind.Necessity ( Necessity( Required ) )
37−import Rel8.Schema.Context ( Interpretation )
31+import Rel8.Expr.Opaleye ( fromPrimExpr )
32+import Rel8.Kind.Context ( SContext(..) )
33+import Rel8.Schema.Field ( Field )
3834import qualified Rel8.Schema.Kind as K
39−import Rel8.Schema.Name ( Name( Name ), Col(..) )
40−import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql )
41−import Rel8.Schema.Dict ( Dict( Dict ) )
42−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
43−import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
44−import qualified Rel8.Schema.Spec.ConstrainDBType as ConstrainDBType
45−import Rel8.Table.Tag ( Tag(..), Taggable, fromAggregate, fromExpr, fromName )
46−
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(..) )
4739
48−type Nullifiable :: K.Context -> Constraint
49−class Interpretation context => Nullifiable context where
50− type ConstrainTag context :: Type -> Constraint
51− type ConstrainTag _context = DefaultConstrainTag
52−
53− encodeTag ::
54− ( Sql (ConstrainTag context) a
55− , KnownSymbol label
56− , Taggable a
57− )
58− => Tag label a
59− -> Col context ('Spec labels 'Required a)
60−
61− decodeTag ::
62− ( Sql (ConstrainTag context) a
63− , KnownSymbol label
64− , Taggable a
65− )
66− => Col context ('Spec labels 'Required a)
67− -> Tag label a
68−
69− nullifier :: ()
70− => Tag label a
71− -> (Expr a -> Expr Bool)
72− -> SSpec ('Spec labels necessity x)
73− -> Col context ('Spec labels necessity x)
74− -> Col context ('Spec labels necessity (Nullify x))
75−
76− unnullifier :: ()
77− => SSpec ('Spec labels necessity x)
78− -> Col context ('Spec labels necessity (Nullify x))
79− -> Col context ('Spec labels necessity x)
8040
41+type Nullifiability :: K.Context -> Type
42+data Nullifiability context where
43+ NAggregate :: Nullifiability Aggregate
44+ NExpr :: Nullifiability Expr
45+ NName :: Nullifiability Name
8146
82−instance Nullifiable Aggregate where
83− encodeTag Tag {aggregator, expr} =
84− Aggregation $ unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr
8547
86− decodeTag (Aggregation aggregate) = fromAggregate aggregate
87−
88− nullifier Tag {expr} test SSpec {nullity} (Aggregation aggregate) =
89− Aggregation $
90− mapInputs (toPrimExpr . runTag nullity condition . fromPrimExpr) $
91− runTag nullity condition <$> aggregate
92− where
93− condition = test expr
48+type Nullifiable :: K.Context -> Constraint
49+class Nullifiable context where
50+ nullifiability :: Nullifiability context
9451
95− unnullifier SSpec {nullity} (Aggregation aggregate) =
96− Aggregation $ unnull nullity <$> aggregate
9752
98− {-# INLINABLE encodeTag #-}
99− {-# INLINABLE decodeTag #-}
100− {-# INLINABLE nullifier #-}
101− {-# INLINABLE unnullifier #-}
53+instance Nullifiable Aggregate where
54+ nullifiability = NAggregate
10255
10356
10457instance Nullifiable Expr where
105− encodeTag Tag {expr} = DB expr
106− decodeTag (DB a) = fromExpr a
107− nullifier Tag {expr} test SSpec {nullity} (DB a) =
108− DB $ runTag nullity (test expr) a
109− unnullifier SSpec {nullity} (DB a) = DB $ unnull nullity a
110−
111− {-# INLINABLE encodeTag #-}
112− {-# INLINABLE decodeTag #-}
113− {-# INLINABLE nullifier #-}
114− {-# INLINABLE unnullifier #-}
58+ nullifiability = NExpr
11559
11660
11761instance Nullifiable Name where
118− encodeTag Tag {name = Name name} = NameCol name
119− decodeTag (NameCol name) = fromName (Name name)
120− nullifier _ _ _ (NameCol name) = NameCol name
121− unnullifier _ (NameCol name) = NameCol name
122−
123− {-# INLINABLE encodeTag #-}
124− {-# INLINABLE decodeTag #-}
125− {-# INLINABLE nullifier #-}
126− {-# INLINABLE unnullifier #-}
127−
128−
129−runTag :: Nullity a -> Expr Bool -> Expr a -> Expr (Nullify a)
130−runTag nullity tag a = case nullity of
131− Null -> boolExpr null a tag
132− NotNull -> boolExpr null (nullify a) tag
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
133131 where
134132 null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit
135133
136134
137−unnull :: Nullity a -> Expr (Nullify a) -> Expr a
138−unnull nullity a = case nullity of
135+snullify :: Nullity a -> Expr a -> Expr (Nullify a)
136+snullify nullity a = case nullity of
139137 Null -> a
140− NotNull -> unsafeUnnullify a
141−
138+ NotNull -> nullify a
142139
143−type HNullifiable :: K.HContext -> Constraint
144−class HNullifiable context where
145− type HConstrainTag context :: Type -> Constraint
146− type HConstrainTag _context = DefaultConstrainTag
147140
148− hencodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)
149− => Tag label a
150− -> context ('Spec labels 'Required a)
151−
152− hdecodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)
153− => context ('Spec labels 'Required a)
154− -> Tag label a
155−
156− hnullifier :: ()
157− => Tag label a
158− -> (Expr a -> Expr Bool)
159− -> SSpec ('Spec labels necessity x)
160− -> context ('Spec labels necessity x)
161− -> context ('Spec labels necessity (Nullify x))
162−
163− hunnullifier :: ()
164− => SSpec ('Spec labels necessity x)
165− -> context ('Spec labels necessity (Nullify x))
166− -> context ('Spec labels necessity x)
167−
168−
169−instance Nullifiable context => HNullifiable (Col context) where
170− type HConstrainTag (Col context) = ConstrainTag context
171− hencodeTag = encodeTag
172− hdecodeTag = decodeTag
173− hnullifier = nullifier
174− hunnullifier = unnullifier
175−
176−
177−instance HNullifiable (Dict (ConstrainDBType constraint)) where
178− type HConstrainTag (Dict (ConstrainDBType constraint)) = constraint
179−
180− hencodeTag _ = Dict
181− hdecodeTag = mempty
182− hnullifier _ _ = ConstrainDBType.nullifier
183− hunnullifier = ConstrainDBType.unnullifier
184−
185−
186−type DefaultConstrainTag :: Type -> Constraint
187−class DefaultConstrainTag a
188−instance DefaultConstrainTag a
141+sunnullify :: Nullity a -> Expr (Nullify a) -> Expr a
142+sunnullify nullity a = case nullity of
143+ Null -> a
144+ NotNull -> unsafeUnnullify a
src/Rel8/Schema/Field.hsnew file+50
@@ -0,0 +1,50 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language MultiParamTypeClasses #-}
4+{-# language StandaloneKindSignatures #-}
5+{-# language TypeFamilies #-}
6+
7+module Rel8.Schema.Field
8+ ( Field(..)
9+ , fields
10+ )
11+where
12+
13+-- base
14+import Data.Functor.Identity ( Identity( Identity ) )
15+import Data.Kind ( Type )
16+import Prelude
17+
18+-- rel8
19+import Rel8.Schema.HTable ( HField, htabulate )
20+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
21+import Rel8.Schema.Kind as K
22+import Rel8.Schema.Null ( Sql )
23+import Rel8.Table
24+ ( Table, Columns, Context, fromColumns, toColumns
25+ , FromExprs, fromResult, toResult
26+ , Transpose
27+ )
28+import Rel8.Table.Transpose ( Transposes )
29+import Rel8.Type ( DBType )
30+
31+
32+-- | A special context used in the construction of 'Rel8.Projection's.
33+type Field :: Type -> K.Context
34+newtype Field table a = Field (HField (Columns table) a)
35+
36+
37+instance Sql DBType a => Table (Field table) (Field table a) where
38+ type Columns (Field table a) = HIdentity a
39+ type Context (Field table a) = Field table
40+ type FromExprs (Field table a) = a
41+ type Transpose to (Field table a) = to a
42+
43+ toColumns = HIdentity
44+ fromColumns (HIdentity a) = a
45+ toResult a = HIdentity (Identity a)
46+ fromResult (HIdentity (Identity a)) = a
47+
48+
49+fields :: Transposes context (Field table) table fields => fields
50+fields = fromColumns $ htabulate Field
src/Rel8/Schema/HTable.hs+51−24
@@ -16,11 +16,12 @@
1616module Rel8.Schema.HTable
1717 ( HTable (HField, HConstrainTable)
1818 , hfield, htabulate, htraverse, hdicts, hspecs
19− , hmap, htabulateA
19+ , hfoldMap, hmap, htabulateA, htraverseP, htraversePWithField
2020 )
2121where
2222
2323-- base
24+import Data.Functor.Const ( Const( Const ), getConst )
2425import Data.Kind ( Constraint, Type )
2526import Data.Functor.Compose ( Compose( Compose ), getCompose )
2627import Data.Proxy ( Proxy )
@@ -32,16 +33,21 @@ import GHC.Generics
3233 )
3334import Prelude
3435
36+-- profunctors
37+import Data.Profunctor ( rmap, Profunctor (lmap) )
38+
39+-- product-profunctors
40+import Data.Profunctor.Product ( ProductProfunctor ((****)) )
41+
3542-- rel8
3643import Rel8.Schema.Dict ( Dict )
37−import Rel8.Schema.Spec ( Spec, SSpec )
44+import Rel8.Schema.Spec ( Spec )
3845import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
3946import qualified Rel8.Schema.Kind as K
4047
4148-- semigroupoids
4249import Data.Functor.Apply ( Apply, (<.>) )
4350
44−
4551-- | A @HTable@ is a functor-indexed/higher-kinded data type that is
4652-- representable ('htabulate'/'hfield'), constrainable ('hdicts'), and
4753-- specified ('hspecs').
@@ -50,14 +56,14 @@ import Data.Functor.Apply ( Apply, (<.>) )
5056-- instances yourself or specify this constraint.
5157type HTable :: K.HTable -> Constraint
5258class HTable t where
53− type HField t = (field :: Spec -> Type) | field -> t
54− type HConstrainTable t (c :: Spec -> Constraint) :: Constraint
59+ type HField t = (field :: Type -> Type) | field -> t
60+ type HConstrainTable t (c :: Type -> Constraint) :: Constraint
5561
56− hfield :: t context -> HField t spec -> context spec
57− htabulate :: (forall spec. HField t spec -> context spec) -> t context
58− htraverse :: Apply m => (forall spec. f spec -> m (g spec)) -> t f -> m (t g)
62+ hfield :: t context -> HField t a -> context a
63+ htabulate :: (forall a. HField t a -> context a) -> t context
64+ htraverse :: Apply m => (forall a. f a -> m (g a)) -> t f -> m (t g)
5965 hdicts :: HConstrainTable t c => t (Dict c)
60− hspecs :: t SSpec
66+ hspecs :: t Spec
6167
6268 type HField t = GHField t
6369 type HConstrainTable t c = HConstrainTable (GHColumns (Rep (t Proxy))) c
@@ -68,7 +74,7 @@ class HTable t where
6874 , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))
6975 , GHTable context (Rep (t context))
7076 )
71− => t context -> HField t spec -> context spec
77+ => t context -> HField t a -> context a
7278 hfield table (GHField field) = hfield (toGHColumns (from table)) field
7379
7480 default htabulate ::
@@ -77,7 +83,7 @@ class HTable t where
7783 , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))
7884 , GHTable context (Rep (t context))
7985 )
80− => (forall spec. HField t spec -> context spec) -> t context
86+ => (forall a. HField t a -> context a) -> t context
8187 htabulate f = to $ fromGHColumns $ htabulate (f . GHField)
8288
8389 default htraverse
@@ -87,7 +93,7 @@ class HTable t where
8793 , Generic (t g), GHTable g (Rep (t g))
8894 , GHColumns (Rep (t f)) ~ GHColumns (Rep (t g))
8995 )
90− => (forall spec. f spec -> m (g spec)) -> t f -> m (t g)
96+ => (forall a. f a -> m (g a)) -> t f -> m (t g)
9197 htraverse f = fmap (to . fromGHColumns) . htraverse f . toGHColumns . from
9298
9399 default hdicts
@@ -101,10 +107,10 @@ class HTable t where
101107 hdicts = to $ fromGHColumns (hdicts @(GHColumns (Rep (t Proxy))) @c)
102108
103109 default hspecs ::
104− ( Generic (t SSpec)
105− , GHTable SSpec (Rep (t SSpec))
110+ ( Generic (t Spec)
111+ , GHTable Spec (Rep (t Spec))
106112 )
107− => t SSpec
113+ => t Spec
108114 hspecs = to $ fromGHColumns hspecs
109115
110116 {-# INLINABLE hfield #-}
@@ -114,22 +120,43 @@ class HTable t where
114120 {-# INLINABLE hspecs #-}
115121
116122
123+hfoldMap :: (HTable t, Semigroup s)
124+ => (forall a. context a -> s) -> t context -> s
125+hfoldMap f a = getConst $ htraverse (Const . f) a
126+
127+
117128hmap :: HTable t
118− => (forall spec. context spec -> context' spec) -> t context -> t context'
129+ => (forall a. context a -> context' a) -> t context -> t context'
119130hmap f a = htabulate $ \field -> f (hfield a field)
120131
121132
122133htabulateA :: (HTable t, Apply m)
123− => (forall spec. HField t spec -> m (context spec)) -> m (t context)
134+ => (forall a. HField t a -> m (context a)) -> m (t context)
124135htabulateA f = htraverse getCompose $ htabulate $ Compose . f
125136{-# INLINABLE htabulateA #-}
126137
138+newtype ApplyP p a b = ApplyP { unApplyP :: p a b }
139+
140+instance Profunctor p => Functor (ApplyP p a) where
141+ fmap f = ApplyP . rmap f . unApplyP
142+
143+instance ProductProfunctor p => Apply (ApplyP p a) where
144+ ApplyP f <.> ApplyP x = ApplyP (rmap id f **** x)
145+
146+htraverseP :: (HTable t, ProductProfunctor p)
147+ => (forall a. p (f a) (g a)) -> p (t f) (t g)
148+htraverseP f = htraversePWithField (const f)
149+
150+htraversePWithField :: (HTable t, ProductProfunctor p)
151+ => (forall a. HField t a -> p (f a) (g a)) -> p (t f) (t g)
152+htraversePWithField f = unApplyP $ htabulateA $ \field -> ApplyP $
153+ lmap (flip hfield field) (f field)
127154
128−type GHField :: K.HTable -> Spec -> Type
129−newtype GHField t spec = GHField (HField (GHColumns (Rep (t Proxy))) spec)
155+type GHField :: K.HTable -> Type -> Type
156+newtype GHField t a = GHField (HField (GHColumns (Rep (t Proxy))) a)
130157
131158
132−type GHTable :: K.HContext -> (Type -> Type) -> Constraint
159+type GHTable :: K.Context -> (Type -> Type) -> Constraint
133160class HTable (GHColumns rep) => GHTable context rep | rep -> context where
134161 type GHColumns rep :: K.HTable
135162 toGHColumns :: rep x -> GHColumns rep context
@@ -155,10 +182,10 @@ instance (GHTable context a, GHTable context b) => GHTable context (a :*: b) whe
155182
156183
157184-- | A HField type for indexing into HProduct.
158−type HProductField :: K.HTable -> K.HTable -> Spec -> Type
159−data HProductField x y spec
160− = HFst (HField x spec)
161− | HSnd (HField y spec)
185+type HProductField :: K.HTable -> K.HTable -> Type -> Type
186+data HProductField x y a
187+ = HFst (HField x a)
188+ | HSnd (HField y a)
162189
163190
164191instance (HTable x, HTable y) => HTable (HProduct x y) where
src/Rel8/Schema/HTable/Either.hs+2−4
@@ -14,19 +14,17 @@ import GHC.Generics ( Generic )
1414import Prelude ()
1515
1616-- rel8
17−import Rel8.Kind.Necessity ( Necessity( Required ) )
1817import Rel8.Schema.HTable ( HTable )
19−import Rel8.Schema.HTable.Identity ( HIdentity(..) )
18+import Rel8.Schema.HTable.Identity ( HIdentity )
2019import Rel8.Schema.HTable.Label ( HLabel )
2120import Rel8.Schema.HTable.Nullify ( HNullify )
2221import qualified Rel8.Schema.Kind as K
23−import Rel8.Schema.Spec ( Spec( Spec ) )
2422import Rel8.Type.Tag ( EitherTag )
2523
2624
2725type HEitherTable :: K.HTable -> K.HTable -> K.HTable
2826data HEitherTable left right context = HEitherTable
29− { htag :: HIdentity ('Spec '["isRight"] 'Required EitherTag) context
27+ { htag :: HLabel "isRight" (HIdentity EitherTag) context
3028 , hleft :: HLabel "Left" (HNullify left) context
3129 , hright :: HLabel "Right" (HNullify right) context
3230 }
src/Rel8/Schema/HTable/Identity.hs+16−29
@@ -1,56 +1,43 @@
11{-# language DataKinds #-}
2−{-# language GADTs #-}
3−{-# language PatternSynonyms #-}
2+{-# language FlexibleContexts #-}
43{-# language StandaloneKindSignatures #-}
54{-# language TypeFamilies #-}
5+{-# language UndecidableInstances #-}
66
77module Rel8.Schema.HTable.Identity
8− ( HIdentity( HIdentity, HType, unHIdentity )
9− , HType
8+ ( HIdentity( HIdentity, unHIdentity )
109 )
1110where
1211
1312-- base
1413import Data.Kind ( Type )
14+import Data.Type.Equality ( (:~:)( Refl ) )
1515import Prelude
1616
1717-- rel8
18−import Rel8.Kind.Necessity ( Necessity( Required ) )
1918import Rel8.Schema.Dict ( Dict( Dict ) )
2019import Rel8.Schema.HTable
2120 ( HTable, HConstrainTable, HField
2221 , hfield, htabulate, htraverse, hdicts, hspecs
2322 )
2423import qualified Rel8.Schema.Kind as K
25−import Rel8.Schema.Spec ( Spec( Spec ), KnownSpec, specSing )
24+import Rel8.Schema.Null ( Sql )
25+import Rel8.Schema.Spec ( specification )
26+import Rel8.Type ( DBType )
2627
2728
28−type HType :: Type -> K.HTable
29−type HType a = HIdentity ('Spec '[] 'Required a)
30−
31−
32−pattern HType :: context ('Spec '[] 'Required a) -> HType a context
33−pattern HType a = HIdentity a
34−{-# COMPLETE HType #-}
35−
36−
37−type HIdentity :: Spec -> K.HTable
38−newtype HIdentity spec context = HIdentity
39− { unHIdentity :: context spec
29+type HIdentity :: Type -> K.HTable
30+newtype HIdentity a context = HIdentity
31+ { unHIdentity :: context a
4032 }
4133
4234
43−type HIdentityField :: Spec -> Spec -> Type
44−data HIdentityField _spec spec where
45− HIdentityField :: HIdentityField spec spec
46−
47−
48−instance KnownSpec spec => HTable (HIdentity spec) where
49− type HConstrainTable (HIdentity spec) c = c spec
50− type HField (HIdentity spec) = HIdentityField spec
35+instance Sql DBType a => HTable (HIdentity a) where
36+ type HConstrainTable (HIdentity a) constraint = constraint a
37+ type HField (HIdentity a) = (:~:) a
5138
52− hfield (HIdentity a) HIdentityField = a
53− htabulate f = HIdentity $ f HIdentityField
39+ hfield (HIdentity a) Refl = a
40+ htabulate f = HIdentity $ f Refl
5441 htraverse f (HIdentity a) = HIdentity <$> f a
5542 hdicts = HIdentity Dict
56− hspecs = HIdentity specSing
43+ hspecs = HIdentity specification
src/Rel8/Schema/HTable/Label.hs+37−50
@@ -1,83 +1,70 @@
1−{-# LANGUAGE DeriveAnyClass #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE DerivingStrategies #-}
4−{-# LANGUAGE LambdaCase #-}
5−{-# language ConstraintKinds #-}
61{-# language DataKinds #-}
7−{-# language FlexibleInstances #-}
8−{-# language GADTs #-}
9−{-# language MultiParamTypeClasses #-}
10−{-# language QuantifiedConstraints #-}
112{-# language RankNTypes #-}
123{-# language RecordWildCards #-}
134{-# language ScopedTypeVariables #-}
145{-# language StandaloneKindSignatures #-}
6+{-# language TypeApplications #-}
157{-# language TypeFamilies #-}
16−{-# language TypeOperators #-}
17−{-# language UndecidableInstances #-}
188
199module Rel8.Schema.HTable.Label
20− ( HLabel, Label
21− , hlabel, hunlabel
10+ ( HLabel, hlabel, hrelabel, hunlabel
11+ , hproject
2212 )
2313where
2414
2515-- base
16+import Data.Kind ( Type )
2617import Data.Proxy ( Proxy( Proxy ) )
27−import GHC.TypeLits ( KnownSymbol, Symbol )
18+import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
2819import Prelude
2920
3021-- rel8
31−import Rel8.Kind.Labels ( SLabels( SCons ) )
3222import Rel8.Schema.HTable
33− ( HTable
34− , hfield, htabulate, hspecs
23+ ( HTable, HConstrainTable, HField
24+ , htabulate, hfield, htraverse, hdicts, hspecs
3525 )
3626import qualified Rel8.Schema.Kind as K
37−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
38−import Rel8.FCF
39−import Rel8.Schema.HTable.MapTable
40−import GHC.Generics (Generic)
27+import Rel8.Schema.Spec ( Spec(..) )
4128
4229
4330type HLabel :: Symbol -> K.HTable -> K.HTable
44−newtype HLabel label table context = HLabel (HMapTable (Label label) table context)
45− deriving stock Generic
46− deriving anyclass HTable
31+newtype HLabel label table context = HLabel (table context)
4732
4833
49−data Label :: Symbol -> Spec -> Exp Spec
34+type HLabelField :: Symbol -> K.HTable -> Type -> Type
35+newtype HLabelField label table a = HLabelField (HField table a)
5036
5137
52−type instance Eval (Label label ('Spec labels necessity a)) = 'Spec (label : labels) necessity a
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
5342
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 #-}
5450
55−instance KnownSymbol l => MapSpec (Label l) where
56− mapInfo = \case
57− SSpec {..} -> SSpec {labels = SCons Proxy labels, ..}
5851
59−
60−hlabel :: (HTable t, KnownSymbol label)
61− => (forall labels necessity a. ()
62− => context ('Spec labels necessity a)
63− -> context ('Spec (label ': labels) necessity a))
64− -> t context
65− -> HLabel label t context
66−hlabel labeler a = HLabel $ htabulate $ \(HMapTableField field) ->
67− case hfield hspecs field of
68− SSpec {} -> labeler (hfield a field)
52+hlabel :: forall label t context. t context -> HLabel label t context
53+hlabel = HLabel
6954{-# INLINABLE hlabel #-}
7055
7156
72−hunlabel :: (HTable t, KnownSymbol label)
73− => (forall labels necessity a. ()
74− => context ('Spec (label ': labels) necessity a)
75− -> context ('Spec labels necessity a))
76− -> HLabel label t context
77− -> t context
78−hunlabel unlabler (HLabel as) =
79− htabulate $ \field ->
80− case hfield hspecs field of
81− SSpec {} -> case hfield as (HMapTableField field) of
82− a -> unlabler a
57+hrelabel :: forall label' label t context. HLabel label t context -> HLabel label' t context
58+hrelabel = hlabel . hunlabel
59+{-# INLINABLE hrelabel #-}
60+
61+
62+hunlabel :: forall label t context. HLabel label t context -> t context
63+hunlabel (HLabel a) = a
8364{-# INLINABLE hunlabel #-}
65+
66+
67+hproject :: ()
68+ => (forall ctx. t ctx -> t' ctx)
69+ -> HLabel label t context -> HLabel label t' context
70+hproject f (HLabel a) = HLabel (f a)
src/Rel8/Schema/HTable/MapTable.hs+22−12
@@ -6,7 +6,7 @@
66{-# language GADTs #-}
77{-# language InstanceSigs #-}
88{-# language MultiParamTypeClasses #-}
9−{-# language PolyKinds #-}
9+{-# language RankNTypes #-}
1010{-# language ScopedTypeVariables #-}
1111{-# language StandaloneKindSignatures #-}
1212{-# language TypeApplications #-}
@@ -19,34 +19,38 @@ module Rel8.Schema.HTable.MapTable
1919 , MapSpec(..)
2020 , Precompose(..)
2121 , HMapTableField(..)
22+ , hproject
2223 )
2324where
2425
2526-- base
2627import Data.Kind ( Constraint, Type )
27−import Prelude ( ($), (.), (<$>), fmap )
28+import Prelude
2829
2930-- rel8
30−import Rel8.FCF
31+import Rel8.FCF ( Exp, Eval )
3132import Rel8.Schema.HTable
32−import Rel8.Schema.Spec ( Spec, SSpec )
33+ ( HTable, HConstrainTable, HField
34+ , hfield, htabulate, htraverse, hdicts, hspecs
35+ )
36+import Rel8.Schema.Spec ( Spec )
3337import qualified Rel8.Schema.Kind as K
3438import Rel8.Schema.Dict ( Dict( Dict ) )
3539
3640
37−type HMapTable :: (a -> Exp b) -> ((a -> Type) -> Type) -> (b -> Type) -> Type
38−newtype HMapTable f t g = HMapTable
39− { unHMapTable :: t (Precompose f g)
41+type HMapTable :: (Type -> Exp Type) -> K.HTable -> K.HTable
42+newtype HMapTable f t context = HMapTable
43+ { unHMapTable :: t (Precompose f context)
4044 }
4145
4246
43−type Precompose :: (a -> Exp b) -> (b -> Type) -> a -> Type
47+type Precompose :: (Type -> Exp Type) -> K.Context -> K.Context
4448newtype Precompose f g x = Precompose
4549 { precomposed :: g (Eval (f x))
4650 }
4751
4852
49−type HMapTableField :: (Spec -> Exp a) -> K.HTable -> a -> Type
53+type HMapTableField :: (Type -> Exp Type) -> K.HTable -> K.Context
5054data HMapTableField f t x where
5155 HMapTableField :: HField t a -> HMapTableField f t (Eval (f a))
5256
@@ -79,11 +83,17 @@ instance (HTable t, MapSpec f) => HTable (HMapTable f t) where
7983 {-# INLINABLE hspecs #-}
8084
8185
82−type MapSpec :: (Spec -> Exp Spec) -> Constraint
86+type MapSpec :: (Type -> Exp Type) -> Constraint
8387class MapSpec f where
84− mapInfo :: SSpec x -> SSpec (Eval (f x))
88+ mapInfo :: Spec x -> Spec (Eval (f x))
8589
8690
87−type ComposeConstraint :: (a -> Exp b) -> (b -> Constraint) -> a -> Constraint
91+type ComposeConstraint :: (Type -> Exp Type) -> (Type -> Constraint) -> Type -> Constraint
8892class c (Eval (f a)) => ComposeConstraint f c a
8993instance c (Eval (f a)) => ComposeConstraint f c a
94+
95+
96+hproject :: ()
97+ => (forall ctx. t ctx -> t' ctx)
98+ -> HMapTable f t context -> HMapTable f t' context
99+hproject f (HMapTable a) = HMapTable (f a)
src/Rel8/Schema/HTable/Maybe.hs+2−4
@@ -14,19 +14,17 @@ import GHC.Generics ( Generic )
1414import Prelude
1515
1616-- rel8
17−import Rel8.Kind.Necessity ( Necessity( Required ) )
1817import Rel8.Schema.HTable ( HTable )
19−import Rel8.Schema.HTable.Identity ( HIdentity(..) )
18+import Rel8.Schema.HTable.Identity ( HIdentity )
2019import Rel8.Schema.HTable.Label ( HLabel )
2120import Rel8.Schema.HTable.Nullify ( HNullify )
2221import qualified Rel8.Schema.Kind as K
23−import Rel8.Schema.Spec ( Spec( Spec ) )
2422import Rel8.Type.Tag ( MaybeTag )
2523
2624
2725type HMaybeTable :: K.HTable -> K.HTable
2826data HMaybeTable table context = HMaybeTable
29− { htag :: HIdentity ('Spec '["isJust"] 'Required (Maybe MaybeTag)) context
27+ { htag :: HLabel "isJust" (HIdentity (Maybe MaybeTag)) context
3028 , hjust :: HLabel "Just" (HNullify table) context
3129 }
3230 deriving stock Generic
src/Rel8/Schema/HTable/Nullify.hs+47−33
@@ -10,6 +10,7 @@
1010{-# language NamedFieldPuns #-}
1111{-# language QuantifiedConstraints #-}
1212{-# language RankNTypes #-}
13+{-# language RecordWildCards #-}
1314{-# language ScopedTypeVariables #-}
1415{-# language StandaloneKindSignatures #-}
1516{-# language TypeFamilies #-}
@@ -18,25 +19,34 @@
1819module Rel8.Schema.HTable.Nullify
1920 ( HNullify( HNullify )
2021 , Nullify
21− , hnulls, hnullify, hunnullify
22+ , hguard
23+ , hnulls
24+ , hnullify
25+ , hunnullify
26+ , hproject
2227 )
2328where
2429
2530-- base
31+import Data.Kind ( Type )
32+import GHC.Generics ( Generic )
2633import Prelude hiding ( null )
2734
2835-- rel8
36+import Rel8.FCF ( Eval, Exp )
2937import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )
38+import Rel8.Schema.HTable.MapTable
39+ ( HMapTable, HMapTableField( HMapTableField )
40+ , MapSpec, mapInfo
41+ )
42+import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )
3043import qualified Rel8.Schema.Kind as K
3144import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
3245import qualified Rel8.Schema.Null as Type ( Nullify )
33−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
46+import Rel8.Schema.Spec ( Spec(..) )
3447
3548-- semigroupoids
3649import Data.Functor.Apply ( Apply )
37−import Rel8.Schema.HTable.MapTable
38−import Rel8.FCF
39−import GHC.Generics (Generic)
4050
4151
4252type HNullify :: K.HTable -> K.HTable
@@ -45,59 +55,63 @@ newtype HNullify table context = HNullify (HMapTable Nullify table context)
4555 deriving anyclass HTable
4656
4757
48−
49−-- | Transform a 'Spec' by allowing it to be @null@.
50−data Nullify :: Spec -> Exp Spec
51−
52−
53−type instance Eval (Nullify ('Spec labels necessity a)) =
54− 'Spec labels necessity (Type.Nullify a)
58+-- | Transform a 'Type' by allowing it to be @null@.
59+data Nullify :: Type -> Exp Type
60+type instance Eval (Nullify a) = Type.Nullify a
5561
5662
5763instance MapSpec Nullify where
5864 mapInfo = \case
59− SSpec{labels, necessity, info, nullity} -> SSpec
60− { labels
61− , necessity
62− , info
63− , nullity = case nullity of
65+ Spec {nullity, ..} -> Spec
66+ { nullity = case nullity of
6467 Null -> Null
6568 NotNull -> Null
66− }
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
6782
6883
6984hnulls :: HTable t
70− => (forall labels necessity a. ()
71− => SSpec ('Spec labels necessity a)
72− -> context ('Spec labels necessity (Type.Nullify a)))
85+ => (forall a. Spec a -> context (Type.Nullify a))
7386 -> HNullify t context
74−hnulls null = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
75− spec@SSpec {} -> null spec
87+hnulls null = HNullify $ htabulate $ \(HMapTableField field) ->
88+ case hfield hspecs field of
89+ spec@Spec {} -> null spec
7690{-# INLINABLE hnulls #-}
7791
7892
7993hnullify :: HTable t
80− => (forall labels necessity a. ()
81− => SSpec ('Spec labels necessity a)
82− -> context ('Spec labels necessity a)
83− -> context ('Spec labels necessity (Type.Nullify a)))
94+ => (forall a. Spec a -> context a -> context (Type.Nullify a))
8495 -> t context
8596 -> HNullify t context
8697hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->
8798 case hfield hspecs field of
88− spec@SSpec {} -> nullifier spec (hfield a field)
99+ spec@Spec {} -> nullifier spec (hfield a field)
89100{-# INLINABLE hnullify #-}
90101
91102
92103hunnullify :: (HTable t, Apply m)
93− => (forall labels necessity a. ()
94− => SSpec ('Spec labels necessity a)
95− -> context ('Spec labels necessity (Type.Nullify a))
96− -> m (context ('Spec labels necessity a)))
104+ => (forall a. Spec a -> context (Type.Nullify a) -> m (context a))
97105 -> HNullify t context
98106 -> m (t context)
99107hunnullify unnullifier (HNullify as) =
100108 htabulateA $ \field -> case hfield hspecs field of
101− spec@SSpec {} -> case hfield as (HMapTableField field) of
109+ spec@Spec {} -> case hfield as (HMapTableField field) of
102110 a -> unnullifier spec a
103111{-# INLINABLE hunnullify #-}
112+
113+
114+hproject :: ()
115+ => (forall ctx. t ctx -> t' ctx)
116+ -> HNullify t context -> HNullify t' context
117+hproject f (HNullify a) = HNullify (HMapTable.hproject f a)
src/Rel8/Schema/HTable/These.hs+2−4
@@ -14,21 +14,19 @@ import GHC.Generics ( Generic )
1414import Prelude
1515
1616-- rel8
17−import Rel8.Kind.Necessity ( Necessity( Required ) )
1817import Rel8.Schema.HTable ( HTable )
1918import Rel8.Schema.HTable.Identity ( HIdentity )
2019import Rel8.Schema.HTable.Label ( HLabel )
2120import Rel8.Schema.HTable.Nullify ( HNullify )
2221import qualified Rel8.Schema.Kind as K
23−import Rel8.Schema.Spec ( Spec( Spec ) )
2422import Rel8.Type.Tag ( MaybeTag )
2523
2624
2725type HTheseTable :: K.HTable -> K.HTable -> K.HTable
2826data HTheseTable here there context = HTheseTable
29− { hhereTag :: HIdentity ('Spec '["hasHere"] 'Required (Maybe MaybeTag)) context
27+ { hhereTag :: HLabel "hereTag" (HIdentity (Maybe MaybeTag)) context
3028 , hhere :: HLabel "Here" (HNullify here) context
31− , hthereTag :: HIdentity ('Spec '["hasThere"] 'Required (Maybe MaybeTag)) context
29+ , hthereTag :: HLabel "thereTag" (HIdentity (Maybe MaybeTag)) context
3230 , hthere :: HLabel "There" (HNullify there) context
3331 }
3432 deriving stock Generic
src/Rel8/Schema/HTable/Vectorize.hs+39−47
@@ -9,8 +9,6 @@
99{-# language GADTs #-}
1010{-# language LambdaCase #-}
1111{-# language MultiParamTypeClasses #-}
12−{-# language NamedFieldPuns #-}
13−{-# language QuantifiedConstraints #-}
1412{-# language RankNTypes #-}
1513{-# language RecordWildCards #-}
1614{-# language ScopedTypeVariables #-}
@@ -23,34 +21,39 @@ module Rel8.Schema.HTable.Vectorize
2321 ( HVectorize
2422 , hvectorize, hunvectorize
2523 , happend, hempty
24+ , hproject
25+ , hcolumn
2626 )
2727where
2828
2929-- base
30−import Data.Kind ( Type )
30+import Data.Kind ( Constraint, Type )
3131import Data.List.NonEmpty ( NonEmpty )
32+import GHC.Generics (Generic)
3233import Prelude
3334
3435-- rel8
35−import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )
36+import Rel8.FCF ( Eval, Exp )
3637import Rel8.Schema.Dict ( Dict( Dict ) )
3738import qualified Rel8.Schema.Kind as K
38−import Rel8.Schema.HTable
39− ( HTable
40− , hfield, htabulate, htabulateA, hspecs
39+import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )
40+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
41+import Rel8.Schema.HTable.MapTable
42+ ( HMapTable( HMapTable ), HMapTableField( HMapTableField )
43+ , MapSpec, mapInfo
44+ , Precompose( Precompose )
4145 )
46+import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )
4247import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )
43−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
48+import Rel8.Schema.Spec ( Spec(..) )
4449import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
4550import Rel8.Type.Information ( TypeInformation )
4651
4752-- semialign
48−import Data.Zip ( Unzip, Repeat, Zippy(..) )
49−import Rel8.FCF
50−import Rel8.Schema.HTable.MapTable
51−import GHC.Generics (Generic)
53+import Data.Zip ( Unzip, Zip, Zippy(..) )
5254
5355
56+type Vector :: (Type -> Type) -> Constraint
5457class Vector list where
5558 listNotNull :: proxy a -> Dict NotNull (list a)
5659 vectorTypeInformation :: ()
@@ -75,16 +78,16 @@ newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) t
7578 deriving anyclass HTable
7679
7780
78−data Vectorize :: (Type -> Type) -> Spec -> Exp Spec
81+data Vectorize :: (Type -> Type) -> Type -> Exp Type
7982
8083
81−type instance Eval (Vectorize list ('Spec labels necessity a)) = 'Spec labels necessity (list a)
84+type instance Eval (Vectorize list a) = list a
8285
8386
8487instance Vector list => MapSpec (Vectorize list) where
8588 mapInfo = \case
86− SSpec {..} -> case listNotNull @list nullity of
87− Dict -> SSpec
89+ Spec {..} -> case listNotNull @list nullity of
90+ Dict -> Spec
8891 { nullity = NotNull
8992 , info = vectorTypeInformation nullity info
9093 , ..
@@ -92,60 +95,49 @@ instance Vector list => MapSpec (Vectorize list) where
9295
9396
9497hvectorize :: (HTable t, Unzip f, Vector list)
95− => (forall labels necessity a. ()
96− => SSpec ('Spec labels necessity a)
97− -> f (context ('Spec labels necessity a))
98− -> context' ('Spec labels necessity (list a)))
98+ => (forall a. Spec a -> f (context a) -> context' (list a))
9999 -> f (t context)
100100 -> HVectorize list t context'
101101hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->
102102 case hfield hspecs field of
103− spec@SSpec {} -> vectorizer spec (fmap (`hfield` field) as)
103+ spec -> vectorizer spec (fmap (`hfield` field) as)
104104{-# INLINABLE hvectorize #-}
105105
106106
107−hunvectorize :: (HTable t, Repeat f, Vector list)
108− => (forall labels necessity a. ()
109− => SSpec ('Spec labels necessity a)
110− -> context ('Spec labels necessity (list a))
111− -> f (context' ('Spec labels necessity a)))
107+hunvectorize :: (HTable t, Zip f, Vector list)
108+ => (forall a. Spec a -> context (list a) -> f (context' a))
112109 -> HVectorize list t context
113110 -> f (t context')
114111hunvectorize unvectorizer (HVectorize table) =
115112 getZippy $ htabulateA $ \field -> case hfield hspecs field of
116− spec@SSpec{} -> case hfield table (HMapTableField field) of
113+ spec -> case hfield table (HMapTableField field) of
117114 a -> Zippy (unvectorizer spec a)
118115{-# INLINABLE hunvectorize #-}
119116
120117
121−happend :: (HTable t, Vector list) =>
122− ( forall labels necessity a. ()
123− => Nullity a
124− -> TypeInformation (Unnullify a)
125− -> context ('Spec labels necessity (list a))
126− -> context ('Spec labels necessity (list a))
127− -> context ('Spec labels necessity (list a))
128− )
118+happend :: (HTable t, Vector list)
119+ => (forall a. Spec a -> context (list a) -> context (list a) -> context (list a))
129120 -> HVectorize list t context
130121 -> HVectorize list t context
131122 -> HVectorize list t context
132123happend append (HVectorize as) (HVectorize bs) = HVectorize $
133124 htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of
134125 (a, b) -> case hfield hspecs j of
135− SSpec {nullity, info} -> append nullity info a b
126+ spec -> append spec a b
136127
137128
138−hempty :: HTable t =>
139− ( forall labels necessity a. ()
140− => Nullity a
141− -> TypeInformation (Unnullify a)
142− -> context ('Spec labels necessity [a])
143− )
129+hempty :: HTable t
130+ => (forall a. Spec a -> context [a])
144131 -> HVectorize [] t context
145−hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
146− SSpec {nullity, info} -> empty nullity info
132+hempty empty = HVectorize $ htabulate $ \(HMapTableField field) ->
133+ empty (hfield hspecs field)
134+
135+
136+hproject :: ()
137+ => (forall ctx. t ctx -> t' ctx)
138+ -> HVectorize list t context -> HVectorize list t' context
139+hproject f (HVectorize a) = HVectorize (HMapTable.hproject f a)
147140
148141
149−instance HLabelable g => HLabelable (Precompose (Vectorize list) g) where
150− hlabeler = Precompose . hlabeler . precomposed
151− hunlabeler = Precompose . hunlabeler . precomposed
142+hcolumn :: HVectorize list (HIdentity a) context -> context (list a)
143+hcolumn (HVectorize (HMapTable (HIdentity (Precompose a)))) = a
src/Rel8/Schema/Insert.hsdeleted−167
@@ -1,167 +0,0 @@
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 PolyKinds #-}
10−{-# language StandaloneKindSignatures #-}
11−{-# language TypeFamilies #-}
12−{-# language UndecidableInstances #-}
13−{-# language UndecidableSuperClasses #-}
14−
15−module Rel8.Schema.Insert
16− ( Insert(..)
17− , OnConflict(..)
18− , Col( RequiredInsert, OptionalInsert )
19− , Inserts
20− , Insertion(..)
21− )
22−where
23−
24−-- base
25−import Data.Functor.Identity ( Identity )
26−import Data.Kind ( Constraint, Type )
27−import Prelude
28−
29−-- rel8
30−import Rel8.Aggregate ( Aggregate )
31−import Rel8.Expr ( Expr )
32−import Rel8.Kind.Necessity ( Necessity(Optional, Required) )
33−import Rel8.Schema.Context ( Interpretation(..) )
34−import Rel8.Schema.Context.Label ( Labelable(..) )
35−import Rel8.Schema.Context.Nullify
36− ( Nullifiable, encodeTag, decodeTag, nullifier, unnullifier
37− , runTag, unnull
38− )
39−import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )
40−import Rel8.Schema.Name ( Name, Selects )
41−import Rel8.Schema.Null ( Sql )
42−import Rel8.Schema.Reify ( notReify )
43−import Rel8.Schema.Result ( Result )
44−import Rel8.Schema.Spec ( SSpec(SSpec, nullity), Spec(Spec) )
45−import Rel8.Schema.Table ( TableSchema )
46−import Rel8.Statement.Returning ( Returning )
47−import Rel8.Table
48− ( Table, Context, Columns, fromColumns, toColumns
49− , reify, unreify
50− )
51−import Rel8.Table.Recontextualize ( Recontextualize )
52−import Rel8.Table.Tag ( Tag(..), fromExpr )
53−import Rel8.Type ( DBType )
54−
55−
56−-- | @OnConflict@ allows you to add an @ON CONFLICT@ clause to an @INSERT@
57−-- statement.
58−data OnConflict
59− = Abort -- ^ @ON CONFLICT ABORT@
60− | DoNothing -- ^ @ON CONFLICT DO NOTHING@
61−
62−
63−-- | The constituent parts of a SQL @INSERT@ statement.
64−type Insert :: k -> Type
65−data Insert a where
66− Insert :: (Selects names exprs, Inserts exprs inserts) =>
67− { into :: TableSchema names
68− -- ^ Which table to insert into.
69− , rows :: [inserts]
70− -- ^ The rows to insert.
71− , onConflict :: OnConflict
72− -- ^ What to do if the inserted rows conflict with data already in the
73− -- table.
74− , returning :: Returning names a
75− -- ^ What information to return on completion.
76− }
77− -> Insert a
78−
79−
80−instance Interpretation Insert where
81− data Col Insert _spec where
82− RequiredInsert :: Expr a -> Col Insert ('Spec labels 'Required a)
83− OptionalInsert :: Maybe (Expr a) -> Col Insert ('Spec labels 'Optional a)
84−
85−
86−type Insertion :: Type -> Type
87−newtype Insertion a = Insertion (Expr a)
88−
89−
90−instance Sql DBType a => Table Insert (Insertion a) where
91− type Columns (Insertion a) = HType a
92− type Context (Insertion a) = Insert
93−
94− toColumns (Insertion a) = HType (RequiredInsert a)
95− fromColumns (HType (RequiredInsert a)) = Insertion a
96− reify = notReify
97− unreify = notReify
98−
99−
100−instance Sql DBType a =>
101− Recontextualize Aggregate Insert (Aggregate (Expr a)) (Insertion a)
102−
103−
104−instance Sql DBType a => Recontextualize Expr Insert (Expr a) (Insertion a)
105−
106−
107−instance Sql DBType a =>
108− Recontextualize Result Insert (Identity a) (Insertion a)
109−
110−
111−instance Sql DBType a =>
112− Recontextualize Insert Aggregate (Insertion a) (Aggregate (Expr a))
113−
114−
115−instance Sql DBType a => Recontextualize Insert Expr (Insertion a) (Expr a)
116−
117−
118−instance Sql DBType a =>
119− Recontextualize Insert Result (Insertion a) (Identity a)
120−
121−
122−instance Sql DBType a => Recontextualize Insert Insert (Insertion a) (Insertion a)
123−
124−
125−instance Sql DBType a => Recontextualize Insert Name (Insertion a) (Name a)
126−
127−
128−instance Sql DBType a => Recontextualize Name Insert (Name a) (Insertion a)
129−
130−
131−instance Labelable Insert where
132− labeler = \case
133− RequiredInsert a -> RequiredInsert a
134− OptionalInsert ma -> OptionalInsert ma
135−
136− unlabeler = \case
137− RequiredInsert a -> RequiredInsert a
138− OptionalInsert ma -> OptionalInsert ma
139−
140−
141−instance Nullifiable Insert where
142− encodeTag = RequiredInsert . expr
143− decodeTag (RequiredInsert a) = fromExpr a
144−
145− nullifier Tag {expr} test SSpec {nullity} = \case
146− RequiredInsert a ->
147− RequiredInsert $ runTag nullity condition a
148− OptionalInsert ma ->
149− OptionalInsert $ runTag nullity condition <$> ma
150− where
151− condition = test expr
152−
153− unnullifier SSpec {nullity} = \case
154− RequiredInsert a -> RequiredInsert $ unnull nullity a
155− OptionalInsert ma -> OptionalInsert $ unnull nullity <$> ma
156−
157− {-# INLINABLE encodeTag #-}
158− {-# INLINABLE decodeTag #-}
159− {-# INLINABLE nullifier #-}
160− {-# INLINABLE unnullifier #-}
161−
162−
163−-- | @Inserts a b@ means that the columns in @a@ are compatible for inserting
164−-- with the table @b@.
165−type Inserts :: Type -> Type -> Constraint
166−class Recontextualize Expr Insert exprs inserts => Inserts exprs inserts
167−instance Recontextualize Expr Insert exprs inserts => Inserts exprs inserts
src/Rel8/Schema/Kind.hs+6−15
@@ -1,8 +1,9 @@
11{-# language StandaloneKindSignatures #-}
22
33module Rel8.Schema.Kind
4− ( Context, Rel8able
5− , HContext, HTable
4+ ( Rel8able
5+ , Context
6+ , HTable
67 )
78where
89
@@ -10,23 +11,13 @@ where
1011import Data.Kind ( Type )
1112import Prelude ()
1213
13−-- rel8
14−import Rel8.Schema.Spec ( Spec )
1514
16−
17−type HContext :: Type
18−type HContext = Spec -> Type
15+type Context :: Type
16+type Context = Type -> Type
1917
2018
2119type HTable :: Type
22−type HTable = HContext -> Type
23−
24−
25−data X
26−
27−
28−type Context :: Type
29−type Context = X -> Type
20+type HTable = Context -> Type
3021
3122
3223type Rel8able :: Type
src/Rel8/Schema/Name.hs+34−54
@@ -3,40 +3,44 @@
33{-# language FlexibleContexts #-}
44{-# language FlexibleInstances #-}
55{-# language GADTs #-}
6+{-# language GeneralizedNewtypeDeriving #-}
67{-# language MultiParamTypeClasses #-}
7−{-# language PolyKinds #-}
88{-# language RankNTypes #-}
9−{-# language StandaloneDeriving #-}
109{-# language StandaloneKindSignatures #-}
1110{-# language TypeFamilies #-}
1211{-# language UndecidableInstances #-}
13−{-# language UndecidableSuperClasses #-}
1412
1513module Rel8.Schema.Name
1614 ( Name(..)
17− , Col( NameCol )
1815 , Selects
16+ , ppColumn
1917 )
2018where
2119
2220-- base
23−import Data.Functor.Identity ( Identity )
21+import Data.Functor.Identity ( Identity( Identity ) )
2422import Data.Kind ( Constraint, Type )
25−import Data.String ( IsString, fromString )
23+import Data.String ( IsString )
2624import Prelude
2725
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+
2833-- rel8
2934import Rel8.Expr ( Expr )
30−import Rel8.Schema.Context ( Interpretation, Col )
31−import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
32−import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )
35+import qualified Rel8.Schema.Kind as K
36+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
3337import Rel8.Schema.Null ( Sql )
34−import Rel8.Schema.Reify ( notReify )
35−import Rel8.Schema.Result ( Result )
3638import Rel8.Table
37− ( Table, Columns, Context, fromColumns, toColumns, reify, unreify
39+ ( Table, Columns, Context, fromColumns, toColumns
40+ , FromExprs, fromResult, toResult
41+ , Transpose
3842 )
39−import Rel8.Table.Recontextualize ( Recontextualize )
43+import Rel8.Table.Transpose ( Transposes )
4044import Rel8.Type ( DBType )
4145
4246
@@ -44,54 +48,30 @@ import Rel8.Type ( DBType )
4448-- schema definition. You can construct names by using the @OverloadedStrings@
4549-- extension and writing string literals. This is typically done when providing
4650-- a 'TableSchema' value.
47−type Name :: k -> Type
48−data Name a where
49− Name :: k ~ Type => !String -> Name (a :: k)
50−
51−
52−deriving stock instance Show (Name a)
53−
54−
55−instance k ~ Type => IsString (Name (a :: k)) where
56− fromString = Name
51+type Name :: K.Context
52+newtype Name a = Name String
53+ deriving stock Show
54+ deriving newtype IsString
5755
5856
5957instance Sql DBType a => Table Name (Name a) where
60− type Columns (Name a) = HType a
58+ type Columns (Name a) = HIdentity a
6159 type Context (Name a) = Name
60+ type FromExprs (Name a) = a
61+ type Transpose to (Name a) = to a
6262
63− toColumns (Name a) = HType (NameCol a)
64− fromColumns (HType (NameCol a)) = Name a
65− reify = notReify
66− unreify = notReify
67−
68−
69−instance Sql DBType a => Recontextualize Expr Name (Expr a) (Name a)
70−
71−
72−instance Sql DBType a => Recontextualize Result Name (Identity a) (Name a)
73−
74−
75−instance Sql DBType a => Recontextualize Name Expr (Name a) (Expr a)
76−
77−
78−instance Sql DBType a => Recontextualize Name Result (Name a) (Identity a)
79−
80−
81−instance Sql DBType a => Recontextualize Name Name (Name a) (Name a)
82−
83−
84−instance Interpretation Name where
85− newtype Col Name _spec = NameCol String
86−
87−
88−instance Labelable Name where
89− labeler (NameCol a) = NameCol a
90− unlabeler (NameCol a) = NameCol a
63+ toColumns a = HIdentity a
64+ fromColumns (HIdentity a) = a
65+ toResult a = HIdentity (Identity a)
66+ fromResult (HIdentity (Identity a)) = a
9167
9268
9369-- | @Selects a b@ means that @a@ is a schema (i.e., a 'Table' of 'Name's) for
9470-- the 'Expr' columns in @b@.
9571type Selects :: Type -> Type -> Constraint
96−class Recontextualize Name Expr names exprs => Selects names exprs
97−instance Recontextualize Name Expr names exprs => Selects names exprs
72+class Transposes Name Expr names exprs => Selects names exprs
73+instance Transposes Name Expr names exprs => Selects names exprs
74+
75+
76+ppColumn :: String -> Doc
77+ppColumn = Opaleye.ppSqlExpr . Opaleye.ColumnSqlExpr . Opaleye.SqlColumn
src/Rel8/Schema/Reify.hsdeleted−74
@@ -1,74 +0,0 @@
1−{-# language AllowAmbiguousTypes #-}
2−{-# language EmptyCase #-}
3−{-# language DataKinds #-}
4−{-# language FlexibleInstances #-}
5−{-# language ScopedTypeVariables #-}
6−{-# language StandaloneKindSignatures #-}
7−{-# language TypeApplications #-}
8−{-# language TypeFamilies #-}
9−{-# language TypeOperators #-}
10−{-# language UndecidableInstances #-}
11−
12−module Rel8.Schema.Reify
13− ( Reify, Col( Reify ), hreify, hunreify
14− , UnwrapReify
15− , NotReify, notReify
16− )
17−where
18−
19−-- base
20−import Data.Kind ( Constraint )
21−import Data.Type.Equality ( (:~:)( Refl ) )
22−import Prelude
23−
24−-- rel8
25−import Rel8.Schema.Context ( Interpretation, Col )
26−import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
27−import Rel8.Schema.HTable ( HTable, hmap )
28−import Rel8.Schema.Kind ( Context )
29−
30−
31−type Reify :: Context -> Context
32−data Reify context a
33−
34−
35−instance Interpretation (Reify context) where
36− newtype Col (Reify context) spec = Reify (Col context spec)
37−
38−
39−instance Labelable context => Labelable (Reify context) where
40− labeler (Reify a) = Reify (labeler a)
41− unlabeler (Reify a) = Reify (unlabeler a)
42−
43−
44−hreify :: HTable t => t (Col context) -> t (Col (Reify context))
45−hreify = hmap Reify
46−
47−
48−hunreify :: HTable t => t (Col (Reify context)) -> t (Col context)
49−hunreify = hmap (\(Reify a) -> a)
50−
51−
52−type UnwrapReify :: Context -> Context
53−type family UnwrapReify context where
54− UnwrapReify (Reify context) = context
55−
56−
57−type IsReify :: Context -> Bool
58−type family IsReify context where
59− IsReify (Reify _) = 'True
60− IsReify _ = 'False
61−
62−
63−type NotReify :: Context -> Constraint
64−class IsReify context ~ 'False => NotReify context
65−instance IsReify context ~ 'False => NotReify context
66−
67−
68−notReify :: forall context ctx a. NotReify context => context :~: Reify ctx -> a
69−notReify refl = case lemma @context of
70− Refl -> case refl of
71−
72−
73−lemma :: NotReify context => IsReify context :~: 'False
74−lemma = Refl
src/Rel8/Schema/Result.hs+20−41
@@ -5,71 +5,50 @@
55{-# language TypeFamilies #-}
66
77module Rel8.Schema.Result
8− ( Col( Result ), Result
9− , relabel
8+ ( Result
109 , null, nullifier, unnullifier
1110 , vectorizer, unvectorizer
1211 )
1312where
1413
1514-- base
15+import Data.Functor.Identity ( Identity( Identity), runIdentity )
1616import Prelude hiding ( null )
1717
1818-- rel8
19−import Rel8.Schema.Context ( Interpretation( Col ) )
20−import Rel8.Schema.HTable.Identity ( HIdentity(..) )
2119import Rel8.Schema.Kind ( Context )
2220import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )
23−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
21+import Rel8.Schema.Spec ( Spec(..) )
2422
2523
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.
2628type Result :: Context
27−data Result a
29+type Result = Identity
2830
2931
30−instance Interpretation Result where
31− data Col Result _spec where
32− Result :: a -> Col Result ('Spec labels necessity a)
32+null :: Result (Maybe a)
33+null = Identity Nothing
3334
3435
35−relabel :: ()
36− => HIdentity ('Spec labels necessity a) (Col Result)
37− -> HIdentity ('Spec relabels necessity a) (Col Result)
38−relabel (HIdentity (Result a)) = HIdentity (Result a)
39−
40−
41−null :: Col Result ('Spec labels necessity (Maybe a))
42−null = Result Nothing
43−
44−
45−nullifier :: ()
46− => SSpec ('Spec labels necessity a)
47− -> Col Result ('Spec labels necessity a)
48− -> Col Result ('Spec labels necessity (Nullify a))
49−nullifier SSpec {nullity} (Result a) = Result $ case nullity of
36+nullifier :: Spec a -> Result a -> Result (Nullify a)
37+nullifier Spec {nullity} (Identity a) = Identity $ case nullity of
5038 Null -> a
5139 NotNull -> Just a
5240
5341
54−unnullifier :: ()
55− => SSpec ('Spec labels necessity a)
56− -> Col Result ('Spec labels necessity (Nullify a))
57− -> Maybe (Col Result ('Spec labels necessity a))
58−unnullifier SSpec {nullity} (Result a) =
42+unnullifier :: Spec a -> Result (Nullify a) -> Maybe (Result a)
43+unnullifier Spec {nullity} (Identity a) =
5944 case nullity of
60− Null -> pure $ Result a
61− NotNull -> Result <$> a
45+ Null -> pure $ Identity a
46+ NotNull -> Identity <$> a
6247
6348
64−vectorizer :: Functor f
65− => SSpec ('Spec labels necessity a)
66− -> f (Col Result ('Spec labels necessity a))
67− -> Col Result ('Spec labels necessity (f a))
68−vectorizer _ = Result . fmap (\(Result a) -> a)
49+vectorizer :: Functor f => Spec a -> f (Result a) -> Result (f a)
50+vectorizer _ = Identity . fmap runIdentity
6951
7052
71−unvectorizer :: Functor f
72− => SSpec ('Spec labels necessity a)
73− -> Col Result ('Spec labels necessity (f a))
74− -> f (Col Result ('Spec labels necessity a))
75−unvectorizer _ (Result results) = Result <$> results
53+unvectorizer :: Functor f => Spec a -> Result (f a) -> f (Result a)
54+unvectorizer _ (Identity results) = Identity <$> results
src/Rel8/Schema/Spec.hs+17−45
@@ -1,62 +1,34 @@
1−{-# language DataKinds #-}
21{-# language FlexibleContexts #-}
3−{-# language GADTs #-}
2+{-# language MonoLocalBinds #-}
43{-# language StandaloneKindSignatures #-}
5−{-# language UndecidableInstances #-}
64
75module Rel8.Schema.Spec
8− ( Spec( Spec )
9− , SSpec( SSpec, labels, necessity, info, nullity )
10− , KnownSpec( specSing )
6+ ( Spec( Spec, labels, info, nullity )
7+ , specification
118 )
129where
1310
1411-- base
15−import Data.Kind ( Constraint, Type )
16−import Prelude ()
12+import Data.Kind ( Type )
13+import Prelude
1714
1815-- rel8
19−import Rel8.Kind.Labels ( Labels, SLabels, KnownLabels, labelsSing )
20−import Rel8.Kind.Necessity
21− ( Necessity
22− , SNecessity
23− , KnownNecessity, necessitySing
24− )
2516import Rel8.Schema.Null ( Nullity, Sql, Unnullify, nullable )
2617import Rel8.Type ( DBType, typeInformation )
2718import Rel8.Type.Information ( TypeInformation )
2819
2920
30−type Spec :: Type
31−data Spec = Spec Labels Necessity Type
32−
33−
34−type SSpec :: Spec -> Type
35−data SSpec spec where
36− SSpec ::
37− { labels :: SLabels labels
38− , necessity :: SNecessity necessity
39− , info :: TypeInformation (Unnullify a)
40− , nullity :: Nullity a
41− }
42− -> SSpec ('Spec labels necessity a)
21+type Spec :: Type -> Type
22+data Spec a = Spec
23+ { labels :: [String]
24+ , info :: TypeInformation (Unnullify a)
25+ , nullity :: Nullity a
26+ }
4327
4428
45−type KnownSpec :: Spec -> Constraint
46−class KnownSpec spec where
47− specSing :: SSpec spec
48−
49−
50−instance
51− ( KnownLabels labels
52− , KnownNecessity necessity
53− , Sql DBType a
54− )
55− => KnownSpec ('Spec labels necessity a)
56− where
57− specSing = SSpec
58− { labels = labelsSing
59− , necessity = necessitySing
60− , info = typeInformation
61− , nullity = nullable
62− }
29+specification :: Sql DBType a => Spec a
30+specification = Spec
31+ { labels = []
32+ , info = typeInformation
33+ , nullity = nullable
34+ }
src/Rel8/Schema/Spec/ConstrainDBType.hsdeleted−89
@@ -1,89 +0,0 @@
1−{-# language ConstraintKinds #-}
2−{-# language DataKinds #-}
3−{-# language FlexibleInstances #-}
4−{-# language MultiParamTypeClasses #-}
5−{-# language NamedFieldPuns #-}
6−{-# language QuantifiedConstraints #-}
7−{-# language StandaloneKindSignatures #-}
8−{-# language TypeFamilies #-}
9−{-# language UndecidableInstances #-}
10−
11−module Rel8.Schema.Spec.ConstrainDBType
12− ( ConstrainDBType
13− , dbTypeNullity, dbTypeDict
14− , nullifier, unnullifier
15− )
16−where
17−
18−-- base
19−import Data.Kind ( Constraint, Type )
20−import Prelude
21−
22−-- rel8
23−import Rel8.Schema.Dict ( Dict( Dict ) )
24−import Rel8.Schema.Null
25− ( Nullify, Unnullify
26− , Nullity( Null, NotNull )
27− , Sql, nullable
28− )
29−import Rel8.Schema.Spec ( Spec( Spec ), SSpec( SSpec, nullity ) )
30−
31−
32−type ConstrainDBType :: (Type -> Constraint) -> Spec -> Constraint
33−class
34− ( forall c 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−dbTypeNullity :: Dict (ConstrainDBType c) ('Spec l n a) -> Nullity a
47−dbTypeNullity = 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 -> Nullity a
53− step2 Dict = nullable
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−fromNullityDict :: Nullity a -> Dict c (Unnullify a) -> Dict (ConstrainDBType c) ('Spec l n a)
67−fromNullityDict Null Dict = Dict
68−fromNullityDict NotNull Dict = Dict
69−
70−
71−nullifier :: ()
72− => SSpec ('Spec labels necessity a)
73− -> Dict (ConstrainDBType c) ('Spec labels necessity a)
74− -> Dict (ConstrainDBType c) ('Spec labels necessity (Nullify a))
75−nullifier SSpec {} dict = case dbTypeDict dict of
76− Dict -> case dbTypeNullity dict of
77− Null -> Dict
78− NotNull -> Dict
79−
80−
81−unnullifier :: ()
82− => SSpec ('Spec labels necessity a)
83− -> Dict (ConstrainDBType c) ('Spec labels necessity (Nullify a))
84− -> Dict (ConstrainDBType c) ('Spec labels necessity a)
85−unnullifier SSpec {nullity} dict = case dbTypeDict dict of
86− Dict -> case nullity of
87− Null -> Dict
88− NotNull -> case dbTypeNullity dict of
89− Null -> fromNullityDict nullity Dict
src/Rel8/Schema/Spec/ConstrainType.hsdeleted−31
@@ -1,31 +0,0 @@
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/Table.hs+20
@@ -1,14 +1,26 @@
11{-# language DeriveFunctor #-}
22{-# language DerivingStrategies #-}
3+{-# language DisambiguateRecordFields #-}
4+{-# language NamedFieldPuns #-}
5+{-# language StandaloneKindSignatures #-}
36
47module Rel8.Schema.Table
58 ( TableSchema(..)
9+ , ppTable
610 )
711where
812
913-- base
14+import Data.Kind ( Type )
1015import Prelude
1116
17+-- opaleye
18+import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye
19+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye
20+
21+-- pretty
22+import Text.PrettyPrint ( Doc )
23+
1224
1325-- | The schema for a table. This is used to specify the name and schema that a
1426-- table belongs to (the @FROM@ part of a SQL query), along with the schema of
@@ -16,6 +28,7 @@ import Prelude
1628--
1729-- For each selectable table in your database, you should provide a
1830-- @TableSchema@ in order to interact with the table via Rel8.
31+type TableSchema :: Type -> Type
1932data TableSchema names = TableSchema
2033 { name :: String
2134 -- ^ The name of the table.
@@ -27,3 +40,10 @@ data TableSchema names = TableSchema
2740 -- data type here, parameterized by the 'Rel8.ColumnSchema.ColumnSchema' functor.
2841 }
2942 deriving stock Functor
43+
44+
45+ppTable :: TableSchema a -> Doc
46+ppTable TableSchema {name, schema} = Opaleye.ppTable Opaleye.SqlTable
47+ { sqlTableSchemaName = schema
48+ , sqlTableName = name
49+ }
src/Rel8/Statement/Delete.hs+35−48
@@ -1,40 +1,37 @@
11{-# language DuplicateRecordFields #-}
22{-# language GADTs #-}
33{-# language NamedFieldPuns #-}
4−{-# language ScopedTypeVariables #-}
4+{-# language RankNTypes #-}
5+{-# language RecordWildCards #-}
56{-# language StandaloneKindSignatures #-}
6−{-# language TypeApplications #-}
7+{-# language StrictData #-}
78
89module Rel8.Statement.Delete
910 ( Delete(..)
1011 , delete
12+ , ppDelete
1113 )
1214where
1315
1416-- base
15−import Control.Exception ( throwIO )
1617import Data.Kind ( Type )
1718import Prelude
1819
1920-- hasql
20−import Hasql.Connection ( Connection )
21−import qualified Hasql.Decoders as Hasql
2221import qualified Hasql.Encoders as Hasql
23−import qualified Hasql.Session as Hasql
2422import qualified Hasql.Statement as Hasql
2523
26−-- opaleye
27−import qualified Opaleye.Internal.Manipulation as Opaleye
24+-- pretty
25+import Text.PrettyPrint ( Doc, (<+>), ($$), text )
2826
2927-- rel8
3028import Rel8.Expr ( Expr )
31−import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
29+import Rel8.Query ( Query )
3230import Rel8.Schema.Name ( Selects )
33−import Rel8.Schema.Table ( TableSchema )
34−import Rel8.Statement.Returning ( Returning( NumberOfRowsAffected, Projection ) )
35−import Rel8.Table ( fromColumns, toColumns )
36−import Rel8.Table.Opaleye ( castTable, table, unpackspec )
37−import Rel8.Table.Serialize ( Serializable, parse )
31+import Rel8.Schema.Table ( TableSchema, ppTable )
32+import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )
33+import Rel8.Statement.Using ( ppUsing )
34+import Rel8.Statement.Where ( ppWhere )
3835
3936-- text
4037import qualified Data.Text as Text
@@ -47,7 +44,10 @@ data Delete a where
4744 Delete :: Selects names exprs =>
4845 { from :: TableSchema names
4946 -- ^ Which table to delete from.
50− , deleteWhere :: exprs -> Expr Bool
47+ , using :: Query using
48+ -- ^ @USING@ clause — this can be used to join against other tables,
49+ -- and its results can be referenced in the @WHERE@ clause
50+ , deleteWhere :: using -> exprs -> Expr Bool
5151 -- ^ Which rows should be selected for deletion.
5252 , returning :: Returning names a
5353 -- ^ What to return from the @DELETE@ statement.
@@ -55,38 +55,25 @@ data Delete a where
5555 -> Delete a
5656
5757
58−-- | Run a @DELETE@ statement.
59−delete :: Connection -> Delete a -> IO a
60−delete c Delete {from, deleteWhere, returning} =
61− case returning of
62− NumberOfRowsAffected -> Hasql.run session c >>= either throwIO pure
63− where
64− session = Hasql.statement () statement
65− statement = Hasql.Statement bytes params decode prepare
66− bytes = encodeUtf8 $ Text.pack sql
67− params = Hasql.noParams
68− decode = Hasql.rowsAffected
69− prepare = False
70− sql = Opaleye.arrangeDeleteSql from' where'
71− where
72− from' = table $ toColumns <$> from
73− where' = toColumn . toPrimExpr . deleteWhere . fromColumns
58+ppDelete :: Delete a -> Doc
59+ppDelete Delete {..} = case ppUsing using of
60+ Nothing ->
61+ text "DELETE FROM" <+> ppTable from $$
62+ text "WHERE false"
63+ Just (usingDoc, i) ->
64+ text "DELETE FROM" <+> ppTable from $$
65+ usingDoc $$
66+ ppWhere from (deleteWhere i) $$
67+ ppReturning from returning
7468
75− Projection project -> Hasql.run session c >>= either throwIO pure
76− where
77− session = Hasql.statement () statement
78− statement = Hasql.Statement bytes params decode prepare
79− bytes = encodeUtf8 $ Text.pack sql
80− params = Hasql.noParams
81− decode = decoder project
82− prepare = False
83− sql =
84− Opaleye.arrangeDeleteReturningSql unpackspec from' where' project'
85− where
86− from' = table $ toColumns <$> from
87− where' = toColumn . toPrimExpr . deleteWhere . fromColumns
88− project' = castTable . toColumns . project . fromColumns
69+
70+-- | Run a 'Delete' statement.
71+delete :: Delete a -> Hasql.Statement () a
72+delete d@Delete {returning} = Hasql.Statement bytes params decode prepare
8973 where
90− decoder :: forall exprs projection a. Serializable projection a
91− => (exprs -> projection) -> Hasql.Result [a]
92− decoder _ = Hasql.rowList (parse @projection @a)
74+ bytes = encodeUtf8 $ Text.pack sql
75+ params = Hasql.noParams
76+ decode = decodeReturning returning
77+ prepare = False
78+ sql = show doc
79+ doc = ppDelete d
src/Rel8/Statement/Insert.hs+60−60
@@ -1,89 +1,89 @@
1+{-# language DuplicateRecordFields #-}
2+{-# language FlexibleContexts #-}
13{-# language GADTs #-}
24{-# language NamedFieldPuns #-}
3−{-# language ScopedTypeVariables #-}
4−{-# language TypeApplications #-}
5+{-# language RecordWildCards #-}
6+{-# language StandaloneKindSignatures #-}
7+{-# language StrictData #-}
58
69module Rel8.Statement.Insert
710 ( Insert(..)
8− , OnConflict(..)
911 , insert
12+ , ppInsert
13+ , ppInto
1014 )
1115where
1216
1317-- base
14−import Control.Exception ( throwIO )
15−import Data.List.NonEmpty ( NonEmpty( (:|) ) )
18+import Data.Foldable ( toList )
19+import Data.Kind ( Type )
1620import Prelude
1721
1822-- hasql
19−import Hasql.Connection ( Connection )
20−import qualified Hasql.Decoders as Hasql
2123import qualified Hasql.Encoders as Hasql
22−import qualified Hasql.Session as Hasql
2324import qualified Hasql.Statement as Hasql
2425
2526-- opaleye
26−import qualified Opaleye.Internal.Manipulation as Opaleye
27−import qualified Opaleye.Manipulation as Opaleye
27+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye
28+
29+-- pretty
30+import Text.PrettyPrint ( Doc, (<+>), ($$), parens, text )
2831
2932-- rel8
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 ( castTable, table, unpackspec )
34−import Rel8.Table.Serialize ( Serializable, parse )
33+import Rel8.Query ( Query )
34+import Rel8.Schema.Name ( Name, Selects, ppColumn )
35+import Rel8.Schema.Table ( TableSchema(..), ppTable )
36+import Rel8.Statement.OnConflict ( OnConflict, ppOnConflict )
37+import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )
38+import Rel8.Statement.Select ( ppRows )
39+import Rel8.Table ( Table )
40+import Rel8.Table.Name ( showNames )
3541
3642-- text
3743import qualified Data.Text as Text ( pack )
3844import Data.Text.Encoding ( encodeUtf8 )
3945
4046
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 []
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
4763
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
6064
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' = castTable . toColumns . project . fromColumns
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
8072
81− where
82− onConflict' =
83− case onConflict of
84− DoNothing -> Just Opaleye.DoNothing
85− Abort -> Nothing
8673
87− decoder :: forall exprs projection a. Serializable projection a
88− => (exprs -> projection) -> Hasql.Result [a]
89− decoder _ = Hasql.rowList (parse @projection @a)
74+ppInto :: Table Name a => TableSchema a -> Doc
75+ppInto table@TableSchema {columns} =
76+ ppTable table <+>
77+ parens (Opaleye.commaV ppColumn (toList (showNames columns)))
78+
79+
80+-- | Run an 'Insert' statement.
81+insert :: Insert a -> Hasql.Statement () a
82+insert i@Insert {returning} = Hasql.Statement bytes params decode prepare
83+ where
84+ bytes = encodeUtf8 $ Text.pack sql
85+ params = Hasql.noParams
86+ decode = decodeReturning returning
87+ prepare = False
88+ sql = show doc
89+ doc = ppInsert i
src/Rel8/Statement/OnConflict.hsnew file+106
@@ -0,0 +1,106 @@
1+{-# language DuplicateRecordFields #-}
2+{-# language FlexibleContexts #-}
3+{-# language GADTs #-}
4+{-# language LambdaCase #-}
5+{-# language NamedFieldPuns #-}
6+{-# language RecordWildCards #-}
7+{-# language StandaloneKindSignatures #-}
8+{-# language StrictData #-}
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+114−10
@@ -1,29 +1,133 @@
11{-# language GADTs #-}
2+{-# language LambdaCase #-}
3+{-# language NamedFieldPuns #-}
4+{-# language RankNTypes #-}
5+{-# language ScopedTypeVariables #-}
26{-# language StandaloneKindSignatures #-}
7+{-# language StrictData #-}
8+{-# language TypeApplications #-}
39
410module Rel8.Statement.Returning
5− ( Returning(..)
11+ ( Returning( NumberOfRowsAffected, Projection )
12+ , decodeReturning
13+ , ppReturning
614 )
715where
816
917-- base
18+import Control.Applicative ( liftA2 )
19+import Data.Foldable ( toList )
1020import Data.Int ( Int64 )
1121import Data.Kind ( Type )
12−import Prelude ()
22+import Data.List.NonEmpty ( NonEmpty )
23+import Prelude
24+
25+-- hasql
26+import qualified Hasql.Decoders as Hasql
27+
28+-- opaleye
29+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
30+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye
31+import qualified Opaleye.Internal.Sql as Opaleye
32+
33+-- pretty
34+import Text.PrettyPrint ( Doc, (<+>), text )
1335
1436-- rel8
1537import Rel8.Schema.Name ( Selects )
16−import Rel8.Table.Serialize ( Serializable )
38+import Rel8.Schema.Table ( TableSchema(..) )
39+import Rel8.Table.Opaleye ( castTable, exprs, view )
40+import Rel8.Table.Serialize ( Serializable, parse )
1741
42+-- semigropuoids
43+import Data.Functor.Apply ( Apply, (<.>) )
1844
19−-- | @INSERT@, @UPDATE@ and @DELETE@ all support returning either the number of
20−-- rows affected, or the actual rows modified. 'Projection' allows you to
21−-- project out of these returned rows, which can be useful if you want to log
22−-- exactly which rows were deleted, or to view a generated id (for example, if
23−-- using a column with an autoincrementing counter as a default value).
45+
46+-- | 'Rel8.Insert', 'Rel8.Update' and 'Rel8.Delete' all support returning either
47+-- the number of rows affected, or the actual rows modified.
2448type Returning :: Type -> Type -> Type
2549data Returning names a where
50+ Pure :: a -> Returning names a
51+ Ap :: Returning names (a -> b) -> Returning names a -> Returning names b
52+
53+ -- | Return the number of rows affected.
2654 NumberOfRowsAffected :: Returning names Int64
27− Projection :: (Selects names exprs, Serializable projection a)
28− => (exprs -> projection)
55+
56+ -- | 'Projection' allows you to project out of the affected rows, which can
57+ -- be useful if you want to log exactly which rows were deleted, or to view
58+ -- a generated id (for example, if using a column with an autoincrementing
59+ -- counter via 'Rel8.nextval').
60+ Projection :: (Selects names exprs, Serializable returning a)
61+ => (exprs -> returning)
2962 -> Returning names [a]
63+
64+
65+instance Functor (Returning names) where
66+ fmap f = \case
67+ Pure a -> Pure (f a)
68+ Ap g a -> Ap (fmap (f .) g) a
69+ m -> Ap (Pure f) m
70+
71+
72+instance Apply (Returning names) where
73+ (<.>) = Ap
74+
75+
76+instance Applicative (Returning names) where
77+ pure = Pure
78+ (<*>) = Ap
79+
80+
81+projections :: ()
82+ => TableSchema names -> Returning names a -> Maybe (NonEmpty Opaleye.PrimExpr)
83+projections schema@TableSchema {columns} = \case
84+ Pure _ -> Nothing
85+ Ap f a -> projections schema f <> projections schema a
86+ NumberOfRowsAffected -> Nothing
87+ Projection f -> Just (exprs (castTable (f (view columns))))
88+
89+
90+runReturning :: ()
91+ => ((Int64 -> a) -> r)
92+ -> (forall x. Hasql.Row x -> ([x] -> a) -> r)
93+ -> Returning names a
94+ -> r
95+runReturning rowCount rowList = \case
96+ Pure a -> rowCount (const a)
97+ Ap fs as ->
98+ runReturning
99+ (\withCount ->
100+ runReturning
101+ (\withCount' -> rowCount (withCount <*> withCount'))
102+ (\decoder -> rowList decoder . liftA2 withCount length64)
103+ as)
104+ (\decoder withRows ->
105+ runReturning
106+ (\withCount -> rowList decoder $ withRows <*> withCount . length64)
107+ (\decoder' withRows' ->
108+ rowList (liftA2 (,) decoder decoder') $
109+ withRows <$> fmap fst <*> withRows' . fmap snd)
110+ as)
111+ fs
112+ NumberOfRowsAffected -> rowCount id
113+ Projection (_ :: exprs -> returning) -> rowList decoder' id
114+ where
115+ decoder' = parse @returning
116+ where
117+ length64 :: Foldable f => f x -> Int64
118+ length64 = fromIntegral . length
119+
120+
121+decodeReturning :: Returning names a -> Hasql.Result a
122+decodeReturning = runReturning
123+ (<$> Hasql.rowsAffected)
124+ (\decoder withRows -> withRows <$> Hasql.rowList decoder)
125+
126+
127+ppReturning :: TableSchema names -> Returning names a -> Doc
128+ppReturning schema returning = case projections schema returning of
129+ Nothing -> mempty
130+ Just columns ->
131+ text "RETURNING" <+> Opaleye.commaV Opaleye.ppSqlExpr (toList sqlExprs)
132+ where
133+ sqlExprs = Opaleye.sqlExpr <$> columns
src/Rel8/Statement/SQL.hsnew file+29
@@ -0,0 +1,29 @@
1+module Rel8.Statement.SQL
2+ ( showDelete
3+ , showInsert
4+ , showUpdate
5+ )
6+where
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+120−35
@@ -1,62 +1,147 @@
1+{-# language DeriveTraversable #-}
2+{-# language DerivingStrategies #-}
3+{-# language FlexibleContexts #-}
14{-# language MonoLocalBinds #-}
25{-# language ScopedTypeVariables #-}
6+{-# language StandaloneKindSignatures #-}
37{-# language TypeApplications #-}
48
59module Rel8.Statement.Select
610 ( select
7− , selectWithNames
11+ , ppSelect
12+
13+ , Optimized(..)
14+ , ppPrimSelect
15+ , ppRows
816 )
917where
1018
1119-- base
12−import Control.Exception ( throwIO )
13−import Prelude
20+import Data.Foldable ( toList )
21+import Data.Kind ( Type )
22+import Data.Void ( Void )
23+import Prelude hiding ( undefined )
1424
1525-- hasql
16−import Hasql.Connection ( Connection )
1726import qualified Hasql.Decoders as Hasql
1827import qualified Hasql.Encoders as Hasql
19−import qualified Hasql.Session as Hasql
2028import qualified Hasql.Statement as Hasql
2129
30+-- opaleye
31+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
32+import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye
33+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye
34+import qualified Opaleye.Internal.PrimQuery as Opaleye
35+import qualified Opaleye.Internal.Print as Opaleye
36+import qualified Opaleye.Internal.Optimize as Opaleye
37+import qualified Opaleye.Internal.QueryArr as Opaleye hiding ( Select )
38+import qualified Opaleye.Internal.Sql as Opaleye hiding ( Values )
39+import qualified Opaleye.Internal.Tag as Opaleye
40+
41+-- pretty
42+import Text.PrettyPrint ( Doc )
43+
2244-- rel8
45+import Rel8.Expr ( Expr )
46+import Rel8.Expr.Bool ( false )
47+import Rel8.Expr.Opaleye ( toPrimExpr )
2348import Rel8.Query ( Query )
24−import Rel8.Query.SQL ( sqlForQuery, sqlForQueryWithNames )
49+import Rel8.Query.Opaleye ( toOpaleye )
2550import Rel8.Schema.Name ( Selects )
51+import Rel8.Table ( Table )
52+import Rel8.Table.Cols ( toCols )
53+import Rel8.Table.Name ( namesFromLabels )
54+import Rel8.Table.Opaleye ( castTable, exprsWithNames )
55+import qualified Rel8.Table.Opaleye as T
2656import Rel8.Table.Serialize ( Serializable, parse )
57+import Rel8.Table.Undefined ( undefined )
2758
2859-- text
2960import qualified Data.Text as Text
3061import Data.Text.Encoding ( encodeUtf8 )
3162
3263
33−-- | Run a @SELECT@ query, returning all rows.
64+-- | Run a @SELECT@ statement, returning all rows.
3465select :: forall exprs a. Serializable exprs a
35− => Connection -> Query exprs -> IO [a]
36−select c query = case sqlForQuery query of
37− Nothing -> pure []
38− Just sql -> Hasql.run session c >>= either throwIO pure
39− where
40− session = Hasql.statement () statement
41− statement = Hasql.Statement bytes params decode prepare
42− bytes = encodeUtf8 (Text.pack sql)
43− params = Hasql.noParams
44− decode = Hasql.rowList (parse @exprs @a)
45− prepare = False
46−
47−
48−selectWithNames :: forall exprs a names.
49− ( Selects names exprs
50− , Serializable exprs a
51− )
52− => Connection -> names -> Query exprs -> IO [a]
53−selectWithNames c names query = case sqlForQueryWithNames names query of
54− Nothing -> pure []
55− Just sql -> Hasql.run session c >>= either throwIO pure
56− where
57− session = Hasql.statement () statement
58− statement = Hasql.Statement bytes params decode prepare
59− bytes = encodeUtf8 (Text.pack sql)
60− params = Hasql.noParams
61− decode = Hasql.rowList (parse @exprs @a)
62− prepare = False
66+ => Query exprs -> Hasql.Statement () [a]
67+select query = Hasql.Statement bytes params decode prepare
68+ where
69+ bytes = encodeUtf8 (Text.pack sql)
70+ params = Hasql.noParams
71+ decode = Hasql.rowList (parse @exprs @a)
72+ prepare = False
73+ sql = show doc
74+ doc = ppSelect query
75+
76+
77+ppSelect :: Table Expr a => Query a -> Doc
78+ppSelect query =
79+ Opaleye.ppSql $ primSelectWith names (toCols exprs') primQuery'
80+ where
81+ names = namesFromLabels
82+ (exprs, primQuery, _) =
83+ Opaleye.runSimpleQueryArrStart (toOpaleye query) ()
84+ (exprs', primQuery') = case optimize primQuery of
85+ Empty -> (undefined, Opaleye.Product (pure (pure Opaleye.Unit)) never)
86+ Unit -> (exprs, Opaleye.Unit)
87+ Optimized pq -> (exprs, pq)
88+ never = pure (toPrimExpr false)
89+
90+
91+ppRows :: Table Expr a => Query a -> Doc
92+ppRows query = case optimize primQuery of
93+ -- Special case VALUES because we can't use DEFAULT inside a SELECT
94+ Optimized (Opaleye.Values symbols rows)
95+ | eqSymbols symbols (toList (T.exprs a)) ->
96+ Opaleye.ppValues_ (map Opaleye.sqlExpr <$> toList rows)
97+ _ -> ppSelect query
98+ where
99+ (a, primQuery, _) = Opaleye.runSimpleQueryArrStart (toOpaleye query) ()
100+
101+ eqSymbols (symbol : symbols) (Opaleye.AttrExpr symbol' : exprs)
102+ | eqSymbol symbol symbol' = eqSymbols symbols exprs
103+ | otherwise = False
104+ eqSymbols [] [] = True
105+ eqSymbols _ _ = False
106+
107+ eqSymbol
108+ (Opaleye.Symbol name (Opaleye.UnsafeTag tag))
109+ (Opaleye.Symbol name' (Opaleye.UnsafeTag tag'))
110+ = name == name' && tag == tag'
111+
112+
113+ppPrimSelect :: Query a -> (Optimized Doc, a)
114+ppPrimSelect query =
115+ (Opaleye.ppSql . primSelect <$> optimize primQuery, a)
116+ where
117+ (a, primQuery, _) = Opaleye.runSimpleQueryArrStart (toOpaleye query) ()
118+
119+
120+type Optimized :: Type -> Type
121+data Optimized a = Empty | Unit | Optimized a
122+ deriving stock (Functor, Foldable, Traversable, Show)
123+
124+
125+optimize :: Opaleye.PrimQuery' a -> Optimized (Opaleye.PrimQuery' Void)
126+optimize query = case Opaleye.removeEmpty (Opaleye.optimize query) of
127+ Nothing -> Empty
128+ Just Opaleye.Unit -> Unit
129+ Just query' -> Optimized query'
130+
131+
132+primSelect :: Opaleye.PrimQuery' Void -> Opaleye.Select
133+primSelect = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator
134+
135+
136+primSelectWith :: Selects names exprs
137+ => names -> exprs -> Opaleye.PrimQuery' Void -> Opaleye.Select
138+primSelectWith names exprs query =
139+ Opaleye.SelectFrom $ Opaleye.newSelect
140+ { Opaleye.attrs = Opaleye.SelectAttrs attrs
141+ , Opaleye.tables = Opaleye.oneTable (primSelect query)
142+ }
143+ where
144+ attrs = makeAttr <$> exprsWithNames names (castTable exprs)
145+ where
146+ makeAttr (label, expr) =
147+ (Opaleye.sqlExpr expr, Just (Opaleye.SqlColumn label))
src/Rel8/Statement/Set.hsnew file+33
@@ -0,0 +1,33 @@
1+{-# language MonoLocalBinds #-}
2+{-# language NamedFieldPuns #-}
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+38−60
@@ -1,43 +1,37 @@
1+{-# language DuplicateRecordFields #-}
12{-# language GADTs #-}
23{-# language NamedFieldPuns #-}
3−{-# language ScopedTypeVariables #-}
4+{-# language RecordWildCards #-}
45{-# language StandaloneKindSignatures #-}
5−{-# language TypeApplications #-}
6+{-# language StrictData #-}
67
78module Rel8.Statement.Update
89 ( Update(..)
910 , update
11+ , ppUpdate
1012 )
1113where
1214
1315-- base
14−import Control.Exception ( throwIO )
1516import Data.Kind ( Type )
1617import Prelude
1718
1819-- hasql
19−import Hasql.Connection ( Connection )
20−import qualified Hasql.Decoders as Hasql
2120import qualified Hasql.Encoders as Hasql
22−import qualified Hasql.Session as Hasql
2321import qualified Hasql.Statement as Hasql
2422
25−-- opaleye
26−import qualified Opaleye.Internal.Manipulation as Opaleye
27−
28−-- profunctors
29−import Data.Profunctor ( lmap )
23+-- pretty
24+import Text.PrettyPrint ( Doc, (<+>), ($$), text )
3025
3126-- rel8
3227import Rel8.Expr ( Expr )
33−import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
28+import Rel8.Query ( Query )
3429import Rel8.Schema.Name ( Selects )
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 ( castTable, table, unpackspec )
40−import Rel8.Table.Serialize ( Serializable, parse )
30+import Rel8.Schema.Table ( TableSchema(..), ppTable )
31+import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )
32+import Rel8.Statement.Set ( ppSet )
33+import Rel8.Statement.Using ( ppFrom )
34+import Rel8.Statement.Where ( ppWhere )
4135
4236-- text
4337import qualified Data.Text as Text
@@ -50,9 +44,12 @@ data Update a where
5044 Update :: Selects names exprs =>
5145 { target :: TableSchema names
5246 -- ^ Which table to update.
53− , set :: exprs -> exprs
47+ , from :: Query from
48+ -- ^ @FROM@ clause — this can be used to join against other tables,
49+ -- and its results can be referenced in the @SET@ and @WHERE@ clauses.
50+ , set :: from -> exprs -> exprs
5451 -- ^ How to update each selected row.
55− , updateWhere :: exprs -> Expr Bool
52+ , updateWhere :: from -> exprs -> Expr Bool
5653 -- ^ Which rows to select for update.
5754 , returning :: Returning names a
5855 -- ^ What to return from the @UPDATE@ statement.
@@ -60,46 +57,27 @@ data Update a where
6057 -> Update a
6158
6259
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
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
8072
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' = castTable . toColumns . project . fromColumns
10173
74+-- | Run an @UPDATE@ statement.
75+update :: Update a -> Hasql.Statement () a
76+update u@Update {returning} = Hasql.Statement bytes params decode prepare
10277 where
103− decoder :: forall exprs projection a. Serializable projection a
104− => (exprs -> projection) -> Hasql.Result [a]
105− decoder _ = Hasql.rowList (parse @projection @a)
78+ bytes = encodeUtf8 $ Text.pack sql
79+ params = Hasql.noParams
80+ decode = decodeReturning returning
81+ prepare = False
82+ sql = show doc
83+ doc = ppUpdate u
src/Rel8/Statement/Using.hsnew file+36
@@ -0,0 +1,36 @@
1+module Rel8.Statement.Using
2+ ( ppFrom
3+ , ppUsing
4+ )
5+where
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+43−28
@@ -3,61 +3,76 @@
33
44module Rel8.Statement.View
55 ( createView
6+ , createOrReplaceView
67 )
78where
89
910-- base
10−import Control.Exception ( throwIO )
11−import Control.Monad ( (>=>) )
12−import Data.Foldable ( fold )
13−import Data.Maybe ( fromMaybe )
1411import Prelude
1512
1613-- hasql
17−import Hasql.Connection ( Connection )
1814import qualified Hasql.Decoders as Hasql
1915import qualified Hasql.Encoders as Hasql
20−import qualified Hasql.Session as Hasql
2116import qualified Hasql.Statement as Hasql
2217
2318-- rel8
2419import Rel8.Query ( Query )
25−import Rel8.Query.SQL ( sqlForQueryWithNames )
2620import Rel8.Schema.Name ( Selects )
27−import Rel8.Schema.Table ( TableSchema( TableSchema ) )
28−import Rel8.Table.Alternative ( emptyTable )
21+import Rel8.Schema.Table ( TableSchema )
22+import Rel8.Statement.Insert ( ppInto )
23+import Rel8.Statement.Select ( ppSelect )
24+
25+-- pretty
26+import Text.PrettyPrint ( Doc, (<+>), ($$), text )
2927
3028-- text
3129import qualified Data.Text as Text
3230import Data.Text.Encoding ( encodeUtf8 )
3331
3432
33+data CreateView = Create | CreateOrReplace
34+
35+
3536-- | Given a 'TableSchema' and 'Query', @createView@ runs a @CREATE VIEW@
3637-- statement that will save the given query as a view. This can be useful if
3738-- you want to share Rel8 queries with other applications.
3839createView :: Selects names exprs
39− => TableSchema names -> Query exprs -> Connection -> IO ()
40−createView (TableSchema name mschema names) query =
41− Hasql.run session >=> either throwIO pure
40+ => TableSchema names -> Query exprs -> Hasql.Statement () ()
41+createView =
42+ createViewGeneric Create
43+
44+
45+-- | Given a 'TableSchema' and 'Query', @createOrReplaceView@ runs a
46+-- @CREATE OR REPLACE VIEW@ statement that will save the given query
47+-- as a view, replacing the current view definition if it exists and
48+-- adheres to the restrictions in place for replacing a view in
49+-- PostgreSQL.
50+createOrReplaceView :: Selects names exprs
51+ => TableSchema names -> Query exprs -> Hasql.Statement () ()
52+createOrReplaceView =
53+ createViewGeneric CreateOrReplace
54+
55+
56+createViewGeneric :: Selects names exprs
57+ => CreateView -> TableSchema names -> Query exprs -> Hasql.Statement () ()
58+createViewGeneric replace schema query =
59+ Hasql.Statement bytes params decode prepare
4260 where
43− session = Hasql.statement () statement
44− statement = Hasql.Statement bytes params decode prepare
4561 bytes = encodeUtf8 (Text.pack sql)
4662 params = Hasql.noParams
4763 decode = Hasql.noResult
4864 prepare = False
49− sql = "CREATE VIEW " <> title <> " AS " <> select
50− where
51− title = case mschema of
52− Nothing -> quote name
53− Just schema -> quote schema <> "." <> quote name
54− select = fromMaybe fallback $ sqlForQueryWithNames names query
55− where
56− fallback = fold $ sqlForQueryWithNames names emptyTable
57−
58−
59−quote :: String -> String
60−quote string = "\"" <> concatMap go string <> "\""
65+ sql = show doc
66+ doc = ppCreateView schema query replace
67+
68+
69+ppCreateView :: Selects names exprs
70+ => TableSchema names -> Query exprs -> CreateView -> Doc
71+ppCreateView schema query replace =
72+ createOrReplace replace <+>
73+ ppInto schema $$
74+ text "AS" <+>
75+ ppSelect query
6176 where
62− go '"' = "\"\""
63− go c = [c]
77+ createOrReplace Create = text "CREATE VIEW"
78+ createOrReplace CreateOrReplace = text "CREATE OR REPLACE VIEW"
src/Rel8/Statement/Where.hsnew file+31
@@ -0,0 +1,31 @@
1+{-# language MonoLocalBinds #-}
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+88−252
@@ -1,77 +1,47 @@
11{-# language AllowAmbiguousTypes #-}
22{-# language DataKinds #-}
33{-# language DefaultSignatures #-}
4−{-# language DisambiguateRecordFields #-}
54{-# language FlexibleContexts #-}
65{-# language FlexibleInstances #-}
76{-# language FunctionalDependencies #-}
8−{-# language LambdaCase #-}
9−{-# language NamedFieldPuns #-}
107{-# language ScopedTypeVariables #-}
118{-# language StandaloneKindSignatures #-}
129{-# language TypeApplications #-}
1310{-# language TypeFamilies #-}
14−{-# language TypeOperators #-}
1511{-# language UndecidableInstances #-}
1612
1713module Rel8.Table
18− ( Table (Columns, Context, Unreify, toColumns, fromColumns, reify, unreify)
14+ ( Table
15+ ( Columns, Context, fromColumns, toColumns
16+ , FromExprs, fromResult, toResult
17+ , Transpose
18+ )
1919 , Congruent
20− , TTable, TColumns, TContext, TUnreify
20+ , TTable, TColumns, TContext, TFromExprs, TTranspose
21+ , TSerialize
2122 )
2223where
2324
2425-- base
25−import Data.Functor ( ($>) )
2626import Data.Functor.Identity ( Identity( Identity ) )
2727import Data.Kind ( Constraint, Type )
28−import Data.List.NonEmpty ( NonEmpty )
29−import Data.Proxy ( Proxy( Proxy ) )
30−import Data.Type.Equality ( (:~:)( Refl ) )
3128import GHC.Generics ( Generic, Rep, from, to )
3229import Prelude hiding ( null )
3330
3431-- rel8
3532import Rel8.FCF ( Eval, Exp )
36−import Rel8.Kind.Algebra ( KnownAlgebra )
37−import Rel8.Generic.Map ( GMap, GMappable, gmap, gunmap )
38−import Rel8.Generic.Table
39− ( GGTable, GGColumns, GGContext, ggfromColumns, ggtoColumns
40− , GAlgebra
33+import Rel8.Generic.Map ( Map )
34+import Rel8.Generic.Table.Record
35+ ( GTable, GColumns, GContext, gfromColumns, gtoColumns
36+ , GSerialize, gfromResult, gtoResult
4137 )
4238import Rel8.Generic.Record ( Record(..) )
43−import Rel8.Generic.Reify ( ARep )
44−import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
4539import Rel8.Schema.HTable ( HTable )
46−import Rel8.Schema.HTable.Either ( HEitherTable(..) )
47−import Rel8.Schema.HTable.Identity ( HIdentity(..), HType )
48−import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
49−import Rel8.Schema.HTable.List ( HListTable )
50−import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
51−import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
52−import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify )
53−import Rel8.Schema.HTable.These ( HTheseTable(..) )
54−import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )
40+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
5541import qualified Rel8.Schema.Kind as K
5642import Rel8.Schema.Null ( Sql )
57−import Rel8.Schema.Reify
58− ( Reify, Col( Reify ), hreify, hunreify
59− , UnwrapReify
60− , notReify
61− )
62−import Rel8.Schema.Result
63− ( Col( Result ), Result
64− , relabel
65− , null, nullifier, unnullifier
66− , vectorizer, unvectorizer
67− )
68−import Rel8.Schema.Spec ( KnownSpec )
43+import Rel8.Schema.Result ( Result )
6944import Rel8.Type ( DBType )
70−import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )
71−
72−-- these
73−import Data.These ( These( This, That, These ) )
74−import Data.These.Combinators ( justHere, justThere )
7545
7646
7747-- | @Table@s are one of the foundational elements of Rel8, and describe data
@@ -86,90 +56,102 @@ import Data.These.Combinators ( justHere, justThere )
8656-- yourself, as anything that's an instance of 'Rel8.Rel8able' is always a
8757-- 'Table'.
8858type Table :: K.Context -> Type -> Constraint
89−class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where
59+class
60+ ( HTable (Columns a)
61+ , context ~ Context a
62+ , a ~ Transpose context a
63+ )
64+ => Table context a | a -> context
65+ where
9066 -- | The 'HTable' functor that describes the schema of this table.
9167 type Columns a :: K.HTable
9268
9369 -- | The common context that all columns use as an interpretation.
9470 type Context a :: K.Context
9571
96− type Unreify a :: Type
72+ -- | The @FromExprs@ type family maps a type in the @Expr@ context to the
73+ -- corresponding Haskell type.
74+ type FromExprs a :: Type
75+
76+ type Transpose (context' :: K.Context) a :: Type
9777
98− toColumns :: a -> Columns a (Col context)
99− fromColumns :: Columns a (Col context) -> a
10078
101− reify :: context :~: Reify ctx -> Unreify a -> a
102− unreify :: context :~: Reify ctx -> a -> Unreify a
79+ toColumns :: a -> Columns a context
80+ fromColumns :: Columns a context -> a
10381
104− type Columns a = Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))
105− type Context a = Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))
106− type Unreify a = DefaultUnreify a
82+ fromResult :: Columns a Result -> FromExprs a
83+ toResult :: FromExprs a -> Columns a Result
84+
85+ type Columns a = GColumns TColumns (Rep (Record a))
86+ type Context a = GContext TContext (Rep (Record a))
87+ type FromExprs a = Map TFromExprs a
88+ type Transpose context a = Map (TTranspose context) a
10789
10890 default toColumns ::
10991 ( Generic (Record a)
110− , KnownAlgebra (GAlgebra (Rep (Record a)))
111− , Eval (GGTable (GAlgebra (Rep (Record a))) (TTable context) TColumns (Col context) (Rep (Record a)))
112− , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))
113− , Context a ~ Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))
92+ , GTable (TTable context) TColumns (Rep (Record a))
93+ , Columns a ~ GColumns TColumns (Rep (Record a))
11494 )
115− => a -> Columns a (Col context)
95+ => a -> Columns a context
11696 toColumns =
117− ggtoColumns
118− @(GAlgebra (Rep (Record a)))
119− @(TTable context)
120− @TColumns
121− id
122− id
123− toColumns .
97+ gtoColumns @(TTable context) @TColumns toColumns .
12498 from .
12599 Record
126100
127101 default fromColumns ::
128102 ( Generic (Record a)
129− , KnownAlgebra (GAlgebra (Rep (Record a)))
130− , Eval (GGTable (GAlgebra (Rep (Record a))) (TTable context) TColumns (Col context) (Rep (Record a)))
131− , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))
132− , Context a ~ Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))
103+ , GTable (TTable context) TColumns (Rep (Record a))
104+ , Columns a ~ GColumns TColumns (Rep (Record a))
133105 )
134− => Columns a (Col context) -> a
106+ => Columns a context -> a
135107 fromColumns =
136108 unrecord .
137109 to .
138− ggfromColumns
139− @(GAlgebra (Rep (Record a)))
140− @(TTable context)
141− @TColumns
142− id
143− id
144− fromColumns
110+ gfromColumns @(TTable context) @TColumns fromColumns
145111
146− default reify ::
147− ( Generic (Record a)
148− , Generic (Record (Unreify a))
149− , GMappable (TTable context) (Rep (Record a))
150− , Rep (Record (Unreify a)) ~ GMap TUnreify (Rep (Record a))
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))
151116 )
152− => context :~: Reify ctx -> Unreify a -> a
153− reify Refl =
154− unrecord .
155− to .
156− gunmap @(TTable context) (Proxy @TUnreify) (reify Refl) .
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) .
157125 from .
158126 Record
159127
160− default unreify ::
161− ( Generic (Record a)
162− , Generic (Record (Unreify a))
163− , GMappable (TTable context) (Rep (Record a))
164− , Rep (Record (Unreify a)) ~ GMap TUnreify (Rep (Record a))
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))
165132 )
166− => context :~: Reify ctx -> a -> Unreify a
167− unreify Refl =
133+ => Columns a Result -> FromExprs a
134+ fromResult =
168135 unrecord .
169136 to .
170− gmap @(TTable context) (Proxy @TUnreify) (unreify Refl) .
171− from .
172− Record
137+ gfromResult
138+ @TSerialize
139+ @TColumns
140+ @(Rep (Record a))
141+ @(Rep (Record (FromExprs a)))
142+ (\(_ :: proxy x) -> fromResult @(Context x) @x)
143+
144+
145+instance Sql DBType a => Table Result (Identity a) where
146+ type Columns (Identity a) = HIdentity a
147+ type Context (Identity a) = Result
148+ type FromExprs (Identity a) = a
149+ type Transpose to (Identity a) = to a
150+
151+ toColumns = HIdentity
152+ fromColumns (HIdentity a) = a
153+ toResult a = HIdentity (Identity a)
154+ fromResult (HIdentity (Identity a)) = a
173155
174156
175157data TTable :: K.Context -> Type -> Exp Constraint
@@ -184,175 +166,32 @@ data TContext :: Type -> Exp K.Context
184166type instance Eval (TContext a) = Context a
185167
186168
187−data TUnreify :: Type -> Exp Type
188−type instance Eval (TUnreify a) = Unreify a
189−
190−
191−type DefaultUnreify :: Type -> Type
192−type family DefaultUnreify a where
193− DefaultUnreify (t a b c d e f g) =
194− t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e) (Unreify f) (Unreify g)
195− DefaultUnreify (t a b c d e f) =
196− t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e) (Unreify f)
197− DefaultUnreify (t a b c d e) =
198− t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e)
199− DefaultUnreify (t a b c d) =
200− t (Unreify a) (Unreify b) (Unreify c) (Unreify d)
201− DefaultUnreify (t a b c) = t (Unreify a) (Unreify b) (Unreify c)
202− DefaultUnreify (t a b) = t (Unreify a) (Unreify b)
203− DefaultUnreify (t a) = t (Unreify a)
204− DefaultUnreify a = ARep (GMap TUnreify (Rep a))
205−
169+data TFromExprs :: Type -> Exp Type
170+type instance Eval (TFromExprs a) = FromExprs a
206171
207−-- | Any 'HTable' is also a 'Table'.
208−instance HTable t => Table context (t (Col context)) where
209− type Columns (t (Col context)) = t
210− type Context (t (Col context)) = context
211− type Unreify (t (Col context)) = t (Col (UnwrapReify context))
212172
213− toColumns = id
214− fromColumns = id
173+data TTranspose :: K.Context -> Type -> Exp Type
174+type instance Eval (TTranspose context a) = Transpose context a
215175
216− reify Refl = hreify
217− unreify Refl = hunreify
218−
219−
220−-- | Any context is trivially a table.
221−instance KnownSpec spec => Table context (Col context spec) where
222− type Columns (Col context spec) = HIdentity spec
223− type Context (Col context spec) = context
224− type Unreify (Col context spec) = Col (UnwrapReify context) spec
225−
226− toColumns = HIdentity
227− fromColumns = unHIdentity
228−
229− reify Refl = Reify
230− unreify Refl (Reify a) = a
231176
177+data TSerialize :: Type -> Type -> Exp Constraint
178+type instance Eval (TSerialize expr a) =
179+ ( Table (Context expr) expr
180+ , a ~ FromExprs expr
181+ )
232182
233−instance Sql DBType a => Table Result (Identity a) where
234− type Columns (Identity a) = HType a
235− type Context (Identity a) = Result
236183
237− toColumns (Identity a) = HType (Result a)
238− fromColumns (HType (Result a)) = Identity a
239−
240− reify = notReify
241− unreify = notReify
242−
243−
244−instance (Table Result a, Table Result b) => Table Result (Either a b) where
245− type Columns (Either a b) = HEitherTable (Columns a) (Columns b)
246− type Context (Either a b) = Result
247−
248− toColumns = \case
249− Left table -> HEitherTable
250− { htag = HIdentity (Result IsLeft)
251− , hleft = hlabel labeler (hnullify nullifier (toColumns table))
252− , hright = hlabel labeler (hnulls (const null))
253− }
254− Right table -> HEitherTable
255− { htag = HIdentity (Result IsRight)
256− , hleft = hlabel labeler (hnulls (const null))
257− , hright = hlabel labeler (hnullify nullifier (toColumns table))
258− }
259−
260− fromColumns HEitherTable {htag, hleft, hright} = case htag of
261− HIdentity (Result tag) -> case tag of
262− IsLeft -> maybe err (Left . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hleft)
263− IsRight -> maybe err (Right . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hright)
264− where
265− err = error "Either.fromColumns: mismatch between tag and data"
266−
267−
268−instance Table Result a => Table Result [a] where
269− type Columns [a] = HListTable (Columns a)
270− type Context [a] = Result
271−
272− toColumns = hvectorize vectorizer . fmap toColumns
273− fromColumns = fmap fromColumns . hunvectorize unvectorizer
274−
275−
276−instance Table Result a => Table Result (Maybe a) where
277− type Columns (Maybe a) = HMaybeTable (Columns a)
278− type Context (Maybe a) = Result
279−
280− toColumns = \case
281− Nothing -> HMaybeTable
282− { htag = HIdentity (Result Nothing)
283− , hjust = hlabel labeler (hnulls (const null))
284− }
285− Just table -> HMaybeTable
286− { htag = HIdentity (Result (Just IsJust))
287− , hjust = hlabel labeler (hnullify nullifier (toColumns table))
288− }
289−
290− fromColumns HMaybeTable {htag, hjust} = case htag of
291− HIdentity (Result tag) -> tag $>
292− case hunnullify unnullifier (hunlabel unlabeler hjust) of
293− Nothing -> error "Maybe.fromColumns: mismatch between tag and data"
294− Just just -> fromColumns just
295−
296−
297−instance Table Result a => Table Result (NonEmpty a) where
298− type Columns (NonEmpty a) = HNonEmptyTable (Columns a)
299− type Context (NonEmpty a) = Result
300−
301− toColumns = hvectorize vectorizer . fmap toColumns
302− fromColumns = fmap fromColumns . hunvectorize unvectorizer
303−
304−
305−instance (Table Result a, Table Result b) => Table Result (These a b) where
306− type Columns (These a b) = HTheseTable (Columns a) (Columns b)
307− type Context (These a b) = Result
308−
309− toColumns tables = HTheseTable
310− { hhereTag = relabel hhereTag
311− , hhere = hlabel labeler (hunlabel unlabeler (toColumns hhere))
312− , hthereTag = relabel hthereTag
313− , hthere = hlabel labeler (hunlabel unlabeler (toColumns hthere))
314− }
315− where
316− HMaybeTable
317− { htag = hhereTag
318− , hjust = hhere
319− } = toColumns (justHere tables)
320− HMaybeTable
321− { htag = hthereTag
322− , hjust = hthere
323− } = toColumns (justThere tables)
324−
325− fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} =
326− case (fromColumns mhere, fromColumns mthere) of
327− (Just a, Nothing) -> This (fromColumns a)
328− (Nothing, Just b) -> That (fromColumns b)
329− (Just a, Just b) -> These (fromColumns a) (fromColumns b)
330− _ -> error "These.fromColumns: mismatch between tags and data"
331− where
332− mhere = HMaybeTable
333− { htag = relabel hhereTag
334− , hjust = hlabel labeler (hunlabel unlabeler hhere)
335− }
336− mthere = HMaybeTable
337− { htag = relabel hthereTag
338− , hjust = hlabel labeler (hunlabel unlabeler hthere)
339− }
340−
341−
342−instance (Table context a, Table context b, Labelable context)
343− => Table context (a, b)
184+instance (Table context a, Table context b) => Table context (a, b)
344185
345186
346187instance
347188 ( Table context a, Table context b, Table context c
348− , Labelable context
349189 )
350190 => Table context (a, b, c)
351191
352192
353193instance
354194 ( Table context a, Table context b, Table context c, Table context d
355− , Labelable context
356195 )
357196 => Table context (a, b, c, d)
358197
@@ -360,7 +199,6 @@ instance
360199instance
361200 ( Table context a, Table context b, Table context c, Table context d
362201 , Table context e
363− , Labelable context
364202 )
365203 => Table context (a, b, c, d, e)
366204
@@ -368,7 +206,6 @@ instance
368206instance
369207 ( Table context a, Table context b, Table context c, Table context d
370208 , Table context e, Table context f
371− , Labelable context
372209 )
373210 => Table context (a, b, c, d, e, f)
374211
@@ -376,7 +213,6 @@ instance
376213instance
377214 ( Table context a, Table context b, Table context c, Table context d
378215 , Table context e, Table context f, Table context g
379− , Labelable context
380216 )
381217 => Table context (a, b, c, d, e, f, g)
382218
src/Rel8/Table/ADT.hs+64−84
@@ -2,21 +2,23 @@
22{-# language DataKinds #-}
33{-# language FlexibleContexts #-}
44{-# language FlexibleInstances #-}
5+{-# language MultiParamTypeClasses #-}
56{-# language RankNTypes #-}
67{-# language ScopedTypeVariables #-}
78{-# language StandaloneKindSignatures #-}
89{-# language TypeApplications #-}
9−{-# language TypeFamilies #-}
10+{-# language TypeFamilyDependencies #-}
1011{-# language UndecidableInstances #-}
1112{-# language UndecidableSuperClasses #-}
1213
1314module Rel8.Table.ADT
1415 ( ADT( ADT )
15− , ADTable, fromADT, toADT
16+ , ADTable
17+ , BuildableADT
18+ , BuildADT, buildADT
1619 , ConstructableADT
1720 , ConstructADT, constructADT
1821 , DeconstructADT, deconstructADT
19− , InsertADT, insertADT
2022 , NameADT, nameADT
2123 , AggregateADT, aggregateADT
2224 , ADTRep
@@ -25,9 +27,8 @@ where
2527
2628-- base
2729import Data.Kind ( Constraint, Type )
28−import Data.Proxy ( Proxy( Proxy ) )
29−import Data.Type.Equality ( (:~:)( Refl ) )
30−import GHC.Generics ( Generic, Rep, from, to )
30+import GHC.Generics ( Generic, from, to )
31+import GHC.TypeLits ( Symbol )
3132import Prelude
3233
3334-- rel8
@@ -35,118 +36,104 @@ import Rel8.Aggregate ( Aggregate )
3536import Rel8.Expr ( Expr )
3637import Rel8.FCF ( Eval, Exp )
3738import Rel8.Generic.Construction
38− ( GGConstructable
39+ ( GGBuildable
40+ , GGBuild, ggbuild
41+ , GGConstructable
3942 , GGConstruct, ggconstruct
4043 , GGDeconstruct, ggdeconstruct
41− , GGInsert, gginsert
4244 , GGName, ggname
4345 , GGAggregate, ggaggregate
4446 )
45−import Rel8.Generic.Map ( GMappable, GMap, gmap, gunmap )
46−import Rel8.Generic.Record ( GRecordable, GRecord, grecord, gunrecord )
47+import Rel8.Generic.Record ( Record( Record ), unrecord )
4748import Rel8.Generic.Rel8able
4849 ( Rel8able
4950 , GRep, GColumns, gfromColumns, gtoColumns
50− , greify, gunreify
51+ , GFromExprs, gfromResult, gtoResult
52+ , TSerialize, deserialize, serialize
5153 )
5254import qualified Rel8.Generic.Table.ADT as G
5355import qualified Rel8.Kind.Algebra as K
54−import Rel8.Schema.Context ( Col )
5556import Rel8.Schema.HTable ( HTable )
56−import Rel8.Schema.Insert ( Insert )
5757import qualified Rel8.Schema.Kind as K
5858import Rel8.Schema.Name ( Name )
59−import Rel8.Schema.Reify ( Col( Reify ), Reify, hreify, hunreify )
6059import Rel8.Schema.Result ( Result )
61−import Rel8.Table
62− ( Table
63− , fromColumns, toColumns, reify, unreify
64− , TTable, TColumns, TUnreify
65− )
60+import Rel8.Table ( Table, TColumns )
6661
6762
6863type ADT :: K.Rel8able -> K.Rel8able
69−newtype ADT t context = ADT (GColumnsADT t (Col context))
64+newtype ADT t context = ADT (GColumnsADT t context)
7065
7166
7267instance ADTable t => Rel8able (ADT t) where
7368 type GColumns (ADT t) = GColumnsADT t
69+ type GFromExprs (ADT t) = t Result
7470
75− gfromColumns = ADT
76− gtoColumns (ADT a) = a
77−
78− greify (ADT a) = ADT (hreify a)
79− gunreify (ADT a) = ADT (hunreify a)
80−
71+ gfromColumns _ = ADT
72+ gtoColumns _ (ADT a) = a
8173
82−instance (ADTable t, context ~ Result) => Generic (ADT t context) where
83− type Rep (ADT t context) = Rep (t context)
84−
85− from =
86− gmap @(TTable (Reify Result)) (Proxy @TUnreify) (unreify Refl) .
87− gunrecord @(Rep (t (Reify Result))) .
88− G.gfromColumnsADT
89− @(TTable (Reify Result))
90− @TColumns
91− (\(Reify a) -> a)
92− Reify
93− fromColumns .
94− hreify .
95− (\(ADT a) -> a)
96−
97− to =
98− ADT .
99− hunreify .
100− G.gtoColumnsADT
101− @(TTable (Reify Result))
74+ gfromResult =
75+ unrecord .
76+ to .
77+ G.gfromResultADT
78+ @TSerialize
10279 @TColumns
103− (\(Reify a) -> a)
104− Reify
105− toColumns .
106− grecord @(Rep (t (Reify Result))) .
107− gunmap @(TTable (Reify Result)) (Proxy @TUnreify) (reify Refl)
80+ @(Eval (ADTRep t Expr))
81+ @(Eval (ADTRep t Result))
82+ (\(_ :: proxy x) -> deserialize @_ @x)
10883
109−
110−fromADT :: ADTable t => ADT t Result -> t Result
111−fromADT = to . from
112−
113−
114−toADT :: ADTable t => t Result -> ADT t Result
115−toADT = to . from
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
11693
11794
11895type ADTable :: K.Rel8able -> Constraint
11996class
120− ( Generic (t Result)
97+ ( Generic (Record (t Result))
12198 , HTable (GColumnsADT t)
122− , G.GTableADT (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRecord (Rep (t (Reify Result))))
123− , GRecordable (Rep (t (Reify Result)))
124− , GMappable (TTable (Reify Result)) (Rep (t (Reify Result)))
125− , GMap TUnreify (Rep (t (Reify Result))) ~ Rep (t Result)
99+ , G.GSerializeADT TSerialize TColumns (Eval (ADTRep t Expr)) (Eval (ADTRep t Result))
126100 )
127101 => ADTable t
128102instance
129− ( Generic (t Result)
103+ ( Generic (Record (t Result))
130104 , HTable (GColumnsADT t)
131− , G.GTableADT (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRecord (Rep (t (Reify Result))))
132− , GRecordable (Rep (t (Reify Result)))
133− , GMappable (TTable (Reify Result)) (Rep (t (Reify Result)))
134− , GMap TUnreify (Rep (t (Reify Result))) ~ Rep (t Result)
105+ , G.GSerializeADT TSerialize TColumns (Eval (ADTRep t Expr)) (Eval (ADTRep t Result))
135106 )
136107 => ADTable t
137108
138109
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+
139124type ConstructableADT :: K.Rel8able -> Constraint
140125class GGConstructable 'K.Sum (ADTRep t) => ConstructableADT t
141126instance GGConstructable 'K.Sum (ADTRep t) => ConstructableADT t
142127
143128
144129type ConstructADT :: K.Rel8able -> Type
145−type ConstructADT t = GGConstruct 'K.Sum (ADTRep t) (ADT t Expr)
130+type ConstructADT t = forall r. GGConstruct 'K.Sum (ADTRep t) r
146131
147132
148−constructADT :: forall t. ConstructableADT t => ConstructADT t
149−constructADT = ggconstruct @'K.Sum @(ADTRep t) @(ADT t Expr) ADT
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))
150137
151138
152139type DeconstructADT :: K.Rel8able -> Type -> Type
@@ -155,15 +142,8 @@ type DeconstructADT t r = GGDeconstruct 'K.Sum (ADTRep t) (ADT t Expr) r
155142
156143deconstructADT :: forall t r. (ConstructableADT t, Table Expr r)
157144 => DeconstructADT t r
158−deconstructADT = ggdeconstruct @'K.Sum @(ADTRep t) @(ADT t Expr) @r (\(ADT a) -> a)
159−
160−
161−type InsertADT :: K.Rel8able -> Type
162−type InsertADT t = GGInsert 'K.Sum (ADTRep t) (ADT t Insert)
163−
164−
165−insertADT :: forall t. ConstructableADT t => InsertADT t
166−insertADT = gginsert @'K.Sum @(ADTRep t) @(ADT t Insert) ADT
145+deconstructADT =
146+ ggdeconstruct @'K.Sum @(ADTRep t) @(ADT t Expr) @r (\(ADT a) -> a)
167147
168148
169149type NameADT :: K.Rel8able -> Type
@@ -179,10 +159,10 @@ type AggregateADT t = forall r. GGAggregate 'K.Sum (ADTRep t) r
179159
180160
181161aggregateADT :: forall t. ConstructableADT t
182− => AggregateADT t -> ADT t Expr -> Aggregate (ADT t Expr)
162+ => AggregateADT t -> ADT t Expr -> ADT t Aggregate
183163aggregateADT f =
184− ggaggregate @'K.Sum @(ADTRep t) @(ADT t Expr) ADT (\(ADT a) -> a)
185− (f @(Aggregate (ADT t Expr)))
164+ ggaggregate @'K.Sum @(ADTRep t) @(ADT t Expr) @(ADT t Aggregate) ADT (\(ADT a) -> a)
165+ (f @(ADT t Aggregate))
186166
187167
188168data ADTRep :: K.Rel8able -> K.Context -> Exp (Type -> Type)
@@ -190,4 +170,4 @@ type instance Eval (ADTRep t context) = GRep t context
190170
191171
192172type GColumnsADT :: K.Rel8able -> K.HTable
193−type GColumnsADT t = G.GColumnsADT TColumns (GRep t (Reify Result))
173+type GColumnsADT t = G.GColumnsADT TColumns (GRep t Expr)
src/Rel8/Table/Aggregate.hs+37−36
@@ -1,13 +1,13 @@
11{-# language FlexibleContexts #-}
2+{-# language NamedFieldPuns #-}
23{-# language ScopedTypeVariables #-}
34{-# language TypeApplications #-}
45{-# language TypeFamilies #-}
56{-# language ViewPatterns #-}
67
78module Rel8.Table.Aggregate
8− ( groupBy
9+ ( groupBy, hgroupBy
910 , listAgg, nonEmptyAgg
10− , listAggWithOrder, nonEmptyAggWithOrder
1111 )
1212where
1313
@@ -16,32 +16,49 @@ import Data.Functor.Identity ( Identity( Identity ) )
1616import Prelude
1717
1818-- rel8
19−import Rel8.Aggregate ( Aggregate, Col(..) )
20−import Rel8.Expr ( Expr, Col(..) )
19+import Rel8.Aggregate ( Aggregate, Aggregates )
20+import Rel8.Expr ( Expr )
2121import Rel8.Expr.Aggregate
2222 ( groupByExpr
23− , listAggExpr
24− , listAggExprWithOrder
25− , nonEmptyAggExpr
26− , nonEmptyAggExprWithOrder
23+ , slistAggExpr
24+ , snonEmptyAggExpr
2725 )
28−import Rel8.Order ( Order )
2926import Rel8.Schema.Dict ( Dict( Dict ) )
30−import Rel8.Schema.HTable ( htabulate, hfield )
27+import Rel8.Schema.HTable ( HTable, hfield, htabulate )
3128import Rel8.Schema.HTable.Vectorize ( hvectorize )
32−import Rel8.Table ( Table, toColumns, fromColumns )
29+import Rel8.Schema.Null ( Sql )
30+import Rel8.Schema.Spec ( Spec( Spec, info ) )
31+import Rel8.Table ( toColumns, fromColumns )
3332import Rel8.Table.Eq ( EqTable, eqTable )
3433import Rel8.Table.List ( ListTable )
3534import Rel8.Table.NonEmpty ( NonEmptyTable )
35+import Rel8.Type.Eq ( DBEq )
3636
3737
3838-- | Group equal tables together. This works by aggregating each column in the
3939-- given table with 'groupByExpr'.
40−groupBy :: forall exprs. EqTable exprs => exprs -> Aggregate exprs
41−groupBy (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
42− case hfield (eqTable @exprs) field of
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
4360 Dict -> case hfield exprs field of
44− DB expr -> Aggregation $ groupByExpr expr
61+ expr -> groupByExpr expr
4562
4663
4764-- | Aggregate rows into a single row containing an array of all aggregated
@@ -54,38 +71,22 @@ groupBy (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
5471-- items:
5572--
5673-- @
57−-- ordersWithItems :: Query (Order Expr, ListTable (Item Expr))
74+-- ordersWithItems :: Query (Order Expr, ListTable Expr (Item Expr))
5875-- ordersWithItems = do
5976-- order <- each orderSchema
6077-- items <- aggregate $ listAgg <$> itemsFromOrder order
6178-- return (order, items)
6279-- @
63−listAgg :: Table Expr a => a -> Aggregate (ListTable a)
80+listAgg :: Aggregates aggregates exprs => exprs -> ListTable Aggregate aggregates
6481listAgg (toColumns -> exprs) = fromColumns $
6582 hvectorize
66− (\_ (Identity (DB a)) -> Aggregation $ listAggExpr a)
83+ (\Spec {info} (Identity a) -> slistAggExpr info a)
6784 (pure exprs)
6885
6986
7087-- | Like 'listAgg', but the result is guaranteed to be a non-empty list.
71−nonEmptyAgg :: Table Expr a => a -> Aggregate (NonEmptyTable a)
88+nonEmptyAgg :: Aggregates aggregates exprs => exprs -> NonEmptyTable Aggregate aggregates
7289nonEmptyAgg (toColumns -> exprs) = fromColumns $
7390 hvectorize
74− (\_ (Identity (DB a)) -> Aggregation $ nonEmptyAggExpr a)
75− (pure exprs)
76−
77−
78−listAggWithOrder :: Table Expr a
79− => Order o -> o -> a -> Aggregate (ListTable a)
80−listAggWithOrder order o (toColumns -> exprs) = fromColumns $
81− hvectorize
82− (\_ (Identity (DB x)) -> Aggregation $ listAggExprWithOrder order o x)
83− (pure exprs)
84−
85−
86−nonEmptyAggWithOrder :: Table Expr a
87− => Order o -> o -> a -> Aggregate (NonEmptyTable a)
88−nonEmptyAggWithOrder order o (toColumns -> exprs) = fromColumns $
89− hvectorize
90− (\_ (Identity (DB x)) -> Aggregation $ nonEmptyAggExprWithOrder order o x)
91+ (\Spec {info} (Identity a) -> snonEmptyAggExpr info a)
9192 (pure exprs)
src/Rel8/Table/Bool.hs+5−6
@@ -13,7 +13,7 @@ where
1313import Prelude
1414
1515-- rel8
16−import Rel8.Expr ( Expr, Col(..) )
16+import Rel8.Expr ( Expr )
1717import Rel8.Expr.Bool ( boolExpr, caseExpr )
1818import Rel8.Expr.Null ( isNull, unsafeUnnullify )
1919import Rel8.Schema.HTable ( htabulate, hfield )
@@ -28,8 +28,7 @@ bool :: Table Expr a => a -> a -> Expr Bool -> a
2828bool (toColumns -> false) (toColumns -> true) condition =
2929 fromColumns $ htabulate $ \field ->
3030 case (hfield false field, hfield true field) of
31− (DB falseExpr, DB trueExpr) ->
32− DB (boolExpr falseExpr trueExpr condition)
31+ (falseExpr, trueExpr) -> boolExpr falseExpr trueExpr condition
3332{-# INLINABLE bool #-}
3433
3534
@@ -39,9 +38,9 @@ bool (toColumns -> false) (toColumns -> true) condition =
3938case_ :: Table Expr a => [(Expr Bool, a)] -> a -> a
4039case_ (map (fmap toColumns) -> branches) (toColumns -> fallback) =
4140 fromColumns $ htabulate $ \field -> case hfield fallback field of
42− DB fallbackExpr ->
43− case map (fmap (unDB . (`hfield` field))) branches of
44− branchExprs -> DB (caseExpr branchExprs fallbackExpr)
41+ fallbackExpr ->
42+ case map (fmap (`hfield` field)) branches of
43+ branchExprs -> caseExpr branchExprs fallbackExpr
4544
4645
4746-- | Like 'maybe', but to eliminate @null@.
src/Rel8/Table/Cols.hsnew file+50
@@ -0,0 +1,50 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleInstances #-}
3+{-# language MultiParamTypeClasses #-}
4+{-# language StandaloneKindSignatures #-}
5+{-# language TypeFamilies #-}
6+{-# language UndecidableInstances #-}
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+147−152
@@ -18,231 +18,226 @@ module Rel8.Table.Either
1818 ( EitherTable(..)
1919 , eitherTable, leftTable, rightTable
2020 , isLeftTable, isRightTable
21− , aggregateEitherTable, insertEitherTable, nameEitherTable
21+ , aggregateEitherTable
22+ , nameEitherTable
2223 )
2324where
2425
2526-- base
26−import Control.Applicative ( liftA2 )
2727import Data.Bifunctor ( Bifunctor, bimap )
28−import Data.Functor.Identity ( runIdentity )
28+import Data.Functor.Identity ( Identity( Identity ) )
2929import Data.Kind ( Type )
3030import Prelude hiding ( undefined )
3131
32+-- comonad
33+import Control.Comonad ( extract )
34+
3235-- rel8
33−import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )
36+import Rel8.Aggregate ( Aggregate )
3437import Rel8.Expr ( Expr )
35−import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
38+import Rel8.Expr.Aggregate ( groupByExpr )
3639import Rel8.Expr.Serialize ( litExpr )
37−import Rel8.Schema.Context.Label
38− ( Labelable
39− , HLabelable, hlabeler, hunlabeler
40− )
41−import Rel8.Schema.Context.Nullify
42− ( Nullifiable, ConstrainTag
43− , HNullifiable, HConstrainTag
44− , hencodeTag, hdecodeTag
45− , hnullifier, hunnullifier
46− )
47−import Rel8.Schema.HTable ( HTable )
40+import Rel8.Kind.Context ( Reifiable )
41+import Rel8.Schema.Context.Nullify ( Nullifiable )
42+import Rel8.Schema.Dict ( Dict( Dict ) )
4843import Rel8.Schema.HTable.Either ( HEitherTable(..) )
4944import Rel8.Schema.HTable.Identity ( HIdentity(..) )
5045import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
51−import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
52−import Rel8.Schema.Insert ( Insert )
46+import qualified Rel8.Schema.Kind as K
5347import Rel8.Schema.Name ( Name )
5448import Rel8.Table
5549 ( Table, Columns, Context, fromColumns, toColumns
56− , reify, unreify
50+ , FromExprs, fromResult, toResult
51+ , Transpose
5752 )
5853import Rel8.Table.Bool ( bool )
5954import Rel8.Table.Eq ( EqTable, eqTable )
60−import Rel8.Table.Insert ( toInsert )
55+import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )
6156import Rel8.Table.Ord ( OrdTable, ordTable )
62−import Rel8.Table.Recontextualize ( Recontextualize )
63−import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
64−import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )
57+import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )
58+import Rel8.Table.Serialize ( ToExprs )
6559import Rel8.Table.Undefined ( undefined )
6660import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
6761
6862-- semigroupoids
69−import Data.Functor.Apply ( Apply, (<.>), liftF3 )
63+import Data.Functor.Apply ( Apply, (<.>) )
7064import Data.Functor.Bind ( Bind, (>>-) )
7165
7266
73−type EitherTable :: Type -> Type -> Type
74−data EitherTable a b = EitherTable
75− { tag :: Tag "isRight" EitherTag
76− , left :: a
77− , right :: b
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
7878 }
7979 deriving stock Functor
8080
8181
82−instance Bifunctor EitherTable where
83− bimap f g (EitherTable tag a b) = EitherTable tag (f a) (g b)
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+
90+
91+instance Projectable (EitherTable context a) where
92+ project f (EitherTable tag a b) = EitherTable tag a (project f b)
8493
8594
86−instance Table Expr a => Apply (EitherTable a) where
95+instance (context ~ Expr, Table Expr a) => Apply (EitherTable context a) where
8796 EitherTable tag l1 f <.> EitherTable tag' l2 a =
88− EitherTable (tag <> tag') (bool l1 l2 (isLeft (expr tag))) (f a)
97+ EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f <.> a)
8998
9099
91−instance Table Expr a => Applicative (EitherTable a) where
100+instance (context ~ Expr, Table Expr a) => Applicative (EitherTable context a) where
92101 pure = rightTable
93102 (<*>) = (<.>)
94103
95104
96−instance Table Expr a => Bind (EitherTable a) where
97− EitherTable tag l1 a >>- f = case f a of
105+instance (context ~ Expr, Table Expr a) => Bind (EitherTable context a) where
106+ EitherTable tag l1 a >>- f = case f (extract a) of
98107 EitherTable tag' l2 b ->
99− EitherTable (tag <> tag') (bool l1 l2 (isRight (expr tag))) b
108+ EitherTable (tag <> tag') (bool l1 l2 (isRight tag)) b
100109
101110
102−instance Table Expr a => Monad (EitherTable a) where
111+instance (context ~ Expr, Table Expr a) => Monad (EitherTable context a) where
103112 (>>=) = (>>-)
104113
105114
106−instance (Table Expr a, Table Expr b) => Semigroup (EitherTable a b) where
115+instance (context ~ Expr, Table Expr a, Table Expr b) =>
116+ Semigroup (EitherTable context a b)
117+ where
107118 a <> b = bool a b (isRightTable a)
108119
109120
110121instance
111122 ( Table context a, Table context b
112− , Labelable context, Nullifiable context, ConstrainTag context EitherTag
113− ) =>
114− Table context (EitherTable a b)
115− where
116− type Columns (EitherTable a b) = HEitherTable (Columns a) (Columns b)
117− type Context (EitherTable a b) = Context a
118−
119− toColumns = toColumns2 toColumns toColumns
120− fromColumns = fromColumns2 fromColumns fromColumns
121− reify = liftA2 bimap reify reify
122− unreify = liftA2 bimap unreify unreify
123−
124−
125−instance
126− ( Nullifiable from, Labelable from, ConstrainTag from EitherTag
127− , Nullifiable to, Labelable to, ConstrainTag to EitherTag
128− , Recontextualize from to a1 b1
129− , Recontextualize from to a2 b2
123+ , Reifiable context, context ~ context'
130124 )
131− => Recontextualize from to (EitherTable a1 a2) (EitherTable b1 b2)
132−
133−
134−instance (EqTable a, EqTable b) => EqTable (EitherTable a b) where
135− eqTable = toColumns2 id id (rightTableWith (eqTable @a) (eqTable @b))
136−
137−
138−instance (OrdTable a, OrdTable b) => OrdTable (EitherTable a b) where
139− ordTable = toColumns2 id id (rightTableWith (ordTable @a) (ordTable @b))
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+ }
138+
139+ fromColumns HEitherTable {htag, hleft, hright} = EitherTable
140+ { tag = unHIdentity $ hunlabel htag
141+ , left = fromColumns $ hunlabel hleft
142+ , right = fromColumns $ hunlabel hright
143+ }
144+
145+ toResult = \case
146+ Left table -> HEitherTable
147+ { htag = hlabel (HIdentity (Identity IsLeft))
148+ , hleft = hlabel (toResult @_ @(Nullify context a) (Just table))
149+ , hright = hlabel (toResult @_ @(Nullify context b) Nothing)
150+ }
151+ Right table -> HEitherTable
152+ { htag = hlabel (HIdentity (Identity IsRight))
153+ , hleft = hlabel (toResult @_ @(Nullify context a) Nothing)
154+ , hright = hlabel (toResult @_ @(Nullify context b) (Just table))
155+ }
156+
157+ fromResult HEitherTable {htag, hleft, hright} = case hunlabel htag of
158+ HIdentity (Identity tag) -> case tag of
159+ IsLeft -> maybe err Left $ fromResult @_ @(Nullify context a) (hunlabel hleft)
160+ IsRight -> maybe err Right $ fromResult @_ @(Nullify context b) (hunlabel hright)
161+ where
162+ err = error "Either.fromColumns: mismatch between tag and data"
163+
164+
165+instance (EqTable a, EqTable b, context ~ Expr) =>
166+ EqTable (EitherTable context a b)
167+ where
168+ eqTable = HEitherTable
169+ { htag = hlabel (HIdentity Dict)
170+ , hleft = hlabel (eqTable @(Nullify context a))
171+ , hright = hlabel (eqTable @(Nullify context b))
172+ }
140173
141174
142−type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
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+ }
143183
144184
145−instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable exprs1 exprs2) =>
185+instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable Expr exprs1 exprs2) =>
146186 ToExprs x (Either a b)
147− where
148− fromResult =
149− bimap (fromResult @exprs1) (fromResult @exprs2) .
150− fromColumns
151− toResult =
152− toColumns .
153− bimap (toResult @exprs1) (toResult @exprs2)
154187
155188
156−isLeftTable :: EitherTable a b -> Expr Bool
157−isLeftTable = isLeft . expr . tag
189+-- | Test if an 'EitherTable' is a 'leftTable'.
190+isLeftTable :: EitherTable Expr a b -> Expr Bool
191+isLeftTable EitherTable {tag} = isLeft tag
158192
159193
160−isRightTable :: EitherTable a b -> Expr Bool
161−isRightTable = isRight . expr . tag
194+-- | Test if an 'EitherTable' is a 'rightTable'.
195+isRightTable :: EitherTable Expr a b -> Expr Bool
196+isRightTable EitherTable {tag} = isRight tag
162197
163198
199+-- | Pattern match/eliminate an 'EitherTable', by providing mappings from a
200+-- 'leftTable' and 'rightTable'.
164201eitherTable :: Table Expr c
165− => (a -> c) -> (b -> c) -> EitherTable a b -> c
202+ => (a -> c) -> (b -> c) -> EitherTable Expr a b -> c
166203eitherTable f g EitherTable {tag, left, right} =
167− bool (f left) (g right) (isRight (expr tag))
168−
169−
170−leftTable :: Table Expr b => a -> EitherTable a b
171−leftTable a = EitherTable (fromExpr (litExpr IsLeft)) a undefined
204+ bool (f (extract left)) (g (extract right)) (isRight tag)
172205
173206
174−rightTable :: Table Expr a => b -> EitherTable a b
175−rightTable = rightTableWith undefined
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
176210
177211
178−rightTableWith :: a -> b -> EitherTable a b
179−rightTableWith = EitherTable (fromExpr (litExpr IsRight))
212+-- | Construct a right 'EitherTable'. Like 'Right'.
213+rightTable :: Table Expr a => b -> EitherTable Expr a b
214+rightTable = EitherTable (litExpr IsRight) undefined . pure
180215
181216
217+-- | Lift a pair of aggregating functions to operate on an 'EitherTable'.
218+-- @leftTable@s and @rightTable@s are grouped separately.
182219aggregateEitherTable :: ()
183− => (a -> Aggregate c)
184− -> (b -> Aggregate d)
185− -> EitherTable a b
186− -> Aggregate (EitherTable c d)
187−aggregateEitherTable f g EitherTable {tag, left, right} =
188− liftF3 EitherTable (tag <$ aggregate) (f left) (g right)
189− where
190− Tag {aggregator, expr} = tag
191− aggregate = unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr
192−
193−
194−insertEitherTable :: (Table Insert a, Table Insert b)
195− => Either a b -> EitherTable a b
196−insertEitherTable = \case
197− Left a -> EitherTable (fromExpr (litExpr IsLeft)) a (fromColumns (toInsert undefined))
198− Right b -> EitherTable (fromExpr (litExpr IsRight)) (fromColumns (toInsert undefined)) b
199−
200−
201−nameEitherTable :: Name EitherTag -> a -> b -> EitherTable a b
202−nameEitherTable = EitherTable . fromName
203−
204−
205−toColumns2 ::
206− ( HTable t
207− , HTable u
208− , HConstrainTag context EitherTag
209− , HLabelable context
210− , HNullifiable context
211− )
212− => (a -> t context)
213− -> (b -> u context)
214− -> EitherTable a b
215− -> HEitherTable t u context
216−toColumns2 f g EitherTable {tag, left, right} = HEitherTable
217− { htag
218− , hleft = hlabel hlabeler $ hnullify (hnullifier tag isLeft) $ f left
219− , hright = hlabel hlabeler $ hnullify (hnullifier tag isRight) $ g right
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
220228 }
221− where
222− htag = HIdentity (hencodeTag tag)
223229
224230
225−fromColumns2 ::
226− ( HTable t
227− , HTable u
228− , HConstrainTag context EitherTag
229− , HLabelable context
230− , HNullifiable context
231− )
232− => (t context -> a)
233− -> (u context -> b)
234− -> HEitherTable t u context
235− -> EitherTable a b
236−fromColumns2 f g HEitherTable {htag, hleft, hright} = EitherTable
237− { tag
238− , left = f $ runIdentity $
239− hunnullify (\a -> pure . hunnullifier a) $
240− hunlabel hunlabeler
241− hleft
242− , right = g $ runIdentity $
243− hunnullify (\a -> pure . hunnullifier a) $
244− hunlabel hunlabeler
245− hright
246− }
247− where
248− tag = hdecodeTag $ unHIdentity htag
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)
src/Rel8/Table/Eq.hs+12−39
@@ -11,7 +11,6 @@
1111{-# language TypeFamilies #-}
1212{-# language TypeOperators #-}
1313{-# language UndecidableInstances #-}
14−{-# language UndecidableSuperClasses #-}
1514{-# language ViewPatterns #-}
1615
1716module Rel8.Table.Eq
@@ -28,24 +27,16 @@ import GHC.Generics ( Rep )
2827import Prelude
2928
3029-- rel8
31−import Rel8.Expr ( Expr, Col(..) )
30+import Rel8.Expr ( Expr )
3231import Rel8.Expr.Bool ( (||.), (&&.) )
3332import Rel8.Expr.Eq ( (==.), (/=.) )
3433import Rel8.FCF ( Eval, Exp )
3534import Rel8.Generic.Record ( Record )
36−import Rel8.Generic.Table
37− ( GGTable, GGColumns, ggtable
38− , GAlgebra
39− )
40−import Rel8.Kind.Algebra ( KnownAlgebra )
35+import Rel8.Generic.Table.Record ( GTable, GColumns, gtable )
4136import Rel8.Schema.Dict ( Dict( Dict ) )
42−import Rel8.Schema.HTable
43− ( HTable, HConstrainTable
44− , htabulateA, hfield, hdicts
45− )
46−import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )
37+import Rel8.Schema.HTable ( htabulateA, hfield )
38+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
4739import Rel8.Schema.Null ( Sql )
48−import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType, nullifier )
4940import Rel8.Table ( Table, Columns, toColumns, TColumns )
5041import Rel8.Type.Eq ( DBEq )
5142
@@ -55,22 +46,14 @@ import Rel8.Type.Eq ( DBEq )
5546-- means "all columns in a 'Table' have an instance of 'DBEq'".
5647type EqTable :: Type -> Constraint
5748class Table Expr a => EqTable a where
58− eqTable :: Columns a (Dict (ConstrainDBType DBEq))
49+ eqTable :: Columns a (Dict (Sql DBEq))
5950
6051 default eqTable ::
61− ( KnownAlgebra (GAlgebra (Rep (Record a)))
62− , Eval (GGTable (GAlgebra (Rep (Record a))) TEqTable TColumns (Dict (ConstrainDBType DBEq)) (Rep (Record a)))
63− , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))
52+ ( GTable TEqTable TColumns (Rep (Record a))
53+ , Columns a ~ GColumns TColumns (Rep (Record a))
6454 )
65− => Columns a (Dict (ConstrainDBType DBEq))
66− eqTable =
67− ggtable
68− @(GAlgebra (Rep (Record a)))
69− @TEqTable
70− @TColumns
71− @(Rep (Record a))
72− table
73− nullifier
55+ => Columns a (Dict (Sql DBEq))
56+ eqTable = gtable @TEqTable @TColumns @(Rep (Record a)) table
7457 where
7558 table (_ :: proxy x) = eqTable @x
7659
@@ -79,18 +62,8 @@ data TEqTable :: Type -> Exp Constraint
7962type instance Eval (TEqTable a) = EqTable a
8063
8164
82−instance
83− ( HTable t
84− , f ~ Col Expr
85− , HConstrainTable t (ConstrainDBType DBEq)
86− )
87− => EqTable (t f)
88− where
89− eqTable = hdicts @(Columns (t f)) @(ConstrainDBType DBEq)
90−
91−
9265instance Sql DBEq a => EqTable (Expr a) where
93− eqTable = HType Dict
66+ eqTable = HIdentity Dict
9467
9568
9669instance (EqTable a, EqTable b) => EqTable (a, b)
@@ -124,7 +97,7 @@ instance
12497(toColumns -> as) ==: (toColumns -> bs) =
12598 foldl1' (&&.) $ getConst $ htabulateA $ \field ->
12699 case (hfield as field, hfield bs field) of
127− (DB a, DB b) -> case hfield (eqTable @a) field of
100+ (a, b) -> case hfield (eqTable @a) field of
128101 Dict -> Const (pure (a ==. b))
129102infix 4 ==:
130103
@@ -136,7 +109,7 @@ infix 4 ==:
136109(toColumns -> as) /=: (toColumns -> bs) =
137110 foldl1' (||.) $ getConst $ htabulateA $ \field ->
138111 case (hfield as field, hfield bs field) of
139− (DB a, DB b) -> case hfield (eqTable @a) field of
112+ (a, b) -> case hfield (eqTable @a) field of
140113 Dict -> Const (pure (a /=. b))
141114infix 4 /=:
142115
src/Rel8/Table/HKD.hs+91−121
@@ -13,11 +13,12 @@
1313
1414module Rel8.Table.HKD
1515 ( HKD( HKD )
16− , HKDable, fromHKD, toHKD, HKDT(..)
16+ , HKDable
17+ , BuildableHKD
18+ , BuildHKD, buildHKD
1719 , ConstructableHKD
1820 , ConstructHKD, constructHKD
1921 , DeconstructHKD, deconstructHKD
20− , InsertHKD, insertHKD
2122 , NameHKD, nameHKD
2223 , AggregateHKD, aggregateHKD
2324 , HKDRep
@@ -26,10 +27,8 @@ where
2627
2728-- base
2829import Data.Kind ( Constraint, Type )
29−import Data.Proxy ( Proxy( Proxy ) )
30−import Data.Type.Equality ( (:~:)( Refl ) )
31−import Data.Void ( Void )
3230import GHC.Generics ( Generic, Rep, from, to )
31+import GHC.TypeLits ( Symbol )
3332import Prelude
3433
3534-- rel8
@@ -39,137 +38,126 @@ import Rel8.Expr ( Expr )
3938import Rel8.FCF ( Eval, Exp )
4039import Rel8.Kind.Algebra ( KnownAlgebra )
4140import Rel8.Generic.Construction
42− ( GGConstructable
41+ ( GGBuildable
42+ , GGBuild, ggbuild
43+ , GGConstructable
4344 , GGConstruct, ggconstruct
4445 , GGDeconstruct, ggdeconstruct
45− , GGInsert, gginsert
4646 , GGName, ggname
4747 , GGAggregate, ggaggregate
4848 )
49−import Rel8.Generic.Map ( GMap, GMappable, gmap, gunmap )
50−import Rel8.Generic.Record ( GRecord, GRecordable, grecord, gunrecord )
49+import Rel8.Generic.Map ( GMap )
50+import Rel8.Generic.Record
51+ ( GRecord, GRecordable, grecord, gunrecord
52+ , Record( Record ), unrecord
53+ )
5154import Rel8.Generic.Rel8able
5255 ( Rel8able
5356 , GColumns, gfromColumns, gtoColumns
54− , greify, gunreify
55− , TUnreifyContext
57+ , GFromExprs, gfromResult, gtoResult
5658 )
5759import Rel8.Generic.Table
58− ( GGTable, GGColumns, GGContext, ggfromColumns, ggtoColumns
59− , GAlgebra
60+ ( GGSerialize, GGColumns, GAlgebra, ggfromResult, ggtoResult
6061 )
61−import Rel8.Schema.Context ( Col )
62+import Rel8.Generic.Table.Record ( GTable, GContext )
63+import qualified Rel8.Generic.Table.Record as G
6264import qualified Rel8.Schema.Kind as K
6365import Rel8.Schema.HTable ( HTable )
64−import Rel8.Schema.Insert ( Insert )
6566import Rel8.Schema.Name ( Name )
66−import Rel8.Schema.Reify ( Col( Reify ), Reify, hreify, hunreify, notReify )
6767import Rel8.Schema.Result ( Result )
6868import Rel8.Table
69− ( Table, Columns, Context, Unreify
70− , fromColumns, toColumns, reify, unreify
71− , TTable, TColumns, TUnreify
69+ ( Table, fromColumns, toColumns, fromResult, toResult
70+ , TTable, TColumns, TContext
71+ , TSerialize
7272 )
73−import Rel8.Table.Serialize ( ToExprs, fromResult, toResult )
7473
7574
7675type GColumnsHKD :: Type -> K.HTable
7776type GColumnsHKD a =
78− Eval (GGColumns (GAlgebra (Rep a)) TColumns (GRecord (GMap (TColumn (Reify Result)) (Rep a))))
77+ Eval (GGColumns (GAlgebra (Rep a)) TColumns (GRecord (GMap (TColumn Expr) (Rep a))))
7978
8079
8180type HKD :: Type -> K.Rel8able
82−newtype HKD a f = HKD (GColumnsHKD a (Col f))
81+newtype HKD a f = HKD (GColumnsHKD a f)
8382
8483
8584instance HKDable a => Rel8able (HKD a) where
8685 type GColumns (HKD a) = GColumnsHKD a
86+ type GFromExprs (HKD a) = a
87+
88+ gfromColumns _ = HKD
89+ gtoColumns _ (HKD a) = a
8790
88− gfromColumns = HKD
89− gtoColumns (HKD a) = a
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)
90101
91− greify (HKD a) = HKD (hreify a)
92− gunreify (HKD a) = HKD (hunreify a)
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
93112
94113
95114instance
96− ( KnownAlgebra (GAlgebra (Rep a))
97− , HTable (GColumnsHKD a)
98− , Eval (GGTable (GAlgebra (Rep a)) (TTable (Reify f)) TColumns (Col (Reify f)) (GRecord (GMap (TColumn (Reify f)) (Rep a))))
99− , Eval (GGColumns (GAlgebra (Rep a)) TColumns (GRecord (GMap (TColumn (Reify f)) (Rep a)))) ~ GColumnsHKD a
100− , Eval (GGContext (GAlgebra (Rep a)) TUnreifyContext (GRecord (GMap (TColumn (Reify f)) (Rep a)))) ~ f
101− , GRecordable (GMap (TColumn (Reify f)) (Rep a))
102− , GMappable (TTable (Reify f)) (GMap (TColumn (Reify f)) (Rep a))
103− , GMap TUnreify (GMap (TColumn (Reify f)) (Rep a)) ~ GMap (TColumn f) (Rep a)
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))
104119 )
105120 => Generic (HKD a f)
106121 where
107122 type Rep (HKD a f) = GMap (TColumn f) (Rep a)
108123
109124 from =
110− gmap @(TTable (Reify f)) (Proxy @TUnreify) (unreify Refl) .
111− gunrecord @(GMap (TColumn (Reify f)) (Rep a)) .
112− ggfromColumns
113− @(GAlgebra (Rep a))
114− @(TTable (Reify f))
125+ gunrecord @(GMap (TColumn f) (Rep a)) .
126+ G.gfromColumns
127+ @(TTable f)
115128 @TColumns
116− (\(Reify a) -> a)
117− Reify
118129 fromColumns .
119− hreify .
120130 (\(HKD a) -> a)
121131
122132 to =
123133 HKD .
124− hunreify .
125− ggtoColumns
126− @(GAlgebra (Rep a))
127− @(TTable (Reify f))
134+ G.gtoColumns
135+ @(TTable f)
128136 @TColumns
129− (\(Reify a) -> a)
130− Reify
131137 toColumns .
132− grecord @(GMap (TColumn (Reify f)) (Rep a)) .
133− gunmap @(TTable (Reify f)) (Proxy @TUnreify) (reify Refl)
134−
135−
136−type HKDT :: Type -> Type
137−newtype HKDT a = HKDT
138− { unHKDT :: a
139− }
140−
141−
142−instance HKDable a => Table Result (HKDT a) where
143− type Columns (HKDT a) = GColumnsHKD a
144− type Context (HKDT a) = Result
145− type Unreify (HKDT a) = Void
146−
147− fromColumns = HKDT . fromHKD . HKD
148− toColumns = (\(HKD a) -> a) . toHKD . (\(HKDT a) -> a)
149− reify = notReify
150− unreify = notReify
138+ grecord @(GMap (TColumn f) (Rep a))
151139
152140
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
153150instance
154− ( Table Expr (HKD a Expr)
155− , Columns (HKD a Expr) ~ GColumns (HKD a)
156− , HKDable a
157− , x ~ HKD a Expr
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)
158156 )
159− => ToExprs x (HKDT a)
160− where
161− toResult = (\(HKD a) -> a) . toHKD . (\(HKDT a) -> a)
162− fromResult = HKDT . fromHKD . HKD
163−
164−
165−fromHKD :: HKDable a => HKD a Result -> a
166−fromHKD = to . gunmap @Top (Proxy @(TColumn Result)) id . from
167−
168−
169−toHKD :: HKDable a => a -> HKD a Result
170−toHKD = to . gmap @Top (Proxy @(TColumn Result)) id . from
157+ => HKDable a
171158
172159
160+type Top_ :: Constraint
173161class Top_
174162instance Top_
175163
@@ -178,30 +166,18 @@ data Top :: Type -> Exp Constraint
178166type instance Eval (Top _) = Top_
179167
180168
181−class
182− ( Generic a
183− , HTable (GColumns (HKD a))
184− , KnownAlgebra (GAlgebra (Rep a))
185− , Eval (GGTable (GAlgebra (Rep a)) (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRecord (GMap (TColumn (Reify Result)) (Rep a))))
186− , Eval (GGContext (GAlgebra (Rep a)) TUnreifyContext (GRecord (GMap (TColumn (Reify Result)) (Rep a)))) ~ Result
187− , GRecordable (GMap (TColumn (Reify Result)) (Rep a))
188− , GMappable Top (Rep a)
189− , GMappable (TTable (Reify Result)) (GMap (TColumn (Reify Result)) (Rep a))
190− , GMap TUnreify (GMap (TColumn (Reify Result)) (Rep a)) ~ GMap (TColumn Result) (Rep a)
191− )
192− => HKDable a
193−instance
194− ( Generic a
195− , HTable (GColumns (HKD a))
196− , KnownAlgebra (GAlgebra (Rep a))
197− , Eval (GGTable (GAlgebra (Rep a)) (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRecord (GMap (TColumn (Reify Result)) (Rep a))))
198− , Eval (GGContext (GAlgebra (Rep a)) TUnreifyContext (GRecord (GMap (TColumn (Reify Result)) (Rep a)))) ~ Result
199− , GRecordable (GMap (TColumn (Reify Result)) (Rep a))
200− , GMappable Top (Rep a)
201− , GMappable (TTable (Reify Result)) (GMap (TColumn (Reify Result)) (Rep a))
202− , GMap TUnreify (GMap (TColumn (Reify Result)) (Rep a)) ~ GMap (TColumn Result) (Rep a)
203− )
204− => HKDable a
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
205181
206182
207183type ConstructableHKD :: Type -> Constraint
@@ -210,11 +186,13 @@ instance GGConstructable (GAlgebra (Rep a)) (HKDRep a) => ConstructableHKD a
210186
211187
212188type ConstructHKD :: Type -> Type
213−type ConstructHKD a = GGConstruct (GAlgebra (Rep a)) (HKDRep a) (HKD a Expr)
189+type ConstructHKD a = forall r. GGConstruct (GAlgebra (Rep a)) (HKDRep a) r
214190
215191
216−constructHKD :: forall a. ConstructableHKD a => ConstructHKD a
217−constructHKD = ggconstruct @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) HKD
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))
218196
219197
220198type DeconstructHKD :: Type -> Type -> Type
@@ -226,14 +204,6 @@ deconstructHKD :: forall a r. (ConstructableHKD a, Table Expr r)
226204deconstructHKD = ggdeconstruct @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) @r (\(HKD a) -> a)
227205
228206
229−type InsertHKD :: Type -> Type
230−type InsertHKD a = GGInsert (GAlgebra (Rep a)) (HKDRep a) (HKD a Insert)
231−
232−
233−insertHKD :: forall a. ConstructableHKD a => InsertHKD a
234−insertHKD = gginsert @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Insert) HKD
235−
236−
237207type NameHKD :: Type -> Type
238208type NameHKD a = GGName (GAlgebra (Rep a)) (HKDRep a) (HKD a Name)
239209
@@ -247,10 +217,10 @@ type AggregateHKD a = forall r. GGAggregate (GAlgebra (Rep a)) (HKDRep a) r
247217
248218
249219aggregateHKD :: forall a. ConstructableHKD a
250− => AggregateHKD a -> HKD a Expr -> Aggregate (HKD a Expr)
220+ => AggregateHKD a -> HKD a Expr -> HKD a Aggregate
251221aggregateHKD f =
252− ggaggregate @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) HKD (\(HKD a) -> a)
253− (f @(Aggregate (HKD a Expr)))
222+ ggaggregate @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) @(HKD a Aggregate) HKD (\(HKD a) -> a)
223+ (f @(HKD a Aggregate))
254224
255225
256226data HKDRep :: Type -> K.Context -> Exp (Type -> Type)
src/Rel8/Table/Insert.hsdeleted−51
@@ -1,51 +0,0 @@
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/List.hs+71−66
@@ -1,3 +1,4 @@
1+{-# language DataKinds #-}
12{-# language FlexibleContexts #-}
23{-# language FlexibleInstances #-}
34{-# language MultiParamTypeClasses #-}
@@ -10,32 +11,36 @@
1011
1112module Rel8.Table.List
1213 ( ListTable(..)
13− , listTable, insertListTable, nameListTable
14+ , ($*)
15+ , listTable
16+ , nameListTable
1417 )
1518where
1619
1720-- base
1821import Data.Functor.Identity ( Identity( Identity ) )
1922import Data.Kind ( Type )
20−import Data.Type.Equality ( (:~:)( Refl ) )
2123import Prelude
2224
2325-- rel8
24−import Rel8.Expr ( Expr, Col(..) )
26+import Rel8.Expr ( Expr )
2527import Rel8.Expr.Array ( sappend, sempty, slistOf )
26−import Rel8.Kind.Necessity ( SNecessity( SOptional, SRequired ) )
2728import Rel8.Schema.Dict ( Dict( Dict ) )
2829import Rel8.Schema.HTable.List ( HListTable )
29−import Rel8.Schema.HTable.Vectorize ( happend, hempty, hvectorize )
30−import Rel8.Schema.Insert ( Col( OptionalInsert, RequiredInsert ), Insert )
31−import Rel8.Schema.Name ( Col( NameCol ), Name )
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 ) )
3237import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
33−import Rel8.Schema.Spec ( SSpec(..) )
34−import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullity )
35−import Rel8.Schema.Reify ( hreify, hunreify )
38+import Rel8.Schema.Result ( vectorizer, unvectorizer )
39+import Rel8.Schema.Spec ( Spec(..) )
3640import Rel8.Table
3741 ( Table, Context, Columns, fromColumns, toColumns
38− , reify, unreify
42+ , FromExprs, fromResult, toResult
43+ , Transpose
3944 )
4045import Rel8.Table.Alternative
4146 ( AltTable, (<|>:)
@@ -43,102 +48,102 @@ import Rel8.Table.Alternative
4348 )
4449import Rel8.Table.Eq ( EqTable, eqTable )
4550import Rel8.Table.Ord ( OrdTable, ordTable )
46−import Rel8.Table.Recontextualize ( Recontextualize )
47−import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
48−import Rel8.Table.Unreify ( Unreifies )
51+import Rel8.Table.Projection
52+ ( Projectable, Projecting, Projection, project, apply
53+ )
54+import Rel8.Table.Serialize ( ToExprs )
4955
5056
5157-- | A @ListTable@ value contains zero or more instances of @a@. You construct
5258-- @ListTable@s with 'Rel8.many' or 'Rel8.listAgg'.
53−type ListTable :: Type -> Type
54−newtype ListTable a = ListTable (HListTable (Columns a) (Col (Context a)))
59+type ListTable :: K.Context -> Type -> Type
60+newtype ListTable context a =
61+ ListTable (HListTable (Columns a) (Context a))
62+
63+
64+instance Projectable (ListTable context) where
65+ project f (ListTable a) = ListTable (hproject (apply f) a)
5566
5667
57−instance (Table context a, Unreifies context a) =>
58− Table context (ListTable a)
68+instance (Table context a, context ~ context') =>
69+ Table context' (ListTable context a)
5970 where
60− type Columns (ListTable a) = HListTable (Columns a)
61− type Context (ListTable a) = Context a
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)
6275
6376 fromColumns = ListTable
6477 toColumns (ListTable a) = a
65−
66− reify Refl (ListTable a) = ListTable (hreify a)
67− unreify Refl (ListTable a) = ListTable (hunreify a)
68−
69−
70−instance
71− ( Unreifies from a, Unreifies to b
72− , Recontextualize from to a b
73− )
74− => Recontextualize from to (ListTable a) (ListTable b)
78+ fromResult = fmap (fromResult @_ @a) . hunvectorize unvectorizer
79+ toResult = hvectorize vectorizer . fmap (toResult @_ @a)
7580
7681
77−instance EqTable a => EqTable (ListTable a) where
82+instance (EqTable a, context ~ Expr) => EqTable (ListTable context a) where
7883 eqTable =
7984 hvectorize
80− (\SSpec {} (Identity dict) -> case dbTypeDict dict of
81− Dict -> case dbTypeNullity dict of
82− Null -> Dict
83− NotNull -> Dict)
85+ (\Spec {nullity} (Identity Dict) -> case nullity of
86+ Null -> Dict
87+ NotNull -> Dict)
8488 (Identity (eqTable @a))
8589
8690
87−instance OrdTable a => OrdTable (ListTable a) where
91+instance (OrdTable a, context ~ Expr) => OrdTable (ListTable context a) where
8892 ordTable =
8993 hvectorize
90− (\SSpec {} (Identity dict) -> case dbTypeDict dict of
91− Dict -> case dbTypeNullity dict of
92− Null -> Dict
93− NotNull -> Dict)
94+ (\Spec {nullity} (Identity Dict) -> case nullity of
95+ Null -> Dict
96+ NotNull -> Dict)
9497 (Identity (ordTable @a))
9598
9699
97−type instance FromExprs (ListTable a) = [FromExprs a]
100+instance (ToExprs exprs a, context ~ Expr) =>
101+ ToExprs (ListTable context exprs) [a]
98102
99103
100−instance ToExprs exprs a => ToExprs (ListTable exprs) [a] where
101− fromResult = fmap (fromResult @exprs) . fromColumns
102− toResult = toColumns . fmap (toResult @exprs)
103−
104−
105−instance AltTable ListTable where
104+instance context ~ Expr => AltTable (ListTable context) where
106105 (<|>:) = (<>)
107106
108107
109−instance AlternativeTable ListTable where
108+instance context ~ Expr => AlternativeTable (ListTable context) where
110109 emptyTable = mempty
111110
112111
113−instance Table Expr a => Semigroup (ListTable a) where
114− ListTable as <> ListTable bs = ListTable $
115− happend (\_ _ (DB a) (DB b) -> DB (sappend a b)) as bs
112+instance (context ~ Expr, Table Expr a) => Semigroup (ListTable context a)
113+ where
114+ ListTable as <> ListTable bs = ListTable $ happend (const sappend) as bs
116115
117116
118−instance Table Expr a => Monoid (ListTable a) where
119− mempty = ListTable $ hempty $ \nullability info ->
120− DB (sempty nullability info)
117+instance (context ~ Expr, Table Expr a) =>
118+ Monoid (ListTable context a)
119+ where
120+ mempty = ListTable $ hempty $ \Spec {info} -> sempty info
121121
122122
123−listTable :: Table Expr a => [a] -> ListTable a
124−listTable =
125− ListTable .
126− hvectorize (\SSpec {info} -> DB . slistOf info . fmap unDB) .
127− fmap toColumns
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 $*
128128
129129
130−insertListTable :: Table Insert a => [a] -> ListTable a
131−insertListTable =
130+-- | Construct a @ListTable@ from a list of expressions.
131+listTable :: Table Expr a => [a] -> ListTable Expr a
132+listTable =
132133 ListTable .
133− hvectorize (\SSpec {necessity, info} -> case necessity of
134− SRequired -> RequiredInsert . slistOf info . fmap (\(RequiredInsert a) -> a)
135− SOptional -> OptionalInsert . fmap (slistOf info) . traverse (\(OptionalInsert a) -> a)) .
134+ hvectorize (\Spec {info} -> slistOf info) .
136135 fmap toColumns
137136
138137
139−nameListTable :: Table Name a => a -> ListTable a
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
140145nameListTable =
141146 ListTable .
142− hvectorize (\_ (Identity (NameCol a)) -> NameCol a) .
147+ hvectorize (\_ (Identity (Name a)) -> Name a) .
143148 pure .
144149 toColumns
src/Rel8/Table/Maybe.hs+121−139
@@ -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 #-}
@@ -16,42 +15,42 @@ module Rel8.Table.Maybe
1615 ( MaybeTable(..)
1716 , maybeTable, nothingTable, justTable
1817 , isNothingTable, isJustTable
18+ , fromMaybeTable
1919 , ($?)
20− , aggregateMaybeTable, insertMaybeTable, nameMaybeTable
20+ , aggregateMaybeTable
21+ , nameMaybeTable
2122 )
2223where
2324
2425-- base
25−import Data.Functor.Identity ( runIdentity )
26+import Data.Functor ( ($>) )
27+import Data.Functor.Identity ( Identity( Identity ) )
2628import Data.Kind ( Type )
29+import Data.Maybe ( fromMaybe, isJust )
2730import Prelude hiding ( null, undefined )
2831
32+-- comonad
33+import Control.Comonad ( extract )
34+
2935-- rel8
30−import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )
36+import Rel8.Aggregate ( Aggregate )
3137import Rel8.Expr ( Expr )
38+import Rel8.Expr.Aggregate ( groupByExpr )
3239import Rel8.Expr.Bool ( boolExpr )
3340import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )
34−import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
35−import Rel8.Schema.Context.Label
36− ( Labelable, HLabelable, hlabeler, hunlabeler
37− )
38−import Rel8.Schema.Context.Nullify
39− ( Nullifiable, ConstrainTag
40− , HNullifiable, HConstrainTag
41− , hencodeTag, hdecodeTag
42− , hnullifier, hunnullifier
43− )
44−import Rel8.Schema.HTable ( HTable )
41+import Rel8.Kind.Context ( Reifiable )
42+import Rel8.Schema.Dict ( Dict( Dict ) )
43+import qualified Rel8.Schema.Kind as K
4544import Rel8.Schema.HTable.Identity ( HIdentity(..) )
4645import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
4746import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
48−import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
49−import Rel8.Schema.Insert ( Insert )
5047import Rel8.Schema.Name ( Name )
51−import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql, nullable )
48+import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
49+import qualified Rel8.Schema.Null as N
5250import Rel8.Table
5351 ( Table, Columns, Context, fromColumns, toColumns
54− , reify, unreify
52+ , FromExprs, fromResult, toResult
53+ , Transpose
5554 )
5655import Rel8.Table.Alternative
5756 ( AltTable, (<|>:)
@@ -59,17 +58,16 @@ import Rel8.Table.Alternative
5958 )
6059import Rel8.Table.Bool ( bool )
6160import Rel8.Table.Eq ( EqTable, eqTable )
62−import Rel8.Table.Insert ( toInsert )
6361import Rel8.Table.Ord ( OrdTable, ordTable )
64−import Rel8.Table.Recontextualize ( Recontextualize )
65−import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
66−import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )
62+import Rel8.Table.Projection ( Projectable, project )
63+import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )
64+import Rel8.Table.Serialize ( ToExprs )
6765import Rel8.Table.Undefined ( undefined )
6866import Rel8.Type ( DBType )
69−import Rel8.Type.Tag ( MaybeTag )
67+import Rel8.Type.Tag ( MaybeTag( IsJust ) )
7068
7169-- semigroupoids
72−import Data.Functor.Apply ( Apply, (<.>), liftF2 )
70+import Data.Functor.Apply ( Apply, (<.>) )
7371import Data.Functor.Bind ( Bind, (>>-) )
7472
7573
@@ -81,184 +79,168 @@ import Data.Functor.Bind ( Bind, (>>-) )
8179-- entirely of nulls, you can't distinguish if you matched an all null row, or
8280-- if the match failed. For this reason @MaybeTable@ contains an extra field -
8381-- a "nullTag" - to track whether or not the outer join produced any rows.
84−type MaybeTable :: Type -> Type
85−data MaybeTable a = MaybeTable
86− { tag :: Tag "isJust" (Maybe MaybeTag)
87− , just :: a
82+type MaybeTable :: K.Context -> Type -> Type
83+data MaybeTable context a = MaybeTable
84+ { tag :: context (Maybe MaybeTag)
85+ , just :: Nullify context a
8886 }
8987 deriving stock Functor
9088
9189
92−instance Apply MaybeTable where
93− MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f a)
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)
9496
9597
9698-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:
9799-- 'Rel8.traverseMaybeTable'.
98−instance Applicative MaybeTable where
100+instance context ~ Expr => Applicative (MaybeTable context) where
99101 (<*>) = (<.>)
100102 pure = justTable
101103
102104
103−instance Bind MaybeTable where
104− MaybeTable tag a >>- f = case f a of
105+instance context ~ Expr => Bind (MaybeTable context) where
106+ MaybeTable tag a >>- f = case f (extract a) of
105107 MaybeTable tag' b -> MaybeTable (tag <> tag') b
106108
107109
108−-- | Has the same behavior as the @Monad@ instance for @Maybe@. See also:
109−-- 'Rel8.bindMaybeTable'.
110−instance Monad MaybeTable where
110+-- | Has the same behavior as the @Monad@ instance for @Maybe@.
111+instance context ~ Expr => Monad (MaybeTable context) where
111112 (>>=) = (>>-)
112113
113114
114−instance AltTable MaybeTable where
115− ma@(MaybeTable tag a) <|>: MaybeTable tag' b = MaybeTable
116− { tag = (tag <> tag')
117− { expr = boolExpr (expr tag) (expr tag') condition
118− }
119− , just = bool a b condition
120− }
121− where
122− condition = isNothingTable ma
115+instance context ~ Expr => AltTable (MaybeTable context) where
116+ ma <|>: mb = bool ma mb (isNothingTable ma)
123117
124118
125−instance AlternativeTable MaybeTable where
119+instance context ~ Expr => AlternativeTable (MaybeTable context) where
126120 emptyTable = nothingTable
127121
128122
129−instance (Table Expr a, Semigroup a) => Semigroup (MaybeTable a) where
123+instance (context ~ Expr, Table Expr a, Semigroup a) =>
124+ Semigroup (MaybeTable context a)
125+ where
130126 ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma
131127
132128
133−instance (Table Expr a, Semigroup a) => Monoid (MaybeTable a) where
129+instance (context ~ Expr, Table Expr a, Semigroup a) =>
130+ Monoid (MaybeTable context a)
131+ where
134132 mempty = nothingTable
135133
136134
137−instance
138− ( Table context a
139− , Labelable context, Nullifiable context
140− , ConstrainTag context MaybeTag
141− ) => Table context (MaybeTable a)
135+instance (Table context a, Reifiable context, context ~ context') =>
136+ Table context' (MaybeTable context a)
142137 where
143− type Columns (MaybeTable a) = HMaybeTable (Columns a)
144− type Context (MaybeTable a) = Context a
145−
146− toColumns = toColumns1 toColumns
147− fromColumns = fromColumns1 fromColumns
148− reify = fmap fmap reify
149− unreify = fmap fmap unreify
150−
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+ }
151147
152−instance
153− ( Labelable from, Nullifiable from, ConstrainTag from MaybeTag
154− , Labelable to, Nullifiable to, ConstrainTag to MaybeTag
155− , Recontextualize from to a b
156− )
157− => Recontextualize from to (MaybeTable a) (MaybeTable b)
148+ fromColumns HMaybeTable {htag, hjust} = MaybeTable
149+ { tag = unHIdentity $ hunlabel htag
150+ , just = fromColumns $ hunlabel hjust
151+ }
158152
153+ toResult ma = HMaybeTable
154+ { htag = hlabel (HIdentity (Identity (IsJust <$ ma)))
155+ , hjust = hlabel (toResult @_ @(Nullify context a) ma)
156+ }
159157
160−instance EqTable a => EqTable (MaybeTable a) where
161− eqTable = toColumns1 id (justTable (eqTable @a))
158+ fromResult HMaybeTable {htag, hjust} = case hunlabel htag of
159+ HIdentity (Identity tag) -> tag $>
160+ fromMaybe err (fromResult @_ @(Nullify context a) (hunlabel hjust))
161+ where
162+ err = error "Maybe.fromColumns: mismatch between tag and data"
162163
163164
164−instance OrdTable a => OrdTable (MaybeTable a) where
165− ordTable = toColumns1 id (justTable (ordTable @a))
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+ }
166170
167171
168−type instance FromExprs (MaybeTable a) = Maybe (FromExprs a)
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+ }
169177
170178
171−instance ToExprs exprs a => ToExprs (MaybeTable exprs) (Maybe a) where
172− fromResult = fmap (fromResult @exprs) . fromColumns
173− toResult = toColumns . fmap (toResult @exprs)
179+instance (ToExprs exprs a, context ~ Expr) =>
180+ ToExprs (MaybeTable context exprs) (Maybe a)
174181
175182
176183-- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.
177−isNothingTable :: MaybeTable a -> Expr Bool
178−isNothingTable (MaybeTable tag _) = isNull (expr tag)
184+isNothingTable :: MaybeTable Expr a -> Expr Bool
185+isNothingTable (MaybeTable tag _) = isNull tag
179186
180187
181188-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.
182−isJustTable :: MaybeTable a -> Expr Bool
183−isJustTable (MaybeTable tag _) = isNonNull (expr tag)
189+isJustTable :: MaybeTable Expr a -> Expr Bool
190+isJustTable (MaybeTable tag _) = isNonNull tag
184191
185192
186193-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.
187−maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable a -> b
188−maybeTable b f ma@(MaybeTable _ a) = bool (f a) b (isNothingTable ma)
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)
189196{-# INLINABLE maybeTable #-}
190197
191198
192199-- | The null table. Like 'Nothing'.
193−nothingTable :: Table Expr a => MaybeTable a
194−nothingTable = MaybeTable (fromExpr null) undefined
200+nothingTable :: Table Expr a => MaybeTable Expr a
201+nothingTable = MaybeTable null (pure undefined)
195202
196203
197204-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use
198205-- 'pure'.
199−justTable :: a -> MaybeTable a
200−justTable = MaybeTable (fromExpr mempty)
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
201213
202214
203215-- | Project a single expression out of a 'MaybeTable'. You can think of this
204216-- operator like the '$' operator, but it also has the ability to return
205217-- @null@.
206218($?) :: forall a b. Sql DBType b
207− => (a -> Expr b) -> MaybeTable a -> Expr (Nullify b)
219+ => (a -> Expr b) -> MaybeTable Expr a -> Expr (N.Nullify b)
208220f $? ma@(MaybeTable _ a) = case nullable @b of
209− Null -> boolExpr (f a) null (isNothingTable ma)
210− NotNull -> boolExpr (nullify (f a)) null (isNothingTable ma)
221+ Null -> boolExpr (f (extract a)) null (isNothingTable ma)
222+ NotNull -> boolExpr (nullify (f (extract a))) null (isNothingTable ma)
211223infixl 4 $?
212224
213225
226+-- | Lift an aggregating function to operate on a 'MaybeTable'.
227+-- @nothingTable@s and @justTable@s are grouped separately.
214228aggregateMaybeTable :: ()
215− => (a -> Aggregate b) -> MaybeTable a -> Aggregate (MaybeTable b)
216−aggregateMaybeTable f MaybeTable {tag = tag@Tag {aggregator, expr}, just} =
217− liftF2 MaybeTable (tag <$ aggregate) (f just)
218− where
219− aggregate = unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr
220−
221−
222−insertMaybeTable :: Table Insert a => Maybe a -> MaybeTable a
223−insertMaybeTable = \case
224− Nothing -> MaybeTable (fromExpr null) (fromColumns (toInsert undefined))
225− Just a -> justTable a
226−
227−
228−nameMaybeTable :: Name (Maybe MaybeTag) -> a -> MaybeTable a
229−nameMaybeTable = MaybeTable . fromName
230−
231−
232−toColumns1 ::
233− ( HTable t
234− , HConstrainTag context MaybeTag
235− , HLabelable context
236− , HNullifiable context
237− )
238− => (a -> t context)
239− -> MaybeTable a
240− -> HMaybeTable t context
241−toColumns1 f MaybeTable {tag, just} = HMaybeTable
242− { htag
243− , hjust = hlabel hlabeler $ hnullify (hnullifier tag isNonNull) $ f just
244− }
245− where
246− htag = HIdentity (hencodeTag tag)
247−
248−
249−fromColumns1 ::
250− ( HTable t
251− , HConstrainTag context MaybeTag
252− , HLabelable context
253− , HNullifiable context
254− )
255− => (t context -> a)
256− -> HMaybeTable t context
257− -> MaybeTable a
258−fromColumns1 f HMaybeTable {htag = HIdentity htag, hjust} = MaybeTable
259− { tag
260− , just = f $ runIdentity $
261− hunnullify (\a -> pure . hunnullifier a) (hunlabel hunlabeler hjust)
262− }
263− where
264− tag = hdecodeTag htag
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
src/Rel8/Table/Name.hs+37−26
@@ -1,14 +1,17 @@
1+{-# language DataKinds #-}
12{-# language FlexibleContexts #-}
3+{-# language FlexibleInstances #-}
4+{-# language MultiParamTypeClasses #-}
25{-# language NamedFieldPuns #-}
36{-# language ScopedTypeVariables #-}
47{-# language TypeApplications #-}
58{-# language TypeFamilies #-}
9+{-# language UndecidableInstances #-}
610{-# language ViewPatterns #-}
711
812module Rel8.Table.Name
913 ( namesFromLabels
1014 , namesFromLabelsWith
11− , showExprs
1215 , showLabels
1316 , showNames
1417 )
@@ -17,52 +20,60 @@ where
1720-- base
1821import Data.Foldable ( fold )
1922import Data.Functor.Const ( Const( Const ), getConst )
20−import Data.List.NonEmpty ( NonEmpty, intersperse )
23+import Data.List.NonEmpty ( NonEmpty, intersperse, nonEmpty )
24+import Data.Maybe ( fromMaybe )
2125import Prelude
2226
23−-- casing
24−import Text.Casing ( quietSnake )
25−
26−-- opaleye
27−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
28−
2927-- rel8
30−import Rel8.Expr ( Expr, Col(..) )
31−import Rel8.Expr.Opaleye ( toPrimExpr )
32−import Rel8.Kind.Labels ( renderLabels )
3328import Rel8.Schema.HTable ( htabulate, htabulateA, hfield, hspecs )
34−import Rel8.Schema.Name ( Name, Col(..) )
35−import Rel8.Schema.Spec ( SSpec(..) )
36−import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
29+import Rel8.Schema.Name ( Name( Name ) )
30+import Rel8.Schema.Spec ( Spec(..) )
31+import Rel8.Table ( Table(..) )
3732
3833
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'.
3938namesFromLabels :: Table Name a => a
4039namesFromLabels = namesFromLabelsWith go
4140 where
42− go = fold . intersperse "/" . fmap quietSnake
41+ go = fold . intersperse "/"
4342
4443
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.
4559namesFromLabelsWith :: Table Name a
4660 => (NonEmpty String -> String) -> a
4761namesFromLabelsWith f = fromColumns $ htabulate $ \field ->
4862 case hfield hspecs field of
49− SSpec {labels} -> NameCol (f (renderLabels labels))
50−
51−
52−showExprs :: Table Expr a => a -> [(String, Opaleye.PrimExpr)]
53−showExprs as = case (namesFromLabels, toColumns as) of
54− (names, exprs) -> getConst $ htabulateA $ \field ->
55− case (hfield names field, hfield exprs field) of
56− (NameCol name, DB expr) -> Const [(name, toPrimExpr expr)]
63+ Spec {labels} -> Name (f (renderLabels labels))
5764
5865
5966showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]
6067showLabels _ = getConst $
6168 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
62− SSpec {labels} -> Const [renderLabels labels]
69+ Spec {labels} -> Const (pure (renderLabels labels))
6370
6471
65−showNames :: forall a. Table Name a => a -> [String]
72+showNames :: forall a. Table Name a => a -> NonEmpty String
6673showNames (toColumns -> names) = getConst $
6774 htabulateA @(Columns a) $ \field -> case hfield names field of
68− NameCol name -> Const [name]
75+ Name name -> Const (pure name)
76+
77+
78+renderLabels :: [String] -> NonEmpty String
79+renderLabels labels = fromMaybe (pure "anon") (nonEmpty labels )
src/Rel8/Table/NonEmpty.hs+72−64
@@ -1,3 +1,4 @@
1+{-# language DataKinds #-}
12{-# language FlexibleContexts #-}
23{-# language FlexibleInstances #-}
34{-# language MultiParamTypeClasses #-}
@@ -10,7 +11,9 @@
1011
1112module Rel8.Table.NonEmpty
1213 ( NonEmptyTable(..)
13− , nonEmptyTable, insertNonEmptyTable, nameNonEmptyTable
14+ , ($+)
15+ , nonEmptyTable
16+ , nameNonEmptyTable
1417 )
1518where
1619
@@ -18,118 +21,123 @@ where
1821import Data.Functor.Identity ( Identity( Identity ) )
1922import Data.Kind ( Type )
2023import Data.List.NonEmpty ( NonEmpty )
21−import Data.Type.Equality ( (:~:)( Refl ) )
22−import Prelude
24+import Prelude hiding ( id )
2325
2426-- rel8
25−import Rel8.Expr ( Expr, Col(..) )
27+import Rel8.Expr ( Expr )
2628import Rel8.Expr.Array ( sappend1, snonEmptyOf )
27−import Rel8.Kind.Necessity ( SNecessity( SOptional, SRequired ) )
2829import Rel8.Schema.Dict ( Dict( Dict ) )
2930import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
30−import Rel8.Schema.HTable.Vectorize ( happend, hvectorize )
31−import Rel8.Schema.Insert ( Col( OptionalInsert, RequiredInsert ), Insert )
32−import Rel8.Schema.Name ( Col( NameCol ), Name )
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 ) )
3338import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
34−import Rel8.Schema.Reify ( hreify, hunreify )
35−import Rel8.Schema.Spec ( SSpec(..) )
36−import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullity )
39+import Rel8.Schema.Result ( vectorizer, unvectorizer )
40+import Rel8.Schema.Spec ( Spec(..) )
3741import Rel8.Table
3842 ( Table, Context, Columns, fromColumns, toColumns
39− , reify, unreify
43+ , FromExprs, fromResult, toResult
44+ , Transpose
4045 )
4146import Rel8.Table.Alternative ( AltTable, (<|>:) )
4247import Rel8.Table.Eq ( EqTable, eqTable )
4348import Rel8.Table.Ord ( OrdTable, ordTable )
44−import Rel8.Table.Recontextualize ( Recontextualize )
45−import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
46−import Rel8.Table.Unreify ( Unreifies )
49+import Rel8.Table.Projection
50+ ( Projectable, Projecting, Projection, project, apply
51+ )
52+import Rel8.Table.Serialize ( ToExprs )
4753
4854
4955-- | A @NonEmptyTable@ value contains one or more instances of @a@. You
5056-- construct @NonEmptyTable@s with 'Rel8.some' or 'nonEmptyAgg'.
51−type NonEmptyTable :: Type -> Type
52−newtype NonEmptyTable a =
53− NonEmptyTable (HNonEmptyTable (Columns a) (Col (Context a)))
57+type NonEmptyTable :: K.Context -> Type -> Type
58+newtype NonEmptyTable context a =
59+ NonEmptyTable (HNonEmptyTable (Columns a) (Context a))
60+
5461
62+instance Projectable (NonEmptyTable context) where
63+ project f (NonEmptyTable a) = NonEmptyTable (hproject (apply f) a)
5564
56−instance (Table context a, Unreifies context a) =>
57− Table context (NonEmptyTable a)
65+
66+instance (Table context a, context ~ context') =>
67+ Table context' (NonEmptyTable context a)
5868 where
59− type Columns (NonEmptyTable a) = HNonEmptyTable (Columns a)
60− type Context (NonEmptyTable a) = Context a
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)
6174
6275 fromColumns = NonEmptyTable
6376 toColumns (NonEmptyTable a) = a
64−
65− reify Refl (NonEmptyTable a) = NonEmptyTable (hreify a)
66− unreify Refl (NonEmptyTable a) = NonEmptyTable (hunreify a)
77+ fromResult = fmap (fromResult @_ @a) . hunvectorize unvectorizer
78+ toResult = hvectorize vectorizer . fmap (toResult @_ @a)
6779
6880
69−instance
70− ( Unreifies from a, Unreifies to b
71− , Recontextualize from to a b
72− )
73− => Recontextualize from to (NonEmptyTable a) (NonEmptyTable b)
74−
75−
76−instance EqTable a => EqTable (NonEmptyTable a) where
81+instance (EqTable a, context ~ Expr) =>
82+ EqTable (NonEmptyTable context a)
83+ where
7784 eqTable =
7885 hvectorize
79− (\SSpec {} (Identity dict) -> case dbTypeDict dict of
80− Dict -> case dbTypeNullity dict of
81− Null -> Dict
82− NotNull -> Dict)
86+ (\Spec {nullity} (Identity Dict) -> case nullity of
87+ Null -> Dict
88+ NotNull -> Dict)
8389 (Identity (eqTable @a))
8490
8591
86−instance OrdTable a => OrdTable (NonEmptyTable a) where
92+instance (OrdTable a, context ~ Expr) =>
93+ OrdTable (NonEmptyTable context a)
94+ where
8795 ordTable =
8896 hvectorize
89− (\SSpec {} (Identity dict) -> case dbTypeDict dict of
90− Dict -> case dbTypeNullity dict of
91− Null -> Dict
92− NotNull -> Dict)
97+ (\Spec {nullity} (Identity Dict) -> case nullity of
98+ Null -> Dict
99+ NotNull -> Dict)
93100 (Identity (ordTable @a))
94101
95102
96−type instance FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)
97−
103+instance (ToExprs exprs a, context ~ Expr) =>
104+ ToExprs (NonEmptyTable context exprs) (NonEmpty a)
98105
99−instance ToExprs exprs a => ToExprs (NonEmptyTable exprs) (NonEmpty a)
100− where
101− fromResult = fmap (fromResult @exprs) . fromColumns
102− toResult = toColumns . fmap (toResult @exprs)
103106
104−
105−instance AltTable NonEmptyTable where
107+instance context ~ Expr => AltTable (NonEmptyTable context) where
106108 (<|>:) = (<>)
107109
108110
109−instance Table Expr a => Semigroup (NonEmptyTable a) where
111+instance (Table Expr a, context ~ Expr) => Semigroup (NonEmptyTable context a)
112+ where
110113 NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $
111− happend (\_ _ (DB a) (DB b) -> DB (sappend1 a b)) as bs
114+ happend (const sappend1) as bs
112115
113116
114−nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable a
115−nonEmptyTable =
116− NonEmptyTable .
117− hvectorize (\SSpec {info} -> DB . snonEmptyOf info . fmap unDB) .
118− fmap toColumns
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 $+
119122
120123
121−insertNonEmptyTable :: Table Insert a => NonEmpty a -> NonEmptyTable a
122−insertNonEmptyTable =
124+-- | Construct a @NonEmptyTable@ from a non-empty list of expressions.
125+nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable Expr a
126+nonEmptyTable =
123127 NonEmptyTable .
124− hvectorize (\SSpec {necessity, info} -> case necessity of
125− SRequired -> RequiredInsert . snonEmptyOf info . fmap (\(RequiredInsert a) -> a)
126− SOptional -> OptionalInsert . fmap (snonEmptyOf info) . traverse (\(OptionalInsert a) -> a)) .
128+ hvectorize (\Spec {info} -> snonEmptyOf info) .
127129 fmap toColumns
128130
129131
130−nameNonEmptyTable :: Table Name a => a -> NonEmptyTable a
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
131139nameNonEmptyTable =
132140 NonEmptyTable .
133− hvectorize (\_ (Identity (NameCol a)) -> NameCol a) .
141+ hvectorize (\_ (Identity (Name a)) -> Name a) .
134142 pure .
135143 toColumns
src/Rel8/Table/Null.hsnew file+147
@@ -0,0 +1,147 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language FlexibleInstances #-}
4+{-# language MultiParamTypeClasses #-}
5+{-# language ScopedTypeVariables #-}
6+{-# language StandaloneKindSignatures #-}
7+{-# language TypeApplications #-}
8+{-# language TypeFamilies #-}
9+{-# language UndecidableInstances #-}
10+
11+module Rel8.Table.Null
12+ ( NullTable(..)
13+ , nullableTable, nullTable, nullifyTable, unsafeUnnullifyTable
14+ , isNullTable, isNonNullTable
15+ , nameNullTable
16+ , toMaybeTable, toNullTable
17+ )
18+where
19+
20+-- base
21+import Data.Kind ( Type )
22+import Prelude hiding ( null, undefined )
23+
24+-- comonad
25+import Control.Comonad ( extract )
26+
27+-- rel8
28+import Rel8.Expr ( Expr )
29+import Rel8.Expr.Bool ( not_ )
30+import Rel8.Kind.Context ( Reifiable )
31+import qualified Rel8.Schema.Kind as K
32+import Rel8.Schema.Name ( Name )
33+import Rel8.Table
34+ ( Table, Columns, Context, fromColumns, toColumns
35+ , FromExprs, fromResult, toResult
36+ , Transpose
37+ )
38+import Rel8.Table.Alternative
39+ ( AltTable, (<|>:)
40+ , AlternativeTable, emptyTable
41+ )
42+import Rel8.Table.Bool ( bool )
43+import Rel8.Table.Eq ( EqTable, eqTable )
44+import Rel8.Table.Maybe ( MaybeTable, justTable, maybeTable, nothingTable )
45+import Rel8.Table.Nullify ( Nullify, isNull )
46+import Rel8.Table.Ord ( OrdTable, ordTable )
47+import Rel8.Table.Projection ( Projectable, project )
48+import Rel8.Table.Serialize ( ToExprs )
49+import Rel8.Table.Undefined ( undefined )
50+
51+
52+-- | @NullTable t@ is the table @t@, but where all the columns in @t@ have the
53+-- possibility of being 'Rel8.null'. This is very similar to
54+-- 'Rel8.MaybeTable', except that it does not use an extra tag field, so it
55+-- cannot distinguish between @Nothing@ and @Just Nothing@ if nested. In other
56+-- words, if all of the columns of the @t@ passed to @NullTable@ are already
57+-- nullable, then @NullTable@ has no effect.
58+type NullTable :: K.Context -> Type -> Type
59+newtype NullTable context a = NullTable (Nullify context a)
60+
61+
62+instance Projectable (NullTable context) where
63+ project f (NullTable a) = NullTable (project f a)
64+
65+
66+instance context ~ Expr => AltTable (NullTable context) where
67+ ma <|>: mb = bool ma mb (isNullTable ma)
68+
69+
70+instance context ~ Expr => AlternativeTable (NullTable context) where
71+ emptyTable = nullTable
72+
73+
74+instance (Table context a, Reifiable context, context ~ context') =>
75+ Table context' (NullTable context a)
76+ where
77+ type Columns (NullTable context a) = Columns (Nullify context a)
78+ type Context (NullTable context a) = Context (Nullify context a)
79+ type FromExprs (NullTable context a) = FromExprs (Nullify context a)
80+ type Transpose to (NullTable context a) = NullTable to (Transpose to a)
81+
82+ toColumns (NullTable a) = toColumns a
83+ fromColumns = NullTable . fromColumns
84+
85+ toResult = toResult @_ @(Nullify context a)
86+ fromResult = fromResult @_ @(Nullify context a)
87+
88+
89+instance (EqTable a, context ~ Expr) => EqTable (NullTable context a) where
90+ eqTable = eqTable @(Nullify context a)
91+
92+
93+instance (OrdTable a, context ~ Expr) => OrdTable (NullTable context a) where
94+ ordTable = ordTable @(Nullify context a)
95+
96+
97+instance (ToExprs exprs a, context ~ Expr) =>
98+ ToExprs (NullTable context exprs) (Maybe a)
99+
100+
101+-- | Check if any of the non-nullable fields of @a@ are 'Rel8.null' under the
102+-- 'NullTable'. Returns 'Rel8.false' if @a@ has no non-nullable fields.
103+isNullTable :: Table Expr a => NullTable Expr a -> Expr Bool
104+isNullTable (NullTable a) = isNull a
105+
106+
107+-- | The inverse of 'isNullTable'.
108+isNonNullTable :: Table Expr a => NullTable Expr a -> Expr Bool
109+isNonNullTable = not_ . isNullTable
110+
111+
112+-- | Like 'Rel8.nullable'.
113+nullableTable :: (Table Expr a, Table Expr b)
114+ => b -> (a -> b) -> NullTable Expr a -> b
115+nullableTable b f ma@(NullTable a) = bool (f (extract a)) b (isNullTable ma)
116+
117+
118+-- | The null table. Like 'Rel8.null'.
119+nullTable :: Table Expr a => NullTable Expr a
120+nullTable = NullTable (pure undefined)
121+
122+
123+-- | Lift any table into 'NullTable'. Like 'Rel8.nullify'.
124+nullifyTable :: a -> NullTable Expr a
125+nullifyTable = NullTable . pure
126+
127+
128+unsafeUnnullifyTable :: NullTable Expr a -> a
129+unsafeUnnullifyTable (NullTable a) = extract a
130+
131+
132+-- | Construct a 'NullTable' in the 'Name' context. This can be useful if you
133+-- have a 'NullTable' that you are storing in a table and need to construct a
134+-- 'TableSchema'.
135+nameNullTable :: a -> NullTable Name a
136+nameNullTable = NullTable . pure
137+
138+
139+-- | Convert a 'NullTable' to a 'MaybeTable'.
140+toMaybeTable :: Table Expr a => NullTable Expr a -> MaybeTable Expr a
141+toMaybeTable = nullableTable nothingTable justTable
142+
143+
144+-- | Convert a 'MaybeTable' to a 'NullTable'. Note that if the underlying @a@
145+-- has no non-nullable fields, this is a lossy conversion.
146+toNullTable :: Table Expr a => MaybeTable Expr a -> NullTable Expr a
147+toNullTable = maybeTable nullTable nullifyTable
src/Rel8/Table/Nullify.hsnew file+211
@@ -0,0 +1,211 @@
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+84−75
@@ -1,141 +1,150 @@
11{-# language BlockArguments #-}
2+{-# language DataKinds #-}
23{-# language DisambiguateRecordFields #-}
34{-# language FlexibleContexts #-}
45{-# language NamedFieldPuns #-}
6+{-# language RankNTypes #-}
57{-# language TypeFamilies #-}
68{-# language ViewPatterns #-}
79
10+{-# options_ghc -Wno-deprecations #-}
11+
812module Rel8.Table.Opaleye
913 ( aggregator
14+ , attributes
1015 , binaryspec
1116 , distinctspec
17+ , exprs
18+ , exprsWithNames
1219 , table
1320 , tableFields
1421 , unpackspec
1522 , valuesspec
23+ , view
1624 , castTable
1725 )
1826where
1927
2028-- base
21−import Prelude hiding ( undefined )
29+import Data.Functor.Const ( Const( Const ), getConst )
30+import Data.List.NonEmpty ( NonEmpty )
31+import Prelude
2232
2333-- opaleye
34+import qualified Opaleye.Adaptors as Opaleye
35+import qualified Opaleye.Field as Opaleye ( Field_ )
2436import qualified Opaleye.Internal.Aggregate as Opaleye
25−import qualified Opaleye.Internal.Binary as Opaleye
26−import qualified Opaleye.Internal.Distinct as Opaleye
2737import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
28−import qualified Opaleye.Internal.PackMap as Opaleye
29−import qualified Opaleye.Internal.Unpackspec as Opaleye
3038import qualified Opaleye.Internal.Values as Opaleye
31−import qualified Opaleye.Internal.Table as Opaleye
39+import qualified Opaleye.Table as Opaleye
3240
3341-- profunctors
3442import Data.Profunctor ( dimap, lmap )
3543
3644-- rel8
37−import Rel8.Aggregate ( Aggregate( Aggregate ) )
38−import Rel8.Expr ( Expr, Col(..) )
45+import Rel8.Aggregate ( Aggregate( Aggregate ), Aggregates )
46+import Rel8.Expr ( Expr )
3947import Rel8.Expr.Opaleye
4048 ( fromPrimExpr, toPrimExpr
41− , traversePrimExpr
42− , fromColumn, toColumn
43− , scastExpr
49+ , scastExpr, traverseFieldP
4450 )
45−import Rel8.Kind.Necessity ( SNecessity( SRequired, SOptional ) )
46−import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs, htabulate )
47−import Rel8.Schema.Insert ( Insert, Inserts, Col(..) )
48−import Rel8.Schema.Name ( Name, Selects, Col(..) )
49−import Rel8.Schema.Spec ( SSpec(..) )
50−import Rel8.Schema.Table ( TableSchema(..) )
51+import Rel8.Schema.HTable ( htabulateA, hfield, hspecs, htabulate,
52+ htraverseP, htraversePWithField )
53+import Rel8.Schema.Name ( Name( Name ), Selects, ppColumn )
54+import Rel8.Schema.Spec ( Spec(..) )
55+import Rel8.Schema.Table ( TableSchema(..), ppTable )
5156import Rel8.Table ( Table, fromColumns, toColumns )
52−import Rel8.Table.Undefined ( undefined )
57+import Rel8.Type.Information ( typeName )
5358
5459-- semigroupoids
5560import 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
5668
5769
58−aggregator :: Opaleye.Aggregator (Aggregate exprs) exprs
59−aggregator = Opaleye.Aggregator $ Opaleye.PackMap $
60− \f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner))) -> inner f ()
70+attributes :: Selects names exprs => TableSchema names -> exprs
71+attributes schema@TableSchema {columns} = fromColumns $ htabulate $ \field ->
72+ case hfield (toColumns columns) field of
73+ Name column -> fromPrimExpr $ Opaleye.ConstExpr $
74+ Opaleye.OtherLit $
75+ show (ppTable schema) <> "." <> show (ppColumn column)
76+
77+
78+fromOpaleyespec :: (ProductProfunctor p, Table Expr a)
79+ => p (Opaleye.Field_ n x) (Opaleye.Field_ n x)
80+ -> p a a
81+fromOpaleyespec x =
82+ dimap toColumns fromColumns (htraverseP (traverseFieldP x))
6183
6284
6385binaryspec :: Table Expr a => Opaleye.Binaryspec a a
64−binaryspec = Opaleye.Binaryspec $ Opaleye.PackMap $ \f (as, bs) ->
65− fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->
66− WrapApplicative $
67− case (hfield (toColumns as) field, hfield (toColumns bs) field) of
68− (DB a, DB b) -> DB . fromPrimExpr <$> f (toPrimExpr a, toPrimExpr b)
86+binaryspec = fromOpaleyespec Opaleye.binaryspecField
6987
7088
7189distinctspec :: Table Expr a => Opaleye.Distinctspec a a
72−distinctspec =
73− Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap $ \f ->
74− fmap fromColumns .
75− unwrapApplicative .
76− htraverse
77− (\(DB a) ->
78− WrapApplicative $ DB . fromPrimExpr <$> f (Nothing, toPrimExpr a)) .
79− toColumns
80−
81−
82−table ::(Selects names exprs, Inserts exprs inserts)
83− => TableSchema names -> Opaleye.Table inserts exprs
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
84107table (TableSchema name schema columns) =
85108 case schema of
86− Nothing -> Opaleye.Table name (tableFields columns)
87− Just schemaName -> Opaleye.TableWithSchema schemaName name (tableFields columns)
109+ Nothing -> Opaleye.table name (tableFields columns)
110+ Just schemaName -> Opaleye.tableWithSchema schemaName name (tableFields columns)
88111
89112
90−tableFields :: (Selects names exprs, Inserts exprs inserts)
91− => names -> Opaleye.TableFields inserts exprs
113+tableFields :: Selects names exprs
114+ => names -> Opaleye.TableFields exprs exprs
92115tableFields (toColumns -> names) = dimap toColumns fromColumns $
93116 unwrapApplicative $ htabulateA $ \field -> WrapApplicative $
94− case hfield hspecs field of
95− specs -> case hfield names field of
96− name -> lmap (`hfield` field) (go specs name)
117+ case hfield names field of
118+ name -> lmap (`hfield` field) (go name)
97119 where
98− go :: SSpec spec -> Col Name spec -> Opaleye.TableFields (Col Insert spec) (Col Expr spec)
99− go SSpec {necessity} (NameCol name) = case necessity of
100− SRequired ->
101− lmap (\(RequiredInsert a) -> toColumn $ toPrimExpr a) $
102− DB . fromPrimExpr . fromColumn <$>
103− Opaleye.requiredTableField name
104− SOptional ->
105− lmap (\(OptionalInsert ma) -> toColumn . toPrimExpr <$> ma) $
106− DB . fromPrimExpr . fromColumn <$>
107− Opaleye.optionalTableField name
120+ go :: Name a -> Opaleye.TableFields (Expr a) (Expr a)
121+ go (Name name) =
122+ traverseFieldP $
123+ Opaleye.requiredTableField name
108124
109125
110126unpackspec :: Table Expr a => Opaleye.Unpackspec a a
111−unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->
112− fmap fromColumns .
113− unwrapApplicative .
114− htraverse (\(DB a) -> WrapApplicative $ DB <$> traversePrimExpr f a) .
115− toColumns
127+unpackspec = fromOpaleyespec Opaleye.unpackspecField
116128{-# INLINABLE unpackspec #-}
117129
118130
119−valuesspec :: Table Expr a => Opaleye.ValuesspecSafe a a
120−valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec
131+valuesspec :: Table Expr a => Opaleye.Valuesspec a a
132+valuesspec = dimap toColumns fromColumns $
133+ htraversePWithField (traverseFieldP . Opaleye.valuesspecFieldType . typeName)
134+ where typeName = Rel8.Type.Information.typeName . info . hfield hspecs
121135
122136
123−toPackMap :: Table Expr a
124− => a -> Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () a
125−toPackMap as = Opaleye.PackMap $ \f () ->
126− fmap fromColumns $
127− unwrapApplicative .
128− htraverse (\(DB a) -> WrapApplicative $ DB <$> traversePrimExpr f a) $
129− toColumns as
137+view :: Selects names exprs => names -> exprs
138+view columns = fromColumns $ htabulate $ \field ->
139+ case hfield (toColumns columns) field of
140+ Name column -> fromPrimExpr $ Opaleye.BaseTableAttrExpr column
130141
131142
132143-- | Transform a table by adding 'CAST' to all columns. This is most useful for
133144-- finalising a SELECT or RETURNING statement, guaranteed that the output
134145-- matches what is encoded in each columns TypeInformation.
135146castTable :: Table Expr a => a -> a
136−castTable (toColumns -> as) = fromColumns $ htabulate \i ->
137− case hfield hspecs i of
138− SSpec{info} ->
139− case hfield as i of
140− DB expr ->
141− DB (scastExpr info expr)
147+castTable (toColumns -> as) = fromColumns $ htabulate \field ->
148+ case hfield hspecs field of
149+ Spec {info} -> case hfield as field of
150+ expr -> scastExpr info expr
src/Rel8/Table/Ord.hs+16−45
@@ -10,7 +10,6 @@
1010{-# language TypeFamilies #-}
1111{-# language TypeOperators #-}
1212{-# language UndecidableInstances #-}
13−{-# language UndecidableSuperClasses #-}
1413{-# language ViewPatterns #-}
1514
1615module Rel8.Table.Ord
@@ -25,29 +24,20 @@ import GHC.Generics ( Rep )
2524import Prelude hiding ( seq )
2625
2726-- rel8
28−import Rel8.Expr ( Expr, Col(..) )
27+import Rel8.Expr ( Expr )
2928import Rel8.Expr.Bool ( (||.), (&&.), false, true )
3029import Rel8.Expr.Eq ( (==.) )
3130import Rel8.Expr.Ord ( (<.), (>.) )
3231import Rel8.FCF ( Eval, Exp )
3332import Rel8.Generic.Record ( Record )
34−import Rel8.Generic.Table
35− ( GGTable, GGColumns, ggtable
36− , GAlgebra
37− )
38−import Rel8.Kind.Algebra ( KnownAlgebra )
33+import Rel8.Generic.Table.Record ( GTable, GColumns, gtable )
3934import Rel8.Schema.Dict ( Dict( Dict ) )
40−import Rel8.Schema.HTable
41− ( HTable, HConstrainTable
42− , htabulateA, hfield, hdicts
43− )
44−import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )
35+import Rel8.Schema.HTable ( htabulateA, hfield )
36+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
4537import Rel8.Schema.Null (Sql)
46−import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType, nullifier )
4738import Rel8.Table ( Columns, toColumns, TColumns )
4839import Rel8.Table.Bool ( bool )
4940import Rel8.Table.Eq ( EqTable )
50−import Rel8.Type.Eq ( DBEq )
5141import Rel8.Type.Ord ( DBOrd )
5242
5343
@@ -56,22 +46,14 @@ import Rel8.Type.Ord ( DBOrd )
5646-- columns in a 'Table' have an instance of 'DBOrd'".
5747type OrdTable :: Type -> Constraint
5848class EqTable a => OrdTable a where
59− ordTable :: Columns a (Dict (ConstrainDBType DBOrd))
49+ ordTable :: Columns a (Dict (Sql DBOrd))
6050
6151 default ordTable ::
62− ( KnownAlgebra (GAlgebra (Rep (Record a)))
63− , Eval (GGTable (GAlgebra (Rep (Record a))) TOrdTable TColumns (Dict (ConstrainDBType DBOrd)) (Rep (Record a)))
64− , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))
52+ ( GTable TOrdTable TColumns (Rep (Record a))
53+ , Columns a ~ GColumns TColumns (Rep (Record a))
6554 )
66− => Columns a (Dict (ConstrainDBType DBOrd))
67− ordTable =
68− ggtable
69− @(GAlgebra (Rep (Record a)))
70− @TOrdTable
71− @TColumns
72− @(Rep (Record a))
73− table
74− nullifier
55+ => Columns a (Dict (Sql DBOrd))
56+ ordTable = gtable @TOrdTable @TColumns @(Rep (Record a)) table
7557 where
7658 table (_ :: proxy x) = ordTable @x
7759
@@ -80,19 +62,8 @@ data TOrdTable :: Type -> Exp Constraint
8062type instance Eval (TOrdTable a) = OrdTable a
8163
8264
83−instance
84− ( HTable t
85− , f ~ Col Expr
86− , HConstrainTable t (ConstrainDBType DBEq)
87− , HConstrainTable t (ConstrainDBType DBOrd)
88− )
89− => OrdTable (t f)
90− where
91− ordTable = hdicts @(Columns (t f)) @(ConstrainDBType DBOrd)
92−
93−
9465instance Sql DBOrd a => OrdTable (Expr a) where
95− ordTable = HType Dict
66+ ordTable = HIdentity Dict
9667
9768
9869instance (OrdTable a, OrdTable b) => OrdTable (a, b)
@@ -127,7 +98,7 @@ instance
12798(toColumns -> as) <: (toColumns -> bs) =
12899 foldr @[] go false $ getConst $ htabulateA $ \field ->
129100 case (hfield as field, hfield bs field) of
130− (DB a, DB b) -> case hfield (ordTable @a) field of
101+ (a, b) -> case hfield (ordTable @a) field of
131102 Dict -> Const [(a <. b, a ==. b)]
132103 where
133104 go (lt, eq) a = lt ||. (eq &&. a)
@@ -140,7 +111,7 @@ infix 4 <:
140111(toColumns -> as) <=: (toColumns -> bs) =
141112 foldr @[] go true $ getConst $ htabulateA $ \field ->
142113 case (hfield as field, hfield bs field) of
143− (DB a, DB b) -> case hfield (ordTable @a) field of
114+ (a, b) -> case hfield (ordTable @a) field of
144115 Dict -> Const [(a <. b, a ==. b)]
145116 where
146117 go (lt, eq) a = lt ||. (eq &&. a)
@@ -153,7 +124,7 @@ infix 4 <=:
153124(toColumns -> as) >: (toColumns -> bs) =
154125 foldr @[] go false $ getConst $ htabulateA $ \field ->
155126 case (hfield as field, hfield bs field) of
156− (DB a, DB b) -> case hfield (ordTable @a) field of
127+ (a, b) -> case hfield (ordTable @a) field of
157128 Dict -> Const [(a >. b, a ==. b)]
158129 where
159130 go (gt, eq) a = gt ||. (eq &&. a)
@@ -166,7 +137,7 @@ infix 4 >:
166137(toColumns -> as) >=: (toColumns -> bs) =
167138 foldr @[] go true $ getConst $ htabulateA $ \field ->
168139 case (hfield as field, hfield bs field) of
169− (DB a, DB b) -> case hfield (ordTable @a) field of
140+ (a, b) -> case hfield (ordTable @a) field of
170141 Dict -> Const [(a >. b, a ==. b)]
171142 where
172143 go (gt, eq) a = gt ||. (eq &&. a)
@@ -175,9 +146,9 @@ infix 4 >=:
175146
176147-- | Given two 'Table's, return the table that sorts before the other.
177148least :: OrdTable a => a -> a -> a
178−least a b = bool a b (a <: b)
149+least a b = bool b a (a <: b)
179150
180151
181152-- | Given two 'Table's, return the table that sorts after the other.
182153greatest :: OrdTable a => a -> a -> a
183−greatest a b = bool a b (a >: b)
154+greatest a b = bool b a (a >: b)
src/Rel8/Table/Order.hs+13−16
@@ -1,4 +1,5 @@
11{-# language DataKinds #-}
2+{-# language NamedFieldPuns #-}
23{-# language ScopedTypeVariables #-}
34{-# language TypeApplications #-}
45{-# language TypeFamilies #-}
@@ -15,16 +16,14 @@ import Data.Functor.Contravariant ( (>$<), contramap )
1516import Prelude
1617
1718-- rel8
18−import Rel8.Expr ( unDB )
1919import Rel8.Expr.Order ( asc, desc, nullsFirst, nullsLast )
2020import Rel8.Order ( Order )
2121import Rel8.Schema.Dict ( Dict( Dict ) )
2222import Rel8.Schema.HTable (htabulateA, hfield, hspecs)
2323import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
24−import Rel8.Schema.Spec ( SSpec( SSpec ) )
25−import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullity )
24+import Rel8.Schema.Spec ( Spec( Spec, nullity ) )
2625import Rel8.Table ( Columns, toColumns )
27−import Rel8.Table.Ord
26+import Rel8.Table.Ord ( OrdTable, ordTable )
2827
2928
3029-- | Construct an 'Order' for a 'Table' by sorting all columns into ascending
@@ -32,12 +31,11 @@ import Rel8.Table.Ord
3231ascTable :: forall a. OrdTable a => Order a
3332ascTable = contramap toColumns $ getConst $
3433 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
35− SSpec {} -> case hfield (ordTable @a) field of
36− dict@Dict -> case dbTypeDict dict of
37− Dict -> Const $ unDB . (`hfield` field) >$<
38− case dbTypeNullity dict of
39− Null -> nullsFirst asc
40− NotNull -> asc
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
4139
4240
4341-- | Construct an 'Order' for a 'Table' by sorting all columns into descending
@@ -45,9 +43,8 @@ ascTable = contramap toColumns $ getConst $
4543descTable :: forall a. OrdTable a => Order a
4644descTable = contramap toColumns $ getConst $
4745 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
48− SSpec {} -> case hfield (ordTable @a) field of
49− dict@Dict -> case dbTypeDict dict of
50− Dict -> Const $ unDB . (`hfield` field) >$<
51− case dbTypeNullity dict of
52− Null -> nullsLast desc
53− NotNull -> desc
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
src/Rel8/Table/Projection.hsnew file+73
@@ -0,0 +1,73 @@
1+{-# language FlexibleContexts #-}
2+{-# language FlexibleInstances #-}
3+{-# language MonoLocalBinds #-}
4+{-# language MultiParamTypeClasses #-}
5+{-# language StandaloneKindSignatures #-}
6+{-# language UndecidableInstances #-}
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.hsdeleted−87
@@ -1,87 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language FlexibleInstances #-}
3−{-# language FunctionalDependencies #-}
4−{-# language StandaloneKindSignatures #-}
5−{-# language TypeFamilies #-}
6−{-# language UndecidableInstances #-}
7−{-# language UndecidableSuperClasses #-}
8−
9−module Rel8.Table.Recontextualize
10− ( Recontextualize
11− )
12−where
13−
14−-- base
15−import Data.Functor.Identity ( Identity )
16−import Data.Kind ( Constraint, Type )
17−import Prelude ()
18−
19−-- rel8
20−import Rel8.Schema.Context ( Col )
21−import Rel8.Schema.Context.Label ( Labelable )
22−import Rel8.Schema.HTable ( HTable )
23−import qualified Rel8.Schema.Kind as K
24−import Rel8.Schema.Null ( Sql )
25−import Rel8.Schema.Result ( Result )
26−import Rel8.Table ( Table, Congruent )
27−import Rel8.Type ( DBType )
28−
29−
30−type Recontextualize :: K.Context -> K.Context -> Type -> Type -> Constraint
31−class
32− ( Table from a
33− , Table to b
34− , Congruent a b
35− , Recontextualize from from a a
36− , Recontextualize to to b b
37− , Recontextualize to from b a
38− ) => Recontextualize from to a b
39− | a -> from
40− , b -> to
41− , a to -> b
42− , b from -> a
43−
44−
45−instance Sql DBType a => Recontextualize Result Result (Identity a) (Identity a)
46−
47−
48−instance HTable t => Recontextualize from to (t (Col from)) (t (Col to))
49−
50−
51−instance
52− ( Recontextualize from to a1 b1
53− , Recontextualize from to a2 b2
54− , Labelable from
55− , Labelable to
56− )
57− => Recontextualize from to (a1, a2) (b1, b2)
58−
59−
60−instance
61− ( Recontextualize from to a1 b1
62− , Recontextualize from to a2 b2
63− , Recontextualize from to a3 b3
64− , Labelable from, Labelable to
65− )
66− => Recontextualize from to (a1, a2, a3) (b1, b2, b3)
67−
68−
69−instance
70− ( Recontextualize from to a1 b1
71− , Recontextualize from to a2 b2
72− , Recontextualize from to a3 b3
73− , Recontextualize from to a4 b4
74− , Labelable from, Labelable to
75− )
76− => Recontextualize from to (a1, a2, a3, a4) (b1, b2, b3, b4)
77−
78−
79−instance
80− ( Recontextualize from to a1 b1
81− , Recontextualize from to a2 b2
82− , Recontextualize from to a3 b3
83− , Recontextualize from to a4 b4
84− , Recontextualize from to a5 b5
85− , Labelable from, Labelable to
86− )
87− => Recontextualize from to (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5)
src/Rel8/Table/Rel8able.hs+29−85
@@ -1,6 +1,6 @@
11{-# language DataKinds #-}
22{-# language FlexibleInstances #-}
3−{-# language FunctionalDependencies #-}
3+{-# language MultiParamTypeClasses #-}
44{-# language ScopedTypeVariables #-}
55{-# language StandaloneKindSignatures #-}
66{-# language TypeApplications #-}
@@ -15,134 +15,78 @@ module Rel8.Table.Rel8able
1515where
1616
1717-- base
18−import Data.Kind ( Constraint, Type )
19−import Data.Type.Equality ( (:~:)( Refl ) )
20−import Prelude
18+import Prelude ()
2119
2220-- rel8
2321import Rel8.Expr ( Expr )
2422import qualified Rel8.Kind.Algebra as K
25−import Rel8.Kind.Context
26− ( SContext( SReify )
27− , Reifiable, contextSing
28− , sLabelable, sReifiable
29− )
23+import Rel8.Kind.Context ( Reifiable, contextSing )
3024import Rel8.Generic.Rel8able
3125 ( Rel8able, Algebra
3226 , GColumns, gfromColumns, gtoColumns
33− , greify, gunreify
27+ , GFromExprs, gfromResult, gtoResult
3428 )
35−import Rel8.Schema.Context ( Col )
36−import Rel8.Schema.Context.Label ( Labelable )
37−import Rel8.Schema.Dict ( Dict( Dict ) )
3829import qualified Rel8.Schema.Kind as K
3930import Rel8.Schema.HTable ( HConstrainTable, hdicts )
40−import Rel8.Schema.Reify ( hreify, hunreify, UnwrapReify )
31+import Rel8.Schema.Null ( Sql )
4132import Rel8.Schema.Result ( Result )
4233import Rel8.Table
43− ( Table, Columns, Context, Congruent, fromColumns, toColumns
44− , Unreify, reify, unreify
34+ ( Table, Columns, Context, fromColumns, toColumns
35+ , FromExprs, fromResult, toResult
36+ , Transpose
4537 )
46−import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
47−import Rel8.Table.ADT ( ADT( ADT ), ADTable, fromADT, toADT )
38+import Rel8.Table.ADT ( ADT )
4839import Rel8.Table.Eq ( EqTable, eqTable )
49−import Rel8.Table.HKD ( HKD )
5040import Rel8.Table.Ord ( OrdTable, ordTable )
51−import Rel8.Table.Recontextualize ( Recontextualize )
52−import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
41+import Rel8.Table.Serialize ( ToExprs )
5342import Rel8.Type.Eq ( DBEq )
5443import Rel8.Type.Ord ( DBOrd )
5544
5645
57−instance (Rel8able t, Labelable context, Reifiable context) =>
58− Table context (t context)
46+instance (Rel8able t, Reifiable context, context ~ context') =>
47+ Table context' (t context)
5948 where
6049 type Columns (t context) = GColumns t
6150 type Context (t context) = context
62− type Unreify (t context) = t (UnwrapReify context)
63−
64− fromColumns = gunreify . gfromColumns . hreify
65− toColumns = hunreify . gtoColumns . greify
66−
67− reify Refl = case contextSing @context of
68− SReify context -> case sLabelable context of
69− Dict -> case sReifiable context of
70− Dict -> greify
71−
72− unreify Refl = case contextSing @context of
73− SReify context -> case sLabelable context of
74− Dict -> case sReifiable context of
75− Dict -> gunreify
76−
51+ type FromExprs (t context) = GFromExprs t
52+ type Transpose to (t context) = t to
7753
78−instance
79− ( Rel8able t
80− , Labelable from, Reifiable from
81− , Labelable to, Reifiable to
82− , Congruent (t from) (t to)
83− )
84− => Recontextualize from to (t from) (t to)
54+ fromColumns = gfromColumns contextSing
55+ toColumns = gtoColumns contextSing
56+ fromResult = gfromResult @t
57+ toResult = gtoResult @t
8558
8659
8760instance
8861 ( context ~ Expr
8962 , Rel8able t
90− , HConstrainTable (Columns (t context)) (ConstrainDBType DBEq)
63+ , HConstrainTable (Columns (t context)) (Sql DBEq)
9164 )
9265 => EqTable (t context)
9366 where
94− eqTable = hdicts @(Columns (t context)) @(ConstrainDBType DBEq)
67+ eqTable = hdicts @(Columns (t context)) @(Sql DBEq)
9568
9669
9770instance
9871 ( context ~ Expr
9972 , Rel8able t
100− , HConstrainTable (Columns (t context)) (ConstrainDBType DBEq)
101− , HConstrainTable (Columns (t context)) (ConstrainDBType DBOrd)
73+ , HConstrainTable (Columns (t context)) (Sql DBEq)
74+ , HConstrainTable (Columns (t context)) (Sql DBOrd)
10275 )
10376 => OrdTable (t context)
10477 where
105− ordTable = hdicts @(Columns (t context)) @(ConstrainDBType DBOrd)
106−
107−
108−type instance FromExprs (t Expr) = FromExprs' t
78+ ordTable = hdicts @(Columns (t context)) @(Sql DBOrd)
10979
11080
11181instance
112− ( x ~ t' Expr
82+ ( Rel8able t', t' ~ Choose (Algebra t) t
83+ , x ~ t' Expr
11384 , result ~ Result
114− , ToExprs' (Algebra t) t' t
11585 )
11686 => ToExprs x (t result)
117− where
118− fromResult = fromResult' @(Algebra t) @t'
119− toResult = toResult' @(Algebra t) @t'
12087
12188
122−type FromExprs' :: K.Rel8able -> Type
123−type family FromExprs' t where
124− FromExprs' (ADT t) = t Result
125− FromExprs' (HKD a) = a
126− FromExprs' t = t Result
127−
128−
129−type ToExprs' :: K.Algebra -> K.Rel8able -> K.Rel8able -> Constraint
130−class (algebra ~ Algebra t, Rel8able t') =>
131− ToExprs' algebra t' t | algebra t -> t'
132− where
133− fromResult' :: GColumns t' (Col Result) -> t Result
134− toResult' :: t Result -> GColumns t' (Col Result)
135−
136−
137−instance (Algebra t ~ 'K.Product, Rel8able t, t ~ t') =>
138− ToExprs' 'K.Product t' t
139− where
140− fromResult' = fromColumns
141− toResult' = toColumns
142−
143−
144−instance (Algebra t ~ 'K.Sum, ADTable t, t' ~ ADT t) =>
145− ToExprs' 'K.Sum t' t
146− where
147− fromResult' = fromADT . ADT
148− toResult' = (\(ADT a) -> a) . toADT
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+24−119
@@ -1,7 +1,4 @@
11{-# language AllowAmbiguousTypes #-}
2−{-# language DataKinds #-}
3−{-# language DefaultSignatures #-}
4−{-# language DisambiguateRecordFields #-}
52{-# language FlexibleContexts #-}
63{-# language FlexibleInstances #-}
74{-# language FunctionalDependencies #-}
@@ -10,111 +7,54 @@
107{-# language StandaloneKindSignatures #-}
118{-# language TypeApplications #-}
129{-# language TypeFamilies #-}
13−{-# language TypeOperators #-}
1410{-# language UndecidableInstances #-}
1511
1612module Rel8.Table.Serialize
17− ( Serializable, lit, parse
18− , ToExprs(..), FromExprs
19− , TToExprs
13+ ( Serializable, lit, litHTable, parse
14+ , ToExprs
2015 )
2116where
2217
2318-- base
19+import Data.Functor.Identity ( Identity( Identity ) )
2420import Data.Kind ( Constraint, Type )
2521import Data.List.NonEmpty ( NonEmpty )
26−import GHC.Generics ( Generic, Rep, from, to )
2722import Prelude
2823
2924-- hasql
3025import qualified Hasql.Decoders as Hasql
3126
3227-- rel8
33−import Rel8.Expr ( Expr, Col(..) )
28+import Rel8.Expr ( Expr )
3429import Rel8.Expr.Serialize ( slitExpr, sparseValue )
35−import Rel8.FCF ( Eval, Exp )
36−import Rel8.Generic.Record ( Record(..) )
37−import Rel8.Generic.Table
38− ( GGToExprs, GGColumns, ggfromResult, ggtoResult
39− , GAlgebra
40− )
41−import Rel8.Kind.Algebra ( KnownAlgebra )
4230import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )
43−import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )
4431import Rel8.Schema.Null ( NotNull, Sql )
45−import Rel8.Schema.Result ( Col( Result ), Result )
46−import Rel8.Schema.Spec ( SSpec(..), KnownSpec )
47−import Rel8.Table ( Table, Columns, fromColumns, toColumns, TColumns )
32+import Rel8.Schema.Result ( Result )
33+import Rel8.Schema.Spec ( Spec(..) )
34+import Rel8.Table ( Table, fromColumns, FromExprs, fromResult, toResult )
4835import Rel8.Type ( DBType )
4936
5037-- semigroupoids
5138import Data.Functor.Apply ( WrappedApplicative(..) )
5239
5340
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.
5444type ToExprs :: Type -> Type -> Constraint
55−class Table Expr exprs => ToExprs exprs a where
56− fromResult :: Columns exprs (Col Result) -> a
57− toResult :: a -> Columns exprs (Col Result)
58−
59− default fromResult ::
60− ( Generic (Record a)
61− , KnownAlgebra (GAlgebra (Rep (Record exprs)))
62− , Eval (GGToExprs (GAlgebra (Rep (Record exprs))) TToExprs TColumns (Rep (Record exprs)) (Rep (Record a)))
63− , Columns exprs ~ Eval (GGColumns (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs)))
64− )
65− => Columns exprs (Col Result) -> a
66− fromResult =
67− unrecord .
68− to .
69− ggfromResult
70− @(GAlgebra (Rep (Record exprs)))
71− @TToExprs
72− @TColumns
73− @(Rep (Record exprs))
74− (\(_ :: proxy expr) -> fromResult @expr)
75−
76− default toResult ::
77− ( Generic (Record a)
78− , KnownAlgebra (GAlgebra (Rep (Record exprs)))
79− , Eval (GGToExprs (GAlgebra (Rep (Record exprs))) TToExprs TColumns (Rep (Record exprs)) (Rep (Record a)))
80− , Columns exprs ~ Eval (GGColumns (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs)))
81− )
82− => a -> Columns exprs (Col Result)
83− toResult =
84− ggtoResult
85− @(GAlgebra (Rep (Record exprs)))
86− @TToExprs
87− @TColumns
88− @(Rep (Record exprs))
89− (\(_ :: proxy expr) -> toResult @expr) .
90− from .
91− Record
92−
93−
94−data TToExprs :: Type -> Type -> Exp Constraint
95−type instance Eval (TToExprs exprs a) = ToExprs exprs a
96−
97−
98−instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a where
99− fromResult (HType (Result a)) = a
100− toResult = HType . Result
101−
102−
103−instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a] where
104− fromResult (HType (Result a)) = a
105− toResult = HType . Result
45+class Table Expr exprs => ToExprs exprs a
46+
47+
48+instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a
49+
50+
51+instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a]
10652
10753
10854instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a)
109− where
110− fromResult (HType (Result a)) = a
111− toResult = HType . Result
11255
11356
11457instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a)
115− where
116− fromResult (HType (Result a)) = a
117− toResult = HType . Result
11858
11959
12060instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>
@@ -176,41 +116,6 @@ instance
176116 => ToExprs x (a, b, c, d, e, f, g)
177117
178118
179−instance (HTable t, result ~ Col Result, x ~ t (Col Expr)) =>
180− ToExprs x (t result)
181− where
182− fromResult = id
183− toResult = id
184−
185−
186−instance (KnownSpec spec, x ~ Col Expr spec) =>
187− ToExprs x (Col Result spec)
188− where
189− fromResult = fromColumns
190− toResult = toColumns
191−
192−
193−type FromExprs :: Type -> Type
194−type family FromExprs a
195−type instance FromExprs (Expr a) = a
196−type instance FromExprs (Col Expr spec) = Col Result spec
197−type instance FromExprs (a, b) = (FromExprs a, FromExprs b)
198−type instance FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)
199−type instance FromExprs (a, b, c, d) =
200− (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
201−type instance FromExprs (a, b, c, d, e) =
202− (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
203−type instance FromExprs (a, b, c, d, e, f) =
204− ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e
205− , FromExprs f
206− )
207−type instance FromExprs (a, b, c, d, e, f, g) =
208− ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e
209− , FromExprs f, FromExprs g
210− )
211−type instance FromExprs (t (Col Expr)) = t (Col Result)
212−
213−
214119-- | @Serializable@ witnesses the one-to-one correspondence between the type
215120-- @sql@, which contains SQL expressions, and the type @haskell@, which
216121-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
@@ -223,21 +128,21 @@ instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a
223128-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is
224129-- capable of lifting single @Expr@s to full tables.
225130lit :: forall exprs a. Serializable exprs a => a -> exprs
226−lit = fromColumns . litHTable . toResult @exprs
131+lit = fromColumns . litHTable . toResult @_ @exprs
227132
228133
229134parse :: forall exprs a. Serializable exprs a => Hasql.Row a
230−parse = fromResult @exprs <$> parseHTable
135+parse = fromResult @_ @exprs <$> parseHTable
231136
232137
233−litHTable :: HTable t => t (Col Result) -> t (Col Expr)
138+litHTable :: HTable t => t Result -> t Expr
234139litHTable as = htabulate $ \field ->
235140 case hfield hspecs field of
236− SSpec {nullity, info} -> case hfield as field of
237− Result value -> DB (slitExpr nullity info value)
141+ Spec {nullity, info} -> case hfield as field of
142+ Identity value -> slitExpr nullity info value
238143
239144
240−parseHTable :: HTable t => Hasql.Row (t (Col Result))
145+parseHTable :: HTable t => Hasql.Row (t Result)
241146parseHTable = unwrapApplicative $ htabulateA $ \field ->
242147 WrapApplicative $ case hfield hspecs field of
243− SSpec {nullity, info} -> Result <$> sparseValue nullity info
148+ Spec {nullity, info} -> Identity <$> sparseValue nullity info
src/Rel8/Table/Tag.hsdeleted−97
@@ -1,97 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language FlexibleInstances #-}
3−{-# language GADTs #-}
4−{-# language InstanceSigs #-}
5−{-# language NamedFieldPuns #-}
6−{-# language ScopedTypeVariables #-}
7−{-# language StandaloneKindSignatures #-}
8−{-# language TypeApplications #-}
9−{-# language UndecidableInstances #-}
10−
11−module Rel8.Table.Tag
12− ( Tag(..), Taggable
13− , fromAggregate
14− , fromExpr
15− , fromName
16− )
17−where
18−
19−-- base
20−import Control.Applicative ( (<|>), empty )
21−import Data.Kind ( Constraint, Type )
22−import Data.Foldable ( fold )
23−import Data.Monoid ( getFirst )
24−import Data.Proxy ( Proxy( Proxy ) )
25−import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
26−import Prelude
27−
28−-- rel8
29−import Rel8.Aggregate ( Aggregate, Aggregator, foldInputs )
30−import Rel8.Expr ( Expr )
31−import Rel8.Expr.Opaleye ( fromPrimExpr )
32−import Rel8.Schema.Name ( Name( Name ) )
33−import Rel8.Schema.Null ( Sql )
34−import Rel8.Type.Monoid ( DBMonoid )
35−
36−
37−type Tag :: Symbol -> Type -> Type
38−data Tag label a = Tag
39− { expr :: Expr a
40− , aggregator :: Maybe Aggregator
41− , name :: Name a
42− }
43−
44−
45−type Taggable :: Type -> Constraint
46−class Taggable a where
47− tappend :: KnownSymbol label => Tag label a -> Tag label a -> Tag label a
48− tempty :: KnownSymbol label => Tag label a
49−
50−
51−instance Sql DBMonoid a => Taggable a where
52− tappend :: forall label. KnownSymbol label
53− => Tag label a -> Tag label a -> Tag label a
54− tappend a b = Tag
55− { expr = expr a <> expr b
56− , aggregator = aggregator a <|> aggregator b
57− , name = case (name a, symbolVal (Proxy @label)) of
58− (Name x, y)
59− | x == y -> name b
60− | otherwise -> name a
61− }
62− {-# INLINABLE tappend #-}
63−
64− tempty :: forall label. KnownSymbol label => Tag label a
65− tempty = Tag
66− { expr = mempty
67− , aggregator = empty
68− , name = Name (symbolVal (Proxy @label))
69− }
70− {-# INLINABLE tempty #-}
71−
72−
73−instance (KnownSymbol label, Taggable a) => Semigroup (Tag label a) where
74− (<>) = tappend
75−
76−
77−instance (KnownSymbol label, Taggable a) => Monoid (Tag label a) where
78− mempty = tempty
79−
80−
81−fromAggregate :: forall a label. (KnownSymbol label, Taggable a)
82− => Aggregate (Expr a) -> Tag label a
83−fromAggregate = fold . getFirst . foldInputs go
84− where
85− go aggregator primExpr = pure $ (tempty @a @label)
86− { expr = fromPrimExpr primExpr
87− , aggregator
88− }
89−
90−
91−fromExpr :: forall label a. (KnownSymbol label, Taggable a)
92− => Expr a -> Tag label a
93−fromExpr expr = (tempty @a @label) {expr}
94−
95−
96−fromName :: forall a label. Taggable a => Name a -> Tag label a
97−fromName name = (tempty @a @"") {name}
src/Rel8/Table/These.hs+201−164
@@ -5,7 +5,6 @@
55{-# language FlexibleInstances #-}
66{-# language MultiParamTypeClasses #-}
77{-# language NamedFieldPuns #-}
8−{-# language RecordWildCards #-}
98{-# language ScopedTypeVariables #-}
109{-# language StandaloneKindSignatures #-}
1110{-# language TupleSections #-}
@@ -21,92 +20,107 @@ module Rel8.Table.These
2120 , isThisTable, isThatTable, isThoseTable
2221 , hasHereTable, hasThereTable
2322 , justHereTable, justThereTable
24− , aggregateTheseTable, insertTheseTable, nameTheseTable
23+ , alignMaybeTable
24+ , aggregateTheseTable
25+ , nameTheseTable
2526 )
2627where
2728
2829-- base
29−import Control.Applicative ( liftA2 )
3030import Data.Bifunctor ( Bifunctor, bimap )
31−import Data.Functor.Identity ( runIdentity )
3231import Data.Kind ( Type )
33−import Prelude hiding ( undefined )
32+import Data.Maybe ( isJust )
33+import Prelude hiding ( null, undefined )
3434
3535-- rel8
3636import Rel8.Aggregate ( Aggregate )
3737import Rel8.Expr ( Expr )
38−import Rel8.Expr.Bool ( (&&.), not_ )
39−import Rel8.Expr.Null ( isNonNull )
40−import Rel8.Schema.Context.Label
41− ( Labelable
42− , HLabelable, hlabeler, hunlabeler
43− )
44−import Rel8.Schema.Context.Nullify
45− ( Nullifiable, ConstrainTag
46− , HNullifiable, HConstrainTag
47− , hencodeTag, hdecodeTag
48− , hnullifier, hunnullifier
49− )
50−import Rel8.Schema.HTable ( HTable )
51−import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
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 )
5244import Rel8.Schema.HTable.Identity ( HIdentity(..) )
53−import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
45+import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
5446import Rel8.Schema.HTable.These ( HTheseTable(..) )
55−import Rel8.Schema.Insert ( Insert )
47+import qualified Rel8.Schema.Kind as K
5648import Rel8.Schema.Name ( Name )
5749import Rel8.Table
5850 ( Table, Columns, Context, fromColumns, toColumns
59− , reify, unreify
51+ , FromExprs, fromResult, toResult
52+ , Transpose
6053 )
6154import Rel8.Table.Eq ( EqTable, eqTable )
6255import Rel8.Table.Maybe
6356 ( MaybeTable(..)
6457 , maybeTable, justTable, nothingTable
6558 , isJustTable
66− , aggregateMaybeTable, insertMaybeTable, nameMaybeTable
59+ , aggregateMaybeTable
60+ , nameMaybeTable
6761 )
62+import Rel8.Table.Nullify ( Nullify, guard )
6863import Rel8.Table.Ord ( OrdTable, ordTable )
69−import Rel8.Table.Recontextualize ( Recontextualize )
70−import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
71−import Rel8.Table.Tag ( Tag(..) )
64+import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )
65+import Rel8.Table.Serialize ( ToExprs )
7266import Rel8.Table.Undefined ( undefined )
7367import Rel8.Type.Tag ( MaybeTag )
7468
7569-- semigroupoids
76−import Data.Functor.Apply ( Apply, (<.>), liftF2 )
70+import Data.Functor.Apply ( Apply, (<.>) )
7771import Data.Functor.Bind ( Bind, (>>-) )
7872
7973-- these
80−import Data.These ( These )
74+import Data.These ( These( This, That, These ) )
8175import Data.These.Combinators ( justHere, justThere )
8276
8377
84−type TheseTable :: Type -> Type -> Type
85−data TheseTable a b = TheseTable
86− { here :: MaybeTable a
87− , there :: MaybeTable b
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
8889 }
8990 deriving stock Functor
9091
9192
92−instance Bifunctor TheseTable where
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
9398 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
9499
95100
96−instance (Table Expr a, Semigroup a) => Apply (TheseTable a) where
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
97108 fs <.> as = TheseTable
98109 { here = here fs <> here as
99110 , there = there fs <.> there as
100111 }
101112
102113
103−instance (Table Expr a, Semigroup a) => Applicative (TheseTable a)
114+instance (context ~ Expr, Table Expr a, Semigroup a) =>
115+ Applicative (TheseTable context a)
104116 where
105117 pure = thatTable
106118 (<*>) = (<.>)
107119
108120
109−instance (Table Expr a, Semigroup a) => Bind (TheseTable a) where
121+instance (context ~ Expr, Table Expr a, Semigroup a) =>
122+ Bind (TheseTable context a)
123+ where
110124 TheseTable here1 ma >>- f = case ma >>- f' of
111125 mtb -> TheseTable
112126 { here = maybeTable here1 ((here1 <>) . fst) mtb
@@ -117,12 +131,14 @@ instance (Table Expr a, Semigroup a) => Bind (TheseTable a) where
117131 TheseTable here2 mb -> (here2,) <$> mb
118132
119133
120−instance (Table Expr a, Semigroup a) => Monad (TheseTable a) where
134+instance (context ~ Expr, Table Expr a, Semigroup a) =>
135+ Monad (TheseTable context a)
136+ where
121137 (>>=) = (>>-)
122138
123139
124−instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
125− Semigroup (TheseTable a b)
140+instance (context ~ Expr, Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
141+ Semigroup (TheseTable context a b)
126142 where
127143 a <> b = TheseTable
128144 { here = here a <> here b
@@ -132,99 +148,175 @@ instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
132148
133149instance
134150 ( Table context a, Table context b
135− , Labelable context, Nullifiable context, ConstrainTag context MaybeTag
136− ) => Table context (TheseTable a b)
151+ , Reifiable context, context ~ context'
152+ )
153+ => Table context' (TheseTable context a b)
137154 where
138− type Columns (TheseTable a b) = HTheseTable (Columns a) (Columns b)
139− type Context (TheseTable a b) = Context a
140−
141− toColumns = toColumns2 toColumns toColumns
142− fromColumns = fromColumns2 fromColumns fromColumns
143− reify = liftA2 bimap reify reify
144− unreify = liftA2 bimap unreify unreify
145−
146−
147−instance
148− ( Labelable from, Nullifiable from, ConstrainTag from MaybeTag
149− , Labelable to, Nullifiable to, ConstrainTag to MaybeTag
150− , Recontextualize from to a1 b1
151− , Recontextualize from to a2 b2
152− ) =>
153− Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2)
154−
155−
156−instance (EqTable a, EqTable b) => EqTable (TheseTable a b) where
157− eqTable = toColumns2 id id (thoseTable (eqTable @a) (eqTable @b))
158−
159−
160−instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where
161− ordTable = toColumns2 id id (thoseTable (ordTable @a) (ordTable @b))
162−
163−
164−type instance FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
155+ type Columns (TheseTable context a b) = HTheseTable (Columns a) (Columns b)
156+ type Context (TheseTable context a b) = Context a
157+ type FromExprs (TheseTable context a b) =
158+ These (FromExprs a) (FromExprs b)
159+ type Transpose to (TheseTable context a b) =
160+ TheseTable to (Transpose to a) (Transpose to b)
161+
162+ toColumns TheseTable {here, there} = HTheseTable
163+ { hhereTag = hlabel $ HIdentity $ tag here
164+ , hhere =
165+ hlabel $ guard (tag here) isJust isNonNull $ toColumns $ just here
166+ , hthereTag = hlabel $ HIdentity $ tag there
167+ , hthere =
168+ hlabel $ guard (tag there) isJust isNonNull $ toColumns $ just there
169+ }
165170
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+ }
166181
167−instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable exprs1 exprs2) =>
168− ToExprs x (These a b)
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)
169219 where
170− fromResult =
171− bimap (fromResult @exprs1) (fromResult @exprs2) .
172− fromColumns
173− toResult =
174− toColumns .
175− bimap (toResult @exprs1) (toResult @exprs2)
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+ }
176226
177227
178−toHereTag :: Tag "isJust" a -> Tag "hasHere" a
179−toHereTag Tag {..} = Tag {..}
228+instance (OrdTable a, OrdTable b, context ~ Expr) =>
229+ OrdTable (TheseTable context a b)
230+ where
231+ ordTable = HTheseTable
232+ { hhereTag = hlabel (HIdentity Dict)
233+ , hhere = hlabel (ordTable @(Nullify context a))
234+ , hthereTag = hlabel (HIdentity Dict)
235+ , hthere = hlabel (ordTable @(Nullify context b))
236+ }
180237
181238
182−toThereTag :: Tag "isJust" a -> Tag "hasThere" a
183−toThereTag Tag {..} = Tag {..}
239+instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable Expr exprs1 exprs2) =>
240+ ToExprs x (These a b)
184241
185242
186−isThisTable :: TheseTable a b -> Expr Bool
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
187247isThisTable a = hasHereTable a &&. not_ (hasThereTable a)
188248
189249
190−isThatTable :: TheseTable a b -> Expr Bool
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
191254isThatTable a = not_ (hasHereTable a) &&. hasThereTable a
192255
193256
194−isThoseTable :: TheseTable a b -> Expr Bool
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
195261isThoseTable a = hasHereTable a &&. hasThereTable a
196262
197263
198−hasHereTable :: TheseTable a b -> Expr Bool
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
199268hasHereTable TheseTable {here} = isJustTable here
200269
201270
202−hasThereTable :: TheseTable a b -> Expr Bool
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
203275hasThereTable TheseTable {there} = isJustTable there
204276
205277
206−justHereTable :: TheseTable a b -> MaybeTable a
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
207282justHereTable = here
208283
209284
210−justThereTable :: TheseTable a b -> MaybeTable b
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
211289justThereTable = there
212290
213291
214−thisTable :: Table Expr b => a -> TheseTable a b
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
215304thisTable a = TheseTable (justTable a) nothingTable
216305
217306
218−thatTable :: Table Expr a => b -> TheseTable a b
307+-- | Construct a @TheseTable@. Corresponds to 'That'.
308+thatTable :: Table Expr a => b -> TheseTable Expr a b
219309thatTable b = TheseTable nothingTable (justTable b)
220310
221311
222−thoseTable :: a -> b -> TheseTable a b
312+-- | Construct a @TheseTable@. Corresponds to 'These'.
313+thoseTable :: a -> b -> TheseTable Expr a b
223314thoseTable a b = TheseTable (justTable a) (justTable b)
224315
225316
317+-- | Pattern match on a 'TheseTable'. Corresponds to 'these'.
226318theseTable :: Table Expr c
227− => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable a b -> c
319+ => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable Expr a b -> c
228320theseTable f g h TheseTable {here, there} =
229321 maybeTable
230322 (maybeTable undefined f here)
@@ -232,89 +324,34 @@ theseTable f g h TheseTable {here, there} =
232324 there
233325
234326
327+-- | Lift a pair of aggregating functions to operate on an 'TheseTable'.
328+-- @thisTable@s, @thatTable@s and @thoseTable@s are grouped separately.
235329aggregateTheseTable :: ()
236− => (a -> Aggregate c)
237− -> (b -> Aggregate d)
238− -> TheseTable a b
239− -> Aggregate (TheseTable c d)
240−aggregateTheseTable f g TheseTable {here, there} =
241− liftF2 TheseTable (aggregateMaybeTable f here) (aggregateMaybeTable g there)
242−
243−
244−insertTheseTable :: (Table Insert a, Table Insert b)
245− => These a b -> TheseTable a b
246−insertTheseTable =
247− TheseTable <$> insertMaybeTable . justHere <*> insertMaybeTable . justThere
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+ }
248338
249339
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'.
250343nameTheseTable :: ()
251344 => Name (Maybe MaybeTag)
345+ -- ^ The name of the column to track the presence of the @a@ table.
252346 -> Name (Maybe MaybeTag)
347+ -- ^ The name of the column to track the presence of the @b@ table.
253348 -> a
349+ -- ^ Names of the columns in the @a@ table.
254350 -> b
255− -> TheseTable a b
351+ -- ^ Names of the columns in the @b@ table.
352+ -> TheseTable Name a b
256353nameTheseTable here there a b =
257354 TheseTable
258355 { here = nameMaybeTable here a
259356 , there = nameMaybeTable there b
260357 }
261−
262−
263−toColumns2 ::
264− ( HTable t
265− , HTable u
266− , HConstrainTag context MaybeTag
267− , HLabelable context
268− , HNullifiable context
269− )
270− => (a -> t context)
271− -> (b -> u context)
272− -> TheseTable a b
273− -> HTheseTable t u context
274−toColumns2 f g TheseTable {here, there} = HTheseTable
275− { hhereTag = HIdentity $ hencodeTag (toHereTag (tag here))
276− , hhere =
277− hlabel hlabeler $ hnullify (hnullifier (tag here) isNonNull) $ f (just here)
278− , hthereTag = HIdentity $ hencodeTag (toThereTag (tag there))
279− , hthere =
280− hlabel hlabeler $ hnullify (hnullifier (tag there) isNonNull) $ g (just there)
281− }
282−
283−
284−fromColumns2 ::
285− ( HTable t
286− , HTable u
287− , HConstrainTag context MaybeTag
288− , HLabelable context
289− , HNullifiable context
290− )
291− => (t context -> a)
292− -> (u context -> b)
293− -> HTheseTable t u context
294− -> TheseTable a b
295−fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable
296− { here =
297− let
298− tag = hdecodeTag $ unHIdentity hhereTag
299− in
300− MaybeTable
301− { tag
302− , just = f $
303− runIdentity $
304− hunnullify (\a -> pure . hunnullifier a) $
305− hunlabel hunlabeler
306− hhere
307− }
308− , there =
309− let
310− tag = hdecodeTag $ unHIdentity hthereTag
311− in
312− MaybeTable
313− { tag
314− , just = g $
315− runIdentity $
316− hunnullify (\a -> pure . hunnullifier a) $
317− hunlabel hunlabeler
318− hthere
319− }
320− }
src/Rel8/Table/Transpose.hsnew file+46
@@ -0,0 +1,46 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleInstances #-}
3+{-# language FunctionalDependencies #-}
4+{-# language StandaloneKindSignatures #-}
5+{-# language TypeFamilies #-}
6+{-# language UndecidableInstances #-}
7+
8+module Rel8.Table.Transpose
9+ ( Transposes
10+ )
11+where
12+
13+-- base
14+import Data.Kind ( Constraint, Type )
15+import Prelude ()
16+
17+-- rel8
18+import qualified Rel8.Schema.Kind as K
19+import Rel8.Table ( Table, Transpose, Congruent )
20+
21+
22+-- | @'Transposes' from to a b@ means that @a@ and @b@ are 'Table's, in the
23+-- @from@ and @to@ contexts respectively, which share the same underlying
24+-- structure. In other words, @b@ is a version of @a@ transposed from the
25+-- @from@ context to the @to@ context (and vice versa).
26+type Transposes :: K.Context -> K.Context -> Type -> Type -> Constraint
27+class
28+ ( Table from a
29+ , Table to b
30+ , Congruent a b
31+ , b ~ Transpose to a
32+ , a ~ Transpose from b
33+ )
34+ => Transposes from to a b
35+ | a -> from
36+ , b -> to
37+ , a to -> b
38+ , b from -> a
39+instance
40+ ( Table from a
41+ , Table to b
42+ , Congruent a b
43+ , b ~ Transpose to a
44+ , a ~ Transpose from b
45+ )
46+ => Transposes from to a b
src/Rel8/Table/Undefined.hs+5−5
@@ -11,16 +11,16 @@ where
1111import Prelude hiding ( undefined )
1212
1313-- rel8
14−import Rel8.Expr ( Expr, Col(..) )
14+import Rel8.Expr ( Expr )
1515import Rel8.Expr.Null ( snull, unsafeUnnullify )
1616import Rel8.Schema.HTable ( htabulate, hfield, hspecs )
1717import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
18−import Rel8.Schema.Spec ( SSpec(..) )
18+import Rel8.Schema.Spec ( Spec(..) )
1919import Rel8.Table ( Table, fromColumns )
2020
2121
2222undefined :: Table Expr a => a
2323undefined = fromColumns $ htabulate $ \field -> case hfield hspecs field of
24− SSpec {nullity, info} -> case nullity of
25− Null -> DB (snull info)
26− NotNull -> DB (unsafeUnnullify (snull info))
24+ Spec {nullity, info} -> case nullity of
25+ Null -> snull info
26+ NotNull -> unsafeUnnullify (snull info)
src/Rel8/Table/Unreify.hsdeleted−106
@@ -1,106 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
3−{-# language FlexibleInstances #-}
4−{-# language GADTs #-}
5−{-# language LambdaCase #-}
6−{-# language MultiParamTypeClasses #-}
7−{-# language QuantifiedConstraints #-}
8−{-# language RankNTypes #-}
9−{-# language StandaloneKindSignatures #-}
10−{-# language TypeFamilies #-}
11−{-# language UndecidableInstances #-}
12−
13−-- | This module implements some machinery for implementing methods of the
14−-- 'Table' class for a particular special (but important) class of polymorphic
15−-- @Table@ types.
16−--
17−-- This special case is characterised by a @newtype@ wrapper around a bare
18−-- 'HTable' which is constructed by applying a type family to the polymorphic
19−-- type variable.
20−--
21−-- Examples of this class of @Table@ include @ListTable@ and @NonEmptyTable@.
22−--
23−-- The tricky part about implementing @Table@ for these types is 'reify' and
24−-- 'unreify'. There is no guarantee in general that @'Unreify' a@ is itself
25−-- a @Table@, let alone a @Table@ with the same 'Columns' as @a@
26−-- (e.g., @Unreify (AColumn Result Bool) = Bool@, and @Bool@ is not a
27−-- @Table@)
28−
29−module Rel8.Table.Unreify
30− ( Unreifiable, Unreifiability(..), unreifiability
31− , Unreifies
32− )
33−where
34−
35−-- base
36−import Data.Kind ( Constraint, Type )
37−import Prelude ()
38−
39−-- rel8
40−import Rel8.Aggregate ( Aggregate )
41−import Rel8.Expr ( Expr )
42−import Rel8.Kind.Context ( SContext(..), Reifiable, sReifiable )
43−import Rel8.Schema.Dict ( Dict( Dict ) )
44−import Rel8.Schema.Insert ( Insert )
45−import qualified Rel8.Schema.Kind as K
46−import Rel8.Schema.Name ( Name )
47−import Rel8.Schema.Reify ( Reify )
48−import Rel8.Schema.Result ( Result )
49−import Rel8.Table ( Table, Context, Congruent, Unreify )
50−
51−
52−type Unreifies :: K.Context -> Type -> Constraint
53−type family Unreifies context a where
54− Unreifies (Reify context) a = Unreifier context a
55− Unreifies _ _ = ()
56−
57−
58−type Unreifiable :: Type -> Constraint
59−class
60− ( Context a ~ Reify Aggregate => Unreifier Aggregate a
61− , Context a ~ Reify Expr => Unreifier Expr a
62− , Context a ~ Reify Insert => Unreifier Insert a
63− , Context a ~ Reify Name => Unreifier Name a
64− , (forall ctx. (Context a ~ Reify (Reify ctx), Reifiable ctx) => Unreifier (Reify ctx) a)
65− )
66− => Unreifiable a
67−instance
68− ( Context a ~ Reify Aggregate => Unreifier Aggregate a
69− , Context a ~ Reify Expr => Unreifier Expr a
70− , Context a ~ Reify Insert => Unreifier Insert a
71− , Context a ~ Reify Name => Unreifier Name a
72− , (forall ctx. (Context a ~ Reify (Reify ctx), Reifiable ctx) => Unreifier (Reify ctx) a)
73− )
74− => Unreifiable a
75−
76−
77−type Unreifier :: K.Context -> Type -> Constraint
78−class
79− ( Table context (Unreify a)
80− , Congruent a (Unreify a)
81− )
82− => Unreifier context a
83−instance
84− ( Table context (Unreify a)
85− , Congruent a (Unreify a)
86− )
87− => Unreifier context a
88−
89−
90−type Unreifiability :: K.Context -> Type -> Type
91−data Unreifiability context a where
92− UResult :: Unreifiability Result a
93− Unreifiability :: Unreifier context a
94− => SContext context -> Unreifiability context a
95−
96−
97−unreifiability :: (Context a ~ Reify context, Unreifiable a)
98− => SContext context -> Unreifiability context a
99−unreifiability = \case
100− SAggregate -> Unreifiability SAggregate
101− SExpr -> Unreifiability SExpr
102− SInsert -> Unreifiability SInsert
103− SName -> Unreifiability SName
104− SResult -> UResult
105− SReify context -> case sReifiable context of
106− Dict -> Unreifiability (SReify context)
src/Rel8/Table/Window.hsnew file+43
@@ -0,0 +1,43 @@
1+{-# language MonoLocalBinds #-}
2+
3+module Rel8.Table.Window
4+ ( cumulative
5+ , cumulative_
6+ , currentRow
7+ )
8+where
9+
10+-- base
11+import Prelude
12+
13+-- opaleye
14+import qualified Opaleye.Window as Opaleye
15+
16+-- rel8
17+import Rel8.Aggregate ( Aggregates )
18+import qualified Rel8.Expr.Window as Expr
19+import Rel8.Schema.HTable ( hfield, htabulateA )
20+import Rel8.Table ( fromColumns, toColumns )
21+import Rel8.Window ( Window( Window ) )
22+
23+
24+-- | 'cumulative' allows the use of aggregation functions in 'Window'
25+-- expressions. In particular, @'cumulative' 'Rel8.sum'@
26+-- (when combined with 'Rel8.Window.orderPartitionBy') gives a running total,
27+-- also known as a \"cumulative sum\", hence the name @cumulative@.
28+cumulative :: Aggregates aggregates exprs => (a -> aggregates) -> Window a exprs
29+cumulative f =
30+ fmap fromColumns $
31+ htabulateA $ \field ->
32+ Expr.cumulative ((`hfield` field) . toColumns . f)
33+
34+
35+-- | A version of 'cumulative' for use with nullary aggregators like
36+-- 'Rel8.Expr.Aggregate.countStar'.
37+cumulative_ :: Aggregates aggregates exprs => aggregates -> Window a exprs
38+cumulative_ = cumulative . const
39+
40+
41+-- | Return every column of the current row of a window query.
42+currentRow :: Window a a
43+currentRow = Window $ Opaleye.over (Opaleye.noWindowFunction id) mempty mempty
src/Rel8/Tabulate.hs+530−246
@@ -1,356 +1,640 @@
1−{-# language DeriveFunctor #-}
2−{-# language DerivingStrategies #-}
31{-# language FlexibleContexts #-}
2+{-# language MonoLocalBinds #-}
3+{-# language ScopedTypeVariables #-}
4+{-# language StandaloneKindSignatures #-}
5+{-# language TypeApplications #-}
46{-# 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').
511
612module Rel8.Tabulate
7− ( Tabulation
8− , runTabulation
9− , tabulate
10− , tabulateA
13+ (
14+ Tabulation
15+
16+ -- * Interfacing with 'Query's
1117 , fromQuery
18+ , toQuery
1219 , liftQuery
13− , prebind
14− , postbind
15− , indexed
16− , ifilter
20+ , through
1721 , 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
1839 , align
1940 , alignWith
2041 , leftAlign
2142 , leftAlignWith
43+ , rightAlign
44+ , rightAlignWith
2245 , zip
2346 , zipWith
2447 , similarity
2548 , difference
26− , aggregateTabulation
27− , optionalTabulation
28− , manyTabulation
29− , someTabulation
3049 )
3150where
3251
3352-- base
34−import Control.Applicative ( liftA2 )
35−import Control.Monad ( join, liftM2 )
36−import Data.Bifunctor ( bimap, first )
53+import Control.Applicative ( (<|>), empty, liftA2 )
54+import Control.Monad ( liftM2 )
55+import Data.Bifunctor ( Bifunctor, bimap, first, second )
3756import Data.Foldable ( traverse_ )
38−import Data.Maybe ( fromMaybe )
39−import Prelude hiding ( filter, lookup, undefined, zip, zipWith )
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
4083
4184-- rel8
42−import Rel8.Aggregate ( Aggregate )
85+import Rel8.Aggregate ( Aggregates )
4386import Rel8.Expr ( Expr )
44−import Rel8.Expr.Bool ( not_, true )
87+import Rel8.Expr.Aggregate ( countStar )
88+import Rel8.Expr.Bool ( true )
89+import Rel8.Order ( Order( Order ) )
4590import Rel8.Query ( Query )
46−import Rel8.Query.Aggregate ( aggregate )
47−import Rel8.Query.Exists ( withBy, withoutBy )
48−import Rel8.Query.Filter ( filter, where_ )
49−import Rel8.Query.Maybe ( optional )
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 )
5097import Rel8.Query.These ( alignBy )
51−import Rel8.Table ( Table )
52−import Rel8.Table.Aggregate ( groupBy, listAgg, nonEmptyAgg )
53−import Rel8.Table.Eq ( EqTable, (==:) )
54−import Rel8.Table.List ( ListTable )
55−import Rel8.Table.Maybe ( MaybeTable, maybeTable )
56−import Rel8.Table.NonEmpty ( NonEmptyTable )
57−import Rel8.Table.These ( TheseTable, theseTable )
58−import Rel8.Table.Undefined ( undefined )
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 )
59118
60119-- semigroupoids
61120import Data.Functor.Apply ( Apply, liftF2 )
62−import Data.Functor.Bind ( Bind )
63−import qualified Data.Functor.Bind
64−import Data.Semigroup.Traversable.Class ( bitraverse1 )
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+
65139
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
66143
67−-- | @'Tabulation' k a@ is denotionally a @MultiMap k a@ — a @Map@ where each
68−-- key @k@ corresponds to potentially multiple @a@ (i.e., @'Query' a@). This
69−-- @MultiMap@ supports 'lookup' and other operations you would expect it to.
144+
145+type Predicate :: Type -> Type
146+newtype Predicate a = Predicate (Maybe (a -> Expr Bool))
147+
148+
149+instance Contravariant Predicate where
150+ contramap f (Predicate a) = Predicate (lmap f <$> a)
151+
152+
153+instance Semigroup (Predicate k) where
154+ Predicate ma <> Predicate mb = Predicate $ ma <|> mb
155+
156+
157+instance Monoid (Predicate k) where
158+ mempty = Predicate Nothing
159+
160+
161+match :: EqTable k => Key k -> Predicate k
162+match = Predicate . fmap (==:)
163+
164+
165+ensure :: Predicate k -> Key k -> Query ()
166+ensure (Predicate mp) = traverse_ (\k -> traverse_ (\p -> where_ (p k)) mp)
167+
168+
169+-- | A @'Tabulation' k a@ is like a @'Query' a@, except that each row also
170+-- has a key @k@ in addition to the value @a@. 'Tabulation's can be composed
171+-- monadically just like 'Query's, but the resulting join is more like a
172+-- @NATURAL JOIN@ (based on the common key column(s) @k@) than the
173+-- @CROSS JOIN@ given by 'Query'.
174+--
175+-- Another way to think of @'Tabulation' k a@ is as analogous to @Map k a@ in
176+-- the same way @'Query' a@ is analogous to @[a]@. However, there's nothing
177+-- stopping a 'Tabulation' from containing multiple rows with the same key, so
178+-- technically @Map k (NonEmpty a)@ is more accurate.
70179--
71−-- \"Identity\" 'Tabulation's are created using 'tabulate'. 'Tabulation's can
72−-- be composed with 'Query's with 'prebind' or 'postbind' to form new
73−-- 'Tabulation's.
74−newtype Tabulation k a = Tabulation (k -> Query (Maybe k, a))
75− deriving stock Functor
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))
76185
77186
187+instance Biprojectable Tabulation where
188+ biproject f g =
189+ bimap
190+ (fromColumns . apply f . toColumns)
191+ (fromColumns . apply g . toColumns)
192+
193+
194+instance Bifunctor Tabulation where
195+ bimap f g (Tabulation a) = Tabulation $ \p ->
196+ bimap (fmap f) g <$> a (f >$< p)
197+
198+
199+instance Functor (Tabulation k) where
200+ fmap = second
201+
202+
203+instance Projectable (Tabulation k) where
204+ project f = fmap (fromColumns . apply f . toColumns)
205+
206+
207+-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<.>)@ is
208+-- @intersectionWith (liftA2 (<*>))@
78209instance EqTable k => Apply (Tabulation k) where
79210 liftF2 = liftA2
80211
81212
213+-- | @pure = 'liftQuery' . pure@
82214instance EqTable k => Applicative (Tabulation k) where
83215 pure = liftQuery . pure
84216 liftA2 = liftM2
85217
86218
87219instance EqTable k => Bind (Tabulation k) where
88− join = join
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)
89228
90229
91230instance EqTable k => Monad (Tabulation k) where
92− Tabulation as >>= f = Tabulation $ \i -> do
93− (mk, a) <- as i
94− case mk of
95− Nothing -> case f a of
96− Tabulation bs -> bs i
97− Just k -> case f a of
98− Tabulation bs -> do
99− (mk', b) <- bs k
100− case mk' of
101− Nothing -> pure (mk, b)
102− Just k' -> do
103− where_ $ k ==: k'
104− pure (mk', b)
105−
106−
107−-- | This "undoes" 'fromQuery'.
108−--
109−-- @
110−-- 'runTabulation' . 'fromQuery' = id
111−-- 'fromQuery' . 'runTabulation' = id
112−-- @
113−--
114−-- Note however that it produces nonsense when passed a 'Tabulation' that was
115−-- made with from 'liftQuery' or 'pure'. In such cases the returned 'Query'
116−-- will always produce zero rows.
117−runTabulation :: EqTable k => Tabulation k a -> Query (k, a)
118−runTabulation (Tabulation f) = do
119− (mk, a) <- f i
120− case mk of
121− Nothing -> do
122− -- Opaleye tries to be too clever optimising "WHERE FALSE" and generates
123− -- invalid SQL, so we use "WHERE NOT TRUE" instead
124− where_ $ not_ true
125− pure (i, a)
126− Just k -> pure (k, a)
127− where
128− i = undefined
231+ (>>=) = (>>-)
129232
130233
131−liftQuery :: Query a -> Tabulation k a
132−liftQuery query = Tabulation $ const $ fmap (Nothing,) query
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
133244
134245
135−-- | 'tabulate' creates an \"identity\" @'Tabulation' k a@ that allows @a@ be
136−-- indexed by one or more of its columns @k@. Some examples:
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.
137268--
138−-- [Tabulation by primary key]:
139−-- @
140−-- projectsById :: Project 'Expr' -> 'Tabulation' ('Expr' ProjectId) (Project 'Expr')
141−-- projectsById = 'tabulate' projectId
142−-- @
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.
143272--
144−-- Note: the nature of primary keys means that each key will be mapped to a
145−-- singleton value in this case.
273+-- A safer, more predictable alternative to 'toQuery' is to use 'lookup' with
274+-- an explicit set of keys:
146275--
147−-- [Tabulation by other unique key]:
148−-- @
149−-- projectsByName :: Project 'Expr' -> 'Tabulation' ('Expr' Text) (Project 'Expr')
150−-- projectsByName = 'tabulate' projectName
151−-- @
276+-- @
277+-- do
278+-- k <- keys
279+-- a <- lookup k tabulation
280+-- pure (k, a)
281+-- @
282+--
283+-- Having said that, in practice, most legitimate uses of 'Tabulation' will
284+-- have a well-defined 'toQuery'. It would be possible in theory to encode
285+-- the necessary invariants at the type level using an indexed monad, but we
286+-- would lose the ability to use @do@-notation, which is the main benefit
287+-- of having 'Tabulation' as a monad in the first place.
288+--
289+-- In particular, @'toQuery' t@ is well-defined for any 'Tabulation' @t@
290+-- defined as @t = fromQuery _@. @'toQuery' t@ is also well-defined for any
291+-- 'Tabulation' @t@ defined as @t = t' >>= _@ or @t = t' *> _@ where
292+-- @'toQuery' t'@ is well-defined. There are other valid permutations too.
293+-- Generally, anything that uses 'fromQuery' at some point, unless wrapped in
294+-- a top-level 'present' or 'absent', will have a well-defined 'toQuery'.
295+toQuery :: Table Expr k => Tabulation k a -> Query (k, a)
296+toQuery (Tabulation f) = do
297+ (mk, a) <- f mempty
298+ k <- cat mk
299+ pure (k, a)
300+
301+
302+-- | A @'Query' a@ can be treated as a @'Tabulation' k a@ where the given @a@
303+-- values exist at every possible key @k@.
304+liftQuery :: Query a -> Tabulation k a
305+liftQuery = Tabulation . const . fmap (empty,)
306+
307+
308+-- | Run a Kleisli arrow in the the 'Query' monad \"through\" a 'Tabulation'.
309+-- Useful for 'Rel8.filter'ing a 'Tabulation'.
152310--
153−-- [Tabulation by foreign key (tabulate a child table by parent key)]:
154−-- @
155−-- revisionsByProjectId :: Revision 'Expr' -> 'Tabulation' ('Expr' ProjectId) (Revision 'Expr')
156−-- revisionsByProjectId = 'tabulate' revisionProjectId
157−-- @
158−tabulate :: (a -> k) -> a -> Tabulation k a
159−tabulate key a = fromQuery $ pure (key a, a)
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`
160320
161321
162−-- | Like 'tabulate' but takes a monadic 'Query' function instead of a pure
163−-- one. This means you can filter rows while calculating the key, which is
164−-- useful in conjunction with 'Rel8.Extra.catNulls'.
165−tabulateA :: (a -> Query k) -> a -> Tabulation k a
166−tabulateA key a = fromQuery $ (,a) <$> key a
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)
167330
168331
169−-- | Analgous to 'Data.Map.Strict.fromList'.
170−fromQuery :: Query (k, a) -> Tabulation k a
171−fromQuery = Tabulation . const . fmap (first Just)
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
172345
173346
174−indexed :: Tabulation k a -> Tabulation k (k, a)
175−indexed (Tabulation query) = Tabulation $ \i ->
176− (\(mk, a) -> (mk, (fromMaybe i mk, a))) <$> query i
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
177354
178355
179−ifilter :: (k -> a -> Expr Bool) -> Tabulation k a -> Tabulation k a
180−ifilter f tabulation = snd <$> do
181− filter (uncurry f) `postbind` indexed tabulation
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))
182365
183366
184−-- | Map a 'Query' over the input side of a 'Tabulation'.
185−prebind :: (a -> Tabulation k b) -> Query a -> Tabulation k b
186−prebind f as = Tabulation $ \k -> do
187− a <- as
188− case f a of
189− Tabulation query -> query k
190−infixr 1 `prebind`
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).
191403
192404
193−-- | Map a 'Query' over the output side of a 'Tabulation'.
194−postbind :: (a -> Query b) -> Tabulation k a -> Tabulation k b
195−postbind f (Tabulation as) = Tabulation $ \i -> do
196− (k, a) <- as i
197− case f a of
198− bs -> do
199− b <- bs
200− pure (k, b)
201−infixr 1 `postbind`
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, ())
202482
203483
204−-- | Note that because 'Tabulation' is a @MultiMap@, the 'Query' returned by
205−-- 'lookup' can and often does contain multiple results.
206−lookup :: EqTable k => k -> Tabulation k a -> Query a
207−lookup key (Tabulation query) = do
208− (mk, a) <- query key
209− traverse_ (where_ . (key ==:)) mk
210− pure a
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, ())
211494
212495
213−-- | Analagous to
214−-- [@align@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:align).
496+-- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns.
215497--
216−-- If 'zip' makes an @INNER JOIN@, then 'align' makes a @FULL OUTER JOIN@.
217−align :: (EqTable k, Table Expr a, Table Expr b)
218− => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable a b)
498+-- Analogous to 'Data.Semialign.align'.
499+align :: EqTable k
500+ => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable Expr a b)
219501align = alignWith id
220502
221503
222−-- | Analagous to
223−-- [@alignWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:alignWith).
504+-- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns.
224505--
225−-- See 'zipWith' and 'align'.
226−alignWith :: (EqTable k, Table Expr a, Table Expr b)
227− => (TheseTable a b -> c)
506+-- Analogous to 'Data.Semialign.alignWith'.
507+alignWith :: EqTable k
508+ => (TheseTable Expr a b -> c)
228509 -> Tabulation k a -> Tabulation k b -> Tabulation k c
229−alignWith f kas kbs = do
230− as <- toQuery kas
231− bs <- toQuery kbs
232− fromQuery $ do
233− tkab <- alignBy (\(l, _) (m, _) -> l ==: m) as bs
234− let
235− k' = theseTable fst fst (const fst) tkab
236− tab = bimap snd snd tkab
237− pure (k', f tab)
238−
239−
240−-- | If 'zip' makes an @INNER JOIN@, then 'leftAlign' makes a @LEFT JOIN@.
241−-- This means it will return at least one row for every row in the left
242−-- 'Tabulation', even if there is no corresponding row in the right (hence the
243−-- 'Rel8.MaybeTable').
244−--
245−-- Analagous to
246−-- [@rpadZip@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:rpadZip).
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.
247535leftAlign :: EqTable k
248− => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable b)
536+ => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable Expr b)
249537leftAlign = leftAlignWith (,)
250538
251539
252−-- | See 'zipWith' and 'leftAlign'.
540+-- | Performs a @NATURAL LEFT OUTER JOIN@ based on the common key columns.
253541--
254−-- Analagous to
255−-- [@rpadZipWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:rpadZipWith).
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.
256548leftAlignWith :: EqTable k
257− => (a -> MaybeTable b -> c)
549+ => (a -> MaybeTable Expr b -> c)
258550 -> Tabulation k a -> Tabulation k b -> Tabulation k c
259−leftAlignWith f left right = liftA2 f left (optionalTabulation right)
551+leftAlignWith f left right = liftA2 f left (optional right)
260552
261553
262−-- | Analagous to
263−-- [@zip@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:zip).
554+-- | Performs a @NATURAL RIGHT OUTER JOIN@ based on the common key columns.
555+--
556+-- Analogous to 'Data.Semialign.lpadZip'.
264557--
265−-- There are multiple correct ways of understanding what this does.
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.
266568--
267−-- You can think of it as @'Data.Map.Strict.intersectionWith'
268−-- ('Control.Applicative.liftA2' (,))@. That is, @intersect@ the two
269−-- `Tabulation`s by matching their keys together (with 'Rel8.==:'), and combine
270−-- their values (remembering that 'Tabulation' is a 'MultiMap' so that the
271−-- values are keys) by getting their cartesian product.
569+-- Analogous to 'Data.Semialign.lpadZipWith'.
272570--
273−-- You can think of it as performing a cross product of the underlying 'Query's
274−-- of the given 'Tabulation's and filtering the results for 'match'ing keys.
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.
275582--
276−-- You can think of it as a natural join in SQL terms.
583+-- Analagous to 'Data.Semialign.zip'.
277584--
278−-- The size of the resulting 'Tabulation' will be \(\sum_{k} min(n_k, m_k) \)
279−-- in terms of the number of keys, but \(\sum_{k} n_k \times m_k\) in terms of
280−-- the number of values.
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.
281588zip :: EqTable k
282589 => Tabulation k a -> Tabulation k b -> Tabulation k (a, b)
283590zip = zipWith (,)
284591
285592
286−-- | Analagous to
287−-- [@zipWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:zipWith).
593+-- | Performs a @NATURAL INNER JOIN@ based on the common key columns.
288594--
289−-- See 'zip'.
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.
290600zipWith :: EqTable k
291601 => (a -> b -> c) -> Tabulation k a -> Tabulation k b -> Tabulation k c
292602zipWith = liftA2
293603
294604
295−-- | 'similarity' returns all the entries in the left 'Tabulation' that have a
296−-- corresponding entry in the right 'Tabulation'. This corresponds to a
297−-- semijoin in relational algebra.
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.
298607--
299−-- This differs from @'zipWith' const x y@ when the right 'Tabulation' @y@
300−-- contains an entry with multiple rows. For 'similarity', the entries in the
301−-- resulting 'Tabulation' will contain the same number of rows as their
302−-- respective entries in the left 'Tabulation' @x@. With `zipWith const x y`,
303−-- each entry would contain the /product/ of the number of rows of their
304−-- respective entries in @x@ and @y@.
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.
305610--
306−-- See 'Rel8.with'.
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.
307615similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
308−similarity kas kbs = do
309− as <- toQuery kas
310− bs <- toQuery kbs
311− fromQuery $ as >>= withBy (\(k, _) (l, _) -> k ==: l) bs
616+similarity a b = a <* present b
312617
313618
314−-- | 'difference' returns all the entries in the left 'Tabulation' that don't
315−-- exist in the right 'Tabulation'. This corresponds to an antijoin in
316−-- relational algebra.
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.
317624--
318−-- See 'Rel8.without'.
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.
319629difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
320−difference kas kbs = do
321− as <- toQuery kas
322− bs <- toQuery kbs
323− fromQuery $ as >>= withoutBy (\(k, _) (l, _) -> k ==: l) bs
324−
325−
326−aggregateTabulation :: EqTable k
327− => Tabulation k (Aggregate a) -> Tabulation k a
328−aggregateTabulation kas = do
329− as <- toQuery kas
330− fromQuery $ aggregate $ bitraverse1 groupBy id <$> as
331−
332−
333−optionalTabulation :: EqTable k
334− => Tabulation k a -> Tabulation k (MaybeTable a)
335−optionalTabulation as = Tabulation $ \k -> do
336− ma <- optional $ lookup k as
337− pure (Just k, ma)
338−
339−
340−manyTabulation :: (EqTable k, Table Expr a)
341− => Tabulation k a -> Tabulation k (ListTable a)
342−manyTabulation =
343− fmap (maybeTable mempty id) .
344− optionalTabulation .
345− aggregateTabulation .
346− fmap listAgg
347−
348−
349−someTabulation :: (EqTable k, Table Expr a)
350− => Tabulation k a -> Tabulation k (NonEmptyTable a)
351−someTabulation = aggregateTabulation . fmap nonEmptyAgg
630+difference a b = a <* absent b
352631
353632
354−toQuery :: Tabulation k a -> Tabulation k (Query (k, a))
355−toQuery (Tabulation as) = Tabulation $ \k ->
356− pure (Nothing, first (fromMaybe k) <$> as k)
633+-- | 'Tabulation's can be produced with either 'fromQuery' or 'liftQuery', and
634+-- in some cases we might want to treat these differently. 'peek' uses
635+-- 'unsafePeekQuery' to determine which type of 'Tabulation' we have.
636+peek :: Tabulation k a -> Tabulation k (Either (Query a) (Query (k, a)))
637+peek (Tabulation f) = Tabulation $ \p ->
638+ pure $ (empty,) $ case unsafePeekQuery (f p) of
639+ (Nothing, _) -> Left $ fmap snd (f p)
640+ (Just _, _) -> Right $ fmap (first fromJust) (f p)
src/Rel8/Type.hs+9−8
@@ -1,3 +1,4 @@
1+{-# language FlexibleContexts #-}
12{-# language FlexibleInstances #-}
23{-# language MonoLocalBinds #-}
34{-# language MultiWayIf #-}
@@ -127,10 +128,10 @@ instance DBType Int64 where
127128instance DBType Float where
128129 typeInformation = TypeInformation
129130 { encode = \x -> Opaleye.ConstExpr
130− if | x == (1 /0) -> Opaleye.OtherLit "'Infinity'"
131− | isNaN x -> Opaleye.OtherLit "'NaN'"
132− | x == (-1/0) -> Opaleye.OtherLit "'-Infinity'"
133− | otherwise -> Opaleye.NumericLit $ realToFrac x
131+ if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'"
132+ | isNaN x -> Opaleye.OtherLit "'NaN'"
133+ | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"
134+ | otherwise -> Opaleye.NumericLit $ realToFrac x
134135 , decode = Hasql.float4
135136 , typeName = "float4"
136137 }
@@ -140,10 +141,10 @@ instance DBType Float where
140141instance DBType Double where
141142 typeInformation = TypeInformation
142143 { encode = \x -> Opaleye.ConstExpr
143− if | x == (1 /0) -> Opaleye.OtherLit "'Infinity'"
144− | isNaN x -> Opaleye.OtherLit "'NaN'"
145− | x == (-1/0) -> Opaleye.OtherLit "'-Infinity'"
146− | otherwise -> Opaleye.NumericLit $ realToFrac x
144+ if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'"
145+ | isNaN x -> Opaleye.OtherLit "'NaN'"
146+ | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"
147+ | otherwise -> Opaleye.NumericLit $ realToFrac x
147148 , decode = Hasql.float8
148149 , typeName = "float8"
149150 }
src/Rel8/Type/Array.hs+46−26
@@ -1,12 +1,13 @@
11{-# language GADTs #-}
2+{-# language LambdaCase #-}
23{-# language NamedFieldPuns #-}
34{-# language OverloadedStrings #-}
5+{-# language ViewPatterns #-}
46
57module Rel8.Type.Array
6− ( array
8+ ( array, encodeArrayElement, extractArrayElement
79 , listTypeInformation
810 , nonEmptyTypeInformation
9− , fromPrimArray, toPrimArray, zipPrimArraysWith
1011 )
1112where
1213
@@ -28,10 +29,9 @@ import Rel8.Type.Information ( TypeInformation(..), parseTypeInformation )
2829
2930array :: Foldable f
3031 => TypeInformation a -> f Opaleye.PrimExpr -> Opaleye.PrimExpr
31−array TypeInformation {typeName} =
32− fromPrimArray .
33− Opaleye.CastExpr (typeName <> "[]") .
34− Opaleye.ArrayExpr . toList
32+array info =
33+ Opaleye.CastExpr (arrayType info <> "[]") .
34+ Opaleye.ArrayExpr . map (encodeArrayElement info) . toList
3535{-# INLINABLE array #-}
3636
3737
@@ -39,19 +39,23 @@ listTypeInformation :: ()
3939 => Nullity a
4040 -> TypeInformation (Unnullify a)
4141 -> TypeInformation [a]
42−listTypeInformation nullity info =
43− case info of
44− TypeInformation{ encode, decode } -> TypeInformation
45− { decode = row $ case nullity of
46− Null -> Hasql.listArray (Hasql.nullable decode)
47− NotNull -> Hasql.listArray (Hasql.nonNullable decode)
48− , encode = case nullity of
49− Null -> array info . fmap (maybe null encode)
50− NotNull -> array info . fmap encode
51− , typeName = "record"
52− }
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+ }
5358 where
54− row = Hasql.composite . Hasql.field . Hasql.nonNullable
5559 null = Opaleye.ConstExpr Opaleye.NullLit
5660
5761
@@ -66,15 +70,31 @@ nonEmptyTypeInformation nullity =
6670 message = "failed to decode NonEmptyList: got empty list"
6771
6872
69−fromPrimArray :: Opaleye.PrimExpr -> Opaleye.PrimExpr
70−fromPrimArray = Opaleye.UnExpr (Opaleye.UnOpOther "ROW")
73+isArray :: TypeInformation a -> Bool
74+isArray = \case
75+ (reverse . typeName -> ']' : '[' : _) -> True
76+ _ -> False
7177
7278
73−toPrimArray :: Opaleye.PrimExpr -> Opaleye.PrimExpr
74−toPrimArray a = Opaleye.CompositeExpr a "f1"
79+arrayType :: TypeInformation a -> String
80+arrayType info
81+ | isArray info = "record"
82+ | otherwise = typeName info
7583
7684
77−zipPrimArraysWith :: ()
78− => (Opaleye.PrimExpr -> Opaleye.PrimExpr -> Opaleye.PrimExpr)
79− -> Opaleye.PrimExpr -> Opaleye.PrimExpr -> Opaleye.PrimExpr
80−zipPrimArraysWith f a b = fromPrimArray (f (toPrimArray a) (toPrimArray b))
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
src/Rel8/Type/Array1D.hsdeleted−139
@@ -1,139 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language DeriveTraversable #-}
3−{-# language DerivingStrategies #-}
4−{-# language FlexibleContexts #-}
5−{-# language FlexibleInstances #-}
6−{-# language GeneralizedNewtypeDeriving #-}
7−{-# language NamedFieldPuns #-}
8−{-# language StandaloneKindSignatures #-}
9−{-# language TypeFamilies #-}
10−{-# language UndecidableInstances #-}
11−
12−{-# options_ghc -fno-warn-redundant-constraints #-}
13−
14−module Rel8.Type.Array1D
15− ( Array1D( Array1D )
16− , NotArray
17− , getArray1D
18− )
19−where
20−
21−-- aeson
22−import Data.Aeson
23− ( ToJSON
24− , ToJSON1
25− , ToJSONKey
26− , FromJSON
27− , FromJSON1
28− , FromJSONKey
29− )
30−
31−-- base
32−import Control.Applicative ( Alternative, (<|>) )
33−import Control.Monad ( MonadPlus )
34−import Data.Functor.Classes ( Eq1, Ord1, Read1, Show1 )
35−import Data.Kind ( Type )
36−import GHC.Exts ( IsList )
37−import Prelude hiding ( null )
38−
39−-- hasql
40−import qualified Hasql.Decoders as Hasql
41−
42−-- opaleye
43−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
44−
45−-- rel8
46−import Rel8.Expr.Opaleye ( zipPrimExprsWith )
47−import Rel8.Expr.Serialize ( litExpr )
48−import Rel8.Schema.Null ( Unnullify, Nullity( Null, NotNull ), Sql, nullable )
49−import Rel8.Type ( DBType, typeInformation )
50−import Rel8.Type.Eq ( DBEq )
51−import Rel8.Type.Information ( TypeInformation(..) )
52−import Rel8.Type.Monoid ( DBMonoid, memptyExpr )
53−import Rel8.Type.Ord ( DBMax, DBMin, DBOrd )
54−import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )
55−
56−-- semigroupoids
57−import Data.Functor.Alt ( Alt, (<!>) )
58−import Data.Functor.Apply ( Apply )
59−import Data.Functor.Bind ( Bind )
60−import Data.Functor.Plus ( Plus )
61−
62−-- semialign
63−import Data.Align ( Align )
64−import Data.Semialign ( Semialign )
65−import Data.Zip ( Repeat, Unzip, Zip )
66−
67−
68−-- | A one dimensional array.
69−newtype Array1D a = Array1D [a]
70− deriving stock Traversable
71− deriving newtype
72− ( Eq, Ord, Read, Show, Semigroup, Monoid, IsList
73− , Functor, Foldable
74− , Eq1, Ord1, Read1, Show1
75− , FromJSON1, ToJSON1, FromJSON, FromJSONKey, ToJSON, ToJSONKey
76− , Apply, Applicative, Alternative, Plus, Bind, Monad, MonadPlus
77− , Align, Semialign, Repeat, Unzip, Zip
78− )
79−
80−
81−instance Alt Array1D where
82− (<!>) = (<|>)
83−
84−
85−getArray1D :: Array1D a -> [a]
86−getArray1D (Array1D a) = a
87−
88−
89−type IsArray1D :: Type -> Bool
90−type family IsArray1D a where
91− IsArray1D (Array1D _) = 'True
92− IsArray1D _ = 'False
93−
94−
95−class IsArray1D a ~ 'False => NotArray a
96−instance IsArray1D a ~ 'False => NotArray a
97−
98−
99−array1DTypeInformation :: Sql NotArray a
100− => Nullity a
101− -> TypeInformation (Unnullify a)
102− -> TypeInformation (Array1D a)
103−array1DTypeInformation nullity info =
104− case info of
105− TypeInformation{ encode, decode, typeName } -> TypeInformation
106− { decode = case nullity of
107− Null -> Array1D <$> Hasql.listArray (Hasql.nullable decode)
108− NotNull -> Array1D <$> Hasql.listArray (Hasql.nonNullable decode)
109− , encode = case nullity of
110− Null -> Opaleye.ArrayExpr . fmap (maybe null encode) . getArray1D
111− NotNull -> Opaleye.ArrayExpr . fmap encode . getArray1D
112− , typeName = typeName <> "[]"
113− }
114− where
115− null = Opaleye.ConstExpr Opaleye.NullLit
116−
117−
118−instance (Sql DBType a, Sql NotArray a) => DBType (Array1D a) where
119− typeInformation = array1DTypeInformation nullable typeInformation
120−
121−
122−instance (Sql DBEq a, Sql NotArray a) => DBEq (Array1D a)
123−
124−
125−instance (Sql DBOrd a, Sql NotArray a) => DBOrd (Array1D a)
126−
127−
128−instance (Sql DBMax a, Sql NotArray a) => DBMax (Array1D a)
129−
130−
131−instance (Sql DBMin a, Sql NotArray a) => DBMin (Array1D a)
132−
133−
134−instance (Sql DBType a, Sql NotArray a) => DBSemigroup (Array1D a) where
135− (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
136−
137−
138−instance (Sql DBType a, Sql NotArray a) => DBMonoid (Array1D a) where
139− memptyExpr = litExpr mempty
src/Rel8/Type/Composite.hs+90−39
@@ -1,27 +1,28 @@
1+{-# language AllowAmbiguousTypes #-}
2+{-# language BlockArguments #-}
13{-# language DataKinds #-}
24{-# language FlexibleContexts #-}
35{-# language GADTs #-}
6+{-# language NamedFieldPuns #-}
47{-# language ScopedTypeVariables #-}
58{-# language StandaloneKindSignatures #-}
69{-# language TypeApplications #-}
7−{-# language TypeOperators #-}
810{-# language UndecidableInstances #-}
11+{-# language UndecidableSuperClasses #-}
12+{-# language ViewPatterns #-}
913
1014module Rel8.Type.Composite
1115 ( Composite( Composite )
16+ , DBComposite( compositeFields, compositeTypeName )
17+ , compose, decompose
1218 )
1319where
1420
1521-- base
16−import Control.Applicative ( liftA2 )
22+import Data.Functor.Const ( Const( Const ), getConst )
23+import Data.Functor.Identity ( Identity( Identity ) )
1724import Data.Kind ( Constraint, Type )
18−import Data.Proxy ( Proxy( Proxy ) )
19−import GHC.Generics
20− ( Generic, Rep, from, to
21− , (:*:)( (:*:) ), K1( K1 ), M1( M1 )
22− )
23−import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
24−import Prelude hiding ( null )
25+import Prelude
2526
2627-- hasql
2728import qualified Hasql.Decoders as Hasql
@@ -30,55 +31,105 @@ import qualified Hasql.Decoders as Hasql
3031import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
3132
3233-- rel8
33−import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
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 )
3447import Rel8.Type ( DBType, typeInformation )
48+import Rel8.Type.Eq ( DBEq )
3549import Rel8.Type.Information ( TypeInformation(..) )
50+import Rel8.Type.Ord ( DBOrd, DBMax, DBMin )
51+
52+-- semigroupoids
53+import Data.Functor.Apply ( WrappedApplicative(..) )
3654
3755
3856-- | A deriving-via helper type for column types that store a Haskell product
3957-- type in a single Postgres column using a Postgres composite type.
4058--
4159-- Note that this must map to a specific extant type in your database's schema
42−-- (created with @CREATE TYPE@). The @name@ parameter of @Composite@ should be
43−-- the name of this type.
44−type Composite :: Symbol -> Type -> Type
45−newtype Composite name a = Composite
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
4665 { unComposite :: a
4766 }
4867
4968
50−instance (KnownSymbol name, Generic a, GComposite (Rep a)) =>
51− DBType (Composite name a)
52− where
69+instance DBComposite a => DBType (Composite a) where
5370 typeInformation = TypeInformation
54− { decode = Hasql.composite (Composite . to <$> gdecode @(Rep a))
55− , encode = Opaleye.FunExpr "ROW" . gencode @(Rep a) . from . unComposite
56− , typeName = symbolVal (Proxy @name)
71+ { decode = Hasql.composite (Composite . fromResult @_ @(HKD a Expr) <$> decoder)
72+ , encode = encoder . litHTable . toResult @_ @(HKD a Expr) . unComposite
73+ , typeName = compositeTypeName @a
5774 }
5875
5976
60−type GComposite :: (Type -> Type) -> Constraint
61−class GComposite rep where
62− gdecode :: Hasql.Composite (rep x)
63− gencode :: rep x -> [Opaleye.PrimExpr]
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)
6484
6585
66−instance GComposite rep => GComposite (M1 i c rep) where
67− gdecode = M1 <$> gdecode
68− gencode (M1 a) = gencode a
86+instance (DBComposite a, OrdTable (HKD a Expr)) => DBMin (Composite a)
6987
7088
71−instance (GComposite a, GComposite b) => GComposite (a :*: b) where
72− gdecode = liftA2 (:*:) gdecode gdecode
73− gencode (a :*: b) = gencode a <> gencode b
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
7495
96+ -- | The name of the composite type that @a@ maps to.
97+ compositeTypeName :: String
7598
76−instance Sql DBType a => GComposite (K1 i a) where
77− gdecode = fmap K1 $ Hasql.field $ case nullable @a of
78− Null -> Hasql.nullable (decode typeInformation)
79− NotNull -> Hasql.nonNullable (decode typeInformation)
80− gencode (K1 a) = case nullable @a of
81− Null -> [maybe null (encode typeInformation) a]
82− NotNull -> [encode typeInformation a]
83− where
84− null = Opaleye.ConstExpr Opaleye.NullLit
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.hs+86−33
@@ -1,27 +1,34 @@
1+{-# language AllowAmbiguousTypes #-}
12{-# language DataKinds #-}
23{-# language FlexibleContexts #-}
34{-# language FlexibleInstances #-}
4−{-# language GADTs #-}
5+{-# language LambdaCase #-}
6+{-# language RankNTypes #-}
57{-# language ScopedTypeVariables #-}
68{-# language StandaloneKindSignatures #-}
79{-# language TypeApplications #-}
10+{-# language TypeFamilies #-}
811{-# language TypeOperators #-}
912{-# language UndecidableInstances #-}
1013
1114module Rel8.Type.Enum
12− ( Enum(..)
15+ ( Enum( Enum )
16+ , DBEnum( enumValue, enumTypeName )
17+ , Enumable
1318 )
1419where
1520
1621-- base
22+import Control.Applicative ( (<|>) )
23+import Control.Arrow ( (&&&) )
1724import Data.Kind ( Constraint, Type )
1825import Data.Proxy ( Proxy( Proxy ) )
1926import GHC.Generics
2027 ( Generic, Rep, from, to
21− , (:+:)( L1, R1 ), M1( M1 ), U1( U1 ), Meta( MetaCons )
22− , D, C
28+ , (:+:)( L1, R1 ), M1( M1 ), U1( U1 )
29+ , D, C, Meta( MetaCons )
2330 )
24−import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
31+import GHC.TypeLits ( KnownSymbol, symbolVal )
2532import Prelude hiding ( Enum )
2633
2734-- hasql
@@ -32,55 +39,101 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
3239
3340-- rel8
3441import Rel8.Type ( DBType, typeInformation )
42+import Rel8.Type.Eq ( DBEq )
3543import Rel8.Type.Information ( TypeInformation(..) )
44+import Rel8.Type.Ord ( DBOrd, DBMax, DBMin )
3645
3746-- text
38−import Data.Text ( unpack )
47+import Data.Text ( pack )
3948
4049
4150-- | A deriving-via helper type for column types that store an \"enum\" type
4251-- (in Haskell terms, a sum type where all constructors are nullary) using a
4352-- Postgres @enum@ type.
4453--
45−-- Note that this must map to a specific type in your database's schema
46−-- (explicitly created with @CREATE TYPE ... AS ENUM@). The @name@ parameter
47−-- of @Enum@ should be the name of this type. Note also the names of the
48−-- Postgres @enum@'s values are assumed to match exactly the names of the
49−-- constructors of the Haskell type (up to and including case sensitivity).
50−type Enum :: Symbol -> Type -> Type
51−newtype Enum name a = Enum
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
5262 { unEnum :: a
5363 }
5464
5565
56−instance (KnownSymbol name, Generic a, GEnum (Rep a)) => DBType (Enum name a)
57− where
66+instance DBEnum a => DBType (Enum a) where
5867 typeInformation = TypeInformation
59− { decode = Hasql.enum ((`lookup` (fmap (Enum . to) <$> gdecode)) . unpack)
60− , encode = Opaleye.ConstExpr . Opaleye.StringLit . gencode . from . unEnum
61− , typeName = symbolVal (Proxy @name)
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
6279 }
6380
6481
65−type GEnum :: (Type -> Type) -> Constraint
66−class GEnum rep where
67− gdecode :: [(String, rep x)]
68− gencode :: rep x -> String
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+
6993
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
70102
71−instance GEnum rep => GEnum (M1 D c rep) where
72− gdecode = fmap M1 <$> gdecode
73− gencode (M1 a) = gencode a
103+ -- | The name of the PostgreSQL @enum@ type that @a@ maps to.
104+ enumTypeName :: String
74105
75106
76−instance (GEnum a, GEnum b) => GEnum (a :+: b) where
77− gdecode = (fmap L1 <$> gdecode) <> (fmap R1 <$> gdecode)
78− gencode (L1 a) = gencode a
79− gencode (R1 a) = gencode a
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
80112
81113
82−instance (KnownSymbol name, a ~ U1) =>
83− GEnum (M1 C ('MetaCons name f r) a)
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)
84137 where
85− gdecode = [(symbolVal (Proxy @name), M1 U1)]
86− gencode _ = symbolVal (Proxy @name)
138+ genumerate = [M1 U1]
139+ gshow (M1 U1) = symbolVal (Proxy @name)
src/Rel8/Type/JSONBEncoded.hs+4
@@ -1,3 +1,5 @@
1+{-# language StandaloneKindSignatures #-}
2+
13module Rel8.Type.JSONBEncoded ( JSONBEncoded(..) ) where
24
35-- aeson
@@ -6,6 +8,7 @@ import Data.Aeson.Types ( parseEither )
68
79-- base
810import Data.Bifunctor ( first )
11+import Data.Kind ( Type )
912import Prelude
1013
1114-- hasql
@@ -20,6 +23,7 @@ import Data.Text ( pack )
2023
2124
2225-- | Like 'Rel8.JSONEncoded', but works for @jsonb@ columns.
26+type JSONBEncoded :: Type -> Type
2327newtype JSONBEncoded a = JSONBEncoded { fromJSONBEncoded :: a }
2428
2529
src/Rel8/Type/JSONEncoded.hs+4
@@ -1,3 +1,5 @@
1+{-# language StandaloneKindSignatures #-}
2+
13module Rel8.Type.JSONEncoded ( JSONEncoded(..) ) where
24
35-- aeson
@@ -5,6 +7,7 @@ import Data.Aeson ( FromJSON, ToJSON, parseJSON, toJSON )
57import Data.Aeson.Types ( parseEither )
68
79-- base
10+import Data.Kind ( Type )
811import Prelude
912
1013-- rel8
@@ -15,6 +18,7 @@ import Rel8.Type.Information ( parseTypeInformation )
1518-- | A deriving-via helper type for column types that store a Haskell value
1619-- using a JSON encoding described by @aeson@'s 'ToJSON' and 'FromJSON' type
1720-- classes.
21+type JSONEncoded :: Type -> Type
1822newtype JSONEncoded a = JSONEncoded { fromJSONEncoded :: a }
1923
2024
src/Rel8/Type/Monoid.hs+2−2
@@ -27,7 +27,7 @@ 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, nullable )
30+import Rel8.Schema.Null ( Sql )
3131import Rel8.Type ( DBType, typeInformation )
3232import Rel8.Type.Semigroup ( DBSemigroup )
3333
@@ -48,7 +48,7 @@ class DBSemigroup a => DBMonoid a where
4848
4949
5050instance Sql DBType a => DBMonoid [a] where
51− memptyExpr = sempty nullable typeInformation
51+ memptyExpr = sempty typeInformation
5252
5353
5454instance DBMonoid CalendarDiffTime where
src/Rel8/Type/Num.hs+4−1
@@ -18,6 +18,7 @@ import Prelude
1818
1919-- rel8
2020import Rel8.Type ( DBType )
21+import Rel8.Type.Ord ( DBOrd )
2122
2223-- scientific
2324import Data.Scientific ( Scientific )
@@ -39,13 +40,14 @@ instance DBNum Scientific
3940-- expressions. This is a Rel8 concept, and allows us to provide
4041-- 'fromIntegral'.
4142type DBIntegral :: Type -> Constraint
42−class DBNum a => DBIntegral a
43+class (DBNum a, DBOrd a) => DBIntegral a
4344instance DBIntegral Int16
4445instance DBIntegral Int32
4546instance DBIntegral Int64
4647
4748
4849-- | The class of database types that support the @/@ operator.
50+type DBFractional :: Type -> Constraint
4951class DBNum a => DBFractional a
5052instance DBFractional Float
5153instance DBFractional Double
@@ -53,6 +55,7 @@ instance DBFractional Scientific
5355
5456
5557-- | The class of database types that support the @/@ operator.
58+type DBFloating :: Type -> Constraint
5659class DBFractional a => DBFloating a
5760instance DBFloating Float
5861instance DBFloating Double
src/Rel8/Type/Ord.hs−2
@@ -75,7 +75,6 @@ instance Sql DBOrd a => DBOrd (NonEmpty a)
7575-- | The class of database types that support the @max@ aggregation function.
7676type DBMax :: Type -> Constraint
7777class DBOrd a => DBMax a
78−instance DBMax Bool
7978instance DBMax Char
8079instance DBMax Int16
8180instance DBMax Int32
@@ -101,7 +100,6 @@ instance Sql DBMax a => DBMax (NonEmpty a)
101100-- | The class of database types that support the @min@ aggregation function.
102101type DBMin :: Type -> Constraint
103102class DBOrd a => DBMin a
104−instance DBMin Bool
105103instance DBMin Char
106104instance DBMin Int16
107105instance DBMin Int32
src/Rel8/Type/ReadShow.hs+3
@@ -1,10 +1,12 @@
11{-# language ScopedTypeVariables #-}
2+{-# language StandaloneKindSignatures #-}
23{-# language TypeApplications #-}
34{-# language ViewPatterns #-}
45
56module Rel8.Type.ReadShow ( ReadShow(..) ) where
67
78-- base
9+import Data.Kind ( Type )
810import Data.Proxy ( Proxy( Proxy ) )
911import Data.Typeable ( Typeable, typeRep )
1012import Prelude
@@ -20,6 +22,7 @@ import qualified Data.Text as Text
2022
2123-- | A deriving-via helper type for column types that store a Haskell value
2224-- using a Haskell's 'Read' and 'Show' type classes.
25+type ReadShow :: Type -> Type
2326newtype ReadShow a = ReadShow { fromReadShow :: a }
2427
2528
src/Rel8/Type/Semigroup.hs+4−2
@@ -1,3 +1,4 @@
1+{-# language BlockArguments #-}
12{-# language DataKinds #-}
23{-# language FlexibleContexts #-}
34{-# language FlexibleInstances #-}
@@ -28,6 +29,7 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
2829
2930-- rel8
3031import {-# SOURCE #-} Rel8.Expr ( Expr )
32+import Rel8.Expr.Array ( sappend, sappend1 )
3133import Rel8.Expr.Opaleye ( zipPrimExprsWith )
3234import Rel8.Schema.Null ( Sql )
3335import Rel8.Type ( DBType )
@@ -50,11 +52,11 @@ class DBType a => DBSemigroup a where
5052
5153
5254instance Sql DBType a => DBSemigroup [a] where
53− (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
55+ (<>.) = sappend
5456
5557
5658instance Sql DBType a => DBSemigroup (NonEmpty a) where
57− (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
59+ (<>.) = sappend1
5860
5961
6062instance DBSemigroup CalendarDiffTime where
src/Rel8/Type/Tag.hs+2−1
@@ -21,7 +21,7 @@ import Prelude
2121import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
2222
2323-- rel8
24−import {-# SOURCE #-} Rel8.Expr ( Expr )
24+import Rel8.Expr ( Expr )
2525import Rel8.Expr.Eq ( (==.) )
2626import Rel8.Expr.Opaleye ( zipPrimExprsWith )
2727import Rel8.Expr.Serialize ( litExpr )
@@ -90,6 +90,7 @@ instance DBMonoid MaybeTag where
9090 memptyExpr = litExpr mempty
9191
9292
93+type Tag :: Type
9394newtype Tag = Tag Text
9495 deriving newtype
9596 ( Eq, Ord, Read, Show
src/Rel8/Window.hsnew file+97
@@ -0,0 +1,97 @@
1+{-# language DerivingVia #-}
2+{-# language FlexibleContexts #-}
3+{-# language GeneralizedNewtypeDeriving #-}
4+{-# language ScopedTypeVariables #-}
5+{-# language StandaloneKindSignatures #-}
6+{-# language TypeApplications #-}
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+323−159
@@ -1,12 +1,11 @@
1+{-# language BangPatterns #-}
12{-# language BlockArguments #-}
2−{-# language DataKinds #-}
33{-# language DeriveAnyClass #-}
44{-# language DeriveGeneric #-}
55{-# language DerivingStrategies #-}
6−{-# language DisambiguateRecordFields #-}
76{-# language FlexibleContexts #-}
87{-# language FlexibleInstances #-}
9−{-# language GADTs #-}
8+{-# language MonoLocalBinds #-}
109{-# language NamedFieldPuns #-}
1110{-# language OverloadedStrings #-}
1211{-# language RecordWildCards #-}
@@ -14,17 +13,15 @@
1413{-# language StandaloneDeriving #-}
1514{-# language TypeApplications #-}
1615
17−{-# options_ghc -fno-warn-redundant-constraints #-}
18−
1916module Main
2017 ( main
2118 )
2219where
2320
2421-- base
25−import Control.Applicative ( liftA2, liftA3 )
26−import Control.Monad (void)
27−import Control.Monad.IO.Class ( MonadIO, liftIO )
22+import Control.Applicative ( empty, liftA2, liftA3 )
23+import Control.Exception ( bracket, throwIO )
24+import Control.Monad ( (>=>), void )
2825import Data.Bifunctor ( bimap )
2926import Data.Foldable ( for_ )
3027import Data.Int ( Int32, Int64 )
@@ -38,25 +35,27 @@ import GHC.Generics ( Generic )
3835import qualified Data.ByteString.Lazy
3936
4037-- case-insensitive
41−import Data.CaseInsensitive (mk)
38+import Data.CaseInsensitive ( mk )
4239
4340-- containers
41+import Data.Containers.ListUtils ( nubOrdOn )
4442import qualified Data.Map.Strict as Map
4543
4644-- hasql
47−import Hasql.Connection ( Connection, acquire, release )
45+import Hasql.Connection ( Connection, acquire, release )
4846import Hasql.Session ( sql, run )
4947
48+-- hasql-transaction
49+import Hasql.Transaction ( Transaction, condemn, statement )
50+import qualified Hasql.Transaction.Sessions as Hasql
51+
5052-- hedgehog
5153import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )
5254import qualified Hedgehog.Gen as Gen
5355import qualified Hedgehog.Range as Range
5456
55−-- lifted-base
56−import Control.Exception.Lifted ( bracket, throwIO, bracket_ )
57−
58−-- monad-control
59−import Control.Monad.Trans.Control ( MonadBaseControl )
57+-- mmorph
58+import Control.Monad.Morph ( hoist )
6059
6160-- rel8
6261import Rel8 ( Result )
@@ -72,12 +71,16 @@ import Test.Tasty
7271import Test.Tasty.Hedgehog ( testProperty )
7372
7473-- text
75−import Data.Text (Text, pack)
74+import Data.Text ( Text, pack, unpack )
7675import qualified Data.Text.Lazy
76+import Data.Text.Encoding ( decodeUtf8 )
7777
7878-- time
7979import Data.Time
8080
81+-- transformers
82+import Control.Monad.Trans.Class ( lift )
83+
8184-- tmp-postgres
8285import qualified Database.Postgres.Temp as TmpPostgres
8386
@@ -113,14 +116,17 @@ tests =
113116 , testCatMaybeTable getTestDatabase
114117 , testCatMaybe getTestDatabase
115118 , testMaybeTable getTestDatabase
119+ , testAggregateMaybeTable getTestDatabase
116120 , testNestedTables getTestDatabase
117121 , testMaybeTableApplicative getTestDatabase
118122 , testLogicalFixities getTestDatabase
119123 , testUpdate getTestDatabase
120124 , testDelete getTestDatabase
125+ , testUpsert getTestDatabase
121126 , testSelectNestedPairs getTestDatabase
122127 , testSelectArray getTestDatabase
123128 , testNestedMaybeTable getTestDatabase
129+ , testEvaluate getTestDatabase
124130 ]
125131
126132 where
@@ -132,25 +138,29 @@ tests =
132138 flip run conn do
133139 sql "CREATE EXTENSION citext"
134140 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"
135143
136144 return db
137145
138146 stopTestDatabase = TmpPostgres.stop
139147
140148
149+connect :: TmpPostgres.DB -> IO Connection
150+connect = acquire . TmpPostgres.toConnectionString >=> either (maybe empty (fail . unpack . decodeUtf8)) pure
151+
152+
141153databasePropertyTest
142154 :: TestName
143− -> (((Connection -> TestT IO ()) -> PropertyT IO ()) -> PropertyT IO ())
155+ -> ((TestT Transaction () -> PropertyT IO ()) -> PropertyT IO ())
144156 -> IO TmpPostgres.DB -> TestTree
145157databasePropertyTest testName f getTestDatabase =
146− withResource connect release $ \c ->
158+ withResource (connect =<< getTestDatabase) release $ \c ->
147159 testProperty testName $ property do
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
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
154164
155165
156166data TestTable f = TestTable
@@ -182,18 +192,17 @@ testSelectTestTable :: IO TmpPostgres.DB -> TestTree
182192testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do
183193 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
184194
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− }
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+ }
194203
195− selected <- liftIO $ Rel8.select connection do
196− Rel8.each testTableSchema
204+ statement () $ Rel8.select do
205+ Rel8.each testTableSchema
197206
198207 sort selected === sort rows
199208
@@ -210,11 +219,12 @@ testWhere_ = databasePropertyTest "WHERE (Rel8.where_)" \transaction -> do
210219
211220 let expected = filter (\t -> testTableColumn2 t == magicBool) rows
212221
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
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
218228
219229 sort selected === sort expected
220230
@@ -227,11 +237,12 @@ testFilter :: IO TmpPostgres.DB -> TestTree
227237testFilter = databasePropertyTest "filter" \transaction -> do
228238 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable
229239
230− transaction \connection -> do
240+ transaction do
231241 let expected = filter testTableColumn2 rows
232242
233− selected <- liftIO $ Rel8.select connection
234− $ Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)
243+ selected <- lift do
244+ statement () $ Rel8.select do
245+ Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)
235246
236247 sort selected === sort expected
237248
@@ -246,9 +257,10 @@ testLimit = databasePropertyTest "LIMIT (Rel8.limit)" \transaction -> do
246257
247258 n <- forAll $ Gen.integral (Range.linear 0 10)
248259
249− transaction \connection -> do
250− selected <- liftIO $ Rel8.select connection do
251− Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)
260+ transaction do
261+ selected <- lift do
262+ statement () $ Rel8.select do
263+ Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)
252264
253265 diff (length selected) (<=) (fromIntegral n)
254266
@@ -266,9 +278,10 @@ testUnion = databasePropertyTest "UNION (Rel8.union)" \transaction -> evalM do
266278 left <- forAll $ Gen.list (Range.linear 0 10) genTestTable
267279 right <- forAll $ Gen.list (Range.linear 0 10) genTestTable
268280
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)
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)
272285
273286 sort selected === sort (nub (left ++ right))
274287
@@ -277,9 +290,11 @@ testDistinct :: IO TmpPostgres.DB -> TestTree
277290testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do
278291 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
279292
280− transaction \connection -> do
281− selected <- liftIO $ Rel8.select connection $ Rel8.distinct do
282− Rel8.values (Rel8.lit <$> rows)
293+ transaction do
294+ selected <- lift do
295+ statement () $ Rel8.select do
296+ Rel8.distinct do
297+ Rel8.values (Rel8.lit <$> rows)
283298
284299 sort selected === nub (sort rows)
285300
@@ -292,8 +307,10 @@ testExists :: IO TmpPostgres.DB -> TestTree
292307testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do
293308 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
294309
295− transaction \connection -> do
296− exists <- liftIO $ Rel8.select connection $ Rel8.exists $ Rel8.values $ Rel8.lit <$> rows
310+ transaction do
311+ exists <- lift do
312+ statement () $ Rel8.select do
313+ Rel8.exists $ Rel8.values $ Rel8.lit <$> rows
297314
298315 case rows of
299316 [] -> exists === [False]
@@ -304,9 +321,10 @@ testOptional :: IO TmpPostgres.DB -> TestTree
304321testOptional = databasePropertyTest "Rel8.optional" \transaction -> do
305322 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
306323
307− transaction \connection -> do
308− selected <- liftIO $ Rel8.select connection do
309− Rel8.optional $ Rel8.values (Rel8.lit <$> rows)
324+ transaction do
325+ selected <- lift do
326+ statement () $ Rel8.select do
327+ Rel8.optional $ Rel8.values (Rel8.lit <$> rows)
310328
311329 case rows of
312330 [] -> selected === [Nothing]
@@ -317,9 +335,10 @@ testAnd :: IO TmpPostgres.DB -> TestTree
317335testAnd = databasePropertyTest "AND (&&.)" \transaction -> do
318336 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
319337
320− transaction \connection -> do
321− [result] <- liftIO $ Rel8.select connection $ pure $
322− Rel8.lit x Rel8.&&. Rel8.lit y
338+ transaction do
339+ [result] <- lift do
340+ statement () $ Rel8.select do
341+ pure $ Rel8.lit x Rel8.&&. Rel8.lit y
323342
324343 result === (x && y)
325344
@@ -328,9 +347,10 @@ testOr :: IO TmpPostgres.DB -> TestTree
328347testOr = databasePropertyTest "OR (||.)" \transaction -> do
329348 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
330349
331− transaction \connection -> do
332− [result] <- liftIO $ Rel8.select connection $ pure $
333− Rel8.lit x Rel8.||. Rel8.lit y
350+ transaction do
351+ [result] <- lift do
352+ statement () $ Rel8.select $ pure $
353+ Rel8.lit x Rel8.||. Rel8.lit y
334354
335355 result === (x || y)
336356
@@ -339,9 +359,10 @@ testLogicalFixities :: IO TmpPostgres.DB -> TestTree
339359testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do
340360 (u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool
341361
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
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
345366
346367 result === (u || v && w == x)
347368
@@ -350,9 +371,10 @@ testNot :: IO TmpPostgres.DB -> TestTree
350371testNot = databasePropertyTest "NOT (not_)" \transaction -> do
351372 x <- forAll Gen.bool
352373
353− transaction \connection -> do
354− [result] <- liftIO $ Rel8.select connection $ pure $
355− Rel8.not_ $ Rel8.lit x
374+ transaction do
375+ [result] <- lift do
376+ statement () $ Rel8.select do
377+ pure $ Rel8.not_ $ Rel8.lit x
356378
357379 result === not x
358380
@@ -361,9 +383,10 @@ testBool :: IO TmpPostgres.DB -> TestTree
361383testBool = databasePropertyTest "ifThenElse_" \transaction -> do
362384 (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool
363385
364− transaction \connection -> do
365− [result] <- liftIO $ Rel8.select connection $ pure $
366− Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)
386+ transaction do
387+ [result] <- lift do
388+ statement () $ Rel8.select do
389+ pure $ Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)
367390
368391 result === if x then y else z
369392
@@ -375,9 +398,10 @@ testAp = databasePropertyTest "Cartesian product (<*>)" \transaction -> do
375398 (Gen.list (Range.linear 1 10) genTestTable)
376399 (Gen.list (Range.linear 1 10) genTestTable)
377400
378− transaction \connection -> do
379− result <- liftIO $ Rel8.select connection $ do
380− liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))
401+ transaction do
402+ result <- lift do
403+ statement () $ Rel8.select do
404+ liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))
381405
382406 sort result === sort (liftA2 (,) rows1 rows2)
383407
@@ -406,21 +430,22 @@ testDBType getTestDatabase = testGroup "DBType instances"
406430 where
407431 dbTypeTest :: (Eq a, Show a, Rel8.DBType a) => TestName -> Gen a -> TestTree
408432 dbTypeTest name generator = testGroup name
409− [ databasePropertyTest name (t (==) generator) getTestDatabase
410− , databasePropertyTest ("Maybe " <> name) (t (==) (Gen.maybe generator)) getTestDatabase
433+ [ databasePropertyTest name (t generator) getTestDatabase
434+ , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase
411435 ]
412436
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)
437+ t :: forall a b. (Eq a, Show a, Rel8.Sql Rel8.DBType a)
438+ => Gen a
439+ -> (TestT Transaction () -> PropertyT IO b)
417440 -> PropertyT IO b
418− t eq generator transaction = do
441+ t generator transaction = do
419442 x <- forAll generator
420443
421− transaction \connection -> do
422− [res] <- liftIO $ Rel8.select connection $ pure (Rel8.litExpr x)
423− diff res eq x
444+ transaction do
445+ [res] <- lift do
446+ statement () $ Rel8.select do
447+ pure (Rel8.litExpr x)
448+ diff res (==) x
424449
425450 genDay :: Gen Day
426451 genDay = do
@@ -462,39 +487,38 @@ testDBEq getTestDatabase = testGroup "DBEq instances"
462487
463488 t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBEq a)
464489 => Gen a
465− -> ((Connection -> TestT IO ()) -> PropertyT IO ())
490+ -> (TestT Transaction () -> PropertyT IO ())
466491 -> PropertyT IO ()
467492 t generator transaction = do
468493 (x, y) <- forAll (liftA2 (,) generator generator)
469494
470− transaction \connection -> do
471− [res] <- liftIO $ Rel8.select connection $ pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y
495+ transaction do
496+ [res] <- lift do
497+ statement () $ Rel8.select do
498+ pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y
472499 res === (x == y)
473500
474− cover 1 "Equal" $ x == y
475− cover 1 "Not Equal" $ x /= y
476−
477501
478502testTableEquality :: IO TmpPostgres.DB -> TestTree
479503testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do
480504 (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable
481505
482− transaction \connection -> do
483− [eq] <- liftIO $ Rel8.select connection do
484− pure $ Rel8.lit x Rel8.==: Rel8.lit y
506+ transaction do
507+ [eq] <- lift do
508+ statement () $ Rel8.select do
509+ pure $ Rel8.lit x Rel8.==: Rel8.lit y
485510
486511 eq === (x == y)
487512
488− cover 1 "Equal" $ x == y
489− cover 1 "Not Equal" $ x /= y
490−
491513
492514testFromString :: IO TmpPostgres.DB -> TestTree
493515testFromString = databasePropertyTest "FromString" \transaction -> do
494516 str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode
495517
496− transaction \connection -> do
497− [result] <- liftIO $ Rel8.select connection $ pure $ fromString str
518+ transaction do
519+ [result] <- lift do
520+ statement () $ Rel8.select do
521+ pure $ fromString str
498522 result === pack str
499523
500524
@@ -502,10 +526,11 @@ testCatMaybeTable :: IO TmpPostgres.DB -> TestTree
502526testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do
503527 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
504528
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)
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)
509534
510535 sort selected === sort (filter testTableColumn2 rows)
511536
@@ -514,9 +539,10 @@ testCatMaybe :: IO TmpPostgres.DB -> TestTree
514539testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do
515540 rows <- forAll $ Gen.list (Range.linear 0 10) $ Gen.maybe Gen.bool
516541
517− transaction \connection -> do
518− selected <- evalM $ liftIO $ Rel8.select connection do
519− Rel8.catNull =<< Rel8.values (map Rel8.lit rows)
542+ transaction do
543+ selected <- lift do
544+ statement () $ Rel8.select do
545+ Rel8.catNull =<< Rel8.values (map Rel8.lit rows)
520546
521547 sort selected === sort (catMaybes rows)
522548
@@ -525,21 +551,44 @@ testMaybeTable :: IO TmpPostgres.DB -> TestTree
525551testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do
526552 (rows, def) <- forAll $ liftA2 (,) (Gen.list (Range.linear 0 10) genTestTable) genTestTable
527553
528− transaction \connection -> do
529− selected <- liftIO $ Rel8.select connection $
530− Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))
554+ transaction do
555+ selected <- lift do
556+ statement () $ Rel8.select do
557+ Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))
531558
532559 case rows of
533560 [] -> selected === [def]
534561 _ -> sort selected === sort rows
535562
536563
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+
537586data TwoTestTables f =
538587 TwoTestTables
539588 { testTable1 :: TestTable f
540589 , testTable2 :: TestTable f
541590 }
542− deriving stock Generic
591+ deriving stock Generic
543592 deriving anyclass Rel8.Rel8able
544593
545594
@@ -554,9 +603,10 @@ testNestedTables = databasePropertyTest "Nested TestTables" \transaction -> eval
554603 Gen.list (Range.linear 0 10) $
555604 liftA2 TwoTestTables genTestTable genTestTable
556605
557− transaction \connection -> do
558− selected <- liftIO $ Rel8.select connection do
559− Rel8.values (Rel8.lit <$> rows)
606+ transaction do
607+ selected <- lift do
608+ statement () $ Rel8.select do
609+ Rel8.values (Rel8.lit <$> rows)
560610
561611 sort selected === sort rows
562612
@@ -566,11 +616,12 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction
566616 rows1 <- genRows
567617 rows2 <- genRows
568618
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
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
574625
575626 case (rows1, rows2) of
576627 ([], []) -> selected === [Nothing]
@@ -582,14 +633,6 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction
582633 genRows = forAll do
583634 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)
584635
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−
593636
594637genTestTable :: Gen (TestTable Result)
595638genTestTable = do
@@ -602,19 +645,19 @@ testUpdate :: IO TmpPostgres.DB -> TestTree
602645testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do
603646 rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable
604647
605− transaction \connection -> do
606− void $ liftIO $ Rel8.insert connection
607− Rel8.Insert
648+ transaction do
649+ selected <- lift do
650+ statement () $ Rel8.insert Rel8.Insert
608651 { into = testTableSchema
609− , rows = map (Rel8.toInsert . Rel8.lit) $ Map.keys rows
652+ , rows = Rel8.values $ map Rel8.lit $ Map.keys rows
610653 , onConflict = Rel8.DoNothing
611− , returning = Rel8.NumberOfRowsAffected
654+ , returning = pure ()
612655 }
613656
614− void $ liftIO $ Rel8.update connection
615− Rel8.Update
657+ statement () $ Rel8.update Rel8.Update
616658 { target = testTableSchema
617− , set = \r ->
659+ , from = pure ()
660+ , set = \_ r ->
618661 let updates = map (bimap Rel8.lit Rel8.lit) $ Map.toList rows
619662 in
620663 foldl
@@ -628,12 +671,12 @@ testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do
628671 )
629672 r
630673 updates
631− , updateWhere = \_ -> Rel8.lit True
632− , returning = Rel8.NumberOfRowsAffected
674+ , updateWhere = \_ _ -> Rel8.lit True
675+ , returning = pure ()
633676 }
634677
635− selected <- liftIO $ Rel8.select connection do
636− Rel8.each testTableSchema
678+ statement () $ Rel8.select do
679+ Rel8.each testTableSchema
637680
638681 sort selected === sort (Map.elems rows)
639682
@@ -646,29 +689,96 @@ testDelete :: IO TmpPostgres.DB -> TestTree
646689testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do
647690 rows <- forAll $ Gen.list (Range.linear 0 5) genTestTable
648691
649− transaction \connection -> do
650− void $ liftIO $ Rel8.insert connection
651− Rel8.Insert
692+ transaction do
693+ (deleted, selected) <- lift do
694+ statement () $ Rel8.insert Rel8.Insert
652695 { into = testTableSchema
653− , rows = map (Rel8.toInsert . Rel8.lit) rows
696+ , rows = Rel8.values $ map Rel8.lit rows
654697 , onConflict = Rel8.DoNothing
655− , returning = Rel8.NumberOfRowsAffected
698+ , returning = pure ()
656699 }
657700
658− deleted <-
659− liftIO $ Rel8.delete connection
660− Rel8.Delete
701+ deleted <- statement () $ Rel8.delete Rel8.Delete
661702 { from = testTableSchema
662− , deleteWhere = testTableColumn2
703+ , using = pure ()
704+ , deleteWhere = const testTableColumn2
663705 , returning = Rel8.Projection id
664706 }
665707
666− selected <- liftIO $ Rel8.select connection do
667− Rel8.each testTableSchema
708+ selected <- statement () $ Rel8.select do
709+ Rel8.each testTableSchema
710+
711+ pure (deleted, selected)
668712
669713 sort (deleted <> selected) === sort rows
670714
671715
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+
672782newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }
673783 deriving stock Generic
674784 deriving anyclass Rel8.Rel8able
@@ -682,9 +792,10 @@ testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree
682792testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do
683793 rows <- forAll $ Gen.list (Range.linear 0 10) $ HKNestedPair <$> liftA2 (,) genTestTable genTestTable
684794
685− transaction \connection -> do
686− selected <- liftIO $ Rel8.select connection do
687− Rel8.values $ map Rel8.lit rows
795+ transaction do
796+ selected <- lift do
797+ statement () $ Rel8.select do
798+ Rel8.values $ map Rel8.lit rows
688799
689800 sort selected === sort rows
690801
@@ -693,12 +804,23 @@ testSelectArray :: IO TmpPostgres.DB -> TestTree
693804testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do
694805 rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool
695806
696− transaction \connection -> do
697− selected <- liftIO $ Rel8.select connection $ Rel8.aggregate do
698− Rel8.listAgg <$> Rel8.values (map Rel8.lit rows)
807+ transaction do
808+ selected <- lift do
809+ statement () $ Rel8.select do
810+ Rel8.many $ Rel8.values (map Rel8.lit rows)
699811
700812 selected === [foldMap pure rows]
701813
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+
702824
703825data NestedMaybeTable f = NestedMaybeTable
704826 { nmt1 :: Rel8.Column f Bool
@@ -717,9 +839,51 @@ testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree
717839testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do
718840 let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) }
719841
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)
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)
724847
725848 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
src/Rel8/Generic/Rel8able/Test.hs → tests/Rel8/Generic/Rel8able/Test.hsrenamed+49−18
@@ -1,11 +1,11 @@
11{-# language DataKinds #-}
22{-# language DeriveAnyClass #-}
33{-# language DeriveGeneric #-}
4−{-# language DerivingVia #-}
4+{-# language DerivingStrategies #-}
55{-# language DuplicateRecordFields #-}
66{-# language FlexibleInstances #-}
77{-# language MultiParamTypeClasses #-}
8−{-# language StandaloneDeriving #-}
8+{-# language StandaloneKindSignatures #-}
99{-# language TypeFamilies #-}
1010{-# language UndecidableInstances #-}
1111
@@ -36,7 +36,7 @@ data TableTest f = TableTest
3636
3737
3838data TablePair f = TablePair
39− { foo :: Default f Bool
39+ { foo :: Column f Bool
4040 , bars :: (Column f Text, Column f Text)
4141 }
4242 deriving stock Generic
@@ -98,30 +98,20 @@ data S3Object = S3Object
9898 deriving stock Generic
9999
100100
101−deriving via HKDT S3Object
102− instance Table Result S3Object
103−
101+instance x ~ HKD S3Object Expr => ToExprs x S3Object
104102
105−deriving via HKDT S3Object
106− instance x ~ HKD S3Object Expr => ToExprs x S3Object
107103
108−
109−data HKDSum = HKDSumA Text | HKDSumB Bool Char
104+data HKDSum = HKDSumA Text | HKDSumB Bool Char | HKDSumC
110105 deriving stock Generic
111106
112107
113−deriving via HKDT HKDSum
114− instance Table Result HKDSum
115−
116−
117−deriving via HKDT HKDSum
118− instance x ~ HKD HKDSum Expr => ToExprs x HKDSum
108+instance x ~ HKD HKDSum Expr => ToExprs x HKDSum
119109
120110
121111data HKDTest f = HKDTest
122112 { s3Object :: Lift f S3Object
123113 , hkdSum :: Lift f HKDSum
124− }
114+ }
125115 deriving stock Generic
126116 deriving anyclass Rel8able
127117
@@ -148,10 +138,51 @@ data TableSum f
148138 deriving stock Generic
149139
150140
141+data BarbieSum f
142+ = BarbieSumA (f Bool) (f Text)
143+ | BarbieSumB
144+ | BarbieSumC (f Text)
145+ deriving stock Generic
146+
147+
151148data TableProduct f = TableProduct
152− { sum :: HADT f TableSum
149+ { sum :: HADT f BarbieSum
153150 , list :: TableList f
154151 , foos :: HList f (HADT f TableSum, Lift f HKDSum, HKDTest f)
155152 }
156153 deriving stock Generic
157154 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