git.iko.soy/rel8
on master help sign in
swap
6c038ec77 ahead, 0 behind
131 files changed+4795−4722
since splitsnapshots
unifiedsplit
.github/workflows/build.yaml+3−3 Changelog.md+128−1 README.md+4 cabal.project−5 cabal.project.haskell-nix−6 default.nix+2−2 docs/concepts/insert.rst+37−10 docs/cookbook.rst+9−7 nix/sources.json+9−9 nix/sources.nix+21−1 rel8.cabal+33−15 shell.nix+1−1 src/Rel8.hs+298−15 src/Rel8/Aggregate.hs+37−105 src/Rel8/Column.hs+5−91 src/Rel8/Column/ADT.hs+4−87 src/Rel8/Column/Either.hs+4−170 src/Rel8/Column/Lift.hs+4−85 src/Rel8/Column/List.hs+5−152 src/Rel8/Column/Maybe.hs+4−123 src/Rel8/Column/NonEmpty.hs+5−152 src/Rel8/Column/Null.hs+26 src/Rel8/Column/These.hs+4−171 src/Rel8/Expr.hs+16−43 src/Rel8/Expr.hs-boot+6−8 src/Rel8/Expr/Aggregate.hs+25−64 src/Rel8/Expr/Eq.hs+1−1 src/Rel8/Expr/Num.hs+39−6 src/Rel8/Expr/Opaleye.hs+12−3 src/Rel8/Expr/Sequence.hs+2−1 src/Rel8/Expr/Text.hs+23−2 src/Rel8/Expr/Window.hs+121 src/Rel8/FCF.hs+3−3 src/Rel8/Generic/Coherence.hs−79 src/Rel8/Generic/Construction.hs+145−163 src/Rel8/Generic/Construction/ADT.hs+20−27 src/Rel8/Generic/Construction/Record.hs+3−3 src/Rel8/Generic/Map.hs+20−64 src/Rel8/Generic/Record.hs+2 src/Rel8/Generic/Reify.hs−24 src/Rel8/Generic/Rel8able.hs+178−71 src/Rel8/Generic/Table.hs+22−107 src/Rel8/Generic/Table/ADT.hs+58−197 src/Rel8/Generic/Table/Record.hs+74−93 src/Rel8/Kind/Context.hs+8−21 src/Rel8/Order.hs+1−8 src/Rel8/Query.hs+28−9 src/Rel8/Query/Aggregate.hs+19 src/Rel8/Query/Distinct.hs+4−9 src/Rel8/Query/Each.hs+3−3 src/Rel8/Query/Evaluate.hs+3−22 src/Rel8/Query/Exists.hs+1−1 src/Rel8/Query/Indexed.hs+21 src/Rel8/Query/List.hs+15−12 src/Rel8/Query/Maybe.hs+9−7 src/Rel8/Query/Null.hs+15 src/Rel8/Query/Opaleye.hs+18−10 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+14−14 src/Rel8/Query/Window.hs+26 src/Rel8/Schema/Context.hs−20 src/Rel8/Schema/Context/Abstract.hs−80 src/Rel8/Schema/Context/Nullify.hs+38−59 src/Rel8/Schema/Field.hs+50 src/Rel8/Schema/HTable.hs+51−24 src/Rel8/Schema/HTable/Either.hs+2−2 src/Rel8/Schema/HTable/Identity.hs+16−28 src/Rel8/Schema/HTable/Label.hs+15−4 src/Rel8/Schema/HTable/MapTable.hs+22−12 src/Rel8/Schema/HTable/Maybe.hs+2−2 src/Rel8/Schema/HTable/Nullify.hs+22−24 src/Rel8/Schema/HTable/These.hs+3−3 src/Rel8/Schema/HTable/Vectorize.hs+39−40 src/Rel8/Schema/Kind.hs+6−15 src/Rel8/Schema/Name.hs+33−52 src/Rel8/Schema/Reify.hs−68 src/Rel8/Schema/Result.hs+16−52 src/Rel8/Schema/Spec.hs+16−30 src/Rel8/Schema/Spec/Constrain.hs−32 src/Rel8/Schema/Table.hs+20 src/Rel8/Statement/Delete.hs+35−48 src/Rel8/Statement/Insert.hs+43−72 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−56 src/Rel8/Statement/Using.hs+36 src/Rel8/Statement/View.hs+43−28 src/Rel8/Statement/Where.hs+31 src/Rel8/Table.hs+83−313 src/Rel8/Table/ADT.hs+33−65 src/Rel8/Table/Aggregate.hs+20−10 src/Rel8/Table/Bool.hs+5−6 src/Rel8/Table/Cols.hs+50 src/Rel8/Table/Either.hs+58−66 src/Rel8/Table/Eq.hs+12−39 src/Rel8/Table/HKD.hs+65−107 src/Rel8/Table/List.hs+43−55 src/Rel8/Table/Maybe.hs+48−49 src/Rel8/Table/Name.hs+11−20 src/Rel8/Table/NonEmpty.hs+42−52 src/Rel8/Table/Null.hs+147 src/Rel8/Table/Nullify.hs+57−50 src/Rel8/Table/Opaleye.hs+78−64 src/Rel8/Table/Ord.hs+16−45 src/Rel8/Table/Order.hs+5−6 src/Rel8/Table/Projection.hs+73 src/Rel8/Table/Recontextualize.hs−143 src/Rel8/Table/Rel8able.hs+28−85 src/Rel8/Table/Serialize.hs+22−122 src/Rel8/Table/These.hs+71−49 src/Rel8/Table/Transpose.hs+46 src/Rel8/Table/Undefined.hs+5−5 src/Rel8/Table/Window.hs+43 src/Rel8/Tabulate.hs+640 src/Rel8/Type.hs+9−8 src/Rel8/Type/Composite.hs+20−19 src/Rel8/Type/Enum.hs+1 src/Rel8/Type/JSONBEncoded.hs+4 src/Rel8/Type/JSONEncoded.hs+4 src/Rel8/Type/Num.hs+4−1 src/Rel8/Type/Ord.hs−2 src/Rel8/Type/ReadShow.hs+3 src/Rel8/Type/Tag.hs+2−1 src/Rel8/Window.hs+97 tests/Main.hs+288−178 tests/Rel8/Generic/Rel8able/Test.hs+46−15
.github/workflows/build.yaml+3−3
@@ -9,14 +9,14 @@ jobs:
99 persist-credentials: false
1010 submodules: true
1111
12− - uses: cachix/install-nix-action@v12
12+ - uses: cachix/install-nix-action@v14.1
1313 with:
1414 nix_path: nixpkgs=channel:nixos-unstable
1515 extra_nix_config: |
1616 trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ=
17− substituters = https://cache.nixos.org/ https://hydra.iohk.io
17+ substituters = https://cache.nixos.org/ https://cache.iog.io
1818
19− - uses: cachix/cachix-action@v8
19+ - uses: cachix/cachix-action@v10
2020 with:
2121 name: rel8
2222 authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}'
Changelog.md+128−1
@@ -1,13 +1,140 @@
1−# 1.1.0.0 (??)
1+# 1.4.0.0 (2002-08-17)
22
33## Breaking changes
44
5+* The behavior of `greatest`/`least` has been corrected, and was previously flipped. ([#183](https://github.com/circuithub/rel8/pull/183))
6+
7+## New features
8+
9+* `NullTable`/`HNull` have been added. This is an alternative to `MaybeTable` that doesn't use a tag columns. It's less flexible (no `Functor` or `Applicative` instance) and is meaningless when used with a table that has no non-nullable columns (so nesting `NullTable` is redundant). But in situations where the underlying `Table` does have non-nullable columns, it can losslessly converted to and from `MaybeTable`. It is useful for embedding into a base table when you don't want to store the extra tag column in your schema. ([#173](https://github.com/circuithub/rel8/pull/173))
10+* Add `fromMaybeTable`. ([#179](https://github.com/circuithub/rel8/pull/179))
11+* Add `alignMaybeTable`. ([#196](https://github.com/circuithub/rel8/pull/196))
12+
13+## Improvements
14+
15+* Optimize implementation of `AltTable` for `Tabulation` ([#178](https://github.com/circuithub/rel8/pull/178))
16+
17+## Other
18+
19+* Documentation improvements for `HADT`. ([#177](https://github.com/circuithub/rel8/pull/177))
20+* Document example usage of `groupBy`. ([#184](https://github.com/circuithub/rel8/pull/184))
21+* Build with and require Opaleye >= 0.9.3.3. ([#190](https://github.com/circuithub/rel8/pull/190))
22+* Build with `hasql` 1.6. ([#195](https://github.com/circuithub/rel8/pull/195))
23+
24+# 1.3.1.0 (2022-01-20)
25+
26+## Other
27+
28+* Rel8 now requires Opaleye >= 0.9.1. ([#165](https://github.com/circuithub/rel8/pull/165))
29+
30+# 1.3.0.0 (2022-01-31)
31+
32+## Breaking changes
33+
34+* `div` and `mod` have been changed to match Haskell semantics. If you need the PostgreSQL `div()` and `mod()` functions, use `quot` and `rem`. While this is not an API change, we feel this is a breaking change in semantics and have bumped the major version number. ([#155](https://github.com/circuithub/rel8/pull/155))
35+
36+## New features
37+
38+* `divMod` and `quotRem` functions have been added, matching Haskell's `Prelude` functions. ([#155](https://github.com/circuithub/rel8/pull/155))
39+* `avg` and `mode` aggregation functions to find the mean value of an expression, or the most common row in a query, respectively. ([#152](https://github.com/circuithub/rel8/pull/152))
40+* The full `EqTable` and `OrdTable` classes have been exported, allowing for instances to be manually created. ([#157](https://github.com/circuithub/rel8/pull/157))
41+* Added `like` and `ilike` (for the `LIKE` and `ILIKE` operators). ([#146](https://github.com/circuithub/rel8/pull/146))
42+
43+## Other
44+
45+* Rel8 now requires Opaleye 0.9. ([#158](https://github.com/circuithub/rel8/pull/158))
46+* Rel8's test suite supports Hedgehog 1.1. ([#160](https://github.com/circuithub/rel8/pull/160))
47+* The documentation for binary operations has been corrected. ([#162](https://github.com/circuithub/rel8/pull/162))
48+
49+# 1.2.2.0 (2021-11-21)
50+
51+## Other
52+
53+* Support GHC 9.2 ([#145](https://github.com/circuithub/rel8/pull/145))
54+* Correct the documentation for `except` ([#147](https://github.com/circuithub/rel8/pull/147))
55+* Support `hasql` 1.5 ([#149](https://github.com/circuithub/rel8/pull/149))
56+
57+# 1.2.1.0 (2021-11-21)
58+
59+## New features
60+
61+* `castTable` has been added, which casts all columns selected from in `Query` according to the types of columns. This can occasionally be useful when using `many`/`some` on older PostgreSQL versions. ([#137](https://github.com/circuithub/rel8/pull/137))
62+
63+* Added `<:`, `<=:`, `>:`, `>=:`, `greatest` and `least`, which sort all columns in a table lexicographically. These operators are like the `<.` operators which operate on `Expr`s, but the `<:` operate on entire tables. ([#139](https://github.com/circuithub/rel8/pull/139))
64+
65+## Other
66+
67+* Support opaleye-0.8 ([#142](https://github.com/circuithub/rel8/pull/142))
68+
69+# 1.2.0.0 (2021-10-22)
70+
71+## New features
72+
73+* New `$*` and `$+` operators for projecting out of `ListTable` and `NonEmptyTable` respectively (analogous to the existing `$?` for `MaybeTable`). ([#125](https://github.com/circuithub/rel8/pull/125))
74+
75+## Bug fixes
76+
77+* Fix `UPSERT` support (and add tests), which was broken due to a typo inside Rel8 that made it impossible to construct `Projection`s which are needed by `UPSERT`. ([#134](https://github.com/circuithub/rel8/pull/134))
78+
79+* Remove `DBMin` and `DBMax` instances for `Bool`, which are invalid as far as Postgres is concerned. `and` and `or` can be used to achieve the same thing. ([#126](https://github.com/circuithub/rel8/pull/126))
80+
81+* Fix `aggregateMaybeTable`, `aggregateEitherTable` and `aggregateTheseTable`, which generated invalid SQL previously. ([#127](https://github.com/circuithub/rel8/pull/127))
82+
83+## Breaking changes
84+
85+* `rebind` now takes an additional argument for the "name" of the binding. ([#128](https://github.com/circuithub/rel8/pull/128))
86+
87+# 1.1.0.0 (2021-07-16)
88+
89+## New features
90+
91+* You can derive `Rel8able` for "vanilla" higher-kinded data types - data types that don't use the `Column` type family. For example, the following is now possible:
92+
93+ ```haskell
94+ data MyTable f = MyTable
95+ { myTableX :: f Int32
96+ , myTableY :: f Text
97+ } deriving (Generic, Rel8able)
98+ ```
99+
100+* The `Projectable` and `Biprojectable` type classes have been introduced. These classes model a type of functors and bifunctors (respectively) on tables, where the mapping function is only able to rearrange columns. For example, the following is now possible:
101+
102+ ```haskell
103+ x <- project myTableX <$> many ...
104+ ```
105+
106+* `Insert`'s `onConflict` field now has a new option - `DoUpdate`. This maps to PostgreSQL's `ON CONFLICT DO UPDATE` syntax, which provides upsert support. ([#85](https://github.com/circuithub/rel8/pull/85))
107+
108+* `Insert`, `Update` and `Delete` has all been expanded to work with `Query`s. In particular:
109+
110+ * `Delete` now supports a `USING` sub-query
111+ * `Update` now supports a `FROM` sub-query
112+ * `Insert` can delete the result of any arbitrary `Query` (providing the types match)
113+
114+* The new `Rel8.Tabulate` module has been added, which gives a `Map`-esque interface to writing and composing queries. ([#70](https://github.com/circuithub/rel8/pull/70))
115+
116+* The new `indexed` `Query -> Query` function was added. This function augments each row in a query with it's 0-based index. ([#117](https://github.com/circuithub/rel8/pull/117))
117+
118+## Breaking changes
119+
120+* `Insert`, `Delete` and `Update` have all changed. In particular, for `Insert` users should now replace `rows = xs` with `rows = values xs`. ([#85](https://github.com/circuithub/rel8/pull/85))
121+
5122* Rename `whereExists` and `whereNotExists` to `present` and `absent` respectively. ([#57](https://github.com/circuithub/rel8/pull/57))
6123
7124* Simplify `evaluate` to run directly inside the `Query` monad, rendering the `Evaluate` monad unnecessary. ([#56](https://github.com/circuithub/rel8/pull/56))
8125
9126* The `Labelable` type class has been removed as it's no longer necessary. This class was mostly internal, though was visible in some public API functions. ([#76](https://github.com/circuithub/rel8/pull/76))
10127
128+* `EitherTable`, `ListTable`, `MaybeTable`, `NonEmptyTable` and `TheseTable` now all have an extra parameter which tracks the context of the table. If you manually specified any types before, you need to provide this parameter - usually `Expr` will be the correct choice. ([#101](https://github.com/circuithub/rel8/pull/101))
129+
130+* We've done a lot of work to simplify the internals of Rel8, but some of these are breaking changes. However, most of these API changes shouldn't affect users as they are mostly types used in type inference, or affect classes where users don't need to define their own instances.
131+
132+ * The kind of a `Rel8able` is now `(Type -> Type) -> Type`. Previously it was `(X -> Type) -> Type`.
133+ * `Table` has a new associated type - `FromExprs`. This was previously an open type family.
134+ * `Table` has a new associated type - `Transpose` - and `Recontextualise` has been renamed to `Transposes`. This `Transposes` class now operates in terms of `Transpose`.
135+
136+* `select`, `insert`, `update` and `delete` now produce Hasql `Statement`s, rather than actually running the statement as IO. This allows Rel8 to be used with transaction/connection-managing monads like [`hasql-transaction`](https://hackage.haskell.org/package/hasql-transaction). ([#94](https://github.com/circuithub/rel8/pull/94))
137+
11138## Bug fixes
12139
13140* Fixes a bug where cartesian products of queries using `catListTable`, `catNonEmptyTable`, `catList` and `catNonEmpty` would incorrectly be zipped instead. ([#61](https://github.com/circuithub/rel8/pull/61))
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+2−2
@@ -1,11 +1,11 @@
11let
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 = "ghc901";
8+ compiler-nix-name = "ghc924";
99
1010 pkgs = import nixpkgsSrc nixpkgsArgs;
1111
docs/concepts/insert.rst+37−10
@@ -21,9 +21,16 @@ using ``delete``. ``Delete`` takes:
2121``from``
2222 The ``TableSchema`` for the table to delete rows from.
2323
24+``using``
25+ This is a simple ``Query`` that forms the ``USING`` clause of the ``DELETE``
26+ statement. This can be used to join against other tables, and the results
27+ can be referenced in the ``deleteWhere`` parameter. For simple ``DELETE``\s
28+ where you don't need to do this, you can set ``using = pure ()``.
29+
2430``deleteWhere``
2531 The ``WHERE`` clause of the ``DELETE`` statement. This is a function that
26− takes a single ``Expr`` table as input.
32+ takes two inputs: the result of the ``using`` query, and the current value
33+ of the row.
2734
2835``returning``
2936 What to return - see :ref:`returning`.
@@ -37,16 +44,23 @@ using ``update``. ``Update`` takes:
3744``target``
3845 The ``TableSchema`` for the table to update rows in.
3946
40−``updateWhere``
41− The ``WHERE`` clause of the ``UPDATE`` statement. This is a function that
42− takes a single ``Expr`` table as input.
47+``from``
48+ This is a simple ``Query`` that forms the ``FROM`` clause of the ``UPDATE``
49+ statement. This can be used to join against other tables, and the results
50+ can be referenced in the ``set`` and ``updateWhere`` parameters. For simple
51+ ``UPDATE``\s where you don't need to do this, you can set ``from = pure ()``.
4352
4453``set``
4554 A row to row transformation function, indicating how to update selected rows.
4655 This function takes rows of the same shape as ``target`` but in the ``Expr``
4756 context. One way to write this function is to use record update syntax::
4857
49− set = \row -> row { rowName = "new name" }
58+ set = \from row -> row { rowName = "new name" }
59+
60+``updateWhere``
61+ The ``WHERE`` clause of the ``UPDATE`` statement. This is a function that
62+ takes two inputs: the result of the ``from`` query, and the current value of
63+ the row.
5064
5165``returning``
5266 What to return - see :ref:`returning`.
@@ -64,11 +78,11 @@ using ``insert``. ``Insert`` takes:
6478 The rows to insert. These are the same as ``into``, but in the ``Expr``
6579 context. You can construct rows from their individual fields::
6680
67− rows = [ MyTable { myTableA = lit "A", myTableB = lit 42 }
81+ rows = values [ MyTable { myTableA = lit "A", myTableB = lit 42 }
6882
6983 or you can use ``lit`` on a table value in the ``Result`` context::
7084
71− rows = [ lit MyTable { myTableA = "A", myTableB = 42 }
85+ rows = values [ lit MyTable { myTableA = "A", myTableB = 42 }
7286
7387``onConflict``
7488 What should happen if an insert clashes with rows that already exist. This
@@ -80,6 +94,10 @@ using ``insert``. ``Insert`` takes:
8094 ``DoNothing``
8195 PostgreSQL should not insert the duplicate rows.
8296
97+ ``DoUpdate``
98+ PostgreSQL should instead try to update any existing rows that conflict
99+ with rows proposed for insertion.
100+
83101``returning``
84102 What to return - see :ref:`returning`.
85103
@@ -99,11 +117,20 @@ For example, if we are inserting orders, we might want the order ids returned::
99117
100118 insert Insert
101119 { into = orderSchema
102− , rows = [ order ]
120+ , rows = values [ order ]
103121 , onConflict = Abort
104122 , returning = Projection orderId
105123 }
106124
125+If we don't want to return anything, we can use ``pure ()``::
126+
127+ insert Insert
128+ { into = orderSchema
129+ , rows = values [ order ]
130+ , onConflict = Abort
131+ , returning = pure ()
132+ }
133+
107134Default values
108135--------------
109136
@@ -119,7 +146,7 @@ construct the ``DEFAULT`` expression::
119146
120147 insert Insert
121148 { into = orderSchema
122− , rows = [ Order { orderId = unsafeDefault, ... } ]
149+ , rows = values [ Order { orderId = unsafeDefault, ... } ]
123150 , onConflict = Abort
124151 , returning = Projection orderId
125152 }
@@ -148,7 +175,7 @@ them in Rel8, rather than in your database schema.
148175
149176 insert Insert
150177 { into = orderSchema
151− , rows = [ Order { orderId = nextval "order_id_seq", ... } ]
178+ , rows = values [ Order { orderId = nextval "order_id_seq", ... } ]
152179 , onConflict = Abort
153180 , returning = Projection orderId
154181 }
docs/cookbook.rst+9−7
@@ -142,23 +142,25 @@ rows, but can also return *tree*\s.
142142To understand what this means, we'll consider a small example query for blog
143143posts. We want our query to return:
144144
145−1. The latest 5 blog posts.
145+1. The latest 5 blog posts that have at least one tag each.
1461462. For each blog post, all tags.
147−3. For each blog post, the latest 3 comments.
147+3. For each blog post, the latest 3 comments if they exist.
148148
149149In Rel8, we can write this query as::
150150
151151 latestBlogPosts = do
152152 post <- each postSchema
153153
154− tags <- aggregate do
154+ -- Returns a `NonEmptyTable a` which ends up as a `Data.List.NonEmpty a` after the query is run
155+ tags <- some $ do
155156 tag <- each tagSchema
156157 where_ (tagPostId tag ==. postId post)
157− return (listAgg (tagName tag))
158+ return (tagName tag)
158159
159− latestComments <-
160− many $
161− limit 3 $
160+ -- Returns a `ListTable a` which ends up as a `[a]` after the query is run
161+ latestComments <-
162+ many $
163+ limit 3 $
162164 orderBy (commentCreatedAt >$< desc) do
163165 comment <- each commentSchema
164166 where_ (commentPostId comment ==. postId post)
nix/sources.json+9−9
@@ -5,10 +5,10 @@
55 "homepage": "https://input-output-hk.github.io/haskell.nix",
66 "owner": "input-output-hk",
77 "repo": "haskell.nix",
8− "rev": "3856d2d24dca0ecc71fcfc314253a2a2d07a3c4f",
9− "sha256": "0s69nasqhkv8n0qmdv075k83p3z584ja9vkzdnp2291mymghvx87",
8+ "rev": "0837156c56cb5350dd9bd84eb424187e00aa1e8a",
9+ "sha256": "1djmv5a0vfj78csw2cad6nicrs8iqrp928b9b3v4h7lwwhhzliwl",
1010 "type": "tarball",
11− "url": "https://github.com/input-output-hk/haskell.nix/archive/3856d2d24dca0ecc71fcfc314253a2a2d07a3c4f.tar.gz",
11+ "url": "https://github.com/input-output-hk/haskell.nix/archive/0837156c56cb5350dd9bd84eb424187e00aa1e8a.tar.gz",
1212 "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
1313 },
1414 "niv": {
@@ -17,10 +17,10 @@
1717 "homepage": "https://github.com/nmattia/niv",
1818 "owner": "nmattia",
1919 "repo": "niv",
20− "rev": "e0ca65c81a2d7a4d82a189f1e23a48d59ad42070",
21− "sha256": "1pq9nh1d8nn3xvbdny8fafzw87mj7gsmp6pxkdl65w2g18rmcmzx",
20+ "rev": "acdb1726783637852c01e0ad639ac9cbec28d8c8",
21+ "sha256": "1wszl8q70z6wfgkh2dvgmhhry6qp9nar421qq2ifd17hq2jj9ck3",
2222 "type": "tarball",
23− "url": "https://github.com/nmattia/niv/archive/e0ca65c81a2d7a4d82a189f1e23a48d59ad42070.tar.gz",
23+ "url": "https://github.com/nmattia/niv/archive/acdb1726783637852c01e0ad639ac9cbec28d8c8.tar.gz",
2424 "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
2525 },
2626 "nixpkgs": {
@@ -29,10 +29,10 @@
2929 "homepage": null,
3030 "owner": "nixos",
3131 "repo": "nixpkgs",
32− "rev": "59b8d9cf24e9fcf10341a0923c9bdca088dca8c8",
33− "sha256": "08f38v4b2kcxnbapdwrb54bglka92cxj9qlnqlk5px206jyq9v4c",
32+ "rev": "1c1f5649bb9c1b0d98637c8c365228f57126f361",
33+ "sha256": "0f2nvdijyxfgl5kwyb4465pppd5vkhqxddx6v40k2s0z9jfhj0xl",
3434 "type": "tarball",
35− "url": "https://github.com/nixos/nixpkgs/archive/59b8d9cf24e9fcf10341a0923c9bdca088dca8c8.tar.gz",
35+ "url": "https://github.com/nixos/nixpkgs/archive/1c1f5649bb9c1b0d98637c8c365228f57126f361.tar.gz",
3636 "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
3737 }
3838}
nix/sources.nix+21−1
@@ -31,8 +31,28 @@ let
3131 if spec ? branch then "refs/heads/${spec.branch}" else
3232 if spec ? tag then "refs/tags/${spec.tag}" else
3333 abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!";
34+ submodules = if spec ? submodules then spec.submodules else false;
35+ submoduleArg =
36+ let
37+ nixSupportsSubmodules = builtins.compareVersions builtins.nixVersion "2.4" >= 0;
38+ emptyArgWithWarning =
39+ if submodules == true
40+ then
41+ builtins.trace
42+ (
43+ "The niv input \"${name}\" uses submodules "
44+ + "but your nix's (${builtins.nixVersion}) builtins.fetchGit "
45+ + "does not support them"
46+ )
47+ {}
48+ else {};
49+ in
50+ if nixSupportsSubmodules
51+ then { inherit submodules; }
52+ else emptyArgWithWarning;
3453 in
35− builtins.fetchGit { url = spec.repo; inherit (spec) rev; inherit ref; };
54+ builtins.fetchGit
55+ ({ url = spec.repo; inherit (spec) rev; inherit ref; } // submoduleArg);
3656
3757 fetch_local = spec: spec.path;
3858
rel8.cabal+33−15
@@ -1,6 +1,6 @@
11cabal-version: 2.0
22name: rel8
3−version: 1.0.0.1
3+version: 1.4.0.0
44synopsis: Hey! Hey! Can u rel8?
55license: BSD3
66license-file: LICENSE
@@ -20,29 +20,33 @@ source-repository head
2020library
2121 build-depends:
2222 aeson
23− , base ^>= 4.14 || ^>=4.15
23+ , base ^>= 4.14 || ^>=4.15 || ^>=4.16
24+ , bifunctors
2425 , bytestring
2526 , case-insensitive
2627 , comonad
2728 , contravariant
28− , hasql ^>= 1.4.5.1
29− , opaleye ^>= 0.7.3.0
29+ , hasql ^>= 1.4.5.1 || ^>= 1.5.0.0 || ^>= 1.6.0.0
30+ , opaleye ^>= 0.9.6.1
31+ , pretty
3032 , profunctors
33+ , product-profunctors
3134 , scientific
3235 , semialign
3336 , semigroupoids
3437 , text
3538 , these
3639 , time
37− , transformers
3840 , uuid
3941 default-language:
4042 Haskell2010
4143 ghc-options:
44+ -Werror=missing-methods -Werror=incomplete-patterns -Werror=missing-fields
4245 -Weverything -Wno-unsafe -Wno-safe -Wno-missing-safe-haskell-mode
4346 -Wno-missing-import-lists -Wno-prepositive-qualified-module
4447 -Wno-monomorphism-restriction
4548 -Wno-missing-local-signatures
49+ -Wno-missing-kind-signatures
4650 hs-source-dirs:
4751 src
4852 exposed-modules:
@@ -50,6 +54,7 @@ library
5054 Rel8.Expr.Num
5155 Rel8.Expr.Text
5256 Rel8.Expr.Time
57+ Rel8.Tabulate
5358
5459 other-modules:
5560 Rel8.Aggregate
@@ -61,6 +66,7 @@ library
6166 Rel8.Column.List
6267 Rel8.Column.Maybe
6368 Rel8.Column.NonEmpty
69+ Rel8.Column.Null
6470 Rel8.Column.These
6571
6672 Rel8.Expr
@@ -76,19 +82,18 @@ library
7682 Rel8.Expr.Order
7783 Rel8.Expr.Sequence
7884 Rel8.Expr.Serialize
85+ Rel8.Expr.Window
7986
8087 Rel8.FCF
8188
8289 Rel8.Kind.Algebra
8390 Rel8.Kind.Context
8491
85− Rel8.Generic.Coherence
8692 Rel8.Generic.Construction
8793 Rel8.Generic.Construction.ADT
8894 Rel8.Generic.Construction.Record
8995 Rel8.Generic.Map
9096 Rel8.Generic.Record
91− Rel8.Generic.Reify
9297 Rel8.Generic.Rel8able
9398 Rel8.Generic.Table
9499 Rel8.Generic.Table.ADT
@@ -104,21 +109,23 @@ library
104109 Rel8.Query.Evaluate
105110 Rel8.Query.Exists
106111 Rel8.Query.Filter
112+ Rel8.Query.Indexed
107113 Rel8.Query.Limit
108114 Rel8.Query.List
109115 Rel8.Query.Maybe
110116 Rel8.Query.Null
111117 Rel8.Query.Opaleye
112118 Rel8.Query.Order
119+ Rel8.Query.Rebind
113120 Rel8.Query.Set
114121 Rel8.Query.SQL
115122 Rel8.Query.These
116123 Rel8.Query.Values
124+ Rel8.Query.Window
117125
118− Rel8.Schema.Context
119− Rel8.Schema.Context.Abstract
120126 Rel8.Schema.Context.Nullify
121127 Rel8.Schema.Dict
128+ Rel8.Schema.Field
122129 Rel8.Schema.HTable
123130 Rel8.Schema.HTable.Either
124131 Rel8.Schema.HTable.Identity
@@ -134,24 +141,28 @@ library
134141 Rel8.Schema.Kind
135142 Rel8.Schema.Name
136143 Rel8.Schema.Null
137− Rel8.Schema.Reify
138144 Rel8.Schema.Result
139145 Rel8.Schema.Spec
140− Rel8.Schema.Spec.Constrain
141146 Rel8.Schema.Table
142147
143148 Rel8.Statement.Delete
144149 Rel8.Statement.Insert
150+ Rel8.Statement.OnConflict
145151 Rel8.Statement.Returning
146152 Rel8.Statement.Select
153+ Rel8.Statement.Set
154+ Rel8.Statement.SQL
147155 Rel8.Statement.Update
156+ Rel8.Statement.Using
148157 Rel8.Statement.View
158+ Rel8.Statement.Where
149159
150160 Rel8.Table
151161 Rel8.Table.ADT
152162 Rel8.Table.Aggregate
153163 Rel8.Table.Alternative
154164 Rel8.Table.Bool
165+ Rel8.Table.Cols
155166 Rel8.Table.Either
156167 Rel8.Table.Eq
157168 Rel8.Table.HKD
@@ -159,15 +170,18 @@ library
159170 Rel8.Table.Maybe
160171 Rel8.Table.Name
161172 Rel8.Table.NonEmpty
173+ Rel8.Table.Null
162174 Rel8.Table.Nullify
163175 Rel8.Table.Opaleye
164176 Rel8.Table.Ord
165177 Rel8.Table.Order
166− Rel8.Table.Recontextualize
178+ Rel8.Table.Projection
167179 Rel8.Table.Rel8able
168180 Rel8.Table.Serialize
169181 Rel8.Table.These
182+ Rel8.Table.Transpose
170183 Rel8.Table.Undefined
184+ Rel8.Table.Window
171185
172186 Rel8.Type
173187 Rel8.Type.Array
@@ -186,6 +200,9 @@ library
186200 Rel8.Type.Sum
187201 Rel8.Type.Tag
188202
203+ Rel8.Window
204+
205+
189206test-suite tests
190207 type: exitcode-stdio-1.0
191208 build-depends:
@@ -194,9 +211,9 @@ test-suite tests
194211 , case-insensitive
195212 , containers
196213 , hasql
197− , hedgehog ^>=1.0.2
198− , lifted-base ^>=0.2.3.12
199− , monad-control ^>=1.0.2.3
214+ , hasql-transaction
215+ , hedgehog ^>= 1.0 || ^>= 1.1
216+ , mmorph
200217 , rel8
201218 , scientific
202219 , tasty
@@ -204,6 +221,7 @@ test-suite tests
204221 , text
205222 , time
206223 , tmp-postgres ^>=1.34.1.0
224+ , transformers
207225 , uuid
208226
209227 other-modules:
shell.nix+1−1
@@ -1,6 +1,6 @@
11let
22 sources = import ./nix/sources.nix;
3− pkgs = import sources.nixpkgs {};
3+ pkgs = import sources.nixpkgs {overlays = [];};
44 hsPkgs = import ./default.nix;
55in
66 hsPkgs.shellFor {
src/Rel8.hs+298−15
@@ -38,24 +38,27 @@ module Rel8
3838 , HMaybe
3939 , HList
4040 , HNonEmpty
41+ , HNull
4142 , HThese
4243 , Lift
4344
4445 , Table(..)
4546 , HTable
46− , Recontextualize
47+ , Transposes
4748 , AltTable((<|>:))
4849 , AlternativeTable( emptyTable )
49− , EqTable, (==:), (/=:)
50− , OrdTable, ascTable, descTable
50+ , EqTable(..), (==:), (/=:)
51+ , OrdTable(..), (<:), (<=:), (>:), (>=:), ascTable, descTable, greatest, least
5152 , lit
5253 , bool
5354 , case_
55+ , castTable
5456
5557 -- ** @MaybeTable@
5658 , MaybeTable
5759 , maybeTable, ($?), nothingTable, justTable
5860 , isNothingTable, isJustTable
61+ , fromMaybeTable
5962 , optional
6063 , catMaybeTable
6164 , traverseMaybeTable
@@ -78,6 +81,7 @@ module Rel8
7881 , isThisTable, isThatTable, isThoseTable
7982 , hasHereTable, hasThereTable
8083 , justHereTable, justThereTable
84+ , alignMaybeTable
8185 , alignBy
8286 , keepHereTable, loseHereTable
8387 , keepThereTable, loseThereTable
@@ -90,7 +94,7 @@ module Rel8
9094
9195 -- ** @ListTable@
9296 , ListTable
93− , listTable
97+ , listTable, ($*)
9498 , nameListTable
9599 , many
96100 , manyExpr
@@ -99,21 +103,44 @@ module Rel8
99103
100104 -- ** @NonEmptyTable@
101105 , NonEmptyTable
102− , nonEmptyTable
106+ , nonEmptyTable, ($+)
103107 , nameNonEmptyTable
104108 , some
105109 , someExpr
106110 , catNonEmptyTable
107111 , catNonEmpty
108112
109− -- ** @ADT@
113+ -- ** @NullTable@
114+ , NullTable
115+ , nullableTable, nullTable, nullifyTable
116+ , isNullTable, isNonNullTable
117+ , catNullTable
118+ , nameNullTable
119+ , toNullTable, toMaybeTable
120+
121+ -- ** Algebraic data types / sum types
122+ -- $adts
123+
124+ -- *** Naming of ADTs
125+ -- $naming
126+ , NameADT, nameADT
110127 , ADT, ADTable
128+
129+ -- *** Deconstruction of ADTs
130+ -- $deconstruction
131+ , DeconstructADT, deconstructADT
132+
133+ -- *** Construction of ADTs
134+ -- $construction
111135 , BuildADT, buildADT
112136 , ConstructADT, constructADT
113− , DeconstructADT, deconstructADT
114− , NameADT, nameADT
137+
138+ -- *** Other ADT operations
115139 , AggregateADT, aggregateADT
116140
141+ -- *** Miscellaneous notes
142+ -- $misc-notes
143+
117144 -- ** @HKD@
118145 , HKD, HKDable
119146 , BuildHKD, buildHKD
@@ -138,6 +165,7 @@ module Rel8
138165 -- ** @null@
139166 , NotNull
140167 , Nullable
168+ , Homonullable
141169 , null
142170 , nullify
143171 , nullable
@@ -156,6 +184,7 @@ module Rel8
156184 , (==.), (/=.), (==?), (/=?)
157185 , in_
158186 , boolExpr, caseExpr
187+ , like, ilike
159188
160189 -- ** Ordering
161190 , DBOrd
@@ -173,6 +202,13 @@ module Rel8
173202 , Query
174203 , showQuery
175204
205+ -- ** Projection
206+ , Projection
207+ , Projectable( project )
208+ , Biprojectable( biproject )
209+ , Projecting
210+ , Field
211+
176212 -- ** Selecting rows
177213 , Selects
178214 , each
@@ -217,10 +253,11 @@ module Rel8
217253 , countRows
218254 , groupBy
219255 , listAgg, listAggExpr
256+ , mode
220257 , nonEmptyAgg, nonEmptyAggExpr
221258 , DBMax, max
222259 , DBMin, min
223− , DBSum, sum, sumWhere
260+ , DBSum, sum, sumWhere, avg
224261 , DBString, stringAgg
225262 , count
226263 , countStar
@@ -237,10 +274,35 @@ module Rel8
237274 , nullsFirst
238275 , nullsLast
239276
277+ -- ** Window functions
278+ , Window
279+ , window
280+ , Partition
281+ , over
282+ , partitionBy
283+ , orderPartitionBy
284+ , cumulative
285+ , cumulative_
286+ , currentRow
287+ , rowNumber
288+ , rank
289+ , denseRank
290+ , percentRank
291+ , cumeDist
292+ , ntile
293+ , lag
294+ , lead
295+ , firstValue
296+ , lastValue
297+ , nthValue
298+ , indexed
299+
300+ -- ** Bindings
301+ , rebind
302+
240303 -- * IO
241304 , Serializable
242− , ToExprs(..)
243− , FromExprs
305+ , ToExprs
244306 , Result
245307
246308 -- * Running statements
@@ -252,29 +314,31 @@ module Rel8
252314 -- ** @INSERT@
253315 , Insert(..)
254316 , OnConflict(..)
317+ , Upsert(..)
255318 , insert
256319 , unsafeDefault
320+ , showInsert
257321
258322 -- ** @DELETE@
259323 , Delete(..)
260324 , delete
325+ , showDelete
261326
262327 -- ** @UPDATE@
263328 , Update(..)
264329 , update
330+ , showUpdate
265331
266332 -- ** @.. RETURNING@
267333 , Returning(..)
268334
269335 -- ** @CREATE VIEW@
270336 , createView
337+ , createOrReplaceView
271338
272339 -- ** Sequences
273340 , nextval
274341 , evaluate
275−
276− -- * Implementation details
277− , HKDT(..)
278342 ) where
279343
280344-- base
@@ -289,6 +353,7 @@ import Rel8.Column.Lift
289353import Rel8.Column.List
290354import Rel8.Column.Maybe
291355import Rel8.Column.NonEmpty
356+import Rel8.Column.Null
292357import Rel8.Column.These
293358import Rel8.Expr
294359import Rel8.Expr.Aggregate
@@ -302,6 +367,8 @@ import Rel8.Expr.Ord
302367import Rel8.Expr.Order
303368import Rel8.Expr.Serialize
304369import Rel8.Expr.Sequence
370+import Rel8.Expr.Text ( like, ilike )
371+import Rel8.Expr.Window hiding ( cumulative )
305372import Rel8.Generic.Rel8able ( KRel8able, Rel8able )
306373import Rel8.Order
307374import Rel8.Query
@@ -312,15 +379,19 @@ import Rel8.Query.Either
312379import 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
393+import Rel8.Query.Window
394+import Rel8.Schema.Field
324395import Rel8.Schema.HTable
325396import Rel8.Schema.Name
326397import Rel8.Schema.Null hiding ( nullable )
@@ -328,8 +399,10 @@ import Rel8.Schema.Result ( Result )
328399import Rel8.Schema.Table
329400import Rel8.Statement.Delete
330401import Rel8.Statement.Insert
402+import Rel8.Statement.OnConflict
331403import Rel8.Statement.Returning
332404import Rel8.Statement.Select
405+import Rel8.Statement.SQL
333406import Rel8.Statement.Update
334407import Rel8.Statement.View
335408import Rel8.Table
@@ -344,12 +417,16 @@ import Rel8.Table.List
344417import Rel8.Table.Maybe
345418import Rel8.Table.Name
346419import Rel8.Table.NonEmpty
420+import Rel8.Table.Null
421+import Rel8.Table.Opaleye ( castTable )
347422import Rel8.Table.Ord
348423import Rel8.Table.Order
349−import Rel8.Table.Recontextualize
424+import Rel8.Table.Projection
350425import Rel8.Table.Rel8able ()
351426import Rel8.Table.Serialize
352427import Rel8.Table.These
428+import Rel8.Table.Transpose
429+import Rel8.Table.Window
353430import Rel8.Type
354431import Rel8.Type.Composite
355432import Rel8.Type.Eq
@@ -364,6 +441,7 @@ import Rel8.Type.ReadShow
364441import Rel8.Type.Semigroup
365442import Rel8.Type.String
366443import Rel8.Type.Sum
444+import Rel8.Window
367445
368446
369447-- $running
@@ -371,3 +449,208 @@ import Rel8.Type.Sum
371449-- provides 'select', 'insert', 'update' and 'delete' functions. Note that
372450-- 'insert', 'update' and 'delete' will generally need the
373451-- `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+37−105
@@ -1,151 +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( A, unA )
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
3432import Rel8.Expr ( Expr )
35−import Rel8.Schema.Context ( Interpretation(..) )
36−import Rel8.Schema.HTable.Identity ( HIdentity(..), HType )
37−import Rel8.Schema.Name ( Name )
33+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
34+import qualified Rel8.Schema.Kind as K
3835import Rel8.Schema.Null ( Sql )
39−import Rel8.Schema.Reify ( notReify )
40−import Rel8.Schema.Result ( Result )
41−import Rel8.Schema.Spec ( Spec( Spec ) )
4236import Rel8.Table
4337 ( Table, Columns, Context, fromColumns, toColumns
44− , reify, unreify, coherence, congruence
38+ , FromExprs, fromResult, toResult
39+ , Transpose
4540 )
46−import Rel8.Table.Recontextualize ( Recontextualize )
41+import Rel8.Table.Transpose ( Transposes )
4742import Rel8.Type ( DBType )
4843
4944
50−-- | An @Aggregate a@ describes how to aggregate @Table@s of type @a@. You can
51−-- unpack an @Aggregate@ back to @a@ by running it with 'Rel8.aggregate'. As
52−-- @Aggregate@ is almost an 'Applicative' functor - but there is no 'pure'
53−-- operation. This means 'Aggregate' is an instance of 'Apply', and you can
54−-- combine @Aggregate@s using the @<.>@ combinator.
55−type Aggregate :: k -> Type
56−data Aggregate a where
57− Aggregate :: !(Opaleye.Aggregator () (Expr a)) -> Aggregate a
58−
59−
60−instance Interpretation Aggregate where
61− data Col Aggregate _spec where
62− A :: ()
63− => { unA :: !(Aggregate a) }
64− -> Col Aggregate ('Spec a)
45+-- | 'Aggregate' is a special context used by 'Rel8.aggregate'.
46+type Aggregate :: K.Context
47+newtype Aggregate a = Aggregate (Opaleye.Aggregator () (Expr a))
6548
6649
6750instance Sql DBType a => Table Aggregate (Aggregate a) where
68− type Columns (Aggregate a) = HType a
51+ type Columns (Aggregate a) = HIdentity a
6952 type Context (Aggregate a) = Aggregate
53+ type FromExprs (Aggregate a) = a
54+ type Transpose to (Aggregate a) = to a
7055
71− toColumns = HIdentity . A
72− fromColumns (HIdentity (A a)) = a
73−
74− reify = notReify
75− unreify = notReify
76− coherence = notReify
77− congruence = notReify
78−
79−
80−instance Sql DBType a =>
81− Recontextualize Aggregate Aggregate (Aggregate a) (Aggregate a)
82−
83−
84−instance Sql DBType a =>
85− Recontextualize Aggregate Expr (Aggregate a) (Expr a)
86−
87−
88−instance Sql DBType a =>
89− Recontextualize Aggregate Result (Aggregate a) (Identity a)
90−
56+ toColumns = HIdentity
57+ fromColumns (HIdentity a) = a
58+ toResult = HIdentity . Identity
59+ fromResult (HIdentity (Identity a)) = a
9160
92−instance Sql DBType a =>
93− Recontextualize Aggregate Name (Aggregate a) (Name a)
9461
95−
96−instance Sql DBType a =>
97− Recontextualize Expr Aggregate (Expr a) (Aggregate a)
98−
99−
100−instance Sql DBType a =>
101− Recontextualize Result Aggregate (Identity a) (Aggregate a)
102−
103−
104−instance Sql DBType a =>
105− Recontextualize Name Aggregate (Name a) (Aggregate a)
106−
107−
108−-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate' 'Expr's
109−-- 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@.
11064type Aggregates :: Type -> Type -> Constraint
111−class Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs
112−instance Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs
113−
114−
115−foldInputs :: Monoid b
116− => (Maybe Aggregator -> Opaleye.PrimExpr -> b) -> Aggregate a -> b
117−foldInputs f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =
118− getConst $ flip agg () $ \(aggregator, a) ->
119− Const $ f (detuplize <$> aggregator) a
120− where
121− detuplize (operation, ordering, distinction) =
122− Aggregator {operation, ordering, distinction}
123−
124−
125−mapInputs :: ()
126− => (Opaleye.PrimExpr -> Opaleye.PrimExpr) -> Aggregate a -> Aggregate a
127−mapInputs transform (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =
128− Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ agg . \f input ->
129− f (fmap transform input)
65+class Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs
66+instance Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs
13067
13168
132−type Aggregator :: Type
133−data Aggregator = Aggregator
134− { operation :: Opaleye.AggrOp
135− , ordering :: [Opaleye.OrderExpr]
136− , distinction :: Opaleye.AggrDistinct
137− }
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)
13872
13973
140−unsafeMakeAggregate :: ()
74+unsafeMakeAggregate :: forall (input :: Type) (output :: Type) n n' a a'. ()
14175 => (Expr input -> Opaleye.PrimExpr)
14276 -> (Opaleye.PrimExpr -> Expr output)
143− -> Maybe Aggregator
77+ -> Opaleye.Aggregator (Opaleye.Field_ n a) (Opaleye.Field_ n' a')
14478 -> Expr input
14579 -> Aggregate output
14680unsafeMakeAggregate input output aggregator expr =
147− Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ \f _ ->
148− output <$> f (tuplize <$> aggregator, input expr)
149− where
150− tuplize Aggregator {operation, ordering, distinction} =
151− (operation, ordering, distinction)
81+ Aggregate $ dimap in_ out aggregator
82+ where out = output . Opaleye.unColumn
83+ in_ = Opaleye.Column . input . const expr
src/Rel8/Column.hs+5−91
@@ -1,41 +1,21 @@
11{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
3−{-# language LambdaCase #-}
4−{-# language MultiParamTypeClasses #-}
5−{-# language ScopedTypeVariables #-}
62{-# language StandaloneKindSignatures #-}
7−{-# language TypeApplications #-}
83{-# language TypeFamilies #-}
94
105module Rel8.Column
11− ( Column, AColumn(..)
6+ ( Column
127 , TColumn
138 )
149where
1510
1611-- base
1712import Data.Kind ( Type )
18−import Data.Type.Equality ( (:~:)( Refl ) )
19−import Prelude
13+import Prelude ()
2014
2115-- rel8
22−import Rel8.Aggregate ( Aggregate, Col( A ) )
23−import Rel8.Expr ( Expr, Col( E ) )
2416import Rel8.FCF ( Eval, Exp )
25−import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )
26−import Rel8.Schema.HTable.Identity ( HIdentity(..), HType )
2717import qualified Rel8.Schema.Kind as K
28−import Rel8.Schema.Name ( Name(..), Col( N ) )
29−import Rel8.Schema.Null ( Sql )
30−import Rel8.Schema.Reify ( Reify, Col(..) )
31−import Rel8.Schema.Result ( Col( R ), Result, absurd )
32−import Rel8.Schema.Spec ( Spec( Spec ) )
33−import Rel8.Table
34− ( Table, Columns, Context, fromColumns, toColumns
35− , Unreify, reify, unreify, coherence, congruence
36− )
37−import Rel8.Table.Recontextualize ( Recontextualize )
38−import Rel8.Type ( DBType )
18+import Rel8.Schema.Result ( Result )
3919
4020
4121-- | This type family is used to specify columns in 'Rel8able's. In @Column f
@@ -43,74 +23,8 @@ import Rel8.Type ( DBType )
4323-- 'Rel8able' definitions), and @a@ is the type of the column.
4424type Column :: K.Context -> Type -> Type
4525type family Column context a where
46− Column (Reify context) a = AColumn context a
47− Column Aggregate a = Aggregate a
48− Column Expr a = Expr a
49− Column Name a = Name a
50− Column Result a = a
51−
52−
53−type AColumn :: K.Context -> Type -> Type
54−newtype AColumn context a = AColumn (Column context a)
55−
56−
57−instance (Reifiable context, Sql DBType a) =>
58− Table (Reify context) (AColumn context a)
59− where
60− type Context (AColumn context a) = Reify context
61− type Columns (AColumn context a) = HType a
62− type Unreify (AColumn context a) = Column context a
63−
64− fromColumns (HType (Reify a)) = sfromColumn contextSing a
65− toColumns = HType . Reify . stoColumn contextSing
66− reify _ = AColumn
67− unreify _ (AColumn a) = a
68−
69− coherence Refl = case contextSing @context of
70− SAggregate -> const Refl
71− SExpr -> const Refl
72− SName -> const Refl
73− SResult -> absurd
74− SReify _ -> const Refl
75−
76− congruence Refl = case contextSing @context of
77− SAggregate -> const Refl
78− SExpr -> const Refl
79− SName -> const Refl
80− SResult -> absurd
81− SReify _ -> const Refl
82−
83−
84−instance (Reifiable context, Reifiable context', Sql DBType a) =>
85− Recontextualize
86− (Reify context)
87− (Reify context')
88− (AColumn context a)
89− (AColumn context' a)
90−
91−
92−sfromColumn :: ()
93− => SContext context
94− -> Col context ('Spec a)
95− -> AColumn context a
96−sfromColumn = \case
97− SAggregate -> \(A a) -> AColumn a
98− SExpr -> \(E a) -> AColumn a
99− SName -> \(N a) -> AColumn a
100− SResult -> \(R a) -> AColumn a
101− SReify context -> \(Reify a) -> AColumn (sfromColumn context a)
102−
103−
104−stoColumn :: ()
105− => SContext context
106− -> AColumn context a
107− -> Col context ('Spec a)
108−stoColumn = \case
109− SAggregate -> \(AColumn a) -> A a
110− SExpr -> \(AColumn a) -> E a
111− SName -> \(AColumn a) -> N a
112− SResult -> \(AColumn a) -> R a
113− SReify context -> \(AColumn a) -> Reify (stoColumn context a)
26+ Column Result a = a
27+ Column context a = context a
11428
11529
11630data TColumn :: K.Context -> Type -> Exp Type
src/Rel8/Column/ADT.hs+4−87
@@ -1,106 +1,23 @@
11{-# language DataKinds #-}
2−{-# language LambdaCase #-}
3−{-# language MultiParamTypeClasses #-}
4−{-# language ScopedTypeVariables #-}
52{-# language StandaloneKindSignatures #-}
6−{-# language TypeApplications #-}
73{-# language TypeFamilies #-}
8−{-# language UndecidableInstances #-}
94
105module Rel8.Column.ADT
11− ( HADT, AHADT(..)
6+ ( HADT
127 )
138where
149
1510-- base
1611import Data.Kind ( Type )
17−import Data.Type.Equality ( (:~:)( Refl ) )
18−import Prelude
12+import Prelude ()
1913
2014-- rel8
21−import Rel8.Generic.Rel8able ( GColumns )
22−import Rel8.Kind.Context ( SContext(..), Reifiable, contextSing )
23−import Rel8.Schema.Context ( Col )
2415import qualified Rel8.Schema.Kind as K
25−import Rel8.Schema.Reify ( Reify, hreify, hunreify )
26−import Rel8.Schema.Result ( Result, absurd )
27−import Rel8.Table
28− ( Table, Columns, Context, fromColumns, toColumns
29− , Unreify, reify, unreify, coherence, congruence
30− )
31−import Rel8.Table.ADT ( ADT( ADT ), ADTable, fromADT, toADT )
32−import Rel8.Table.Rel8able ()
33−import Rel8.Table.Recontextualize ( Recontextualize )
16+import Rel8.Schema.Result ( Result )
17+import Rel8.Table.ADT ( ADT )
3418
3519
3620type HADT :: K.Context -> K.Rel8able -> Type
3721type family HADT context t where
38− HADT (Reify context) t = AHADT context t
3922 HADT Result t = t Result
4023 HADT context t = ADT t context
41−
42−
43−type AHADT :: K.Context -> K.Rel8able -> Type
44−newtype AHADT context t = AHADT (HADT context t)
45−
46−
47−instance (ADTable t, Reifiable context) =>
48− Table (Reify context) (AHADT context t)
49− where
50− type Context (AHADT context t) = Reify context
51− type Columns (AHADT context t) = GColumns (ADT t)
52− type Unreify (AHADT context t) = HADT context t
53−
54− fromColumns = sfromColumnsADT contextSing
55− toColumns = stoColumnsADT contextSing
56− reify _ = AHADT
57− unreify _ (AHADT a) = a
58−
59− coherence = case contextSing @context of
60− SAggregate -> \Refl _ -> Refl
61− SExpr -> \Refl _ -> Refl
62− SName -> \Refl _ -> Refl
63− SResult -> \Refl -> absurd
64− SReify _ -> \Refl _ -> Refl
65−
66− congruence = case contextSing @context of
67− SAggregate -> \_ _ -> Refl
68− SExpr -> \_ _ -> Refl
69− SName -> \_ _ -> Refl
70− SResult -> \Refl -> absurd
71− SReify _ -> \_ _ -> Refl
72−
73−
74−instance
75− ( Reifiable context, Reifiable context'
76− , ADTable t, t ~ t'
77− )
78− => Recontextualize
79− (Reify context)
80− (Reify context')
81− (AHADT context t)
82− (AHADT context' t')
83−
84−
85−sfromColumnsADT :: ADTable t
86− => SContext context
87− -> GColumns (ADT t) (Col (Reify context))
88− -> AHADT context t
89−sfromColumnsADT = \case
90− SAggregate -> AHADT . ADT . hunreify
91− SExpr -> AHADT . ADT . hunreify
92− SName -> AHADT . ADT . hunreify
93− SResult -> AHADT . fromADT . ADT . hunreify
94− SReify context -> AHADT . sfromColumnsADT context . hunreify
95−
96−
97−stoColumnsADT :: ADTable t
98− => SContext context
99− -> AHADT context t
100− -> GColumns (ADT t) (Col (Reify context))
101−stoColumnsADT = \case
102− SAggregate -> hreify . (\(AHADT (ADT a)) -> a)
103− SExpr -> hreify . (\(AHADT (ADT a)) -> a)
104− SName -> hreify . (\(AHADT (ADT a)) -> a)
105− SResult -> hreify . (\(ADT a) -> a) . toADT . (\(AHADT a) -> a)
106− SReify context -> hreify . stoColumnsADT context . (\(AHADT a) -> a)
src/Rel8/Column/Either.hs+4−170
@@ -1,42 +1,20 @@
11{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
3−{-# language LambdaCase #-}
4−{-# language MultiParamTypeClasses #-}
5−{-# language ScopedTypeVariables #-}
62{-# language StandaloneKindSignatures #-}
7−{-# language TypeApplications #-}
83{-# language TypeFamilyDependencies #-}
9−{-# language UndecidableInstances #-}
104
115module Rel8.Column.Either
12− ( HEither, AHEither(..)
6+ ( HEither
137 )
148where
159
1610-- base
17−import Control.Applicative ( liftA2 )
18−import Control.Category ( id )
19−import Data.Bifunctor ( Bifunctor, bimap )
2011import Data.Kind ( Type )
21−import Data.Type.Equality ( (:~:)( Refl ), apply )
22−import Prelude hiding ( id )
12+import Prelude
2313
2414-- rel8
25−import Rel8.Aggregate ( Aggregate )
26−import Rel8.Expr ( Expr )
27−import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )
28−import Rel8.Schema.Context ( Col )
29−import Rel8.Schema.HTable.Either ( HEitherTable )
3015import qualified Rel8.Schema.Kind as K
31−import Rel8.Schema.Name ( Name(..) )
32−import Rel8.Schema.Reify ( Reify, hreify, hunreify )
33−import Rel8.Schema.Result ( Result, absurd )
34−import Rel8.Table
35− ( Table, Columns, Context, fromColumns, toColumns
36− , Unreify, reify, unreify, coherence, congruence
37− )
16+import Rel8.Schema.Result ( Result )
3817import Rel8.Table.Either ( EitherTable )
39−import Rel8.Table.Recontextualize ( Recontextualize )
4018
4119
4220-- | Nest an 'Either' value within a 'Rel8able'. @HEither f a b@ will produce a
@@ -44,149 +22,5 @@ import Rel8.Table.Recontextualize ( Recontextualize )
4422-- 'Result' context.
4523type HEither :: K.Context -> Type -> Type -> Type
4624type family HEither context = either | either -> context where
47− HEither (Reify context) = AHEither context
48− HEither Aggregate = EitherTable Aggregate
49− HEither Expr = EitherTable Expr
50− HEither Name = EitherTable Name
5125 HEither Result = Either
52−
53−
54−type AHEither :: K.Context -> Type -> Type -> Type
55−newtype AHEither context a b = AHEither (HEither context a b)
56−
57−
58−instance Reifiable context => Bifunctor (AHEither context) where
59− bimap = sbimapEither contextSing
60−
61−
62−instance Reifiable context => Functor (AHEither context a) where
63− fmap = bimap id
64−
65−
66−instance (Reifiable context, Table (Reify context) a, Table (Reify context) b)
67− => Table (Reify context) (AHEither context a b)
68− where
69− type Context (AHEither context a b) = Reify context
70− type Columns (AHEither context a b) = HEitherTable (Columns a) (Columns b)
71− type Unreify (AHEither context a b) = HEither context (Unreify a) (Unreify b)
72−
73− fromColumns = sfromColumnsEither contextSing
74− toColumns = stoColumnsEither contextSing
75− reify proof = liftA2 bimap reify reify proof . AHEither
76− unreify proof = (\(AHEither a) -> a) . liftA2 bimap unreify unreify proof
77−
78− coherence = case contextSing @context of
79− SAggregate -> coherence @(Reify context) @a
80− SExpr -> coherence @(Reify context) @a
81− SName -> coherence @(Reify context) @a
82− SResult -> \Refl -> absurd
83− SReify _ -> \Refl _ -> Refl
84−
85− congruence proof@Refl abstract = case contextSing @context of
86− SAggregate ->
87− id `apply`
88− congruence @(Reify context) @a proof abstract `apply`
89− congruence @(Reify context) @b proof abstract
90− SExpr ->
91− id `apply`
92− congruence @(Reify context) @a proof abstract `apply`
93− congruence @(Reify context) @b proof abstract
94− SName ->
95− id `apply`
96− congruence @(Reify context) @a proof abstract `apply`
97− congruence @(Reify context) @b proof abstract
98− SResult -> absurd abstract
99− SReify _ ->
100− id `apply`
101− congruence @(Reify context) @a proof abstract `apply`
102− congruence @(Reify context) @b proof abstract
103−
104−
105−instance
106− ( Reifiable context, Reifiable context'
107− , Recontextualize (Reify context) (Reify context') a a'
108− , Recontextualize (Reify context) (Reify context') b b'
109− ) =>
110− Recontextualize
111− (Reify context)
112− (Reify context')
113− (AHEither context a b)
114− (AHEither context' a' b')
115−
116−
117−sbimapEither :: ()
118− => SContext context
119− -> (a -> c)
120− -> (b -> d)
121− -> AHEither context a b
122− -> AHEither context c d
123−sbimapEither = \case
124− SAggregate -> \f g (AHEither a) -> AHEither (bimap f g a)
125− SExpr -> \f g (AHEither a) -> AHEither (bimap f g a)
126− SResult -> \f g (AHEither a) -> AHEither (bimap f g a)
127− SName -> \f g (AHEither a) -> AHEither (bimap f g a)
128− SReify context -> \f g (AHEither a) -> AHEither (sbimapEither context f g a)
129−
130−
131−sfromColumnsEither :: (Table (Reify context) a, Table (Reify context) b)
132− => SContext context
133− -> HEitherTable (Columns a) (Columns b) (Col (Reify context))
134− -> AHEither context a b
135−sfromColumnsEither = \case
136− SAggregate ->
137− AHEither .
138− bimap (fromColumns . hreify) (fromColumns . hreify) .
139− fromColumns .
140− hunreify
141− SExpr ->
142− AHEither .
143− bimap (fromColumns . hreify) (fromColumns . hreify) .
144− fromColumns .
145− hunreify
146− SResult ->
147− AHEither .
148− bimap (fromColumns . hreify) (fromColumns . hreify) .
149− fromColumns .
150− hunreify
151− SName ->
152− AHEither .
153− bimap (fromColumns . hreify) (fromColumns . hreify) .
154− fromColumns .
155− hunreify
156− SReify context ->
157− AHEither .
158− sbimapEither context (fromColumns . hreify) (fromColumns . hreify) .
159− sfromColumnsEither context .
160− hunreify
161−
162−
163−stoColumnsEither :: (Table (Reify context) a, Table (Reify context) b)
164− => SContext context
165− -> AHEither context a b
166− -> HEitherTable (Columns a) (Columns b) (Col (Reify context))
167−stoColumnsEither = \case
168− SAggregate ->
169− hreify .
170− toColumns .
171− bimap (hunreify . toColumns) (hunreify . toColumns) .
172− (\(AHEither a) -> a)
173− SExpr ->
174− hreify .
175− toColumns .
176− bimap (hunreify . toColumns) (hunreify . toColumns) .
177− (\(AHEither a) -> a)
178− SResult ->
179− hreify .
180− toColumns .
181− bimap (hunreify . toColumns) (hunreify . toColumns) .
182− (\(AHEither a) -> a)
183− SName ->
184− hreify .
185− toColumns .
186− bimap (hunreify . toColumns) (hunreify . toColumns) .
187− (\(AHEither a) -> a)
188− SReify context ->
189− hreify .
190− stoColumnsEither context .
191− sbimapEither context (hunreify . toColumns) (hunreify . toColumns) .
192− (\(AHEither a) -> a)
26+ HEither context = EitherTable context
src/Rel8/Column/Lift.hs+4−85
@@ -1,104 +1,23 @@
11{-# language DataKinds #-}
2−{-# language LambdaCase #-}
3−{-# language MultiParamTypeClasses #-}
4−{-# language ScopedTypeVariables #-}
52{-# language StandaloneKindSignatures #-}
6−{-# language TypeApplications #-}
73{-# language TypeFamilies #-}
84
95module Rel8.Column.Lift
10− ( Lift, ALift(..)
6+ ( Lift
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.Generic.Rel8able ( GColumns )
21−import Rel8.Kind.Context ( Reifiable(..), SContext(..) )
22−import Rel8.Schema.Context ( Col )
2315import qualified Rel8.Schema.Kind as K
24−import Rel8.Schema.Reify ( Reify, hreify, hunreify )
25−import Rel8.Schema.Result ( Result, absurd )
26−import Rel8.Table
27− ( Table, Columns, Context, fromColumns, toColumns
28− , Unreify, reify, unreify, coherence, congruence
29− )
30−import Rel8.Table.Rel8able ()
31−import Rel8.Table.HKD ( HKD( HKD ), HKDable, fromHKD, toHKD )
32−import Rel8.Table.Recontextualize ( Recontextualize )
16+import Rel8.Schema.Result ( Result )
17+import Rel8.Table.HKD ( HKD )
3318
3419
3520type Lift :: K.Context -> Type -> Type
3621type family Lift context a where
37− Lift (Reify context) a = ALift context a
3822 Lift Result a = a
3923 Lift context a = HKD a context
40−
41−
42−type ALift :: K.Context -> Type -> Type
43−newtype ALift context a = ALift
44− { unALift :: Lift context a
45− }
46−
47−
48−instance (Reifiable context, HKDable a) =>
49− Table (Reify context) (ALift context a)
50− where
51− type Context (ALift context a) = Reify context
52− type Columns (ALift context a) = GColumns (HKD a)
53− type Unreify (ALift context a) = Lift context a
54−
55− fromColumns = sfromColumnsLift contextSing
56− toColumns = stoColumnsLift contextSing
57− reify _ = ALift
58− unreify _ (ALift a) = a
59−
60− coherence = case contextSing @context of
61− SAggregate -> \Refl _ -> Refl
62− SExpr -> \Refl _ -> Refl
63− SName -> \Refl _ -> Refl
64− SResult -> \Refl -> absurd
65− SReify _ -> \Refl _ -> Refl
66−
67− congruence = case contextSing @context of
68− SAggregate -> \_ _ -> Refl
69− SExpr -> \_ _ -> Refl
70− SName -> \_ _ -> Refl
71− SResult -> \Refl -> absurd
72− SReify _ -> \_ _ -> Refl
73−
74−
75−instance (Reifiable context, Reifiable context', HKDable a) =>
76− Recontextualize
77− (Reify context)
78− (Reify context')
79− (ALift context a)
80− (ALift context' a)
81−
82−
83−sfromColumnsLift :: HKDable a
84− => SContext context
85− -> GColumns (HKD a) (Col (Reify context))
86− -> ALift context a
87−sfromColumnsLift = \case
88− SAggregate -> ALift . fromColumns . hunreify
89− SExpr -> ALift . fromColumns . hunreify
90− SName -> ALift . fromColumns . hunreify
91− SResult -> ALift . fromHKD . HKD . hunreify
92− SReify context -> ALift . sfromColumnsLift context . hunreify
93−
94−
95−stoColumnsLift :: HKDable a
96− => SContext context
97− -> ALift context a
98− -> GColumns (HKD a) (Col (Reify context))
99−stoColumnsLift = \case
100− SAggregate -> hreify . toColumns . unALift
101− SExpr -> hreify . toColumns . unALift
102− SName -> hreify . toColumns . unALift
103− SResult -> hreify . (\(HKD a) -> a) . toHKD . unALift
104− SReify context -> hreify . stoColumnsLift context . unALift
src/Rel8/Column/List.hs+5−152
@@ -1,172 +1,25 @@
11{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
3−{-# language LambdaCase #-}
4−{-# language MultiParamTypeClasses #-}
5−{-# language RankNTypes #-}
6−{-# language ScopedTypeVariables #-}
72{-# language StandaloneKindSignatures #-}
8−{-# language TypeApplications #-}
93{-# language TypeFamilyDependencies #-}
10−{-# language UndecidableInstances #-}
114
125module Rel8.Column.List
13− ( HList, AHList(..)
6+ ( HList
147 )
158where
169
1710-- base
18−import Control.Category ( id )
1911import Data.Kind ( Type )
20−import Data.Type.Equality ( (:~:)( Refl ), apply )
21−import Prelude hiding ( id )
12+import Prelude ()
2213
2314-- rel8
24−import Rel8.Aggregate ( Aggregate )
25−import Rel8.Expr ( Expr )
26−import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )
27−import Rel8.Schema.Context ( Col )
28−import Rel8.Schema.Context.Abstract ( exclusivity, virtualOrResult )
29−import Rel8.Schema.HTable.List ( HListTable )
3015import qualified Rel8.Schema.Kind as K
31−import Rel8.Schema.Name ( Name )
32−import Rel8.Schema.Reify ( Reify, hreify, hunreify )
33−import Rel8.Schema.Result ( Result, absurd )
34−import Rel8.Table
35− ( Table, Columns, Congruent, Context, fromColumns, toColumns
36− , Unreify, reify, unreify, coherence, congruence
37− )
38−import Rel8.Table.List ( ListTable( ListTable ) )
39−import Rel8.Table.Recontextualize ( Recontextualize )
16+import Rel8.Schema.Result ( Result )
17+import Rel8.Table.List ( ListTable )
4018
4119
4220-- | Nest a list within a 'Rel8able'. @HList f a@ will produce a 'ListTable'
4321-- @a@ in the 'Expr' context, and a @[a]@ in the 'Result' context.
4422type HList :: K.Context -> Type -> Type
4523type family HList context = list | list -> context where
46− HList (Reify context) = AHList context
47− HList Aggregate = ListTable Aggregate
48− HList Expr = ListTable Expr
49− HList Name = ListTable Name
5024 HList Result = []
51−
52−
53−type AHList :: K.Context -> Type -> Type
54−newtype AHList context a = AHList (HList context a)
55−
56−
57−instance (Reifiable context, Table (Reify context) a) =>
58− Table (Reify context) (AHList context a)
59− where
60− type Context (AHList context a) = Reify context
61− type Columns (AHList context a) = HListTable (Columns a)
62− type Unreify (AHList context a) = HList context (Unreify a)
63−
64− fromColumns = sfromColumnsList contextSing
65− toColumns = stoColumnsList contextSing
66−
67− reify _ = sreifyList contextSing
68− unreify _ = sunreifyList contextSing
69−
70− coherence = case contextSing @context of
71− SAggregate -> coherence @(Reify context) @a
72− SExpr -> coherence @(Reify context) @a
73− SName -> coherence @(Reify context) @a
74− SResult -> \Refl -> absurd
75− SReify _ -> \Refl _ -> Refl
76−
77− congruence proof@Refl abstract = case contextSing @context of
78− SAggregate -> id `apply` congruence @(Reify context) @a proof abstract
79− SExpr -> id `apply` congruence @(Reify context) @a proof abstract
80− SName -> id `apply` congruence @(Reify context) @a proof abstract
81− SResult -> absurd abstract
82− SReify _ -> id `apply` congruence @(Reify context) @a proof abstract
83−
84−
85−instance
86− ( Reifiable context, Reifiable context'
87− , Recontextualize (Reify context) (Reify context') a a'
88− )
89− => Recontextualize
90− (Reify context)
91− (Reify context')
92− (AHList context a)
93− (AHList context' a')
94−
95−
96−smapList :: Congruent a b
97− => SContext context
98− -> (a -> b)
99− -> (HListTable (Columns a) (Col (Context a)) -> HListTable (Columns b) (Col (Context b)))
100− -> AHList context a
101− -> AHList context b
102−smapList = \case
103− SAggregate -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
104− SExpr -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
105− SResult -> \f _ (AHList as) -> AHList (fmap f as)
106− SName -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
107− SReify context -> \f g (AHList as) -> AHList (smapList context f g as)
108−
109−
110−sfromColumnsList :: Table (Reify context) a
111− => SContext context
112− -> HListTable (Columns a) (Col (Reify context))
113− -> AHList context a
114−sfromColumnsList = \case
115− SAggregate -> AHList . ListTable
116− SExpr -> AHList . ListTable
117− SResult -> AHList . fmap (fromColumns . hreify) . fromColumns . hunreify
118− SName -> AHList . ListTable
119− SReify context ->
120− AHList .
121− smapList context (fromColumns . hreify) hreify .
122− sfromColumnsList context .
123− hunreify
124−
125−
126−stoColumnsList :: Table (Reify context) a
127− => SContext context
128− -> AHList context a
129− -> HListTable (Columns a) (Col (Reify context))
130−stoColumnsList = \case
131− SAggregate -> \(AHList (ListTable a)) -> a
132− SExpr -> \(AHList (ListTable a)) -> a
133− SResult ->
134− hreify . toColumns . fmap (hunreify . toColumns) . (\(AHList a) -> a)
135− SName -> \(AHList (ListTable a)) -> a
136− SReify context ->
137− hreify .
138− stoColumnsList context .
139− smapList context (hunreify . toColumns) hunreify .
140− (\(AHList a) -> a)
141−
142−
143−sreifyList :: forall context a. Table (Reify context) a
144− => SContext context
145− -> HList context (Unreify a)
146− -> AHList context a
147−sreifyList context = case virtualOrResult context of
148− Left Refl -> AHList . fmap (reify Refl)
149− Right virtual ->
150− case coherence @(Reify context) @a Refl abstract of
151− Refl -> case congruence @(Reify context) @a Refl abstract of
152− Refl ->
153− smapList context (reify Refl) hreify .
154− AHList
155− where
156− abstract = exclusivity virtual
157−
158−
159−sunreifyList :: forall context a. Table (Reify context) a
160− => SContext context
161− -> AHList context a
162− -> HList context (Unreify a)
163−sunreifyList context = case virtualOrResult context of
164− Left Refl -> fmap (unreify Refl) . (\(AHList a) -> a)
165− Right virtual ->
166− case coherence @(Reify context) @a Refl abstract of
167− Refl -> case congruence @(Reify context) @a Refl abstract of
168− Refl ->
169− (\(AHList a) -> a) .
170− smapList context (unreify Refl) hunreify
171− where
172− abstract = exclusivity virtual
25+ HList context = ListTable context
src/Rel8/Column/Maybe.hs+4−123
@@ -1,41 +1,20 @@
11{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
3−{-# language GADTs #-}
4−{-# language LambdaCase #-}
5−{-# language MultiParamTypeClasses #-}
6−{-# language ScopedTypeVariables #-}
72{-# language StandaloneKindSignatures #-}
8−{-# language TypeApplications #-}
93{-# language TypeFamilyDependencies #-}
10−{-# language UndecidableInstances #-}
114
125module Rel8.Column.Maybe
13− ( HMaybe, AHMaybe(..)
6+ ( HMaybe
147 )
158where
169
1710-- base
18−import Control.Category ( id )
1911import Data.Kind ( Type )
20−import Data.Type.Equality ( (:~:)( Refl ), apply )
21−import Prelude hiding ( id )
12+import Prelude
2213
2314-- rel8
24−import Rel8.Aggregate ( Aggregate )
25−import Rel8.Expr ( Expr )
26−import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )
27−import Rel8.Schema.Context ( Col )
28−import Rel8.Schema.HTable.Maybe ( HMaybeTable )
2915import qualified Rel8.Schema.Kind as K
30−import Rel8.Schema.Name ( Name )
31−import Rel8.Schema.Reify ( Reify, hreify, hunreify )
32−import Rel8.Schema.Result ( Result, absurd )
33−import Rel8.Table
34− ( Table, Columns, Context, fromColumns, toColumns
35− , Unreify, reify, unreify, coherence, congruence
36− )
16+import Rel8.Schema.Result ( Result )
3717import Rel8.Table.Maybe ( MaybeTable )
38−import Rel8.Table.Recontextualize ( Recontextualize )
3918
4019
4120-- | Nest a 'Maybe' value within a 'Rel8able'. @HMaybe f a@ will produce a
@@ -43,103 +22,5 @@ import Rel8.Table.Recontextualize ( Recontextualize )
4322-- context.
4423type HMaybe :: K.Context -> Type -> Type
4524type family HMaybe context = maybe | maybe -> context where
46− HMaybe (Reify context) = AHMaybe context
47− HMaybe Aggregate = MaybeTable Aggregate
48− HMaybe Expr = MaybeTable Expr
49− HMaybe Name = MaybeTable Name
5025 HMaybe Result = Maybe
51−
52−
53−type AHMaybe :: K.Context -> Type -> Type
54−newtype AHMaybe context a = AHMaybe (HMaybe context a)
55−
56−
57−instance Reifiable context => Functor (AHMaybe context) where
58− fmap = smapMaybe contextSing
59−
60−
61−instance (Reifiable context, Table (Reify context) a) =>
62− Table (Reify context) (AHMaybe context a)
63− where
64− type Context (AHMaybe context a) = Reify context
65− type Columns (AHMaybe context a) = HMaybeTable (Columns a)
66− type Unreify (AHMaybe context a) = HMaybe context (Unreify a)
67−
68− fromColumns = sfromColumnsMaybe contextSing
69− toColumns = stoColumnsMaybe contextSing
70− reify proof = fmap fmap reify proof . AHMaybe
71− unreify proof = (\(AHMaybe a) -> a) . fmap fmap unreify proof
72−
73− coherence = case contextSing @context of
74− SAggregate -> coherence @(Reify context) @a
75− SExpr -> coherence @(Reify context) @a
76− SName -> coherence @(Reify context) @a
77− SResult -> \Refl -> absurd
78− SReify _ -> \Refl _ -> Refl
79−
80− congruence proof@Refl abstract = case contextSing @context of
81− SAggregate -> id `apply` congruence @(Reify context) @a proof abstract
82− SExpr -> id `apply` congruence @(Reify context) @a proof abstract
83− SName -> id `apply` congruence @(Reify context) @a proof abstract
84− SResult -> absurd abstract
85− SReify _ -> id `apply` congruence @(Reify context) @a proof abstract
86−
87−
88−instance
89− ( Reifiable context, Reifiable context'
90− , Recontextualize (Reify context) (Reify context') a a'
91− )
92− => Recontextualize
93− (Reify context)
94− (Reify context')
95− (AHMaybe context a)
96− (AHMaybe context' a')
97−
98−
99−smapMaybe :: ()
100− => SContext context
101− -> (a -> b)
102− -> AHMaybe context a
103− -> AHMaybe context b
104−smapMaybe = \case
105− SAggregate -> \f (AHMaybe a) -> AHMaybe (fmap f a)
106− SExpr -> \f (AHMaybe a) -> AHMaybe (fmap f a)
107− SResult -> \f (AHMaybe a) -> AHMaybe (fmap f a)
108− SName -> \f (AHMaybe a) -> AHMaybe (fmap f a)
109− SReify context -> \f (AHMaybe a) -> AHMaybe (smapMaybe context f a)
110−
111−
112−sfromColumnsMaybe :: Table (Reify context) a
113− => SContext context
114− -> HMaybeTable (Columns a) (Col (Reify context))
115− -> AHMaybe context a
116−sfromColumnsMaybe = \case
117− SAggregate -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
118− SExpr -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
119− SResult -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
120− SName -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
121− SReify context ->
122− AHMaybe .
123− smapMaybe context (fromColumns . hreify) .
124− sfromColumnsMaybe context .
125− hunreify
126−
127−
128−stoColumnsMaybe :: Table (Reify context) a
129− => SContext context
130− -> AHMaybe context a
131− -> HMaybeTable (Columns a) (Col (Reify context))
132−stoColumnsMaybe = \case
133− SAggregate ->
134− hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
135− SExpr ->
136− hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
137− SResult ->
138− hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
139− SName ->
140− hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
141− SReify context ->
142− hreify .
143− stoColumnsMaybe context .
144− smapMaybe context (hunreify . toColumns) .
145− (\(AHMaybe a) -> a)
26+ HMaybe context = MaybeTable context
src/Rel8/Column/NonEmpty.hs+5−152
@@ -1,42 +1,21 @@
11{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
3−{-# language LambdaCase #-}
4−{-# language MultiParamTypeClasses #-}
5−{-# language ScopedTypeVariables #-}
62{-# language StandaloneKindSignatures #-}
7−{-# language TypeApplications #-}
83{-# language TypeFamilyDependencies #-}
9−{-# language UndecidableInstances #-}
104
115module Rel8.Column.NonEmpty
12− ( HNonEmpty, AHNonEmpty(..)
6+ ( HNonEmpty
137 )
148where
159
1610-- base
17−import Control.Category ( id )
1811import Data.Kind ( Type )
1912import Data.List.NonEmpty ( NonEmpty )
20−import Data.Type.Equality ( (:~:)( Refl ), apply )
21−import Prelude hiding ( id )
13+import Prelude ()
2214
2315-- rel8
24−import Rel8.Aggregate ( Aggregate )
25−import Rel8.Expr ( Expr )
26−import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )
27−import Rel8.Schema.Context ( Col )
28−import Rel8.Schema.Context.Abstract ( exclusivity, virtualOrResult )
29−import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
3016import qualified Rel8.Schema.Kind as K
31−import Rel8.Schema.Name ( Name )
32−import Rel8.Schema.Reify ( Reify, hreify, hunreify )
33−import Rel8.Schema.Result ( Result, absurd )
34−import Rel8.Table
35− ( Table, Columns, Congruent, Context, fromColumns, toColumns
36− , Unreify, reify, unreify, coherence, congruence
37− )
38−import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )
39−import Rel8.Table.Recontextualize ( Recontextualize )
17+import Rel8.Schema.Result ( Result )
18+import Rel8.Table.NonEmpty ( NonEmptyTable )
4019
4120
4221-- | Nest a 'NonEmpty' list within a 'Rel8able'. @HNonEmpty f a@ will produce a
@@ -44,131 +23,5 @@ import Rel8.Table.Recontextualize ( Recontextualize )
4423-- 'Result' context.
4524type HNonEmpty :: K.Context -> Type -> Type
4625type family HNonEmpty context = nonEmpty | nonEmpty -> context where
47− HNonEmpty (Reify context) = AHNonEmpty context
48− HNonEmpty Aggregate = NonEmptyTable Aggregate
49− HNonEmpty Expr = NonEmptyTable Expr
50− HNonEmpty Name = NonEmptyTable Name
5126 HNonEmpty Result = NonEmpty
52−
53−
54−type AHNonEmpty :: K.Context -> Type -> Type
55−newtype AHNonEmpty context a = AHNonEmpty (HNonEmpty context a)
56−
57−
58−instance (Reifiable context, Table (Reify context) a) =>
59− Table (Reify context) (AHNonEmpty context a)
60− where
61− type Context (AHNonEmpty context a) = Reify context
62− type Columns (AHNonEmpty context a) = HNonEmptyTable (Columns a)
63− type Unreify (AHNonEmpty context a) = HNonEmpty context (Unreify a)
64−
65− fromColumns = sfromColumnsNonEmpty contextSing
66− toColumns = stoColumnsNonEmpty contextSing
67−
68− reify _ = sreifyNonEmpty contextSing
69− unreify _ = sunreifyNonEmpty contextSing
70−
71− coherence = case contextSing @context of
72− SAggregate -> coherence @(Reify context) @a
73− SExpr -> coherence @(Reify context) @a
74− SName -> coherence @(Reify context) @a
75− SResult -> \Refl -> absurd
76− SReify _ -> \Refl _ -> Refl
77−
78− congruence proof@Refl abstract = case contextSing @context of
79− SAggregate -> id `apply` congruence @(Reify context) @a proof abstract
80− SExpr -> id `apply` congruence @(Reify context) @a proof abstract
81− SName -> id `apply` congruence @(Reify context) @a proof abstract
82− SResult -> absurd abstract
83− SReify _ -> id `apply` congruence @(Reify context) @a proof abstract
84−
85−
86−instance
87− ( Reifiable context, Reifiable context'
88− , Recontextualize (Reify context) (Reify context') a a'
89− )
90− => Recontextualize
91− (Reify context)
92− (Reify context')
93− (AHNonEmpty context a)
94− (AHNonEmpty context' a')
95−
96−
97−smapNonEmpty :: Congruent a b
98− => SContext context
99− -> (a -> b)
100− -> (HNonEmptyTable (Columns a) (Col (Context a)) -> HNonEmptyTable (Columns b) (Col (Context b)))
101− -> AHNonEmpty context a
102− -> AHNonEmpty context b
103−smapNonEmpty = \case
104− SAggregate -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
105− SExpr -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
106− SResult -> \f _ (AHNonEmpty as) -> AHNonEmpty (fmap f as)
107− SName -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
108− SReify context -> \f g (AHNonEmpty as) -> AHNonEmpty (smapNonEmpty context f g as)
109−
110−
111−sfromColumnsNonEmpty :: Table (Reify context) a
112− => SContext context
113− -> HNonEmptyTable (Columns a) (Col (Reify context))
114− -> AHNonEmpty context a
115−sfromColumnsNonEmpty = \case
116− SAggregate -> AHNonEmpty . NonEmptyTable
117− SExpr -> AHNonEmpty . NonEmptyTable
118− SResult ->
119− AHNonEmpty . fmap (fromColumns . hreify) . fromColumns . hunreify
120− SName -> AHNonEmpty . NonEmptyTable
121− SReify context ->
122− AHNonEmpty .
123− smapNonEmpty context (fromColumns . hreify) hreify .
124− sfromColumnsNonEmpty context .
125− hunreify
126−
127−
128−stoColumnsNonEmpty :: Table (Reify context) a
129− => SContext context
130− -> AHNonEmpty context a
131− -> HNonEmptyTable (Columns a) (Col (Reify context))
132−stoColumnsNonEmpty = \case
133− SAggregate -> \(AHNonEmpty (NonEmptyTable a)) -> a
134− SExpr -> \(AHNonEmpty (NonEmptyTable a)) -> a
135− SResult ->
136− hreify . toColumns . fmap (hunreify . toColumns) . (\(AHNonEmpty a) -> a)
137− SName -> \(AHNonEmpty (NonEmptyTable a)) -> a
138− SReify context ->
139− hreify .
140− stoColumnsNonEmpty context .
141− smapNonEmpty context (hunreify . toColumns) hunreify .
142− (\(AHNonEmpty a) -> a)
143−
144−
145−sreifyNonEmpty :: forall context a. Table (Reify context) a
146− => SContext context
147− -> HNonEmpty context (Unreify a)
148− -> AHNonEmpty context a
149−sreifyNonEmpty context = case virtualOrResult context of
150− Left Refl -> AHNonEmpty . fmap (reify Refl)
151− Right virtual ->
152− case coherence @(Reify context) @a Refl abstract of
153− Refl -> case congruence @(Reify context) @a Refl abstract of
154− Refl ->
155− smapNonEmpty context (reify Refl) hreify .
156− AHNonEmpty
157− where
158− abstract = exclusivity virtual
159−
160−
161−sunreifyNonEmpty :: forall context a. Table (Reify context) a
162− => SContext context
163− -> AHNonEmpty context a
164− -> HNonEmpty context (Unreify a)
165−sunreifyNonEmpty context = case virtualOrResult context of
166− Left Refl -> fmap (unreify Refl) . (\(AHNonEmpty a) -> a)
167− Right virtual ->
168− case coherence @(Reify context) @a Refl abstract of
169− Refl -> case congruence @(Reify context) @a Refl abstract of
170− Refl ->
171− (\(AHNonEmpty a) -> a) .
172− smapNonEmpty context (unreify Refl) hunreify
173− where
174− abstract = exclusivity virtual
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+4−171
@@ -1,42 +1,19 @@
11{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
3−{-# language GADTs #-}
4−{-# language LambdaCase #-}
5−{-# language MultiParamTypeClasses #-}
6−{-# language ScopedTypeVariables #-}
72{-# language StandaloneKindSignatures #-}
8−{-# language TypeApplications #-}
93{-# language TypeFamilyDependencies #-}
10−{-# language UndecidableInstances #-}
114
125module Rel8.Column.These
13− ( HThese, AHThese(..)
6+ ( HThese
147 )
158where
169
1710-- base
18−import Control.Applicative ( liftA2 )
19−import Control.Category ( id )
20−import Data.Bifunctor ( Bifunctor, bimap )
2111import Data.Kind ( Type )
22−import Data.Type.Equality ( (:~:)( Refl ), apply )
23−import Prelude hiding ( id )
12+import Prelude ()
2413
2514-- rel8
26−import Rel8.Aggregate ( Aggregate )
27−import Rel8.Expr ( Expr )
28−import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )
29−import Rel8.Schema.Context ( Col )
30−import Rel8.Schema.HTable.These ( HTheseTable )
3115import qualified Rel8.Schema.Kind as K
32−import Rel8.Schema.Name ( Name )
33−import Rel8.Schema.Reify ( Reify, hreify, hunreify )
34−import Rel8.Schema.Result ( Result, absurd )
35−import Rel8.Table
36− ( Table, Columns, Context, fromColumns, toColumns
37− , Unreify, reify, unreify, coherence, congruence
38− )
39−import Rel8.Table.Recontextualize ( Recontextualize )
16+import Rel8.Schema.Result ( Result )
4017import Rel8.Table.These ( TheseTable )
4118
4219-- these
@@ -48,149 +25,5 @@ import Data.These ( These )
4825-- 'Result' context.
4926type HThese :: K.Context -> Type -> Type -> Type
5027type family HThese context = these | these -> context where
51− HThese (Reify context) = AHThese context
52− HThese Aggregate = TheseTable Aggregate
53− HThese Expr = TheseTable Expr
54− HThese Name = TheseTable Name
5528 HThese Result = These
56−
57−
58−type AHThese :: K.Context -> Type -> Type -> Type
59−newtype AHThese context a b = AHThese (HThese context a b)
60−
61−
62−instance Reifiable context => Bifunctor (AHThese context) where
63− bimap = sbimapThese contextSing
64−
65−
66−instance Reifiable context => Functor (AHThese context a) where
67− fmap = bimap id
68−
69−
70−instance (Reifiable context, Table (Reify context) a, Table (Reify context) b)
71− => Table (Reify context) (AHThese context a b)
72− where
73− type Context (AHThese context a b) = Reify context
74− type Columns (AHThese context a b) = HTheseTable (Columns a) (Columns b)
75− type Unreify (AHThese context a b) = HThese context (Unreify a) (Unreify b)
76−
77− fromColumns = sfromColumnsThese contextSing
78− toColumns = stoColumnsThese contextSing
79− reify proof = liftA2 bimap reify reify proof . AHThese
80− unreify proof = (\(AHThese a) -> a) . liftA2 bimap unreify unreify proof
81−
82− coherence = case contextSing @context of
83− SAggregate -> coherence @(Reify context) @a
84− SExpr -> coherence @(Reify context) @a
85− SName -> coherence @(Reify context) @a
86− SResult -> \Refl -> absurd
87− SReify _ -> \Refl _ -> Refl
88−
89− congruence proof@Refl abstract = case contextSing @context of
90− SAggregate ->
91− id `apply`
92− congruence @(Reify context) @a proof abstract `apply`
93− congruence @(Reify context) @b proof abstract
94− SExpr ->
95− id `apply`
96− congruence @(Reify context) @a proof abstract `apply`
97− congruence @(Reify context) @b proof abstract
98− SName ->
99− id `apply`
100− congruence @(Reify context) @a proof abstract `apply`
101− congruence @(Reify context) @b proof abstract
102− SResult -> absurd abstract
103− SReify _ ->
104− id `apply`
105− congruence @(Reify context) @a proof abstract `apply`
106− congruence @(Reify context) @b proof abstract
107−
108−
109−instance
110− ( Reifiable context, Reifiable context'
111− , Recontextualize (Reify context) (Reify context') a a'
112− , Recontextualize (Reify context) (Reify context') b b'
113− ) =>
114− Recontextualize
115− (Reify context)
116− (Reify context')
117− (AHThese context a b)
118− (AHThese context' a' b')
119−
120−
121−sbimapThese :: ()
122− => SContext context
123− -> (a -> c)
124− -> (b -> d)
125− -> AHThese context a b
126− -> AHThese context c d
127−sbimapThese = \case
128− SAggregate -> \f g (AHThese a) -> AHThese (bimap f g a)
129− SExpr -> \f g (AHThese a) -> AHThese (bimap f g a)
130− SResult -> \f g (AHThese a) -> AHThese (bimap f g a)
131− SName -> \f g (AHThese a) -> AHThese (bimap f g a)
132− SReify context -> \f g (AHThese a) -> AHThese (sbimapThese context f g a)
133−
134−
135−sfromColumnsThese :: (Table (Reify context) a, Table (Reify context) b)
136− => SContext context
137− -> HTheseTable (Columns a) (Columns b) (Col (Reify context))
138− -> AHThese context a b
139−sfromColumnsThese = \case
140− SAggregate ->
141− AHThese .
142− bimap (fromColumns . hreify) (fromColumns . hreify) .
143− fromColumns .
144− hunreify
145− SExpr ->
146− AHThese .
147− bimap (fromColumns . hreify) (fromColumns . hreify) .
148− fromColumns .
149− hunreify
150− SResult ->
151− AHThese .
152− bimap (fromColumns . hreify) (fromColumns . hreify) .
153− fromColumns .
154− hunreify
155− SName ->
156− AHThese .
157− bimap (fromColumns . hreify) (fromColumns . hreify) .
158− fromColumns .
159− hunreify
160− SReify context ->
161− AHThese .
162− sbimapThese context (fromColumns . hreify) (fromColumns . hreify) .
163− sfromColumnsThese context .
164− hunreify
165−
166−
167−stoColumnsThese :: (Table (Reify context) a, Table (Reify context) b)
168− => SContext context
169− -> AHThese context a b
170− -> HTheseTable (Columns a) (Columns b) (Col (Reify context))
171−stoColumnsThese = \case
172− SAggregate ->
173− hreify .
174− toColumns .
175− bimap (hunreify . toColumns) (hunreify . toColumns) .
176− (\(AHThese a) -> a)
177− SExpr ->
178− hreify .
179− toColumns .
180− bimap (hunreify . toColumns) (hunreify . toColumns) .
181− (\(AHThese a) -> a)
182− SResult ->
183− hreify .
184− toColumns .
185− bimap (hunreify . toColumns) (hunreify . toColumns) .
186− (\(AHThese a) -> a)
187− SName ->
188− hreify .
189− toColumns .
190− bimap (hunreify . toColumns) (hunreify . toColumns) .
191− (\(AHThese a) -> a)
192− SReify context ->
193− hreify .
194− stoColumnsThese context .
195− sbimapThese context (hunreify . toColumns) (hunreify . toColumns) .
196− (\(AHThese a) -> a)
29+ HThese context = TheseTable context
src/Rel8/Expr.hs+16−43
@@ -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( E, unE )
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.HTable.Identity ( HIdentity( HType ), HType )
35+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
36+import qualified Rel8.Schema.Kind as K
4337import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
44−import Rel8.Schema.Reify ( notReify )
45−import Rel8.Schema.Result ( Result )
46−import Rel8.Schema.Spec ( Spec( Spec ) )
4738import Rel8.Table
4839 ( Table, Columns, Context, fromColumns, toColumns
49− , reify, unreify, coherence, congruence
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,27 +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− E :: {unE :: !(Expr a)} -> Col Expr ('Spec 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 (E a)
139− fromColumns (HType (E a)) = a
140− reify = notReify
141− unreify = notReify
142− coherence = notReify
143− congruence = notReify
144−
145−
146−instance Sql DBType a => Recontextualize Expr Expr (Expr a) (Expr a)
147−
148−
149−instance Sql DBType a => Recontextualize Expr Result (Expr a) (Identity a)
150−
151−
152−instance Sql DBType a => Recontextualize Result Expr (Identity a) (Expr a)
122+ toColumns a = HIdentity a
123+ fromColumns (HIdentity a) = a
124+ toResult a = HIdentity (Identity a)
125+ fromResult (HIdentity (Identity a)) = a
src/Rel8/Expr.hs-boot+6−8
@@ -1,6 +1,4 @@
1−{-# language GADTs #-}
2−{-# language PolyKinds #-}
3−{-# language RoleAnnotations #-}
1+{-# language DataKinds #-}
42{-# language StandaloneKindSignatures #-}
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+25−64
@@ -10,6 +10,7 @@ module Rel8.Expr.Aggregate
1010 , and, or
1111 , min, max
1212 , sum, sumWhere
13+ , avg
1314 , stringAgg
1415 , groupByExpr
1516 , listAggExpr, nonEmptyAggExpr
@@ -23,10 +24,12 @@ import Data.List.NonEmpty ( NonEmpty )
2324import Prelude hiding ( and, max, min, null, or, sum )
2425
2526-- opaleye
26−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
27+import qualified Opaleye.Internal.Aggregate as Opaleye
28+import Opaleye.Internal.Column ( Field_( Column ) )
29+import qualified Opaleye.Aggregate as Opaleye
2730
2831-- rel8
29−import Rel8.Aggregate ( Aggregate, Aggregator(..), unsafeMakeAggregate )
32+import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )
3033import Rel8.Expr ( Expr )
3134import Rel8.Expr.Bool ( caseExpr )
3235import Rel8.Expr.Opaleye
@@ -50,23 +53,13 @@ import Rel8.Type.Sum ( DBSum )
5053
5154-- | Count the occurances of a single column. Corresponds to @COUNT(a)@
5255count :: Expr a -> Aggregate Int64
53−count = unsafeMakeAggregate toPrimExpr fromPrimExpr $
54− Just Aggregator
55− { operation = Opaleye.AggrCount
56− , ordering = []
57− , distinction = Opaleye.AggrAll
58− }
59−
56+count = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.count
6057
6158-- | Count the number of distinct occurances of a single column. Corresponds to
6259-- @COUNT(DISTINCT a)@
6360countDistinct :: Sql DBEq a => Expr a -> Aggregate Int64
6461countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $
65− Just Aggregator
66− { operation = Opaleye.AggrCount
67− , ordering = []
68− , distinction = Opaleye.AggrDistinct
69− }
62+ Opaleye.distinctAggregator Opaleye.count
7063
7164
7265-- | Corresponds to @COUNT(*)@.
@@ -81,56 +74,39 @@ countWhere condition = count (caseExpr [(condition, litExpr (Just True))] null)
8174
8275-- | Corresponds to @bool_and@.
8376and :: Expr Bool -> Aggregate Bool
84−and = unsafeMakeAggregate toPrimExpr fromPrimExpr $
85− Just Aggregator
86− { operation = Opaleye.AggrBoolAnd
87− , ordering = []
88− , distinction = Opaleye.AggrAll
89− }
77+and = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolAnd
9078
9179
9280-- | Corresponds to @bool_or@.
9381or :: Expr Bool -> Aggregate Bool
94−or = unsafeMakeAggregate toPrimExpr fromPrimExpr $
95− Just Aggregator
96− { operation = Opaleye.AggrBoolOr
97− , ordering = []
98− , distinction = Opaleye.AggrAll
99− }
82+or = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolOr
10083
10184
10285-- | Produce an aggregation for @Expr a@ using the @max@ function.
10386max :: Sql DBMax a => Expr a -> Aggregate a
104−max = unsafeMakeAggregate toPrimExpr fromPrimExpr $
105− Just Aggregator
106− { operation = Opaleye.AggrMax
107− , ordering = []
108− , distinction = Opaleye.AggrAll
109− }
87+max = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMax
11088
11189
11290-- | Produce an aggregation for @Expr a@ using the @max@ function.
11391min :: Sql DBMin a => Expr a -> Aggregate a
114−min = unsafeMakeAggregate toPrimExpr fromPrimExpr $
115− Just Aggregator
116− { operation = Opaleye.AggrMin
117− , ordering = []
118− , distinction = Opaleye.AggrAll
119− }
92+min = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMin
12093
12194-- | Corresponds to @sum@. Note that in SQL, @sum@ is type changing - for
12295-- example the @sum@ of @integer@ returns a @bigint@. Rel8 doesn't support
123−-- this, and will add explicit cast back to the original input type. This can
96+-- this, and will add explicit casts back to the original input type. This can
12497-- lead to overflows, and if you anticipate very large sums, you should upcast
12598-- your input.
12699sum :: Sql DBSum a => Expr a -> Aggregate a
127−sum = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $
128− Just Aggregator
129− { operation = Opaleye.AggrSum
130− , ordering = []
131− , distinction = Opaleye.AggrAll
132− }
100+sum = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) Opaleye.unsafeSum
101+
133102
103+-- | Corresponds to @avg@. Note that in SQL, @avg@ is type changing - for
104+-- example, the @avg@ of @integer@ returns a @numeric@. Rel8 doesn't support
105+-- this, and will add explicit casts back to the original input type. If you
106+-- need a fractional result on an integral column, you should cast your input
107+-- to 'Double' or 'Data.Scientific.Scientific' before calling 'avg'.
108+avg :: Sql DBSum a => Expr a -> Aggregate a
109+avg = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) Opaleye.unsafeAvg
134110
135111-- | Take the sum of all expressions that satisfy a predicate.
136112sumWhere :: (Sql DBNum a, Sql DBSum a)
@@ -142,17 +118,12 @@ sumWhere condition a = sum (caseExpr [(condition, a)] 0)
142118stringAgg :: Sql DBString a
143119 => Expr db -> Expr a -> Aggregate a
144120stringAgg delimiter =
145− unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $
146− Just Aggregator
147− { operation = Opaleye.AggrStringAggr (toPrimExpr delimiter)
148− , ordering = []
149− , distinction = Opaleye.AggrAll
150− }
121+ unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) (Opaleye.stringAgg (Column (toPrimExpr delimiter)))
151122
152123
153124-- | Aggregate a value by grouping by it.
154125groupByExpr :: Sql DBEq a => Expr a -> Aggregate a
155−groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Nothing
126+groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.groupBy
156127
157128
158129-- | Collect expressions values as a list.
@@ -167,23 +138,13 @@ nonEmptyAggExpr = snonEmptyAggExpr typeInformation
167138
168139slistAggExpr :: ()
169140 => TypeInformation (Unnullify a) -> Expr a -> Aggregate [a]
170−slistAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just
171− Aggregator
172− { operation = Opaleye.AggrArr
173− , ordering = []
174− , distinction = Opaleye.AggrAll
175− }
141+slistAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg
176142 where
177143 to = encodeArrayElement info . toPrimExpr
178144
179145
180146snonEmptyAggExpr :: ()
181147 => TypeInformation (Unnullify a) -> Expr a -> Aggregate (NonEmpty a)
182−snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just
183− Aggregator
184− { operation = Opaleye.AggrArr
185− , ordering = []
186− , distinction = Opaleye.AggrAll
187− }
148+snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg
188149 where
189150 to = encodeArrayElement info . toPrimExpr
src/Rel8/Expr/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+12−3
@@ -10,7 +10,7 @@ module Rel8.Expr.Opaleye
1010 , scastExpr, sunsafeCastExpr
1111 , unsafeLiteral
1212 , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith, traversePrimExpr
13− , toColumn, fromColumn
13+ , toColumn, fromColumn, traverseFieldP
1414 )
1515where
1616
@@ -27,6 +27,9 @@ import Rel8.Schema.Null ( Unnullify, Sql )
2727import Rel8.Type ( DBType, typeInformation )
2828import Rel8.Type.Information ( TypeInformation(..) )
2929
30+-- profunctors
31+import Data.Profunctor ( Profunctor, dimap )
32+
3033
3134castExpr :: Sql DBType a => Expr a -> Expr a
3235castExpr = scastExpr typeInformation
@@ -80,9 +83,15 @@ traversePrimExpr :: Functor f
8083traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr
8184
8285
83−toColumn :: Opaleye.PrimExpr -> Opaleye.Column b
86+traverseFieldP :: Profunctor p
87+ => p (Opaleye.Field_ n x) (Opaleye.Field_ m y)
88+ -> p (Expr a) (Expr b)
89+traverseFieldP = dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn)
90+
91+
92+toColumn :: Opaleye.PrimExpr -> Opaleye.Field_ n b
8493toColumn = Opaleye.Column
8594
8695
87−fromColumn :: Opaleye.Column b -> Opaleye.PrimExpr
96+fromColumn :: Opaleye.Field_ n b -> Opaleye.PrimExpr
8897fromColumn (Opaleye.Column a) = a
src/Rel8/Expr/Sequence.hs+2−1
@@ -11,6 +11,7 @@ import Prelude
1111import Rel8.Expr ( Expr )
1212import Rel8.Expr.Function ( function )
1313import Rel8.Expr.Serialize ( litExpr )
14+import Rel8.Expr.Text ( quoteIdent )
1415
1516-- text
1617import Data.Text ( pack )
@@ -18,4 +19,4 @@ import Data.Text ( pack )
1819
1920-- | See https://www.postgresql.org/docs/current/functions-sequence.html
2021nextval :: String -> Expr Int64
21−nextval = function "nextval" . litExpr . pack
22+nextval = function "nextval" . quoteIdent . litExpr . pack
src/Rel8/Expr/Text.hs+23−2
@@ -17,6 +17,9 @@ module Rel8.Expr.Text
1717 , pgClientEncoding, quoteIdent, quoteLiteral, quoteNullable, regexpReplace
1818 , regexpSplitToArray, repeat, replace, reverse, right, rpad, rtrim
1919 , splitPart, strpos, substr, translate
20+
21+ -- * @LIKE@ and @ILIKE@
22+ , like, ilike
2023 )
2124where
2225
@@ -24,7 +27,7 @@ where
2427import Data.Bool ( Bool )
2528import Data.Int ( Int32 )
2629import Data.Maybe ( Maybe( Nothing, Just ) )
27−import Prelude ()
30+import Prelude ( flip )
2831
2932-- bytestring
3033import Data.ByteString ( ByteString )
@@ -49,7 +52,7 @@ infixr 6 ++.
4952
5053
5154-- | Matches regular expression, case sensitive
52−--
55+--
5356-- Corresponds to the @~.@ operator.
5457(~.) :: Expr Text -> Expr Text -> Expr Bool
5558(~.) = binaryOperator "~."
@@ -273,3 +276,21 @@ substr a b Nothing = function "substr" a b
273276-- | Corresponds to the @translate@ function.
274277translate :: Expr Text -> Expr Text -> Expr Text -> Expr Text
275278translate = function "translate"
279+
280+
281+-- | @like x y@ corresponds to the expression @y LIKE x@.
282+--
283+-- Note that the arguments to @like@ are swapped. This is to aid currying, so
284+-- you can write expressions like
285+-- @filter (like "Rel%" . packageName) =<< each haskellPackages@
286+like :: Expr Text -> Expr Text -> Expr Bool
287+like = flip (binaryOperator "LIKE")
288+
289+
290+-- | @ilike x y@ corresponds to the expression @y ILIKE x@.
291+--
292+-- Note that the arguments to @ilike@ are swapped. This is to aid currying, so
293+-- you can write expressions like
294+-- @filter (ilike "Rel%" . packageName) =<< each haskellPackages@
295+ilike :: Expr Text -> Expr Text -> Expr Bool
296+ilike = flip (binaryOperator "ILIKE")
src/Rel8/Expr/Window.hsnew file+121
@@ -0,0 +1,121 @@
1+module Rel8.Expr.Window
2+ ( cumulative
3+ , rowNumber
4+ , rank
5+ , denseRank
6+ , percentRank
7+ , cumeDist
8+ , ntile
9+ , lag
10+ , lead
11+ , firstValue
12+ , lastValue
13+ , nthValue
14+ )
15+where
16+
17+-- base
18+import Data.Int ( Int32, Int64 )
19+import Prelude
20+
21+-- opaleye
22+import qualified Opaleye.Internal.Aggregate as Opaleye
23+import qualified Opaleye.Internal.PackMap as Opaleye
24+import qualified Opaleye.Internal.Window as Opaleye
25+import qualified Opaleye.Window as Opaleye
26+
27+-- profunctors
28+import Data.Profunctor (dimap)
29+
30+-- rel8
31+import Rel8.Aggregate ( Aggregate( Aggregate ) )
32+import Rel8.Expr ( Expr )
33+import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr, toColumn, toPrimExpr )
34+import Rel8.Schema.Null ( Nullify )
35+import Rel8.Window ( Window( Window ) )
36+
37+
38+cumulative :: (a -> Aggregate b) -> Window a (Expr b)
39+cumulative f =
40+ fromWindowFunction $ Opaleye.aggregatorWindowFunction (fromAggregate f) id
41+
42+
43+-- | [@row_number()@](https://www.postgresql.org/docs/current/functions-window.html)
44+rowNumber :: Window a (Expr Int64)
45+rowNumber = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.rowNumber
46+
47+
48+-- | [@rank()@](https://www.postgresql.org/docs/current/functions-window.html)
49+rank :: Window a (Expr Int64)
50+rank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.rank
51+
52+
53+-- | [@dense_rank()@](https://www.postgresql.org/docs/current/functions-window.html)
54+denseRank :: Window a (Expr Int64)
55+denseRank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.denseRank
56+
57+
58+-- | [@percent_rank()@](https://www.postgresql.org/docs/current/functions-window.html)
59+percentRank :: Window a (Expr Double)
60+percentRank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.percentRank
61+
62+
63+-- | [@cume_dist()@](https://www.postgresql.org/docs/current/functions-window.html)
64+cumeDist :: Window a (Expr Double)
65+cumeDist = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.cumeDist
66+
67+
68+-- | [@ntile(num_buckets)@](https://www.postgresql.org/docs/current/functions-window.html)
69+ntile :: Expr Int32 -> Window a (Expr Int32)
70+ntile buckets = fromWindowFunction $ fromPrimExpr . fromColumn <$>
71+ Opaleye.ntile (toColumn (toPrimExpr buckets))
72+
73+
74+-- | [@lag(value, offset, default)@](https://www.postgresql.org/docs/current/functions-window.html)
75+lag :: Expr Int32 -> Expr a -> Window (Expr a) (Expr a)
76+lag offset def =
77+ fromWindowFunction $
78+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $
79+ Opaleye.lag (toColumn (toPrimExpr offset)) (toColumn (toPrimExpr def))
80+
81+
82+-- | [@lead(value, offset, default)@](https://www.postgresql.org/docs/current/functions-window.html)
83+lead :: Expr Int32 -> Expr a -> Window (Expr a) (Expr a)
84+lead offset def =
85+ fromWindowFunction $
86+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $
87+ Opaleye.lead (toColumn (toPrimExpr offset)) (toColumn (toPrimExpr def))
88+
89+
90+-- | [@first_value(value)@](https://www.postgresql.org/docs/current/functions-window.html)
91+firstValue :: Window (Expr a) (Expr a)
92+firstValue =
93+ fromWindowFunction $
94+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn)
95+ Opaleye.firstValue
96+
97+
98+-- | [@last_value(value)@](https://www.postgresql.org/docs/current/functions-window.html)
99+lastValue :: Window (Expr a) (Expr a)
100+lastValue =
101+ fromWindowFunction $
102+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn)
103+ Opaleye.lastValue
104+
105+
106+-- | [@nth_value(value, n)@](https://www.postgresql.org/docs/current/functions-window.html)
107+nthValue :: Expr Int32 -> Window (Expr a) (Expr (Nullify a))
108+nthValue n =
109+ fromWindowFunction $
110+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $
111+ Opaleye.nthValue (toColumn (toPrimExpr n))
112+
113+
114+fromAggregate :: (a -> Aggregate b) -> Opaleye.Aggregator a (Expr b)
115+fromAggregate f = Opaleye.Aggregator $ Opaleye.PackMap $ \w a -> case f a of
116+ Aggregate (Opaleye.Aggregator (Opaleye.PackMap x)) -> x w ()
117+
118+
119+fromWindowFunction :: Opaleye.WindowFunction a b -> Window a b
120+fromWindowFunction (Opaleye.WindowFunction (Opaleye.PackMap w)) =
121+ Window $ Opaleye.Windows $ Opaleye.PackMap $ \f -> w $ \o -> f (o, mempty)
src/Rel8/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/Coherence.hsdeleted−79
@@ -1,79 +0,0 @@
1−{-# language AllowAmbiguousTypes #-}
2−{-# language DataKinds #-}
3−{-# language FlexibleInstances #-}
4−{-# language MultiParamTypeClasses #-}
5−{-# language PolyKinds #-}
6−{-# language RankNTypes #-}
7−{-# language ScopedTypeVariables #-}
8−{-# language StandaloneKindSignatures #-}
9−{-# language TypeApplications #-}
10−{-# language TypeFamilies #-}
11−{-# language TypeOperators #-}
12−{-# language UndecidableInstances #-}
13−
14−module Rel8.Generic.Coherence
15− ( GCoherent
16− , gcoherence
17− , gcongruence
18− )
19−where
20−
21−-- base
22−import Control.Category ( id )
23−import Data.Kind ( Constraint, Type )
24−import Data.Proxy ( Proxy( Proxy ) )
25−import Data.Type.Equality ( (:~:), apply )
26−import GHC.Generics ( (:*:), K1, M1, Meta( MetaSel ), C, D, S )
27−import Prelude hiding ( id )
28−
29−-- rel8
30−import Rel8.FCF ( Eval, Exp )
31−import Rel8.Generic.Map ( GMap )
32−import Rel8.Generic.Table.Record ( GColumns, GContext )
33−
34−
35−type GCoherent :: (Type -> Exp Constraint) -> (Type -> Type) -> Constraint
36−class GCoherent _Table rep where
37− gcoherence :: ()
38− => proxy _Context
39− -> proxy' f
40− -> (forall a proxy_. Eval (_Table a)
41− => proxy_ a -> Eval (_Context (Eval (f a))) :~: context)
42− -> GContext _Context (GMap f rep) :~: context
43−
44− gcongruence :: ()
45− => proxy _Columns
46− -> proxy' f
47− -> (forall a proxy_. Eval (_Table a)
48− => proxy_ a -> Eval (_Columns a) :~: Eval (_Columns (Eval (f a))))
49− -> GColumns _Columns rep :~: GColumns _Columns (GMap f rep)
50−
51−
52−instance GCoherent _Table rep => GCoherent _Table (M1 D c rep) where
53− gcoherence = gcoherence @_Table @rep
54− gcongruence = gcongruence @_Table @rep
55−
56−
57−instance GCoherent _Table rep => GCoherent _Table (M1 C c rep) where
58− gcoherence = gcoherence @_Table @rep
59− gcongruence = gcongruence @_Table @rep
60−
61−
62−instance (GCoherent _Table rep1, GCoherent _Table rep2) =>
63− GCoherent _Table (rep1 :*: rep2)
64− where
65− gcoherence = gcoherence @_Table @rep1
66− gcongruence _Columns f proof = id `apply`
67− gcongruence @_Table @rep1 _Columns f proof `apply`
68− gcongruence @_Table @rep2 _Columns f proof
69−
70−
71−instance
72− ( Eval (_Table a)
73− , meta ~ 'MetaSel ('Just _l) _su _ss _ds
74− , k1 ~ K1 i a
75− )
76− => GCoherent _Table (M1 S meta k1)
77− where
78− gcoherence _ _ proof = proof (Proxy @a)
79− gcongruence _ _ proof = id `apply` proof (Proxy @a)
src/Rel8/Generic/Construction.hs+145−163
@@ -2,8 +2,6 @@
22{-# language ConstraintKinds #-}
33{-# language DataKinds #-}
44{-# language FlexibleContexts #-}
5−{-# language FlexibleInstances #-}
6−{-# language MultiParamTypeClasses #-}
75{-# language NamedFieldPuns #-}
86{-# language ScopedTypeVariables #-}
97{-# language StandaloneKindSignatures #-}
@@ -27,18 +25,17 @@ where
2725import Data.Bifunctor ( first )
2826import Data.Kind ( Constraint, Type )
2927import Data.List.NonEmpty ( NonEmpty( (:|) ) )
30−import Data.Type.Equality ( (:~:)( Refl ) )
3128import GHC.TypeLits ( Symbol )
3229import Prelude
3330
3431-- rel8
35−import Rel8.Aggregate ( Col( A ), Aggregate( Aggregate ) )
36−import Rel8.Expr ( Col( E ), 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 ( Eval, Exp )
38+import Rel8.FCF ( Eval, Exp, Id )
4239import Rel8.Generic.Construction.ADT
4340 ( GConstructorADT, GMakeableADT, gmakeADT
4441 , GConstructableADT
@@ -60,16 +57,14 @@ import Rel8.Kind.Algebra
6057import qualified Rel8.Kind.Algebra as K
6158import Rel8.Schema.Context.Nullify ( sguard, snullify )
6259import Rel8.Schema.HTable ( HTable )
63−import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )
60+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
6461import qualified Rel8.Schema.Kind as K
65−import Rel8.Schema.Name ( Col( N ), Name( Name ) )
62+import Rel8.Schema.Name ( Name( Name ) )
6663import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
67−import Rel8.Schema.Spec ( SSpec( SSpec, 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 )
@@ -78,10 +73,10 @@ import Rel8.Type.Tag ( Tag )
7873type GGBuildable :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Constraint
7974type GGBuildable algebra name rep =
8075 ( KnownAlgebra algebra
81− , Eval (GGColumns algebra TColumns (Eval (rep (Reify Aggregate)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))
82− , Eval (GGColumns algebra TColumns (Eval (rep (Reify Expr)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))
83− , Eval (GGColumns algebra TColumns (Eval (rep (Reify Name)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))
84− , HTable (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))))
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))))
8580 , GGBuildable' algebra name rep
8681 )
8782
@@ -89,65 +84,63 @@ type GGBuildable algebra name rep =
8984type GGBuildable' :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Constraint
9085type family GGBuildable' algebra name rep where
9186 GGBuildable' 'K.Product name rep =
92− ( name ~ GConstructor (Eval (rep (Reify Expr)))
93− , Representable TUnreify (Eval (rep (Reify Expr)))
94− , GConstructable (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) (Eval (rep (Reify Expr)))
87+ ( name ~ GConstructor (Eval (rep Expr))
88+ , Representable Id (Eval (rep Expr))
89+ , GConstructable (TTable Expr) TColumns Id Expr (Eval (rep Expr))
9590 )
9691 GGBuildable' 'K.Sum name rep =
97− ( Representable TUnreify (GConstructorADT name (Eval (rep (Reify Expr))))
98− , GMakeableADT (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) name (Eval (rep (Reify Expr)))
92+ ( Representable Id (GConstructorADT name (Eval (rep Expr)))
93+ , GMakeableADT (TTable Expr) TColumns Id Expr name (Eval (rep Expr))
9994 )
10095
10196
10297type GGBuild :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Type -> Type
10398type family GGBuild algebra name rep r where
10499 GGBuild 'K.Product _name rep r =
105− GConstruct TUnreify (Eval (rep (Reify Expr))) r
100+ GConstruct Id (Eval (rep Expr)) r
106101 GGBuild 'K.Sum name rep r =
107− GConstruct TUnreify (GConstructorADT name (Eval (rep (Reify Expr)))) r
102+ GConstruct Id (GConstructorADT name (Eval (rep Expr))) r
108103
109104
110105ggbuild :: forall algebra name rep a. GGBuildable algebra name rep
111− => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr) -> a)
106+ => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a)
112107 -> GGBuild algebra name rep a
113108ggbuild gfromColumns = case algebraSing @algebra of
114109 SProduct ->
115− gtabulate @TUnreify @(Eval (rep (Reify Expr))) @a $
110+ gtabulate @Id @(Eval (rep Expr)) @a $
116111 gfromColumns .
117− hunreify .
118112 gconstruct
119− @(TTable (Reify Expr))
113+ @(TTable Expr)
120114 @TColumns
121− @TUnreify
122− @(Col (Reify Expr))
123− @(Eval (rep (Reify Expr)))
124− (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
115+ @Id
116+ @Expr
117+ @(Eval (rep Expr))
118+ (const toColumns)
125119 SSum ->
126− gtabulate @TUnreify @(GConstructorADT name (Eval (rep (Reify Expr)))) @a $
120+ gtabulate @Id @(GConstructorADT name (Eval (rep Expr))) @a $
127121 gfromColumns .
128− hunreify .
129122 gmakeADT
130− @(TTable (Reify Expr))
123+ @(TTable Expr)
131124 @TColumns
132− @TUnreify
133− @(Col (Reify Expr))
125+ @Id
126+ @Expr
134127 @name
135− @(Eval (rep (Reify Expr)))
136− (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
137− (\SSpec {info} -> Reify (E (snull info)))
138− (\SSpec {nullity} -> case nullity of
128+ @(Eval (rep Expr))
129+ (const toColumns)
130+ (\Spec {info} -> snull info)
131+ (\Spec {nullity} -> case nullity of
139132 Null -> id
140− NotNull -> \(Reify (E a)) -> Reify (E (nullify a)))
141− (HType . Reify . E . litExpr)
133+ NotNull -> nullify)
134+ (HIdentity . litExpr)
142135
143136
144137type GGConstructable :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint
145138type GGConstructable algebra rep =
146139 ( KnownAlgebra algebra
147− , Eval (GGColumns algebra TColumns (Eval (rep (Reify Aggregate)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))
148− , Eval (GGColumns algebra TColumns (Eval (rep (Reify Expr)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))
149− , Eval (GGColumns algebra TColumns (Eval (rep (Reify Name)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))
150− , 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))))
151144 , GGConstructable' algebra rep
152145 )
153146
@@ -155,105 +148,100 @@ type GGConstructable algebra rep =
155148type GGConstructable' :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint
156149type family GGConstructable' algebra rep where
157150 GGConstructable' 'K.Product rep =
158− ( Representable TUnreify (Eval (rep (Reify Aggregate)))
159− , Representable TUnreify (Eval (rep (Reify Expr)))
160− , Representable TUnreify (Eval (rep (Reify Name)))
161− , GConstructable (TTable (Reify Aggregate)) TColumns TUnreify (Col (Reify Aggregate)) (Eval (rep (Reify Aggregate)))
162− , GConstructable (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) (Eval (rep (Reify Expr)))
163− , 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))
164157 )
165158 GGConstructable' 'K.Sum rep =
166− ( RepresentableConstructors TUnreify (Eval (rep (Reify Expr)))
167− , RepresentableFields TUnreify (Eval (rep (Reify Aggregate)))
168− , RepresentableFields TUnreify (Eval (rep (Reify Expr)))
169− , RepresentableFields TUnreify (Eval (rep (Reify Name)))
170− , Functor (GConstructors TUnreify (Eval (rep (Reify Expr))))
171− , GConstructableADT (TTable (Reify Aggregate)) TColumns TUnreify (Col (Reify Aggregate)) (Eval (rep (Reify Aggregate)))
172− , GConstructableADT (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) (Eval (rep (Reify Expr)))
173− , 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))
174167 )
175168
176169
177170type GGConstruct :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type
178171type family GGConstruct algebra rep r where
179− GGConstruct 'K.Product rep r =
180− GConstruct TUnreify (Eval (rep (Reify Expr))) r -> r
181− GGConstruct 'K.Sum rep r =
182− GConstructADT TUnreify (Eval (rep (Reify Expr))) r r
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
183174
184175
185176ggconstruct :: forall algebra rep a. GGConstructable algebra rep
186− => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr) -> a)
177+ => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a)
187178 -> GGConstruct algebra rep a -> a
188179ggconstruct gfromColumns f = case algebraSing @algebra of
189180 SProduct ->
190181 f $
191− gtabulate @TUnreify @(Eval (rep (Reify Expr))) @a $
182+ gtabulate @Id @(Eval (rep Expr)) @a $
192183 gfromColumns .
193− hunreify .
194184 gconstruct
195− @(TTable (Reify Expr))
185+ @(TTable Expr)
196186 @TColumns
197− @TUnreify
198− @(Col (Reify Expr))
199− @(Eval (rep (Reify Expr)))
200− (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
187+ @Id
188+ @Expr
189+ @(Eval (rep Expr))
190+ (const toColumns)
201191 SSum ->
202− gcindex @TUnreify @(Eval (rep (Reify Expr))) @a f $
203− fmap (gfromColumns . hunreify) $
192+ gcindex @Id @(Eval (rep Expr)) @a f $
193+ fmap gfromColumns $
204194 gconstructADT
205− @(TTable (Reify Expr))
195+ @(TTable Expr)
206196 @TColumns
207− @TUnreify
208− @(Col (Reify Expr))
209− @(Eval (rep (Reify Expr)))
210− (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
211− (\SSpec {info} -> Reify (E (snull info)))
212− (\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
213203 Null -> id
214− NotNull -> \(Reify (E a)) -> Reify (E (nullify a)))
215− (HType . Reify . E . litExpr)
204+ NotNull -> nullify)
205+ (HIdentity . litExpr)
216206
217207
218208type GGDeconstruct :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type -> Type
219209type family GGDeconstruct algebra rep a r where
220210 GGDeconstruct 'K.Product rep a r =
221− GConstruct TUnreify (Eval (rep (Reify Expr))) r -> a -> r
211+ GConstruct Id (Eval (rep Expr)) r -> a -> r
222212 GGDeconstruct 'K.Sum rep a r =
223− GConstructADT TUnreify (Eval (rep (Reify Expr))) r (a -> r)
213+ GConstructADT Id (Eval (rep Expr)) r (a -> r)
224214
225215
226216ggdeconstruct :: forall algebra rep a r. (GGConstructable algebra rep, Table Expr r)
227− => (a -> Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr))
217+ => (a -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)
228218 -> GGDeconstruct algebra rep a r
229219ggdeconstruct gtoColumns = case algebraSing @algebra of
230220 SProduct -> \build ->
231− gindex @TUnreify @(Eval (rep (Reify Expr))) @r build .
221+ gindex @Id @(Eval (rep Expr)) @r build .
232222 gdeconstruct
233− @(TTable (Reify Expr))
223+ @(TTable Expr)
234224 @TColumns
235− @TUnreify
236− @(Col (Reify Expr))
237− @(Eval (rep (Reify Expr)))
238− (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns) .
239− hreify .
225+ @Id
226+ @Expr
227+ @(Eval (rep Expr))
228+ (const fromColumns) .
240229 gtoColumns
241230 SSum ->
242− gctabulate @TUnreify @(Eval (rep (Reify Expr))) @r @(a -> r) $ \constructors as ->
231+ gctabulate @Id @(Eval (rep Expr)) @r @(a -> r) $ \constructors as ->
243232 let
244− (HType (Reify (E tag)), cases) =
233+ (HIdentity tag, cases) =
245234 gdeconstructADT
246− @(TTable (Reify Expr))
235+ @(TTable Expr)
247236 @TColumns
248− @TUnreify
249− @(Col (Reify Expr))
250− @(Eval (rep (Reify Expr)))
251− (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns)
252− (\SSpec {nullity} -> case nullity of
237+ @Id
238+ @Expr
239+ @(Eval (rep Expr))
240+ (const fromColumns)
241+ (\Spec {nullity} -> case nullity of
253242 Null -> id
254− NotNull -> \(Reify (E a)) -> Reify (E (unsafeUnnullify a)))
243+ NotNull -> unsafeUnnullify)
255244 constructors $
256− hreify $
257245 gtoColumns as
258246 in
259247 case cases of
@@ -263,108 +251,102 @@ ggdeconstruct gtoColumns = case algebraSing @algebra of
263251
264252type GGName :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type
265253type family GGName algebra rep a where
266− GGName 'K.Product rep a = GConstruct TUnreify (Eval (rep (Reify Name))) a
267− 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
268256
269257
270258ggname :: forall algebra rep a. GGConstructable algebra rep
271− => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Name) -> a)
259+ => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Name -> a)
272260 -> GGName algebra rep a
273261ggname gfromColumns = case algebraSing @algebra of
274262 SProduct ->
275− gtabulate @TUnreify @(Eval (rep (Reify Name))) @a $
263+ gtabulate @Id @(Eval (rep Name)) @a $
276264 gfromColumns .
277− hunreify .
278265 gconstruct
279− @(TTable (Reify Name))
266+ @(TTable Name)
280267 @TColumns
281− @TUnreify
282− @(Col (Reify Name))
283− @(Eval (rep (Reify Name)))
284− (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
268+ @Id
269+ @Name
270+ @(Eval (rep Name))
271+ (const toColumns)
285272 SSum -> \tag ->
286− gftabulate @TUnreify @(Eval (rep (Reify Name))) @a $
273+ gftabulate @Id @(Eval (rep Name)) @a $
287274 gfromColumns .
288− hunreify .
289275 gbuildADT
290− @(TTable (Reify Name))
276+ @(TTable Name)
291277 @TColumns
292− @TUnreify
293− @(Col (Reify Name))
294− @(Eval (rep (Reify Name)))
295− (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
296− (\_ _ (Reify (N (Name a))) -> Reify (N (Name a)))
297− (HType (Reify (N tag)))
278+ @Id
279+ @Name
280+ @(Eval (rep Name))
281+ (const toColumns)
282+ (\_ _ (Name a) -> Name a)
283+ (HIdentity tag)
298284
299285
300286type GGAggregate :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type
301287type family GGAggregate algebra rep r where
302288 GGAggregate 'K.Product rep r =
303− GConstruct TUnreify (Eval (rep (Reify Aggregate))) r ->
304− GConstruct TUnreify (Eval (rep (Reify Expr))) r
289+ GConstruct Id (Eval (rep Aggregate)) r ->
290+ GConstruct Id (Eval (rep Expr)) r
305291 GGAggregate 'K.Sum rep r =
306− GBuildADT TUnreify (Eval (rep (Reify Aggregate))) r ->
307− GBuildADT TUnreify (Eval (rep (Reify Expr))) r
292+ GBuildADT Id (Eval (rep Aggregate)) r ->
293+ GBuildADT Id (Eval (rep Expr)) r
308294
309295
310296ggaggregate :: forall algebra rep exprs agg. GGConstructable algebra rep
311− => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Aggregate) -> agg)
312− -> (exprs -> Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr))
297+ => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Aggregate -> agg)
298+ -> (exprs -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)
313299 -> GGAggregate algebra rep agg -> exprs -> agg
314300ggaggregate gfromColumns gtoColumns agg es = case algebraSing @algebra of
315301 SProduct -> flip f exprs $
316302 gfromColumns .
317− hunreify .
318303 gconstruct
319− @(TTable (Reify Aggregate))
304+ @(TTable Aggregate)
320305 @TColumns
321− @TUnreify
322− @(Col (Reify Aggregate))
323− @(Eval (rep (Reify Aggregate)))
324− (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
306+ @Id
307+ @Aggregate
308+ @(Eval (rep Aggregate))
309+ (const toColumns)
325310 where
326311 f =
327− gindex @TUnreify @(Eval (rep (Reify Expr))) @agg .
312+ gindex @Id @(Eval (rep Expr)) @agg .
328313 agg .
329− gtabulate @TUnreify @(Eval (rep (Reify Aggregate))) @agg
314+ gtabulate @Id @(Eval (rep Aggregate)) @agg
330315 exprs =
331316 gdeconstruct
332− @(TTable (Reify Expr))
317+ @(TTable Expr)
333318 @TColumns
334− @TUnreify
335− @(Col (Reify Expr))
336− @(Eval (rep (Reify Expr)))
337− (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns) $
338− hreify $
319+ @Id
320+ @Expr
321+ @(Eval (rep Expr))
322+ (const fromColumns) $
339323 gtoColumns es
340324 SSum -> flip f exprs $
341325 gfromColumns .
342− hunreify .
343326 gbuildADT
344− @(TTable (Reify Aggregate))
327+ @(TTable Aggregate)
345328 @TColumns
346− @TUnreify
347− @(Col (Reify Aggregate))
348− @(Eval (rep (Reify Aggregate)))
349− (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
350− (\tag' SSpec {nullity} (Reify (A (Aggregate a))) ->
351− Reify $ A $ Aggregate $ sguard (tag ==. litExpr tag') . snullify nullity <$> a)
352− (HType (Reify (A (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))
353336 where
354337 f =
355− gfindex @TUnreify @(Eval (rep (Reify Expr))) @agg .
338+ gfindex @Id @(Eval (rep Expr)) @agg .
356339 agg .
357− gftabulate @TUnreify @(Eval (rep (Reify Aggregate))) @agg
358− (HType (Reify (E tag)), exprs) =
340+ gftabulate @Id @(Eval (rep Aggregate)) @agg
341+ (HIdentity tag, exprs) =
359342 gunbuildADT
360− @(TTable (Reify Expr))
343+ @(TTable Expr)
361344 @TColumns
362− @TUnreify
363− @(Col (Reify Expr))
364− @(Eval (rep (Reify Expr)))
365− (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns)
366− (\SSpec {nullity} -> case nullity of
345+ @Id
346+ @Expr
347+ @(Eval (rep Expr))
348+ (const fromColumns)
349+ (\Spec {nullity} -> case nullity of
367350 Null -> id
368− NotNull -> \(Reify (E a)) -> Reify (E (unsafeUnnullify a))) $
369− hreify $
351+ NotNull -> unsafeUnnullify) $
370352 gtoColumns es
src/Rel8/Generic/Construction/ADT.hs+20−27
@@ -1,6 +1,7 @@
11{-# language AllowAmbiguousTypes #-}
22{-# language BlockArguments #-}
33{-# language DataKinds #-}
4+{-# language FlexibleContexts #-}
45{-# language FlexibleInstances #-}
56{-# language MultiParamTypeClasses #-}
67{-# language RankNTypes #-}
@@ -49,12 +50,12 @@ import Rel8.Generic.Construction.Record
4950import Rel8.Generic.Table.ADT ( GColumnsADT, GColumnsADT' )
5051import Rel8.Generic.Table.Record ( GColumns )
5152import Rel8.Schema.HTable ( HTable )
52−import Rel8.Schema.HTable.Identity ( HType )
53+import Rel8.Schema.HTable.Identity ( HIdentity )
5354import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
5455import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify )
5556import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
5657import Rel8.Schema.Null ( Nullify )
57−import Rel8.Schema.Spec ( Spec( Spec ), SSpec )
58+import Rel8.Schema.Spec ( Spec )
5859import qualified Rel8.Schema.Kind as K
5960import Rel8.Type.Tag ( Tag( Tag ) )
6061
@@ -62,24 +63,16 @@ import Rel8.Type.Tag ( Tag( Tag ) )
6263import Data.Text ( pack )
6364
6465
65−type Null :: K.HContext -> Type
66−type Null context = forall a. ()
67− => SSpec ('Spec a)
68− -> context ('Spec (Nullify a))
66+type Null :: K.Context -> Type
67+type Null context = forall a. Spec a -> context (Nullify a)
6968
7069
71−type Nullifier :: K.HContext -> Type
72−type Nullifier context = forall a. ()
73− => SSpec ('Spec a)
74− -> context ('Spec a)
75− -> context ('Spec (Nullify a))
70+type Nullifier :: K.Context -> Type
71+type Nullifier context = forall a. Spec a -> context a -> context (Nullify a)
7672
7773
78−type Unnullifier :: K.HContext -> Type
79−type Unnullifier context = forall a. ()
80− => SSpec ('Spec a)
81− -> context ('Spec (Nullify a))
82− -> context ('Spec a)
74+type Unnullifier :: K.Context -> Type
75+type Unnullifier context = forall a. Spec a -> context (Nullify a) -> context a
8376
8477
8578type NoConstructor :: Symbol -> Symbol -> ErrorMessage
@@ -188,12 +181,12 @@ type GConstructableADT
188181 :: (Type -> Exp Constraint)
189182 -> (Type -> Exp K.HTable)
190183 -> (Type -> Exp Type)
191− -> K.HContext -> (Type -> Type) -> Constraint
184+ -> K.Context -> (Type -> Type) -> Constraint
192185class GConstructableADT _Table _Columns f context rep where
193186 gbuildADT :: ()
194187 => ToColumns _Table _Columns f context
195188 -> (Tag -> Nullifier context)
196− -> HType Tag context
189+ -> HIdentity Tag context
197190 -> GFieldsADT f rep
198191 -> GColumnsADT _Columns rep context
199192
@@ -201,13 +194,13 @@ class GConstructableADT _Table _Columns f context rep where
201194 => FromColumns _Table _Columns f context
202195 -> Unnullifier context
203196 -> GColumnsADT _Columns rep context
204− -> (HType Tag context, GFieldsADT f rep)
197+ -> (HIdentity Tag context, GFieldsADT f rep)
205198
206199 gconstructADT :: ()
207200 => ToColumns _Table _Columns f context
208201 -> Null context
209202 -> Nullifier context
210− -> (Tag -> HType Tag context)
203+ -> (Tag -> HIdentity Tag context)
211204 -> GConstructors f rep (GColumnsADT _Columns rep context)
212205
213206 gdeconstructADT :: ()
@@ -215,11 +208,11 @@ class GConstructableADT _Table _Columns f context rep where
215208 -> Unnullifier context
216209 -> GConstructors f rep r
217210 -> GColumnsADT _Columns rep context
218− -> (HType Tag context, NonEmpty (Tag, r))
211+ -> (HIdentity Tag context, NonEmpty (Tag, r))
219212
220213
221214instance
222− ( htable ~ HLabel "tag" (HType Tag)
215+ ( htable ~ HLabel "tag" (HIdentity Tag)
223216 , GConstructableADT' _Table _Columns f context htable rep
224217 )
225218 => GConstructableADT _Table _Columns f context (M1 D meta rep)
@@ -245,7 +238,7 @@ type GConstructableADT'
245238 :: (Type -> Exp Constraint)
246239 -> (Type -> Exp K.HTable)
247240 -> (Type -> Exp Type)
248− -> K.HContext -> K.HTable -> (Type -> Type) -> Constraint
241+ -> K.Context -> K.HTable -> (Type -> Type) -> Constraint
249242class GConstructableADT' _Table _Columns f context htable rep where
250243 gbuildADT' :: ()
251244 => ToColumns _Table _Columns f context
@@ -383,19 +376,19 @@ type GMakeableADT
383376 :: (Type -> Exp Constraint)
384377 -> (Type -> Exp K.HTable)
385378 -> (Type -> Exp Type)
386− -> K.HContext -> Symbol -> (Type -> Type) -> Constraint
379+ -> K.Context -> Symbol -> (Type -> Type) -> Constraint
387380class GMakeableADT _Table _Columns f context name rep where
388381 gmakeADT :: ()
389382 => ToColumns _Table _Columns f context
390383 -> Null context
391384 -> Nullifier context
392− -> (Tag -> HType Tag context)
385+ -> (Tag -> HIdentity Tag context)
393386 -> GFields f (GConstructorADT name rep)
394387 -> GColumnsADT _Columns rep context
395388
396389
397390instance
398− ( htable ~ HLabel "tag" (HType Tag)
391+ ( htable ~ HLabel "tag" (HIdentity Tag)
399392 , meta ~ 'MetaData datatype _module _package _newtype
400393 , fallback ~ TypeError (NoConstructor datatype name)
401394 , fields ~ GFields f (GConstructorADT' name rep fallback)
@@ -417,7 +410,7 @@ type GMakeableADT'
417410 :: (Type -> Exp Constraint)
418411 -> (Type -> Exp K.HTable)
419412 -> (Type -> Exp Type)
420− -> K.HContext -> K.HTable -> Symbol -> (Type -> Type) -> Type -> Constraint
413+ -> K.Context -> K.HTable -> Symbol -> (Type -> Type) -> Type -> Constraint
421414class GMakeableADT' _Table _Columns f context htable name rep fields where
422415 gmakeADT' :: ()
423416 => ToColumns _Table _Columns f context
src/Rel8/Generic/Construction/Record.hs+3−3
@@ -43,7 +43,7 @@ type FromColumns
4343 :: (Type -> Exp Constraint)
4444 -> (Type -> Exp K.HTable)
4545 -> (Type -> Exp Type)
46− -> K.HContext
46+ -> K.Context
4747 -> Type
4848type FromColumns _Table _Columns f context = forall proxy x.
4949 Eval (_Table x) => proxy x -> Eval (_Columns x) context -> Eval (f x)
@@ -53,7 +53,7 @@ type ToColumns
5353 :: (Type -> Exp Constraint)
5454 -> (Type -> Exp K.HTable)
5555 -> (Type -> Exp Type)
56− -> K.HContext
56+ -> K.Context
5757 -> Type
5858type ToColumns _Table _Columns f context = forall proxy x.
5959 Eval (_Table x) => proxy x -> Eval (f x) -> Eval (_Columns x) context
@@ -117,7 +117,7 @@ type GConstructable
117117 :: (Type -> Exp Constraint)
118118 -> (Type -> Exp K.HTable)
119119 -> (Type -> Exp Type)
120− -> K.HContext -> (Type -> Type) -> Constraint
120+ -> K.Context -> (Type -> Type) -> Constraint
121121class GConstructable _Table _Columns f context rep where
122122 gconstruct :: ()
123123 => ToColumns _Table _Columns f context
src/Rel8/Generic/Map.hs+20−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+178−71
@@ -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,35 +20,39 @@ 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 )
43+import Rel8.Kind.Context ( SContext(..) )
44+import Rel8.Schema.Field ( Field )
3945import Rel8.Schema.HTable ( HTable )
4046import qualified Rel8.Schema.Kind as K
41−import Rel8.Schema.Reify ( Reify, UnwrapReify )
47+import Rel8.Schema.Name ( Name )
4248import Rel8.Schema.Result ( Result )
4349import Rel8.Table
44− ( fromColumns, toColumns, reify, unreify
45− , TTable, TColumns, TContext, TUnreify
50+ ( Table, Columns, Context, fromColumns, toColumns
51+ , FromExprs, fromResult, toResult
52+ , Transpose
53+ , TTable, TColumns
4654 )
55+import Rel8.Table.Transpose ( Transposes )
4756
4857
4958-- | The kind of 'Rel8able' types
@@ -51,6 +60,59 @@ type 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--
@@ -84,7 +146,7 @@ type KRel8able = K.Rel8able
84146-- [Supplying @Rel8able@ instances]
85147--
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:
89151--
90152-- @
@@ -96,79 +158,124 @@ type KRel8able = K.Rel8able
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 :: Reifiable context
101− => GColumns t (Col (Reify context)) -> t (Reify context)
102−
103− gtoColumns :: Reifiable context
104− => t (Reify context) -> GColumns t (Col (Reify context))
163+ gfromColumns :: SContext context -> GColumns t context -> t context
164+ gtoColumns :: SContext context -> t context -> GColumns t context
105165
106− greify :: Reifiable context
107− => t context -> t (Reify context)
166+ gfromResult :: GColumns t Result -> GFromExprs t
167+ gtoResult :: GFromExprs t -> GColumns t Result
108168
109− gunreify :: Reifiable context
110− => t (Reify context) -> t context
111−
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))
188+ ( SRel8able t Aggregate
189+ , SRel8able t Expr
190+ , forall table. SRel8able t (Field table)
191+ , SRel8able t Name
192+ , SSerialize t
141193 )
142− => t context -> t (Reify context)
143− greify =
144− unrecord .
145− to .
146− gunmap @(TTable (Reify context)) (Proxy @TUnreify) (reify Refl) .
147− from .
148− Record
149−
150− default gunreify :: forall context.
151− ( Generic (Record (t context))
152− , Generic (Record (t (Reify context)))
153− , GMappable (TTable (Reify context)) (GRep t (Reify context))
154− , GRep t context ~ GMap TUnreify (GRep t (Reify context))
155− )
156− => t (Reify context) -> t context
157− gunreify =
158− unrecord .
159− to .
160− gmap @(TTable (Reify context)) (Proxy @TUnreify) (unreify Refl) .
161− from .
162− Record
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+22−107
@@ -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 f g h x = case algebraSing @algebra of
128− SProduct -> gfromColumns @_Table @_Columns h x
129− SSum -> gfromColumnsADT @_Table @_Columns f g h x
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 f g h x = case algebraSing @algebra of
142− SProduct -> gtoColumns @_Table @_Columns h x
143− SSum -> gtoColumnsADT @_Table @_Columns f g h x
144−
145−
146−ggtable :: forall algebra _Table _Columns rep context.
147− ( KnownAlgebra algebra
148− , Eval (GGTable algebra _Table _Columns context rep)
149− )
150− => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)
151− -> (forall a. ()
152− => SSpec ('Spec a)
153− -> context ('Spec a)
154− -> context ('Spec (Nullify a)))
155− -> Eval (GGColumns algebra _Columns rep) context
156−ggtable = case algebraSing @algebra of
157− SProduct -> \table _ -> gtable @_Table @_Columns @_ @rep table
158− SSum -> gtableADT @_Table @_Columns @_ @rep
159−
160−
161−ggfromResult :: forall algebra _ToExprs _Columns exprs rep x.
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
17188ggfromResult f x = case algebraSing @algebra of
172− SProduct -> gfromResult @_ToExprs @_Columns @exprs f x
173− SSum -> gfromResultADT @_ToExprs @_Columns @exprs f x
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)
100+ -> Eval (GGColumns algebra _Columns exprs) Result
186101ggtoResult f x = case algebraSing @algebra of
187− SProduct -> gtoResult @_ToExprs @_Columns @exprs f x
188− SSum -> gtoResultADT @_ToExprs @_Columns @exprs f x
102+ SProduct -> gtoResult @_Serialize @_Columns @exprs @rep f x
103+ SSum -> gtoResultADT @_Serialize @_Columns @exprs @rep f x
src/Rel8/Generic/Table/ADT.hs+58−197
@@ -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,22 +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.HTable ( HTable, hmap )
41−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 ) )
4238import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
4339import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify )
4440import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
4541import qualified Rel8.Schema.Kind as K
46−import Rel8.Schema.Null ( Nullify )
47−import Rel8.Schema.Spec ( Spec( Spec ), SSpec )
48−import Rel8.Schema.Result
49− ( Col( R ), Result
50− , null, nullifier, unnullifier
51− )
42+import Rel8.Schema.Result ( Result, null, nullifier, unnullifier )
5243import Rel8.Type.Tag ( Tag( Tag ) )
5344
5445-- text
@@ -60,7 +51,7 @@ type GColumnsADT
6051 -> (Type -> Type) -> K.HTable
6152type family GColumnsADT _Columns rep where
6253 GColumnsADT _Columns (M1 D _ rep) =
63− GColumnsADT' _Columns (HLabel "tag" (HType Tag)) rep
54+ GColumnsADT' _Columns (HLabel "tag" (HIdentity Tag)) rep
6455
6556
6657type GColumnsADT'
@@ -74,244 +65,118 @@ type family GColumnsADT' _Columns htable rep where
7465 HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))
7566
7667
77−type GTableADT
78− :: (Type -> Exp Constraint)
79− -> (Type -> Exp K.HTable)
80− -> K.HContext -> (Type -> Type) -> Constraint
81−class GTableADT _Table _Columns context rep where
82− gfromColumnsADT :: ()
83− => (forall spec. context spec -> Col Result spec)
84− -> (forall spec. Col Result spec -> context spec)
85− -> (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)
86− -> GColumnsADT _Columns rep context
87− -> rep x
88−
89− gtoColumnsADT :: ()
90− => (forall spec. context spec -> Col Result spec)
91− -> (forall spec. Col Result spec -> context spec)
92− -> (forall a. Eval (_Table a) => a -> Eval (_Columns a) context)
93− -> rep x
94− -> GColumnsADT _Columns rep context
95−
96− gtableADT :: ()
97− => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)
98− -> (forall a. ()
99− => SSpec ('Spec a)
100− -> context ('Spec a)
101− -> context ('Spec (Nullify a)))
102− -> GColumnsADT _Columns rep context
103−
104−
105−instance
106− ( htable ~ HLabel "tag" (HType Tag)
107− , HTable (GColumnsADT _Columns (M1 D meta rep))
108− , Eval (_Table (htable context))
109− , Eval (_Columns (htable context)) ~ htable
110− , GTableADT' _Table _Columns htable context rep
111− , GToExprsADT' (Const _Table) _Columns htable rep rep
112− )
113− => GTableADT _Table _Columns context (M1 D meta rep)
114− where
115− gfromColumnsADT fromContext toContext fromColumns =
116− gfromResultADT @(Const _Table) @_Columns @(M1 D meta rep) @(M1 D meta rep)
117− (const (fromColumns . hmap toContext)) .
118− hmap fromContext
119−
120− gtoColumnsADT fromContext toContext toColumns =
121− hmap toContext .
122− gtoResultADT @(Const _Table) @_Columns @(M1 D meta rep) @(M1 D meta rep)
123− (const (hmap fromContext . toColumns))
124−
125− gtableADT table hnullifier =
126− gtableADT' @_Table @_Columns @htable @context @rep table hnullifier htable
127− where
128− htable = table (Proxy @(htable context))
129−
130−
131−type GTableADT'
132− :: (Type -> Exp Constraint)
133− -> (Type -> Exp K.HTable)
134− -> K.HTable -> K.HContext -> (Type -> Type) -> Constraint
135−class GTableADT' _Table _Columns htable context rep where
136− gtableADT' :: ()
137− => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)
138− -> (forall a. ()
139− => SSpec ('Spec a)
140− -> context ('Spec a)
141− -> context ('Spec (Nullify a)))
142− -> htable context
143− -> GColumnsADT' _Columns htable rep context
144−
145−
146−instance
147− ( htable' ~ GColumnsADT' _Columns htable a
148− , GTableADT' _Table _Columns htable context a
149− , GTableADT' _Table _Columns htable' context b
150− )
151− => GTableADT' _Table _Columns htable context (a :+: b)
152− where
153− gtableADT' table hnullifier =
154− gtableADT' @_Table @_Columns @_ @_ @b table hnullifier .
155− gtableADT' @_Table @_Columns @_ @_ @a table hnullifier
156−
157−
158−instance meta ~ 'MetaCons label _fixity _isRecord =>
159− GTableADT' _Table _Columns htable context (M1 C meta U1)
160− where
161− gtableADT' _ _ = id
162−
163−
164−instance {-# OVERLAPPABLE #-}
165− ( HTable (GColumns _Columns rep)
166− , GTable _Table _Columns context rep
167− , meta ~ 'MetaCons label _fixity _isRecord
168− , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) rep) ~
169− HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))
170− )
171− => GTableADT' _Table _Columns htable context (M1 C meta rep)
172− where
173− gtableADT' table hnullifier htable =
174− HProduct htable $
175− hlabel $
176− hnullify hnullifier $
177− gtable @_Table @_Columns @_ @rep table
178−
179−
180−type GToExprsADT
68+type GSerializeADT
18169 :: (Type -> Type -> Exp Constraint)
18270 -> (Type -> Exp K.HTable)
18371 -> (Type -> Type) -> (Type -> Type) -> Constraint
184−class GToExprsADT _ToExprs _Columns exprs rep where
72+class GSerializeADT _Serialize _Columns exprs rep where
18573 gfromResultADT :: ()
186− => (forall expr a proxy.
187− ( Eval (_ToExprs expr a)
188− , HTable (Eval (_Columns expr))
189− )
190− => proxy expr
191− -> Eval (_Columns expr) (Col Result)
192− -> a)
193− -> GColumnsADT _Columns exprs (Col Result)
74+ => (forall expr a proxy. Eval (_Serialize expr a)
75+ => proxy expr -> Eval (_Columns expr) Result -> a)
76+ -> GColumnsADT _Columns exprs Result
19477 -> rep x
19578
19679 gtoResultADT :: ()
197− => (forall expr a proxy.
198− ( Eval (_ToExprs expr a)
199− , HTable (Eval (_Columns expr))
200− )
201− => proxy expr
202− -> a
203− -> Eval (_Columns expr) (Col Result))
80+ => (forall expr a proxy. Eval (_Serialize expr a)
81+ => proxy expr -> a -> Eval (_Columns expr) Result)
20482 -> rep x
205− -> GColumnsADT _Columns exprs (Col Result)
83+ -> GColumnsADT _Columns exprs Result
20684
20785
20886instance
209− ( htable ~ HLabel "tag" (HType Tag)
210− , GToExprsADT' _ToExprs _Columns htable exprs rep
87+ ( htable ~ HLabel "tag" (HIdentity Tag)
88+ , GSerializeADT' _Serialize _Columns htable exprs rep
21189 )
212− => GToExprsADT _ToExprs _Columns (M1 D meta exprs) (M1 D meta rep)
90+ => GSerializeADT _Serialize _Columns (M1 D meta exprs) (M1 D meta rep)
21391 where
21492 gfromResultADT fromResult columns =
215− case gfromResultADT' @_ToExprs @_Columns @_ @exprs fromResult tag columns of
93+ case gfromResultADT' @_Serialize @_Columns @htable @exprs @rep fromResult tag columns of
21694 Just rep -> M1 rep
21795 _ -> error "ADT.fromColumns: mismatch between tag and data"
21896 where
219− tag = (\(HType (R a)) -> a) . hunlabel @"tag"
97+ tag = (\(HIdentity (Identity a)) -> a) . hunlabel @"tag"
22098
22199 gtoResultADT toResult (M1 rep) =
222− gtoResultADT' @_ToExprs @_Columns @_ @exprs toResult tag (Just rep)
100+ gtoResultADT' @_Serialize @_Columns @htable @exprs @rep toResult tag (Just rep)
223101 where
224− tag = hlabel @"tag" . HType . R
102+ tag = hlabel @"tag" . HIdentity . Identity
225103
226104
227−type GToExprsADT'
105+type GSerializeADT'
228106 :: (Type -> Type -> Exp Constraint)
229107 -> (Type -> Exp K.HTable)
230108 -> K.HTable -> (Type -> Type) -> (Type -> Type) -> Constraint
231−class GToExprsADT' _ToExprs _Columns htable exprs rep where
232− gfromResultADT' :: ()
233− => (forall expr a proxy.
234− ( Eval (_ToExprs expr a)
235− , HTable (Eval (_Columns expr))
236− )
237− => proxy expr
238− -> Eval (_Columns expr) (Col Result)
239− -> a)
240− -> (htable (Col Result) -> Tag)
241− -> GColumnsADT' _Columns htable exprs (Col Result)
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
242115 -> Maybe (rep x)
243116
244− gtoResultADT' :: ()
245− => (forall expr a proxy.
246− ( Eval (_ToExprs expr a)
247− , HTable (Eval (_Columns expr))
248− )
249− => proxy expr
250− -> a
251− -> Eval (_Columns expr) (Col Result))
252− -> (Tag -> htable (Col Result))
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)
253121 -> Maybe (rep x)
254− -> GColumnsADT' _Columns htable exprs (Col Result)
122+ -> GColumnsADT' _Columns htable exprs context
255123
256124 extract :: GColumnsADT' _Columns htable exprs context -> htable context
257125
258126
259127instance
260− ( htable' ~ GColumnsADT' _Columns htable a
261− , GToExprsADT' _ToExprs _Columns htable a rep1
262− , 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
263131 )
264− => GToExprsADT' _ToExprs _Columns htable (a :+: b) (rep1 :+: rep2)
132+ => GSerializeADT' _Serialize _Columns htable (exprs1 :+: exprs2) (a :+: b)
265133 where
266134 gfromResultADT' fromResult f columns =
267135 case ma of
268136 Just a -> Just (L1 a)
269137 Nothing -> R1 <$>
270− gfromResultADT' @_ToExprs @_Columns @_ @b @rep2
138+ gfromResultADT' @_Serialize @_Columns @_ @exprs2 @b
271139 fromResult
272− (f . extract @_ToExprs @_Columns @_ @a @rep1)
140+ (f . extract @_Serialize @_Columns @_ @exprs1 @a)
273141 columns
274142 where
275143 ma =
276− gfromResultADT' @_ToExprs @_Columns @_ @a @rep1
144+ gfromResultADT' @_Serialize @_Columns @_ @exprs1 @a
277145 fromResult
278146 f
279− (extract @_ToExprs @_Columns @_ @b @rep2 columns)
147+ (extract @_Serialize @_Columns @_ @exprs2 @b columns)
280148
281149 gtoResultADT' toResult tag = \case
282150 Just (L1 a) ->
283− gtoResultADT' @_ToExprs @_Columns @_ @b @rep2
151+ gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b
284152 toResult
285− (\_ -> gtoResultADT' @_ToExprs @_Columns @_ @a @rep1
153+ (\_ -> gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a
286154 toResult
287155 tag
288156 (Just a))
289157 Nothing
290158 Just (R1 b) ->
291− gtoResultADT' @_ToExprs @_Columns @_ @b @rep2
159+ gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b
292160 toResult
293161 (\tag' ->
294− gtoResultADT' @_ToExprs @_Columns @_ @a @rep1
162+ gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a
295163 toResult
296164 (\_ -> tag tag')
297165 Nothing)
298166 (Just b)
299167 Nothing ->
300− gtoResultADT' @_ToExprs @_Columns @_ @b @rep2
168+ gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b
301169 toResult
302− (\_ -> gtoResultADT' @_ToExprs @_Columns @_ @a @rep1 toResult tag Nothing)
170+ (\_ -> gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a toResult tag Nothing)
303171 Nothing
304172
305173 extract =
306− extract @_ToExprs @_Columns @_ @a @rep1 .
307− extract @_ToExprs @_Columns @_ @b @rep2
174+ extract @_Serialize @_Columns @_ @exprs1 @a .
175+ extract @_Serialize @_Columns @_ @exprs2 @b
308176
309177
310−instance
311− ( meta ~ 'MetaCons label _fixity _isRecord
312− , KnownSymbol label
313− )
314− => GToExprsADT' _ToExprs _Columns htable (M1 C meta U1) (M1 C meta U1)
178+instance (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) =>
179+ GSerializeADT' _Serialize _Columns _htable (M1 C meta U1) (M1 C meta U1)
315180 where
316181 gfromResultADT' _ tag columns
317182 | tag columns == tag' = Just (M1 U1)
@@ -328,17 +193,17 @@ instance
328193
329194instance {-# OVERLAPPABLE #-}
330195 ( HTable (GColumns _Columns exprs)
331− , GToExprs _ToExprs _Columns exprs rep
196+ , GSerialize _Serialize _Columns exprs rep
332197 , meta ~ 'MetaCons label _fixity _isRecord
333198 , KnownSymbol label
334− , GColumnsADT' _Columns htable (M1 C meta exprs) ~
199+ , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) exprs) ~
335200 HProduct htable (HLabel label (HNullify (GColumns _Columns exprs)))
336201 )
337− => 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)
338203 where
339204 gfromResultADT' fromResult tag (HProduct a b)
340205 | tag a == tag' =
341− M1 . gfromResult @_ToExprs @_Columns @exprs fromResult <$>
206+ M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult <$>
342207 hunnullify unnullifier (hunlabel b)
343208 | otherwise = Nothing
344209 where
@@ -349,12 +214,8 @@ instance {-# OVERLAPPABLE #-}
349214 Just (M1 rep) -> HProduct (tag tag') $
350215 hlabel $
351216 hnullify nullifier $
352− gtoResult @_ToExprs @_Columns @exprs toResult rep
217+ gtoResult @_Serialize @_Columns @exprs @rep toResult rep
353218 where
354219 tag' = Tag $ pack $ symbolVal (Proxy @label)
355220
356221 extract (HProduct a _) = a
357−
358−
359−data Const :: (a -> Exp Constraint) -> a -> a -> Exp Constraint
360−type instance Eval (Const f x a) = (Eval (f a), x ~ a)
src/Rel8/Generic/Table/Record.hs+74−93
@@ -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
@@ -30,12 +30,9 @@ import Prelude hiding ( null )
3030
3131-- rel8
3232import Rel8.FCF ( Eval, Exp )
33−import Rel8.Schema.Context ( Col )
34−import Rel8.Schema.HTable ( HTable )
3533import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
3634import Rel8.Schema.HTable.Product ( HProduct(..) )
3735import qualified Rel8.Schema.Kind as K
38−import Rel8.Schema.Result ( Result )
3936
4037
4138type GColumns :: (Type -> Exp K.HTable) -> (Type -> Type) -> K.HTable
@@ -58,8 +55,8 @@ type family GContext _Context rep where
5855type GTable
5956 :: (Type -> Exp Constraint)
6057 -> (Type -> Exp K.HTable)
61− -> K.HContext -> (Type -> Type) -> Constraint
62−class GTable _Table _Columns context rep
58+ -> (Type -> Type) -> Constraint
59+class GTable _Table _Columns rep
6360 where
6461 gfromColumns :: ()
6562 => (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)
@@ -76,125 +73,109 @@ class GTable _Table _Columns context rep
7673 -> GColumns _Columns rep context
7774
7875
79−instance GTable _Table _Columns context rep =>
80− 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
8181 where
82− gfromColumns fromColumns =
83− M1 . gfromColumns @_Table @_Columns @context @rep fromColumns
84− gtoColumns toColumns (M1 a) =
85− gtoColumns @_Table @_Columns @context @rep toColumns a
86− gtable = gtable @_Table @_Columns @context @rep
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
8787
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
8893
89−instance GTable _Table _Columns context rep =>
90− GTable _Table _Columns context (M1 C c rep)
94+
95+instance GTable _Table _Columns rep => GTable _Table _Columns (M1 D c rep)
9196 where
9297 gfromColumns fromColumns =
93− M1 . gfromColumns @_Table @_Columns @context @rep fromColumns
98+ M1 . gfromColumns @_Table @_Columns @rep fromColumns
9499 gtoColumns toColumns (M1 a) =
95− gtoColumns @_Table @_Columns @context @rep toColumns a
96− gtable = gtable @_Table @_Columns @context @rep
100+ gtoColumns @_Table @_Columns @rep toColumns a
101+ gtable = gtable @_Table @_Columns @rep
97102
98103
99−instance
100− ( GTable _Table _Columns context rep1
101− , GTable _Table _Columns context rep2
102− )
103− => 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)
104106 where
105− gfromColumns fromColumns (HProduct a b) =
106− gfromColumns @_Table @_Columns @context @rep1 fromColumns a :*:
107− gfromColumns @_Table @_Columns @context @rep2 fromColumns b
108− gtoColumns toColumns (a :*: b) = HProduct
109− (gtoColumns @_Table @_Columns @context @rep1 toColumns a)
110− (gtoColumns @_Table @_Columns @context @rep2 toColumns b)
111− gtable table = HProduct
112− (gtable @_Table @_Columns @context @rep1 table)
113− (gtable @_Table @_Columns @context @rep2 table)
107+ gfromResult fromResult =
108+ M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult
109+ gtoResult toResult (M1 a) =
110+ gtoResult @_Serialize @_Columns @exprs @rep toResult a
114111
115112
116−instance
117− ( Eval (_Table a)
118− , meta ~ 'MetaSel ('Just label) _su _ss _ds
119− , k1 ~ K1 i a
120− )
121− => GTable _Table _Columns context (M1 S meta k1)
113+instance GTable _Table _Columns rep => GTable _Table _Columns (M1 C c rep)
122114 where
123− gfromColumns fromColumns = M1 . K1 . fromColumns . hunlabel
124− gtoColumns toColumns (M1 (K1 a)) = hlabel (toColumns a)
125− gtable table = hlabel (table (Proxy @a))
126−
127−
128−type GToExprs
129− :: (Type -> Type -> Exp Constraint)
130− -> (Type -> Exp K.HTable)
131− -> (Type -> Type) -> (Type -> Type) -> Constraint
132−class GToExprs _ToExprs _Columns exprs rep where
133− gfromResult :: ()
134− => (forall expr a proxy.
135− ( Eval (_ToExprs expr a)
136− , HTable (Eval (_Columns expr))
137− )
138− => proxy expr
139− -> Eval (_Columns expr) (Col Result)
140− -> a)
141− -> GColumns _Columns exprs (Col Result)
142− -> rep x
143− gtoResult :: ()
144− => (forall expr a proxy.
145− ( Eval (_ToExprs expr a)
146− , HTable (Eval (_Columns expr))
147− )
148− => proxy expr
149− -> a
150− -> Eval (_Columns expr) (Col Result))
151− -> rep x
152− -> GColumns _Columns exprs (Col Result)
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
153120
154121
155−instance GToExprs _ToExprs _Columns exprs rep =>
156− 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)
157124 where
158125 gfromResult fromResult =
159− M1 . gfromResult @_ToExprs @_Columns @exprs fromResult
126+ M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult
160127 gtoResult toResult (M1 a) =
161− gtoResult @_ToExprs @_Columns @exprs toResult a
128+ gtoResult @_Serialize @_Columns @exprs @rep toResult a
162129
163130
164−instance GToExprs _ToExprs _Columns exprs rep =>
165− 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)
166133 where
167− gfromResult fromResult =
168− M1 . gfromResult @_ToExprs @_Columns @exprs fromResult
169− gtoResult toResult (M1 a) =
170− 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)
171143
172144
173145instance
174− ( GToExprs _ToExprs _Columns exprs1 rep1
175− , GToExprs _ToExprs _Columns exprs2 rep2
146+ ( GSerialize _Serialize _Columns expr1 rep1
147+ , GSerialize _Serialize _Columns expr2 rep2
176148 )
177− => GToExprs _ToExprs _Columns (exprs1 :*: exprs2) (rep1 :*: rep2)
149+ => GSerialize _Serialize _Columns (expr1 :*: expr2) (rep1 :*: rep2)
178150 where
179151 gfromResult fromResult (HProduct a b) =
180− gfromResult @_ToExprs @_Columns @exprs1 fromResult a :*:
181− gfromResult @_ToExprs @_Columns @exprs2 fromResult b
152+ gfromResult @_Serialize @_Columns @expr1 @rep1 fromResult a :*:
153+ gfromResult @_Serialize @_Columns @expr2 @rep2 fromResult b
182154 gtoResult toResult (a :*: b) =
183155 HProduct
184− (gtoResult @_ToExprs @_Columns @exprs1 toResult a)
185− (gtoResult @_ToExprs @_Columns @exprs2 toResult b)
156+ (gtoResult @_Serialize @_Columns @expr1 @rep1 toResult a)
157+ (gtoResult @_Serialize @_Columns @expr2 @rep2 toResult b)
186158
187159
188160instance
189− ( Eval (_ToExprs exprs a)
190− , HTable (Eval (_Columns exprs))
161+ ( Eval (_Table a)
191162 , meta ~ 'MetaSel ('Just label) _su _ss _ds
192− , 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
193176 , k1' ~ K1 i a
194177 )
195− => GToExprs _ToExprs _Columns (M1 S meta k1) (M1 S meta k1')
178+ => GSerialize _Serialize _Columns (M1 S meta k1) (M1 S meta k1')
196179 where
197− gfromResult fromResult =
198− M1 . K1 . fromResult (Proxy @exprs) . hunlabel
199− gtoResult toResult (M1 (K1 a)) =
200− hlabel (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−21
@@ -1,12 +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
109 )
1110where
1211
@@ -17,11 +16,9 @@ import Prelude ()
1716-- rel8
1817import Rel8.Aggregate ( Aggregate )
1918import Rel8.Expr ( Expr )
20−import Rel8.Schema.Dict ( Dict( Dict ) )
21−import Rel8.Schema.Context ( Interpretation )
19+import Rel8.Schema.Field ( Field )
2220import Rel8.Schema.Kind ( Context )
2321import Rel8.Schema.Name ( Name )
24−import Rel8.Schema.Reify ( Reify )
2522import Rel8.Schema.Result ( Result )
2623
2724
@@ -29,13 +26,13 @@ type SContext :: Context -> Type
2926data SContext context where
3027 SAggregate :: SContext Aggregate
3128 SExpr :: SContext Expr
29+ SField :: SContext (Field table)
3230 SName :: SContext Name
3331 SResult :: SContext Result
34− SReify :: SContext context -> SContext (Reify context)
3532
3633
3734type Reifiable :: Context -> Constraint
38−class Interpretation context => Reifiable context where
35+class Reifiable context where
3936 contextSing :: SContext context
4037
4138
@@ -47,23 +44,13 @@ instance Reifiable Expr where
4744 contextSing = SExpr
4845
4946
47+instance Reifiable (Field table) where
48+ contextSing = SField
49+
50+
5051instance Reifiable Result where
5152 contextSing = SResult
5253
5354
5455instance Reifiable Name where
5556 contextSing = SName
56−
57−
58−instance Reifiable context => Reifiable (Reify context) where
59− contextSing = SReify contextSing
60−
61−
62−sReifiable :: SContext context -> Dict Reifiable context
63−sReifiable = \case
64− SAggregate -> Dict
65− SExpr -> Dict
66− SName -> Dict
67− SResult -> Dict
68− SReify context -> case sReifiable context of
69− Dict -> Dict
src/Rel8/Order.hs+1−8
@@ -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
@@ -30,8 +28,3 @@ import qualified Opaleye.Internal.Order as Opaleye
3028type Order :: Type -> Type
3129newtype Order a = Order (Opaleye.Order a)
3230 deriving newtype (Contravariant, Divisible, Decidable, Semigroup, Monoid)
33−
34−
35−toOrderExprs :: Order a -> a -> [Opaleye.OrderExpr]
36−toOrderExprs (Order (Opaleye.Order order)) a =
37− uncurry Opaleye.OrderExpr <$> order a
src/Rel8/Query.hs+28−9
@@ -1,4 +1,6 @@
1+{-# language FlexibleContexts #-}
12{-# language StandaloneKindSignatures #-}
3+{-# language UndecidableInstances #-}
24
35module Rel8.Query
46 ( Query( Query )
@@ -15,18 +17,21 @@ import Prelude
1517-- opaleye
1618import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
1719import qualified Opaleye.Internal.PackMap as Opaleye
18−import qualified Opaleye.Internal.PrimQuery as Opaleye
20+import qualified Opaleye.Internal.PrimQuery as Opaleye hiding (lateral)
1921import qualified Opaleye.Internal.QueryArr as Opaleye
2022import qualified Opaleye.Internal.Tag as Opaleye
2123
2224-- rel8
25+import Rel8.Expr ( Expr )
2326import Rel8.Query.Set ( unionAll )
2427import Rel8.Query.Opaleye ( fromOpaleye )
2528import Rel8.Query.Values ( values )
29+import Rel8.Table ( Table, fromColumns, toColumns )
2630import Rel8.Table.Alternative
2731 ( AltTable, (<|>:)
2832 , AlternativeTable, emptyTable
2933 )
34+import Rel8.Table.Projection ( Projectable, apply, project )
3035
3136-- semigroupoids
3237import Data.Functor.Apply ( Apply, (<.>) )
@@ -151,6 +156,10 @@ newtype Query a =
151156 )
152157
153158
159+instance Projectable Query where
160+ project f = fmap (fromColumns . apply f . toColumns)
161+
162+
154163instance Functor Query where
155164 fmap f (Query a) = Query (fmap (fmap (fmap f)) a)
156165
@@ -169,14 +178,14 @@ instance Bind Query where
169178
170179
171180instance Monad Query where
172− Query q >>= f = Query $ \dummies -> Opaleye.QueryArr $ \(_, tag) ->
181+ Query q >>= f = Query $ \dummies -> Opaleye.stateQueryArr $ \_ tag ->
173182 let
174− Opaleye.QueryArr qa = q dummies
175− ((m, a), query, tag') = qa ((), tag)
183+ qa = q dummies
184+ ((m, a), query, tag') = Opaleye.runStateQueryArr qa () tag
176185 Query q' = f a
177186 (dummies', query', tag'') =
178187 ( dummy : dummies
179− , \lateral -> Opaleye.Rebind True bindings . query lateral
188+ , query <> Opaleye.aRebind bindings
180189 , Opaleye.next tag'
181190 )
182191 where
@@ -184,11 +193,11 @@ instance Monad Query where
184193 where
185194 random = Opaleye.FunExpr "random" []
186195 name = Opaleye.extractAttr "dummy" tag'
187− Opaleye.QueryArr qa' = Opaleye.lateral $ \_ -> q' dummies'
188− ((m'@(Any needsDummies), b), query'', tag''') = qa' ((), tag'')
196+ qa' = Opaleye.lateral $ \_ -> q' dummies'
197+ ((m'@(Any needsDummies), b), query'', tag''') = Opaleye.runStateQueryArr qa' () tag''
189198 query'''
190− | needsDummies = \lateral -> query'' lateral . query' lateral
191− | otherwise = \lateral -> query'' lateral . query lateral
199+ | needsDummies = query' <> query''
200+ | otherwise = query <> query''
192201 m'' = m <> m'
193202 in
194203 ((m'', b), query''', tag''')
@@ -202,3 +211,13 @@ instance AltTable Query where
202211-- | 'emptyTable' = 'values' @[]@.
203212instance AlternativeTable Query where
204213 emptyTable = values []
214+
215+
216+-- | '<>' = 'unionAll'.
217+instance Table Expr a => Semigroup (Query a) where
218+ (<>) = (<|>:)
219+
220+
221+-- | 'mempty' = @'values' []@.
222+instance Table Expr a => Monoid (Query a) where
223+ mempty = emptyTable
src/Rel8/Query/Aggregate.hs+19
@@ -1,13 +1,17 @@
11{-# language FlexibleContexts #-}
22{-# language MonoLocalBinds #-}
3+{-# language ScopedTypeVariables #-}
4+{-# language TypeApplications #-}
35
46module Rel8.Query.Aggregate
57 ( aggregate
68 , countRows
9+ , mode
710 )
811where
912
1013-- base
14+import Data.Functor.Contravariant ( (>$<) )
1115import Data.Int ( Int64 )
1216import Prelude
1317
@@ -18,9 +22,16 @@ import qualified Opaleye.Aggregate as Opaleye
1822import Rel8.Aggregate ( Aggregates )
1923import Rel8.Expr ( Expr )
2024import Rel8.Expr.Aggregate ( countStar )
25+import Rel8.Expr.Order ( desc )
2126import Rel8.Query ( Query )
27+import Rel8.Query.Limit ( limit )
2228import Rel8.Query.Maybe ( optional )
2329import Rel8.Query.Opaleye ( mapOpaleye )
30+import Rel8.Query.Order ( orderBy )
31+import Rel8.Table ( toColumns )
32+import Rel8.Table.Aggregate ( hgroupBy )
33+import Rel8.Table.Cols ( Cols( Cols ), fromCols )
34+import Rel8.Table.Eq ( EqTable, eqTable )
2435import Rel8.Table.Opaleye ( aggregator )
2536import Rel8.Table.Maybe ( maybeTable )
2637
@@ -35,3 +46,11 @@ aggregate = mapOpaleye (Opaleye.aggregate aggregator)
3546-- will return @0@.
3647countRows :: Query a -> Query (Expr Int64)
3748countRows = fmap (maybeTable 0 id) . optional . aggregate . fmap (const countStar)
49+
50+
51+-- | Return the most common row in a query.
52+mode :: forall a. EqTable a => Query a -> Query a
53+mode rows = limit 1 $ fmap (fromCols . snd) $ orderBy (fst >$< desc) $ do
54+ aggregate $ do
55+ row <- toColumns <$> rows
56+ pure (countStar, Cols $ hgroupBy (eqTable @a) row)
src/Rel8/Query/Distinct.hs+4−9
@@ -1,5 +1,3 @@
1−{-# options_ghc -fno-warn-redundant-constraints #-}
2−
31module Rel8.Query.Distinct
42 ( distinct
53 , distinctOn
@@ -8,12 +6,11 @@ module Rel8.Query.Distinct
86where
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/Evaluate.hs+3−22
@@ -3,7 +3,6 @@
33
44module Rel8.Query.Evaluate
55 ( evaluate
6− , rebind
76 )
87where
98
@@ -16,28 +15,23 @@ import Prelude hiding ( undefined )
1615
1716-- opaleye
1817import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
19−import qualified Opaleye.Internal.PackMap as Opaleye
20−import qualified Opaleye.Internal.PrimQuery as Opaleye
21−import qualified Opaleye.Internal.QueryArr as Opaleye
22−import qualified Opaleye.Internal.Tag as Opaleye
23−import qualified Opaleye.Internal.Unpackspec as Opaleye
2418
2519-- rel8
2620import Rel8.Expr ( Expr )
2721import Rel8.Expr.Bool ( (&&.) )
2822import Rel8.Expr.Opaleye ( fromPrimExpr )
2923import Rel8.Query ( Query( Query ) )
24+import Rel8.Query.Rebind ( rebind )
3025import Rel8.Table ( Table )
3126import Rel8.Table.Bool ( case_ )
32−import Rel8.Table.Opaleye ( unpackspec )
33−import Rel8.Table.Undefined
27+import Rel8.Table.Undefined ( undefined )
3428
3529
3630-- | 'evaluate' takes expressions that could potentially have side effects and
3731-- \"runs\" them in the 'Query' monad. The returned expressions have no side
3832-- effects and can safely be reused.
3933evaluate :: Table Expr a => a -> Query a
40−evaluate = laterally >=> rebind
34+evaluate = laterally >=> rebind "eval"
4135
4236
4337laterally :: Table Expr a => a -> Query a
@@ -51,18 +45,5 @@ laterally a = Query $ \bindings -> pure $ (Any True,) $
5145 go = fromPrimExpr . Opaleye.UnExpr Opaleye.OpIsNotNull
5246
5347
54−-- | 'rebind' takes some expressions, and binds each of them to a new
55−-- variable in the SQL. The @a@ returned consists only of these
56−-- variables. It's essentially a @let@ binding for Postgres expressions.
57−rebind :: Table Expr a => a -> Query a
58−rebind a = Query $ \_ -> Opaleye.QueryArr $ \(_, tag) ->
59− let
60− tag' = Opaleye.next tag
61− (a', bindings) = Opaleye.run $
62− Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr "eval" tag') a
63− in
64− ((mempty, a'), \_ -> Opaleye.Rebind True bindings, tag')
65−
66−
6748foldl1' :: (a -> a -> a) -> NonEmpty a -> a
6849foldl1' f (a :| as) = foldl' f a as
src/Rel8/Query/Exists.hs+1−1
@@ -12,7 +12,7 @@ import Prelude hiding ( filter )
1212
1313-- opaleye
1414import qualified Opaleye.Exists as Opaleye
15−import qualified Opaleye.Operators as Opaleye hiding ( exists )
15+import qualified Opaleye.Operators as Opaleye
1616
1717-- rel8
1818import Rel8.Expr ( Expr )
src/Rel8/Query/Indexed.hsnew file+21
@@ -0,0 +1,21 @@
1+module Rel8.Query.Indexed
2+ ( indexed
3+ )
4+where
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+15−12
@@ -19,17 +19,18 @@ import Prelude
1919import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
2020
2121-- rel8
22−import Rel8.Expr ( Col( E, unE ), Expr )
22+import Rel8.Expr ( Expr )
2323import Rel8.Expr.Aggregate ( listAggExpr, nonEmptyAggExpr )
2424import Rel8.Expr.Opaleye ( mapPrimExpr )
2525import Rel8.Query ( Query )
2626import Rel8.Query.Aggregate ( aggregate )
27−import Rel8.Query.Evaluate ( rebind )
2827import Rel8.Query.Maybe ( optional )
28+import Rel8.Query.Rebind ( rebind )
2929import Rel8.Schema.HTable.Vectorize ( hunvectorize )
3030import Rel8.Schema.Null ( Sql, Unnullify )
31−import Rel8.Schema.Spec ( SSpec( SSpec, info ) )
32−import Rel8.Table ( Table, fromColumns, toColumns )
31+import Rel8.Schema.Spec ( Spec( Spec, info ) )
32+import Rel8.Table ( Table, fromColumns )
33+import Rel8.Table.Cols ( toCols )
3334import Rel8.Table.Aggregate ( listAgg, nonEmptyAgg )
3435import Rel8.Table.List ( ListTable( ListTable ) )
3536import Rel8.Table.Maybe ( maybeTable )
@@ -51,7 +52,7 @@ many =
5152 fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .
5253 optional .
5354 aggregate .
54− fmap (listAgg . toColumns)
55+ fmap (listAgg . toCols)
5556
5657
5758-- | Aggregate a 'Query' into a 'NonEmptyTable'. If the supplied query returns
@@ -66,7 +67,7 @@ some :: Table Expr a => Query a -> Query (NonEmptyTable Expr a)
6667some =
6768 fmap (\(NonEmptyTable a) -> NonEmptyTable a) .
6869 aggregate .
69− fmap (nonEmptyAgg . toColumns)
70+ fmap (nonEmptyAgg . toCols)
7071
7172
7273-- | A version of 'many' specialised to single expressions.
@@ -84,8 +85,9 @@ someExpr = aggregate . fmap nonEmptyAggExpr
8485--
8586-- @catListTable@ is an inverse to 'many'.
8687catListTable :: Table Expr a => ListTable Expr a -> Query a
87−catListTable (ListTable as) = rebind $ fromColumns $ runIdentity $
88− hunvectorize (\SSpec {info} -> pure . E . sunnest info . unE) as
88+catListTable (ListTable as) =
89+ rebind "unnest" $ fromColumns $ runIdentity $
90+ hunvectorize (\Spec {info} -> pure . sunnest info) as
8991
9092
9193-- | Expand a 'NonEmptyTable' into a 'Query', where each row in the query is an
@@ -93,8 +95,9 @@ catListTable (ListTable as) = rebind $ fromColumns $ runIdentity $
9395--
9496-- @catNonEmptyTable@ is an inverse to 'some'.
9597catNonEmptyTable :: Table Expr a => NonEmptyTable Expr a -> Query a
96−catNonEmptyTable (NonEmptyTable as) = rebind $ fromColumns $ runIdentity $
97− hunvectorize (\SSpec {info} -> pure . E . sunnest info . unE) as
98+catNonEmptyTable (NonEmptyTable as) =
99+ rebind "unnest" $ fromColumns $ runIdentity $
100+ hunvectorize (\Spec {info} -> pure . sunnest info) as
98101
99102
100103-- | Expand an expression that contains a list into a 'Query', where each row
@@ -102,7 +105,7 @@ catNonEmptyTable (NonEmptyTable as) = rebind $ fromColumns $ runIdentity $
102105--
103106-- @catList@ is an inverse to 'manyExpr'.
104107catList :: Sql DBType a => Expr [a] -> Query (Expr a)
105−catList = rebind . sunnest typeInformation
108+catList = rebind "unnest" . sunnest typeInformation
106109
107110
108111-- | Expand an expression that contains a non-empty list into a 'Query', where
@@ -110,7 +113,7 @@ catList = rebind . sunnest typeInformation
110113--
111114-- @catNonEmpty@ is an inverse to 'someExpr'.
112115catNonEmpty :: Sql DBType a => Expr (NonEmpty a) -> Query (Expr a)
113−catNonEmpty = rebind . sunnest typeInformation
116+catNonEmpty = rebind "unnest" . sunnest typeInformation
114117
115118
116119sunnest :: TypeInformation (Unnullify a) -> Expr (list a) -> Expr a
src/Rel8/Query/Maybe.hs+9−7
@@ -1,4 +1,5 @@
11{-# language GADTs #-}
2+{-# language LambdaCase #-}
23{-# language NamedFieldPuns #-}
34
45module Rel8.Query.Maybe
@@ -18,7 +19,7 @@ import Control.Comonad ( extract )
1819import qualified Opaleye.Internal.MaybeFields as Opaleye
1920
2021-- rel8
21−import Rel8.Expr ( Col( E ), Expr )
22+import Rel8.Expr ( Expr )
2223import Rel8.Expr.Eq ( (==.) )
2324import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )
2425import Rel8.Query ( Query )
@@ -34,7 +35,7 @@ import Rel8.Table.Maybe ( MaybeTable(..), isJustTable )
3435-- JOIN@s.
3536optional :: Query a -> Query (MaybeTable Expr a)
3637optional = mapOpaleye $ Opaleye.optionalInternal $ \tag a -> MaybeTable
37− { tag = E $ fromPrimExpr $ fromColumn tag
38+ { tag = fromPrimExpr $ fromColumn tag
3839 , just = pure a
3940 }
4041
@@ -54,13 +55,14 @@ catMaybeTable ma@(MaybeTable _ a) = do
5455-- to step through multiple @LEFT JOINs@.
5556--
5657-- Note that @traverseMaybeTable@ takes a @a -> Query b@ function, which means
57−-- you also have the ability to "expand" one row into multiple rows. If the
58+-- you also have the ability to "expand" one row into multiple rows. If the
5859-- @a -> Query b@ function returns no rows, then the resulting query will also
5960-- have no rows. However, regardless of the given @a -> Query b@ function, if
6061-- the input is @nothingTable@, you will always get exactly one @nothingTable@
6162-- back.
6263traverseMaybeTable :: (a -> Query b) -> MaybeTable Expr a -> Query (MaybeTable Expr b)
63−traverseMaybeTable query ma@(MaybeTable (E input) _) = do
64− MaybeTable (E output) b <- optional (query =<< catMaybeTable ma)
65− where_ $ output ==. input
66− pure $ MaybeTable (E input) b
64+traverseMaybeTable query ma@(MaybeTable input _) = do
65+ optional (query =<< catMaybeTable ma) >>= \case
66+ MaybeTable output b -> do
67+ where_ $ output ==. input
68+ pure $ MaybeTable input b
src/Rel8/Query/Null.hs+15
@@ -1,5 +1,8 @@
1+{-# language FlexibleContexts #-}
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+18−10
@@ -5,6 +5,7 @@ module Rel8.Query.Opaleye
55 , toOpaleye
66 , mapOpaleye
77 , zipOpaleyeWith
8+ , unsafePeekQuery
89 )
910where
1011
@@ -14,6 +15,7 @@ import Prelude
1415
1516-- opaleye
1617import qualified Opaleye.Internal.QueryArr as Opaleye
18+import qualified Opaleye.Internal.Tag as Opaleye
1719
1820-- rel8
1921import {-# SOURCE #-} Rel8.Query ( Query( Query ) )
@@ -37,26 +39,32 @@ zipOpaleyeWith :: ()
3739zipOpaleyeWith f (Query a) (Query b) = Query $ liftA2 (zipping f) a b
3840
3941
42+unsafePeekQuery :: Query a -> a
43+unsafePeekQuery (Query q) = case q mempty of
44+ f -> case Opaleye.runStateQueryArr f () Opaleye.start of
45+ ((_, a), _, _) -> a
46+
47+
4048mapping :: ()
4149 => (Opaleye.Select a -> Opaleye.Select b)
4250 -> Opaleye.Select (m, a) -> Opaleye.Select (m, b)
43−mapping f q@(Opaleye.QueryArr qa) = Opaleye.QueryArr $ \(_, tag) ->
51+mapping f q = Opaleye.stateQueryArr $ \_ tag ->
4452 let
45− ((m, _), _, _) = qa ((), tag)
46− Opaleye.QueryArr qa' = (m,) <$> f (snd <$> q)
53+ ((m, _), _, _) = Opaleye.runStateQueryArr q () tag
54+ q' = (m,) <$> f (snd <$> q)
4755 in
48− qa' ((), tag)
56+ Opaleye.runStateQueryArr q' () tag
4957
5058
5159zipping :: Semigroup m
5260 => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)
5361 -> Opaleye.Select (m, a) -> Opaleye.Select (m, b) -> Opaleye.Select (m, c)
54−zipping f q@(Opaleye.QueryArr qa) q'@(Opaleye.QueryArr qa') =
55− Opaleye.QueryArr $ \(_, tag) ->
62+zipping f q q' =
63+ Opaleye.stateQueryArr $ \_ tag ->
5664 let
57− ((m, _), _, _) = qa ((), tag)
58− ((m', _), _, _) = qa' ((), tag)
65+ ((m, _), _, _) = Opaleye.runStateQueryArr q () tag
66+ ((m', _), _, _) = Opaleye.runStateQueryArr q' () tag
5967 m'' = m <> m'
60− Opaleye.QueryArr qa'' = (m'',) <$> f (snd <$> q) (snd <$> q')
68+ q'' = (m'',) <$> f (snd <$> q) (snd <$> q')
6169 in
62− qa'' ((), tag)
70+ Opaleye.runStateQueryArr q'' () tag
src/Rel8/Query/Rebind.hsnew file+27
@@ -0,0 +1,27 @@
1+{-# language FlexibleContexts #-}
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( E ) )
27−import Rel8.Expr.Opaleye ( toPrimExpr )
13+import Rel8.Expr ( Expr )
2814import Rel8.Query ( Query )
29−import Rel8.Query.Opaleye ( toOpaleye )
30−import Rel8.Schema.Name ( Name( Name ), Selects, Col( N ) )
31−import Rel8.Schema.HTable ( htabulateA, hfield )
32−import Rel8.Table ( Table, toColumns )
33−import Rel8.Table.Name ( namesFromLabels )
34−import Rel8.Table.Opaleye ( castTable )
15+import Rel8.Statement.Select ( ppSelect )
16+import Rel8.Table ( Table )
3517
3618
37−-- | Convert a query to a 'String' containing the query as a @SELECT@
38−-- statement.
19+-- | Convert a 'Query' to a 'String' containing a @SELECT@ statement.
3920showQuery :: Table Expr a => Query a -> String
40−showQuery = fold . sqlForQuery
41−
42−
43−sqlForQuery :: Table Expr a
44− => Query a -> Maybe String
45−sqlForQuery = sqlForQueryWithNames namesFromLabels . fmap toColumns
46−
47−
48−sqlForQueryWithNames :: Selects names exprs
49− => names -> Query exprs -> Maybe String
50−sqlForQueryWithNames names query =
51− show . Opaleye.ppSql . selectFrom names exprs <$> optimize primQuery
52− where
53− (exprs, primQuery, _) =
54− Opaleye.runSimpleQueryArrStart (toOpaleye query) ()
55−
56−
57−optimize :: Opaleye.PrimQuery' a -> Maybe (Opaleye.PrimQuery' Void)
58−optimize = Opaleye.removeEmpty . Opaleye.optimize
59−
60−
61−selectFrom :: Selects names exprs
62− => names -> exprs -> Opaleye.PrimQuery' Void -> Opaleye.Select
63−selectFrom (toColumns -> names) (toColumns . castTable -> exprs) query =
64− Opaleye.SelectFrom $ Opaleye.newSelect
65− { Opaleye.attrs = Opaleye.SelectAttrs attributes
66− , Opaleye.tables = Opaleye.oneTable select
67− }
68− where
69− select = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator query
70− attributes = getConst $ htabulateA $ \field -> case hfield names field of
71− N (Name name) -> case hfield exprs field of
72− E (toPrimExpr -> expr) -> Const (pure (makeAttr name expr))
73− makeAttr label expr =
74− (Opaleye.sqlExpr expr, Just (Opaleye.SqlColumn label))
21+showQuery = show . ppSelect
src/Rel8/Query/Set.hs+6−6
@@ -23,36 +23,36 @@ import Rel8.Table.Opaleye ( binaryspec )
2323
2424
2525-- | Combine the results of two queries of the same type, collapsing
26−-- duplicates. @union a b@ is the same as the SQL statement @x UNION b@.
26+-- duplicates. @union a b@ is the same as the SQL statement @a UNION b@.
2727union :: EqTable a => Query a -> Query a -> Query a
2828union = zipOpaleyeWith (Opaleye.unionExplicit binaryspec)
2929
3030
3131-- | Combine the results of two queries of the same type, retaining duplicates.
32−-- @unionAll a b@ is the same as the SQL statement @x UNION ALL b@.
32+-- @unionAll a b@ is the same as the SQL statement @a UNION ALL b@.
3333unionAll :: Table Expr a => Query a -> Query a -> Query a
3434unionAll = zipOpaleyeWith (Opaleye.unionAllExplicit binaryspec)
3535
3636
3737-- | Find the intersection of two queries, collapsing duplicates. @intersect a
38−-- b@ is the same as the SQL statement @x INTERSECT b@.
38+-- b@ is the same as the SQL statement @a INTERSECT b@.
3939intersect :: EqTable a => Query a -> Query a -> Query a
4040intersect = zipOpaleyeWith (Opaleye.intersectExplicit binaryspec)
4141
4242
4343-- | Find the intersection of two queries, retaining duplicates. @intersectAll
44−-- a b@ is the same as the SQL statement @x INTERSECT ALL b@.
44+-- a b@ is the same as the SQL statement @a INTERSECT ALL b@.
4545intersectAll :: EqTable a => Query a -> Query a -> Query a
4646intersectAll = zipOpaleyeWith (Opaleye.intersectAllExplicit binaryspec)
4747
4848
4949-- | Find the difference of two queries, collapsing duplicates @except a b@ is
50−-- the same as the SQL statement @x INTERSECT b@.
50+-- the same as the SQL statement @a EXCEPT b@.
5151except :: EqTable a => Query a -> Query a -> Query a
5252except = zipOpaleyeWith (Opaleye.exceptExplicit binaryspec)
5353
5454
5555-- | Find the difference of two queries, retaining duplicates. @exceptAll a b@
56−-- is the same as the SQL statement @x EXCEPT ALL b@.
56+-- is the same as the SQL statement @a EXCEPT ALL b@.
5757exceptAll :: EqTable a => Query a -> Query a -> Query a
5858exceptAll = zipOpaleyeWith (Opaleye.exceptAllExplicit binaryspec)
src/Rel8/Query/These.hs+14−14
@@ -25,7 +25,7 @@ import qualified Opaleye.Internal.QueryArr as Opaleye
2525import qualified Opaleye.Internal.Tag as Opaleye
2626
2727-- rel8
28−import Rel8.Expr ( Col( E ), Expr )
28+import Rel8.Expr ( Expr )
2929import Rel8.Expr.Bool ( boolExpr, not_ )
3030import Rel8.Expr.Eq ( (==.) )
3131import Rel8.Expr.Opaleye ( toPrimExpr, traversePrimExpr )
@@ -48,27 +48,27 @@ import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) )
4848alignBy :: ()
4949 => (a -> b -> Expr Bool)
5050 -> Query a -> Query b -> Query (TheseTable Expr a b)
51−alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.QueryArr $ \i -> case i of
52− (_, tag) -> (tab, join', tag''')
51+alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.stateQueryArr $ \_ t -> case t of
52+ tag -> (tab, join', tag''')
5353 where
54− (ma, left', tag') = Opaleye.runSimpleQueryArr (pure <$> left) ((), tag)
55− (mb, right', tag'') = Opaleye.runSimpleQueryArr (pure <$> right) ((), tag')
56− MaybeTable (E hasHere) a = ma
57− MaybeTable (E hasThere) b = mb
54+ (ma, left', tag') = Opaleye.runStateQueryArr (pure <$> left) () tag
55+ (mb, right', tag'') = Opaleye.runStateQueryArr (pure <$> right) () tag'
56+ MaybeTable hasHere a = ma
57+ MaybeTable hasThere b = mb
5858 (hasHere', lbindings) = Opaleye.run $ do
5959 traversePrimExpr (Opaleye.extractAttr "hasHere" tag'') hasHere
6060 (hasThere', rbindings) = Opaleye.run $ do
6161 traversePrimExpr (Opaleye.extractAttr "hasThere" tag'') hasThere
6262 tag''' = Opaleye.next tag''
63− join lateral = Opaleye.Join Opaleye.FullJoin on left'' right''
63+ join = Opaleye.Join Opaleye.FullJoin on left'' right''
6464 where
6565 on = toPrimExpr $ condition (extract a) (extract b)
66− left'' = (lateral, Opaleye.Rebind True lbindings left')
67− right'' = (lateral, Opaleye.Rebind True rbindings right')
68− ma' = MaybeTable (E hasHere') a
69− mb' = MaybeTable (E hasThere') b
66+ left'' = (Opaleye.NonLateral, Opaleye.toPrimQuery (left' <> Opaleye.aRebind lbindings))
67+ right'' = (Opaleye.NonLateral, Opaleye.toPrimQuery (right' <> Opaleye.aRebind rbindings))
68+ ma' = MaybeTable hasHere' a
69+ mb' = MaybeTable hasThere' b
7070 tab = TheseTable {here = ma', there = mb'}
71− join' lateral input = Opaleye.times lateral input (join lateral)
71+ join' = Opaleye.aProduct join
7272
7373
7474keepHereTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)
@@ -120,7 +120,7 @@ keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
120120loseThoseTable :: TheseTable Expr a b -> Query (EitherTable Expr a b)
121121loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
122122 where_ $ not_ $ isThoseTable t
123− pure $ EitherTable (E tag) a b
123+ pure $ EitherTable tag a b
124124 where
125125 tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)
126126
src/Rel8/Query/Window.hsnew file+26
@@ -0,0 +1,26 @@
1+module Rel8.Query.Window
2+ ( window
3+ )
4+where
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/Abstract.hsdeleted−80
@@ -1,80 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language GADTs #-}
3−{-# language LambdaCase #-}
4−{-# language StandaloneKindSignatures #-}
5−{-# language TypeFamilies #-}
6−{-# language TypeOperators #-}
7−
8−module Rel8.Schema.Context.Abstract
9− ( Abstract, virtual
10− , Virtual(..), virtualOrResult, exclusivity
11− )
12−where
13−
14−-- base
15−import Data.Kind ( Constraint, Type )
16−import Data.Type.Equality ( (:~:)( Refl) )
17−import Prelude
18−
19−-- rel8
20−import Rel8.Aggregate ( Aggregate )
21−import Rel8.Expr ( Expr )
22−import Rel8.Kind.Context ( SContext(..) )
23−import qualified Rel8.Schema.Kind as K
24−import Rel8.Schema.Name ( Name )
25−import Rel8.Schema.Reify ( Reify )
26−import Rel8.Schema.Result ( Result, NotResult( NotResult ) )
27−
28−
29−type Abstract :: K.Context -> Constraint
30−type family Abstract context where
31− Abstract (Reify context) = IsVirtual context
32− Abstract _ = ()
33−
34−
35−type IsVirtual :: K.Context -> Constraint
36−class IsVirtual context where
37− virtual :: Virtual context
38−
39−
40−instance IsVirtual Aggregate where
41− virtual = VAggregate
42−
43−
44−instance IsVirtual Expr where
45− virtual = VExpr
46−
47−
48−instance IsVirtual Name where
49− virtual = VName
50−
51−
52−instance IsVirtual (Reify context) where
53− virtual = VReify
54−
55−
56−type Virtual :: K.Context -> Type
57−data Virtual context where
58− VAggregate :: Virtual Aggregate
59− VExpr :: Virtual Expr
60− VName :: Virtual Name
61− VReify :: Virtual (Reify context)
62−
63−
64−virtualOrResult :: ()
65− => SContext context
66− -> Either (context :~: Result) (Virtual context)
67−virtualOrResult = \case
68− SAggregate -> Right VAggregate
69− SExpr -> Right VExpr
70− SName -> Right VName
71− SResult -> Left Refl
72− SReify _ -> Right VReify
73−
74−
75−exclusivity :: Virtual context -> NotResult context
76−exclusivity = \case
77− VAggregate -> NotResult
78− VExpr -> NotResult
79− VName -> NotResult
80− VReify -> NotResult
src/Rel8/Schema/Context/Nullify.hs+38−59
@@ -15,31 +15,27 @@ module Rel8.Schema.Context.Nullify
1515where
1616
1717-- base
18−import Data.Bifunctor ( bimap )
1918import Data.Bool ( bool )
19+import Data.Functor.Identity ( Identity( Identity ) )
2020import Data.Kind ( Constraint, Type )
21−import Data.Monoid ( getFirst )
2221import Prelude hiding ( null )
2322
2423-- opaleye
2524import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
2625
2726-- rel8
28−import Rel8.Aggregate
29− ( Col( A ), Aggregate( Aggregate )
30− , foldInputs, mapInputs
31− )
32−import Rel8.Expr ( Col( E ), Expr )
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 )
31+import Rel8.Expr.Opaleye ( fromPrimExpr )
3632import Rel8.Kind.Context ( SContext(..) )
33+import Rel8.Schema.Field ( Field )
3734import qualified Rel8.Schema.Kind as K
38−import Rel8.Schema.Name ( Col( N ), Name( Name ) )
35+import Rel8.Schema.Name ( Name( Name ) )
3936import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )
40−import Rel8.Schema.Reify ( Col( Reify ), Reify )
41−import Rel8.Schema.Result ( Col( R ), Result )
42−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
37+import Rel8.Schema.Result ( Result )
38+import Rel8.Schema.Spec ( Spec(..) )
4339
4440
4541type Nullifiability :: K.Context -> Type
@@ -47,7 +43,6 @@ data Nullifiability context where
4743 NAggregate :: Nullifiability Aggregate
4844 NExpr :: Nullifiability Expr
4945 NName :: Nullifiability Name
50− NReify :: Nullifiability context -> Nullifiability (Reify context)
5146
5247
5348type Nullifiable :: K.Context -> Constraint
@@ -67,14 +62,10 @@ instance Nullifiable Name where
6762 nullifiability = NName
6863
6964
70−instance Nullifiable context => Nullifiable (Reify context) where
71− nullifiability = NReify nullifiability
72−
73−
7465type NonNullifiability :: K.Context -> Type
7566data NonNullifiability context where
76− NNResult :: NonNullifiability Result
77− NNReify :: NonNullifiability context -> NonNullifiability (Reify context)
67+ NField :: NonNullifiability (Field table)
68+ NResult :: NonNullifiability Result
7869
7970
8071nullifiableOrNot :: ()
@@ -83,9 +74,9 @@ nullifiableOrNot :: ()
8374nullifiableOrNot = \case
8475 SAggregate -> Right NAggregate
8576 SExpr -> Right NExpr
77+ SField -> Left NField
8678 SName -> Right NName
87− SResult -> Left NNResult
88− SReify context -> bimap NNReify NReify $ nullifiableOrNot context
79+ SResult -> Left NResult
8980
9081
9182absurd :: Nullifiability context -> NonNullifiability context -> a
@@ -93,58 +84,46 @@ absurd = \case
9384 NAggregate -> \case
9485 NExpr -> \case
9586 NName -> \case
96− NReify context -> \case
97− NNReify context' -> absurd context context'
9887
9988
10089guarder :: ()
10190 => SContext context
102− -> Col context ('Spec tag)
91+ -> context tag
10392 -> (tag -> Bool)
10493 -> (Expr tag -> Expr Bool)
105− -> Col context ('Spec (Maybe a))
106− -> Col context ('Spec (Maybe a))
107−guarder SAggregate (A tag) _ isNonNull (A (Aggregate a)) =
108− A $
109− mapInputs (toPrimExpr . run . fromPrimExpr) $
110− Aggregate $
111− run <$> a
112− where
113− mtag = foldInputs (\_ -> pure . fromPrimExpr) tag
114− run = maybe id (sguard . isNonNull) (getFirst mtag)
115−guarder SExpr (E tag) _ isNonNull (E a) = E $ sguard condition a
116− where
117− condition = isNonNull tag
118−guarder SName _ _ _ name = name
119−guarder SResult (R tag) isNonNull _ (R a) = R (bool Nothing a condition)
120− where
121− condition = isNonNull tag
122−guarder (SReify context) (Reify tag) isNonNull isNonNullExpr (Reify a) =
123− Reify $ guarder context tag isNonNull isNonNullExpr a
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))
124103
125104
126105nullifier :: ()
127106 => Nullifiability context
128− -> SSpec ('Spec a)
129− -> Col context ('Spec a)
130− -> Col context ('Spec (Nullify a))
131−nullifier NAggregate SSpec {nullity} (A (Aggregate a)) =
132− A $ Aggregate $ snullify nullity <$> a
133−nullifier NExpr SSpec {nullity} (E a) = E $ snullify nullity a
134−nullifier NName _ (N (Name a)) = N $ Name a
135−nullifier (NReify context) spec (Reify a) = Reify $ nullifier context spec a
107+ -> Spec a
108+ -> context a
109+ -> context (Nullify a)
110+nullifier = \case
111+ NAggregate -> \Spec {nullity} (Aggregate a) ->
112+ Aggregate $ snullify nullity <$> a
113+ NExpr -> \Spec {nullity} a -> snullify nullity a
114+ NName -> \_ (Name a) -> Name a
136115
137116
138117unnullifier :: ()
139118 => Nullifiability context
140− -> SSpec ('Spec a)
141− -> Col context ('Spec (Nullify a))
142− -> Col context ('Spec a)
143−unnullifier NAggregate SSpec {nullity} (A (Aggregate a)) =
144− A $ Aggregate $ sunnullify nullity <$> a
145−unnullifier NExpr SSpec {nullity} (E a) = E $ sunnullify nullity a
146−unnullifier NName _ (N (Name a)) = N $ Name a
147−unnullifier (NReify context) spec (Reify a) = Reify (unnullifier context spec a)
119+ -> Spec a
120+ -> context (Nullify a)
121+ -> context a
122+unnullifier = \case
123+ NAggregate -> \Spec {nullity} (Aggregate a) ->
124+ Aggregate $ sunnullify nullity <$> a
125+ NExpr -> \Spec {nullity} a -> sunnullify nullity a
126+ NName -> \_ (Name a) -> Name a
148127
149128
150129sguard :: Expr Bool -> Expr (Maybe a) -> Expr (Maybe 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−2
@@ -15,7 +15,7 @@ import Prelude ()
1515
1616-- rel8
1717import Rel8.Schema.HTable ( HTable )
18−import Rel8.Schema.HTable.Identity ( HType )
18+import Rel8.Schema.HTable.Identity ( HIdentity )
1919import Rel8.Schema.HTable.Label ( HLabel )
2020import Rel8.Schema.HTable.Nullify ( HNullify )
2121import qualified Rel8.Schema.Kind as K
@@ -24,7 +24,7 @@ import Rel8.Type.Tag ( EitherTag )
2424
2525type HEitherTable :: K.HTable -> K.HTable -> K.HTable
2626data HEitherTable left right context = HEitherTable
27− { htag :: HLabel "isRight" (HType EitherTag) context
27+ { htag :: HLabel "isRight" (HIdentity EitherTag) context
2828 , hleft :: HLabel "Left" (HNullify left) context
2929 , hright :: HLabel "Right" (HNullify right) context
3030 }
src/Rel8/Schema/HTable/Identity.hs+16−28
@@ -1,17 +1,17 @@
11{-# language DataKinds #-}
2−{-# language GADTs #-}
3−{-# language PatternSynonyms #-}
2+{-# language FlexibleContexts #-}
43{-# language StandaloneKindSignatures #-}
54{-# language TypeFamilies #-}
5+{-# language UndecidableInstances #-}
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
@@ -21,35 +21,23 @@ import Rel8.Schema.HTable
2121 , hfield, htabulate, htraverse, hdicts, hspecs
2222 )
2323import qualified Rel8.Schema.Kind as K
24−import Rel8.Schema.Spec ( Spec( Spec ), KnownSpec, specSing )
24+import Rel8.Schema.Null ( Sql )
25+import Rel8.Schema.Spec ( specification )
26+import Rel8.Type ( DBType )
2527
2628
27−type HType :: Type -> K.HTable
28−type HType a = HIdentity ('Spec a)
29−
30−
31−pattern HType :: context ('Spec a) -> HType a context
32−pattern HType a = HIdentity a
33−{-# COMPLETE HType #-}
34−
35−
36−type HIdentity :: Spec -> K.HTable
37−newtype HIdentity spec context = HIdentity
38− { unHIdentity :: context spec
29+type HIdentity :: Type -> K.HTable
30+newtype HIdentity a context = HIdentity
31+ { unHIdentity :: context a
3932 }
4033
4134
42−type HIdentityField :: Spec -> Spec -> Type
43−data HIdentityField _spec spec where
44− HIdentityField :: HIdentityField spec spec
45−
46−
47−instance KnownSpec spec => HTable (HIdentity spec) where
48− type HConstrainTable (HIdentity spec) c = c spec
49− type HField (HIdentity spec) = HIdentityField spec
35+instance Sql DBType a => HTable (HIdentity a) where
36+ type HConstrainTable (HIdentity a) constraint = constraint a
37+ type HField (HIdentity a) = (:~:) a
5038
51− hfield (HIdentity a) HIdentityField = a
52− htabulate f = HIdentity $ f HIdentityField
39+ hfield (HIdentity a) Refl = a
40+ htabulate f = HIdentity $ f Refl
5341 htraverse f (HIdentity a) = HIdentity <$> f a
5442 hdicts = HIdentity Dict
55− hspecs = HIdentity specSing
43+ hspecs = HIdentity specification
src/Rel8/Schema/HTable/Label.hs+15−4
@@ -1,4 +1,5 @@
11{-# language DataKinds #-}
2+{-# language RankNTypes #-}
23{-# language RecordWildCards #-}
34{-# language ScopedTypeVariables #-}
45{-# language StandaloneKindSignatures #-}
@@ -7,6 +8,7 @@
78
89module Rel8.Schema.HTable.Label
910 ( HLabel, hlabel, hrelabel, hunlabel
11+ , hproject
1012 )
1113where
1214
@@ -18,16 +20,19 @@ import Prelude
1820
1921-- rel8
2022import Rel8.Schema.HTable
23+ ( HTable, HConstrainTable, HField
24+ , htabulate, hfield, htraverse, hdicts, hspecs
25+ )
2126import qualified Rel8.Schema.Kind as K
22−import Rel8.Schema.Spec ( Spec, SSpec(..) )
27+import Rel8.Schema.Spec ( Spec(..) )
2328
2429
2530type HLabel :: Symbol -> K.HTable -> K.HTable
2631newtype HLabel label table context = HLabel (table context)
2732
2833
29−type HLabelField :: Symbol -> K.HTable -> Spec -> Type
30−newtype HLabelField label table spec = HLabelField (HField table spec)
34+type HLabelField :: Symbol -> K.HTable -> Type -> Type
35+newtype HLabelField label table a = HLabelField (HField table a)
3136
3237
3338instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where
@@ -40,7 +45,7 @@ instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where
4045 htraverse f (HLabel a) = HLabel <$> htraverse f a
4146 hdicts = HLabel (hdicts @table)
4247 hspecs = HLabel $ htabulate $ \field -> case hfield (hspecs @table) field of
43− SSpec {..} -> SSpec {labels = symbolVal (Proxy @label) : labels, ..}
48+ Spec {..} -> Spec {labels = symbolVal (Proxy @label) : labels, ..}
4449 {-# INLINABLE hspecs #-}
4550
4651
@@ -57,3 +62,9 @@ hrelabel = hlabel . hunlabel
5762hunlabel :: forall label t context. HLabel label t context -> t context
5863hunlabel (HLabel a) = a
5964{-# INLINABLE hunlabel #-}
65+
66+
67+hproject :: ()
68+ => (forall ctx. t ctx -> t' ctx)
69+ -> HLabel label t context -> HLabel label t' context
70+hproject f (HLabel a) = HLabel (f a)
src/Rel8/Schema/HTable/MapTable.hs+22−12
@@ -6,7 +6,7 @@
66{-# language GADTs #-}
77{-# language InstanceSigs #-}
88{-# language MultiParamTypeClasses #-}
9−{-# language PolyKinds #-}
9+{-# language RankNTypes #-}
1010{-# language ScopedTypeVariables #-}
1111{-# language StandaloneKindSignatures #-}
1212{-# language TypeApplications #-}
@@ -19,34 +19,38 @@ module Rel8.Schema.HTable.MapTable
1919 , MapSpec(..)
2020 , Precompose(..)
2121 , HMapTableField(..)
22+ , hproject
2223 )
2324where
2425
2526-- base
2627import Data.Kind ( Constraint, Type )
27−import Prelude ( ($), (.), (<$>), fmap )
28+import Prelude
2829
2930-- rel8
30−import Rel8.FCF
31+import Rel8.FCF ( Exp, Eval )
3132import Rel8.Schema.HTable
32−import Rel8.Schema.Spec ( Spec, SSpec )
33+ ( HTable, HConstrainTable, HField
34+ , hfield, htabulate, htraverse, hdicts, hspecs
35+ )
36+import Rel8.Schema.Spec ( Spec )
3337import qualified Rel8.Schema.Kind as K
3438import Rel8.Schema.Dict ( Dict( Dict ) )
3539
3640
37−type HMapTable :: (a -> Exp b) -> ((a -> Type) -> Type) -> (b -> Type) -> Type
38−newtype HMapTable f t g = HMapTable
39− { unHMapTable :: t (Precompose f g)
41+type HMapTable :: (Type -> Exp Type) -> K.HTable -> K.HTable
42+newtype HMapTable f t context = HMapTable
43+ { unHMapTable :: t (Precompose f context)
4044 }
4145
4246
43−type Precompose :: (a -> Exp b) -> (b -> Type) -> a -> Type
47+type Precompose :: (Type -> Exp Type) -> K.Context -> K.Context
4448newtype Precompose f g x = Precompose
4549 { precomposed :: g (Eval (f x))
4650 }
4751
4852
49−type HMapTableField :: (Spec -> Exp a) -> K.HTable -> a -> Type
53+type HMapTableField :: (Type -> Exp Type) -> K.HTable -> K.Context
5054data HMapTableField f t x where
5155 HMapTableField :: HField t a -> HMapTableField f t (Eval (f a))
5256
@@ -79,11 +83,17 @@ instance (HTable t, MapSpec f) => HTable (HMapTable f t) where
7983 {-# INLINABLE hspecs #-}
8084
8185
82−type MapSpec :: (Spec -> Exp Spec) -> Constraint
86+type MapSpec :: (Type -> Exp Type) -> Constraint
8387class MapSpec f where
84− mapInfo :: SSpec x -> SSpec (Eval (f x))
88+ mapInfo :: Spec x -> Spec (Eval (f x))
8589
8690
87−type ComposeConstraint :: (a -> Exp b) -> (b -> Constraint) -> a -> Constraint
91+type ComposeConstraint :: (Type -> Exp Type) -> (Type -> Constraint) -> Type -> Constraint
8892class c (Eval (f a)) => ComposeConstraint f c a
8993instance c (Eval (f a)) => ComposeConstraint f c a
94+
95+
96+hproject :: ()
97+ => (forall ctx. t ctx -> t' ctx)
98+ -> HMapTable f t context -> HMapTable f t' context
99+hproject f (HMapTable a) = HMapTable (f a)
src/Rel8/Schema/HTable/Maybe.hs+2−2
@@ -15,7 +15,7 @@ import Prelude
1515
1616-- rel8
1717import Rel8.Schema.HTable ( HTable )
18−import Rel8.Schema.HTable.Identity ( HType )
18+import Rel8.Schema.HTable.Identity ( HIdentity )
1919import Rel8.Schema.HTable.Label ( HLabel )
2020import Rel8.Schema.HTable.Nullify ( HNullify )
2121import qualified Rel8.Schema.Kind as K
@@ -24,7 +24,7 @@ import Rel8.Type.Tag ( MaybeTag )
2424
2525type HMaybeTable :: K.HTable -> K.HTable
2626data HMaybeTable table context = HMaybeTable
27− { htag :: HLabel "isJust" (HType (Maybe MaybeTag)) context
27+ { htag :: HLabel "isJust" (HIdentity (Maybe MaybeTag)) context
2828 , hjust :: HLabel "Just" (HNullify table) context
2929 }
3030 deriving stock Generic
src/Rel8/Schema/HTable/Nullify.hs+22−24
@@ -23,10 +23,12 @@ module Rel8.Schema.HTable.Nullify
2323 , hnulls
2424 , hnullify
2525 , hunnullify
26+ , hproject
2627 )
2728where
2829
2930-- base
31+import Data.Kind ( Type )
3032import GHC.Generics ( Generic )
3133import Prelude hiding ( null )
3234
@@ -37,10 +39,11 @@ import Rel8.Schema.HTable.MapTable
3739 ( HMapTable, HMapTableField( HMapTableField )
3840 , MapSpec, mapInfo
3941 )
42+import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )
4043import qualified Rel8.Schema.Kind as K
4144import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
4245import qualified Rel8.Schema.Null as Type ( Nullify )
43−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
46+import Rel8.Schema.Spec ( Spec(..) )
4447
4548-- semigroupoids
4649import Data.Functor.Apply ( Apply )
@@ -52,17 +55,14 @@ newtype HNullify table context = HNullify (HMapTable Nullify table context)
5255 deriving anyclass HTable
5356
5457
55−-- | Transform a 'Spec' by allowing it to be @null@.
56−data Nullify :: Spec -> Exp Spec
57−
58−
59−type instance Eval (Nullify ('Spec a)) =
60− 'Spec (Type.Nullify a)
58+-- | Transform a 'Type' by allowing it to be @null@.
59+data Nullify :: Type -> Exp Type
60+type instance Eval (Nullify a) = Type.Nullify a
6161
6262
6363instance MapSpec Nullify where
6464 mapInfo = \case
65− SSpec {nullity, ..} -> SSpec
65+ Spec {nullity, ..} -> Spec
6666 { nullity = case nullity of
6767 Null -> Null
6868 NotNull -> Null
@@ -71,49 +71,47 @@ instance MapSpec Nullify where
7171
7272
7373hguard :: HTable t
74− => (forall a. context ('Spec (Maybe a)) -> context ('Spec (Maybe a)))
74+ => (forall a. context (Maybe a) -> context (Maybe a))
7575 -> HNullify t context -> HNullify t context
7676hguard guarder (HNullify as) = HNullify $ htabulate $ \(HMapTableField field) ->
7777 case hfield hspecs field of
78− SSpec {nullity} -> case hfield as (HMapTableField field) of
78+ Spec {nullity} -> case hfield as (HMapTableField field) of
7979 a -> case nullity of
8080 Null -> guarder a
8181 NotNull -> guarder a
8282
8383
8484hnulls :: HTable t
85− => (forall a. ()
86− => SSpec ('Spec a)
87− -> context ('Spec (Type.Nullify a)))
85+ => (forall a. Spec a -> context (Type.Nullify a))
8886 -> HNullify t context
8987hnulls null = HNullify $ htabulate $ \(HMapTableField field) ->
9088 case hfield hspecs field of
91− spec@SSpec {} -> null spec
89+ spec@Spec {} -> null spec
9290{-# INLINABLE hnulls #-}
9391
9492
9593hnullify :: HTable t
96− => (forall a. ()
97− => SSpec ('Spec a)
98− -> context ('Spec a)
99− -> context ('Spec (Type.Nullify a)))
94+ => (forall a. Spec a -> context a -> context (Type.Nullify a))
10095 -> t context
10196 -> HNullify t context
10297hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->
10398 case hfield hspecs field of
104− spec@SSpec {} -> nullifier spec (hfield a field)
99+ spec@Spec {} -> nullifier spec (hfield a field)
105100{-# INLINABLE hnullify #-}
106101
107102
108103hunnullify :: (HTable t, Apply m)
109− => (forall a. ()
110− => SSpec ('Spec a)
111− -> context ('Spec (Type.Nullify a))
112− -> m (context ('Spec a)))
104+ => (forall a. Spec a -> context (Type.Nullify a) -> m (context a))
113105 -> HNullify t context
114106 -> m (t context)
115107hunnullify unnullifier (HNullify as) =
116108 htabulateA $ \field -> case hfield hspecs field of
117− spec@SSpec {} -> case hfield as (HMapTableField field) of
109+ spec@Spec {} -> case hfield as (HMapTableField field) of
118110 a -> unnullifier spec a
119111{-# INLINABLE hunnullify #-}
112+
113+
114+hproject :: ()
115+ => (forall ctx. t ctx -> t' ctx)
116+ -> HNullify t context -> HNullify t' context
117+hproject f (HNullify a) = HNullify (HMapTable.hproject f a)
src/Rel8/Schema/HTable/These.hs+3−3
@@ -15,7 +15,7 @@ import Prelude
1515
1616-- rel8
1717import Rel8.Schema.HTable ( HTable )
18−import Rel8.Schema.HTable.Identity ( HType )
18+import Rel8.Schema.HTable.Identity ( HIdentity )
1919import Rel8.Schema.HTable.Label ( HLabel )
2020import Rel8.Schema.HTable.Nullify ( HNullify )
2121import qualified Rel8.Schema.Kind as K
@@ -24,9 +24,9 @@ import Rel8.Type.Tag ( MaybeTag )
2424
2525type HTheseTable :: K.HTable -> K.HTable -> K.HTable
2626data HTheseTable here there context = HTheseTable
27− { hhereTag :: HLabel "hereTag" (HType (Maybe MaybeTag)) context
27+ { hhereTag :: HLabel "hereTag" (HIdentity (Maybe MaybeTag)) context
2828 , hhere :: HLabel "Here" (HNullify here) context
29− , hthereTag :: HLabel "thereTag" (HType (Maybe MaybeTag)) context
29+ , hthereTag :: HLabel "thereTag" (HIdentity (Maybe MaybeTag)) context
3030 , hthere :: HLabel "There" (HNullify there) context
3131 }
3232 deriving stock Generic
src/Rel8/Schema/HTable/Vectorize.hs+39−40
@@ -9,7 +9,6 @@
99{-# language GADTs #-}
1010{-# language LambdaCase #-}
1111{-# language MultiParamTypeClasses #-}
12−{-# language NamedFieldPuns #-}
1312{-# language RankNTypes #-}
1413{-# language RecordWildCards #-}
1514{-# language ScopedTypeVariables #-}
@@ -22,33 +21,39 @@ module Rel8.Schema.HTable.Vectorize
2221 ( HVectorize
2322 , hvectorize, hunvectorize
2423 , happend, hempty
24+ , hproject
25+ , hcolumn
2526 )
2627where
2728
2829-- base
29−import Data.Kind ( Type )
30+import Data.Kind ( Constraint, Type )
3031import Data.List.NonEmpty ( NonEmpty )
32+import GHC.Generics (Generic)
3133import Prelude
3234
3335-- rel8
36+import Rel8.FCF ( Eval, Exp )
3437import Rel8.Schema.Dict ( Dict( Dict ) )
3538import qualified Rel8.Schema.Kind as K
36−import Rel8.Schema.HTable
37− ( HTable
38− , hfield, htabulate, htabulateA, hspecs
39+import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )
40+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
41+import Rel8.Schema.HTable.MapTable
42+ ( HMapTable( HMapTable ), HMapTableField( HMapTableField )
43+ , MapSpec, mapInfo
44+ , Precompose( Precompose )
3945 )
46+import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )
4047import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )
41−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
48+import Rel8.Schema.Spec ( Spec(..) )
4249import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
4350import Rel8.Type.Information ( TypeInformation )
4451
4552-- semialign
4653import Data.Zip ( Unzip, Zip, Zippy(..) )
47−import Rel8.FCF
48−import Rel8.Schema.HTable.MapTable
49−import GHC.Generics (Generic)
5054
5155
56+type Vector :: (Type -> Type) -> Constraint
5257class Vector list where
5358 listNotNull :: proxy a -> Dict NotNull (list a)
5459 vectorTypeInformation :: ()
@@ -73,16 +78,16 @@ newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) t
7378 deriving anyclass HTable
7479
7580
76−data Vectorize :: (Type -> Type) -> Spec -> Exp Spec
81+data Vectorize :: (Type -> Type) -> Type -> Exp Type
7782
7883
79−type instance Eval (Vectorize list ('Spec a)) = 'Spec (list a)
84+type instance Eval (Vectorize list a) = list a
8085
8186
8287instance Vector list => MapSpec (Vectorize list) where
8388 mapInfo = \case
84− SSpec {..} -> case listNotNull @list nullity of
85− Dict -> SSpec
89+ Spec {..} -> case listNotNull @list nullity of
90+ Dict -> Spec
8691 { nullity = NotNull
8792 , info = vectorTypeInformation nullity info
8893 , ..
@@ -90,55 +95,49 @@ instance Vector list => MapSpec (Vectorize list) where
9095
9196
9297hvectorize :: (HTable t, Unzip f, Vector list)
93− => (forall a. ()
94− => SSpec ('Spec a)
95− -> f (context ('Spec a))
96− -> context' ('Spec (list a)))
98+ => (forall a. Spec a -> f (context a) -> context' (list a))
9799 -> f (t context)
98100 -> HVectorize list t context'
99101hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->
100102 case hfield hspecs field of
101− spec@SSpec {} -> vectorizer spec (fmap (`hfield` field) as)
103+ spec -> vectorizer spec (fmap (`hfield` field) as)
102104{-# INLINABLE hvectorize #-}
103105
104106
105107hunvectorize :: (HTable t, Zip f, Vector list)
106− => (forall a. ()
107− => SSpec ('Spec a)
108− -> context ('Spec (list a))
109− -> f (context' ('Spec a)))
108+ => (forall a. Spec a -> context (list a) -> f (context' a))
110109 -> HVectorize list t context
111110 -> f (t context')
112111hunvectorize unvectorizer (HVectorize table) =
113112 getZippy $ htabulateA $ \field -> case hfield hspecs field of
114− spec@SSpec{} -> case hfield table (HMapTableField field) of
113+ spec -> case hfield table (HMapTableField field) of
115114 a -> Zippy (unvectorizer spec a)
116115{-# INLINABLE hunvectorize #-}
117116
118117
119−happend :: (HTable t, Vector list) =>
120− ( forall a. ()
121− => Nullity a
122− -> TypeInformation (Unnullify a)
123− -> context ('Spec (list a))
124− -> context ('Spec (list a))
125− -> context ('Spec (list a))
126− )
118+happend :: (HTable t, Vector list)
119+ => (forall a. Spec a -> context (list a) -> context (list a) -> context (list a))
127120 -> HVectorize list t context
128121 -> HVectorize list t context
129122 -> HVectorize list t context
130123happend append (HVectorize as) (HVectorize bs) = HVectorize $
131124 htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of
132125 (a, b) -> case hfield hspecs j of
133− SSpec {nullity, info} -> append nullity info a b
126+ spec -> append spec a b
134127
135128
136−hempty :: HTable t =>
137− ( forall a. ()
138− => Nullity a
139− -> TypeInformation (Unnullify a)
140− -> context ('Spec [a])
141− )
129+hempty :: HTable t
130+ => (forall a. Spec a -> context [a])
142131 -> HVectorize [] t context
143−hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
144− SSpec {nullity, info} -> empty nullity info
132+hempty empty = HVectorize $ htabulate $ \(HMapTableField field) ->
133+ empty (hfield hspecs field)
134+
135+
136+hproject :: ()
137+ => (forall ctx. t ctx -> t' ctx)
138+ -> HVectorize list t context -> HVectorize list t' context
139+hproject f (HVectorize a) = HVectorize (HMapTable.hproject f a)
140+
141+
142+hcolumn :: HVectorize list (HIdentity a) context -> context (list a)
143+hcolumn (HVectorize (HMapTable (HIdentity (Precompose a)))) = a
src/Rel8/Schema/Kind.hs+6−15
@@ -1,8 +1,9 @@
11{-# language StandaloneKindSignatures #-}
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+33−52
@@ -3,41 +3,44 @@
33{-# language FlexibleContexts #-}
44{-# language FlexibleInstances #-}
55{-# language GADTs #-}
6+{-# language GeneralizedNewtypeDeriving #-}
67{-# language MultiParamTypeClasses #-}
7−{-# language PolyKinds #-}
88{-# language RankNTypes #-}
9−{-# language StandaloneDeriving #-}
109{-# language StandaloneKindSignatures #-}
1110{-# language TypeFamilies #-}
1211{-# language UndecidableInstances #-}
13−{-# language UndecidableSuperClasses #-}
1412
1513module Rel8.Schema.Name
1614 ( Name(..)
17− , Col( N, unN )
1815 , Selects
16+ , ppColumn
1917 )
2018where
2119
2220-- base
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.HTable.Identity ( HIdentity( HType ), HType )
35+import qualified Rel8.Schema.Kind as K
36+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
3237import Rel8.Schema.Null ( Sql )
33−import Rel8.Schema.Reify ( notReify )
34−import Rel8.Schema.Result ( Result )
35−import Rel8.Schema.Spec ( Spec( Spec ) )
3638import Rel8.Table
3739 ( Table, Columns, Context, fromColumns, toColumns
38− , reify, unreify, coherence, congruence
40+ , FromExprs, fromResult, toResult
41+ , Transpose
3942 )
40−import Rel8.Table.Recontextualize ( Recontextualize )
43+import Rel8.Table.Transpose ( Transposes )
4144import Rel8.Type ( DBType )
4245
4346
@@ -45,52 +48,30 @@ import Rel8.Type ( DBType )
4548-- schema definition. You can construct names by using the @OverloadedStrings@
4649-- extension and writing string literals. This is typically done when providing
4750-- a 'TableSchema' value.
48−type Name :: k -> Type
49−data Name a where
50− Name :: k ~ Type => !String -> Name (a :: k)
51−
52−
53−deriving stock instance Show (Name a)
54−
55−
56−instance k ~ Type => IsString (Name (a :: k)) where
57− fromString = Name
51+type Name :: K.Context
52+newtype Name a = Name String
53+ deriving stock Show
54+ deriving newtype IsString
5855
5956
6057instance Sql DBType a => Table Name (Name a) where
61− type Columns (Name a) = HType a
58+ type Columns (Name a) = HIdentity a
6259 type Context (Name a) = Name
60+ type FromExprs (Name a) = a
61+ type Transpose to (Name a) = to a
6362
64− toColumns a = HType (N a)
65− fromColumns (HType (N a)) = a
66− reify = notReify
67− unreify = notReify
68− coherence = notReify
69− congruence = notReify
70−
71−
72−instance Sql DBType a => Recontextualize Expr Name (Expr a) (Name a)
73−
74−
75−instance Sql DBType a => Recontextualize Result Name (Identity a) (Name a)
76−
77−
78−instance Sql DBType a => Recontextualize Name Expr (Name a) (Expr a)
79−
80−
81−instance Sql DBType a => Recontextualize Name Result (Name a) (Identity a)
82−
83−
84−instance Sql DBType a => Recontextualize Name Name (Name a) (Name a)
85−
86−
87−instance Interpretation Name where
88− data Col Name _spec where
89− N :: {unN :: !(Name a)} -> Col Name ('Spec a)
63+ toColumns a = HIdentity a
64+ fromColumns (HIdentity a) = a
65+ toResult a = HIdentity (Identity a)
66+ fromResult (HIdentity (Identity a)) = a
9067
9168
9269-- | @Selects a b@ means that @a@ is a schema (i.e., a 'Table' of 'Name's) for
9370-- the 'Expr' columns in @b@.
9471type Selects :: Type -> Type -> Constraint
95−class Recontextualize Name Expr names exprs => Selects names exprs
96−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−68
@@ -1,68 +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.HTable ( HTable, hmap )
27−import Rel8.Schema.Kind ( Context )
28−
29−
30−type Reify :: Context -> Context
31−data Reify context a
32−
33−
34−instance Interpretation (Reify context) where
35− newtype Col (Reify context) spec = Reify (Col context spec)
36−
37−
38−hreify :: HTable t => t (Col context) -> t (Col (Reify context))
39−hreify = hmap Reify
40−
41−
42−hunreify :: HTable t => t (Col (Reify context)) -> t (Col context)
43−hunreify = hmap (\(Reify a) -> a)
44−
45−
46−type UnwrapReify :: Context -> Context
47−type family UnwrapReify context where
48− UnwrapReify (Reify context) = context
49−
50−
51−type IsReify :: Context -> Bool
52−type family IsReify context where
53− IsReify (Reify _) = 'True
54− IsReify _ = 'False
55−
56−
57−type NotReify :: Context -> Constraint
58−class IsReify context ~ 'False => NotReify context
59−instance IsReify context ~ 'False => NotReify context
60−
61−
62−notReify :: forall context ctx a. NotReify context => context :~: Reify ctx -> a
63−notReify refl = case lemma @context of
64− Refl -> case refl of
65−
66−
67−lemma :: NotReify context => IsReify context :~: 'False
68−lemma = Refl
src/Rel8/Schema/Result.hs+16−52
@@ -1,28 +1,24 @@
11{-# language DataKinds #-}
2−{-# language EmptyCase #-}
32{-# language GADTs #-}
4−{-# language LambdaCase #-}
53{-# language NamedFieldPuns #-}
64{-# language StandaloneKindSignatures #-}
75{-# language TypeFamilies #-}
86
97module Rel8.Schema.Result
10− ( Col( R, unR ), Result
11− , NotResult( NotResult ), absurd
8+ ( Result
129 , null, nullifier, unnullifier
1310 , vectorizer, unvectorizer
1411 )
1512where
1613
1714-- base
18−import Data.Kind ( Type )
15+import Data.Functor.Identity ( Identity( Identity), runIdentity )
1916import Prelude hiding ( null )
2017
2118-- rel8
22−import Rel8.Schema.Context ( Interpretation( Col ) )
2319import Rel8.Schema.Kind ( Context )
2420import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )
25−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
21+import Rel8.Schema.Spec ( Spec(..) )
2622
2723
2824-- | The @Result@ context is the context used for decoded query results.
@@ -30,61 +26,29 @@ import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
3026-- When a query is executed against a PostgreSQL database, Rel8 parses the
3127-- returned rows, decoding each row into the @Result@ context.
3228type Result :: Context
33−data Result a
29+type Result = Identity
3430
3531
36−instance Interpretation Result where
37− data Col Result _spec where
38− R :: {unR :: !a} -> Col Result ('Spec a)
32+null :: Result (Maybe a)
33+null = Identity Nothing
3934
4035
41−type IsResult :: Context -> Bool
42−type family IsResult context where
43− IsResult Result = 'True
44− IsResult _ = 'False
45−
46−
47−type NotResult :: Context -> Type
48−data NotResult context where
49− NotResult :: IsResult context ~ 'False => NotResult context
50−
51−
52−absurd :: NotResult Result -> a
53−absurd = \case
54−
55−
56−null :: Col Result ('Spec (Maybe a))
57−null = R Nothing
58−
59−
60−nullifier :: ()
61− => SSpec ('Spec a)
62− -> Col Result ('Spec a)
63− -> Col Result ('Spec (Nullify a))
64−nullifier SSpec {nullity} (R a) = R $ case nullity of
36+nullifier :: Spec a -> Result a -> Result (Nullify a)
37+nullifier Spec {nullity} (Identity a) = Identity $ case nullity of
6538 Null -> a
6639 NotNull -> Just a
6740
6841
69−unnullifier :: ()
70− => SSpec ('Spec a)
71− -> Col Result ('Spec (Nullify a))
72− -> Maybe (Col Result ('Spec a))
73−unnullifier SSpec {nullity} (R a) =
42+unnullifier :: Spec a -> Result (Nullify a) -> Maybe (Result a)
43+unnullifier Spec {nullity} (Identity a) =
7444 case nullity of
75− Null -> pure $ R a
76− NotNull -> R <$> a
45+ Null -> pure $ Identity a
46+ NotNull -> Identity <$> a
7747
7848
79−vectorizer :: Functor f
80− => SSpec ('Spec a)
81− -> f (Col Result ('Spec a))
82− -> Col Result ('Spec (f a))
83−vectorizer _ = R . fmap unR
49+vectorizer :: Functor f => Spec a -> f (Result a) -> Result (f a)
50+vectorizer _ = Identity . fmap runIdentity
8451
8552
86−unvectorizer :: Functor f
87− => SSpec ('Spec a)
88− -> Col Result ('Spec (f a))
89− -> f (Col Result ('Spec a))
90−unvectorizer _ (R results) = R <$> results
53+unvectorizer :: Functor f => Spec a -> Result (f a) -> f (Result a)
54+unvectorizer _ (Identity results) = Identity <$> results
src/Rel8/Schema/Spec.hs+16−30
@@ -1,18 +1,15 @@
1−{-# language DataKinds #-}
21{-# language FlexibleContexts #-}
3−{-# language GADTs #-}
2+{-# language MonoLocalBinds #-}
43{-# language StandaloneKindSignatures #-}
5−{-# language UndecidableInstances #-}
64
75module Rel8.Schema.Spec
8− ( Spec( Spec )
9− , SSpec( SSpec, labels, info, nullity )
10− , KnownSpec( specSing )
6+ ( Spec( Spec, labels, info, nullity )
7+ , specification
118 )
129where
1310
1411-- base
15−import Data.Kind ( Constraint, Type )
12+import Data.Kind ( Type )
1613import Prelude
1714
1815-- rel8
@@ -21,28 +18,17 @@ import Rel8.Type ( DBType, typeInformation )
2118import Rel8.Type.Information ( TypeInformation )
2219
2320
24−type Spec :: Type
25−newtype Spec = Spec Type
21+type Spec :: Type -> Type
22+data Spec a = Spec
23+ { labels :: [String]
24+ , info :: TypeInformation (Unnullify a)
25+ , nullity :: Nullity a
26+ }
2627
2728
28−type SSpec :: Spec -> Type
29−data SSpec spec where
30− SSpec ::
31− { labels :: [String]
32− , info :: TypeInformation (Unnullify a)
33− , nullity :: Nullity a
34− }
35− -> SSpec ('Spec a)
36−
37−
38−type KnownSpec :: Spec -> Constraint
39−class KnownSpec spec where
40− specSing :: SSpec spec
41−
42−
43−instance Sql DBType a => KnownSpec ('Spec a) where
44− specSing = SSpec
45− { labels = []
46− , info = typeInformation
47− , nullity = nullable
48− }
29+specification :: Sql DBType a => Spec a
30+specification = Spec
31+ { labels = []
32+ , info = typeInformation
33+ , nullity = nullable
34+ }
src/Rel8/Schema/Spec/Constrain.hsdeleted−32
@@ -1,32 +0,0 @@
1−{-# language ConstraintKinds #-}
2−{-# language DataKinds #-}
3−{-# language FlexibleInstances #-}
4−{-# language MultiParamTypeClasses #-}
5−{-# language StandaloneKindSignatures #-}
6−{-# language TypeFamilies #-}
7−{-# language UndecidableInstances #-}
8−{-# language UndecidableSuperClasses #-}
9−
10−module Rel8.Schema.Spec.Constrain
11− ( ConstrainSpec
12− )
13−where
14−
15−-- base
16−import Data.Kind ( Constraint, Type )
17−import Prelude ()
18−
19−-- rel8
20−import Rel8.Schema.Spec ( Spec( Spec ) )
21−
22−
23−type Unspec :: Spec -> Type
24−type family Unspec spec where
25− Unspec ('Spec a) = a
26−
27−
28−type ConstrainSpec :: (Type -> Constraint) -> Spec -> Constraint
29−class (spec ~ 'Spec (Unspec spec), constraint (Unspec spec)) =>
30− ConstrainSpec constraint spec
31−instance (spec ~ 'Spec (Unspec spec), constraint (Unspec spec)) =>
32− ConstrainSpec constraint spec
src/Rel8/Schema/Table.hs+20
@@ -1,14 +1,26 @@
11{-# language DeriveFunctor #-}
22{-# language DerivingStrategies #-}
3+{-# language DisambiguateRecordFields #-}
4+{-# language NamedFieldPuns #-}
5+{-# language StandaloneKindSignatures #-}
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+43−72
@@ -1,64 +1,59 @@
11{-# language DuplicateRecordFields #-}
2+{-# language FlexibleContexts #-}
23{-# language GADTs #-}
34{-# language NamedFieldPuns #-}
4−{-# language ScopedTypeVariables #-}
5+{-# language RecordWildCards #-}
56{-# language StandaloneKindSignatures #-}
6−{-# language TypeApplications #-}
7+{-# language StrictData #-}
78
89module Rel8.Statement.Insert
910 ( Insert(..)
10− , OnConflict(..)
1111 , insert
12+ , ppInsert
13+ , ppInto
1214 )
1315where
1416
1517-- base
16−import Control.Exception ( throwIO )
17−import Data.List.NonEmpty ( NonEmpty( (:|) ) )
18+import Data.Foldable ( toList )
1819import Data.Kind ( Type )
1920import Prelude
2021
2122-- hasql
22−import Hasql.Connection ( Connection )
23−import qualified Hasql.Decoders as Hasql
2423import qualified Hasql.Encoders as Hasql
25−import qualified Hasql.Session as Hasql
2624import qualified Hasql.Statement as Hasql
2725
2826-- opaleye
29−import qualified Opaleye.Internal.Manipulation as Opaleye
30−import qualified Opaleye.Manipulation as Opaleye
27+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye
28+
29+-- pretty
30+import Text.PrettyPrint ( Doc, (<+>), ($$), parens, text )
3131
3232-- rel8
33−import Rel8.Schema.Name ( Selects )
34−import Rel8.Schema.Table ( TableSchema )
35−import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) )
36−import Rel8.Table ( fromColumns, toColumns )
37−import Rel8.Table.Opaleye ( castTable, table, unpackspec )
38−import Rel8.Table.Serialize ( Serializable, parse )
33+import Rel8.Query ( Query )
34+import Rel8.Schema.Name ( Name, Selects, ppColumn )
35+import Rel8.Schema.Table ( TableSchema(..), ppTable )
36+import Rel8.Statement.OnConflict ( OnConflict, ppOnConflict )
37+import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )
38+import Rel8.Statement.Select ( ppRows )
39+import Rel8.Table ( Table )
40+import Rel8.Table.Name ( showNames )
3941
4042-- text
4143import qualified Data.Text as Text ( pack )
4244import Data.Text.Encoding ( encodeUtf8 )
4345
4446
45−-- | @OnConflict@ allows you to add an @ON CONFLICT@ clause to an @INSERT@
46−-- statement.
47−type OnConflict :: Type
48−data OnConflict
49− = Abort -- ^ @ON CONFLICT ABORT@
50− | DoNothing -- ^ @ON CONFLICT DO NOTHING@
51−
52−
5347-- | The constituent parts of a SQL @INSERT@ statement.
5448type Insert :: Type -> Type
5549data Insert a where
5650 Insert :: Selects names exprs =>
5751 { into :: TableSchema names
5852 -- ^ Which table to insert into.
59− , rows :: [exprs]
60− -- ^ The rows to insert.
61− , onConflict :: OnConflict
53+ , rows :: Query exprs
54+ -- ^ The rows to insert. This can be an arbitrary query — use
55+ -- 'Rel8.values' insert a static list of rows.
56+ , onConflict :: OnConflict names
6257 -- ^ What to do if the inserted rows conflict with data already in the
6358 -- table.
6459 , returning :: Returning names a
@@ -67,52 +62,28 @@ data Insert a where
6762 -> Insert a
6863
6964
70−-- | Run an @INSERT@ statement
71−insert :: Connection -> Insert a -> IO a
72−insert c Insert {into, rows, onConflict, returning} =
73− case (rows, returning) of
74− ([], NumberOfRowsAffected) -> pure 0
75− ([], Projection _) -> pure []
65+ppInsert :: Insert a -> Doc
66+ppInsert Insert {..} =
67+ text "INSERT INTO" <+>
68+ ppInto into $$
69+ ppRows rows $$
70+ ppOnConflict into onConflict $$
71+ ppReturning into returning
7672
77− (x:xs, NumberOfRowsAffected) -> Hasql.run session c >>= either throwIO pure
78− where
79− session = Hasql.statement () statement
80− statement = Hasql.Statement bytes params decode prepare
81− bytes = encodeUtf8 $ Text.pack sql
82− params = Hasql.noParams
83− decode = Hasql.rowsAffected
84− prepare = False
85− sql = Opaleye.arrangeInsertManySql into' rows' onConflict'
86− where
87− into' = table $ toColumns <$> into
88− rows' = toColumns <$> x :| xs
8973
90− (x:xs, Projection project) -> Hasql.run session c >>= either throwIO pure
91− where
92− session = Hasql.statement () statement
93− statement = Hasql.Statement bytes params decode prepare
94− bytes = encodeUtf8 $ Text.pack sql
95− params = Hasql.noParams
96− decode = decoder project
97− prepare = False
98− sql =
99− Opaleye.arrangeInsertManyReturningSql
100− unpackspec
101− into'
102− rows'
103− project'
104− onConflict'
105− where
106− into' = table $ toColumns <$> into
107− rows' = toColumns <$> x :| xs
108− project' = castTable . toColumns . project . fromColumns
74+ppInto :: Table Name a => TableSchema a -> Doc
75+ppInto table@TableSchema {columns} =
76+ ppTable table <+>
77+ parens (Opaleye.commaV ppColumn (toList (showNames columns)))
10978
110− where
111− onConflict' =
112− case onConflict of
113− DoNothing -> Just Opaleye.DoNothing
114− Abort -> Nothing
11579
116− decoder :: forall exprs projection a. Serializable projection a
117− => (exprs -> projection) -> Hasql.Result [a]
118− decoder _ = Hasql.rowList (parse @projection @a)
80+-- | Run an 'Insert' statement.
81+insert :: Insert a -> Hasql.Statement () a
82+insert i@Insert {returning} = Hasql.Statement bytes params decode prepare
83+ where
84+ bytes = encodeUtf8 $ Text.pack sql
85+ params = Hasql.noParams
86+ decode = decodeReturning returning
87+ prepare = False
88+ sql = show doc
89+ doc = ppInsert i
src/Rel8/Statement/OnConflict.hsnew file+106
@@ -0,0 +1,106 @@
1+{-# language DuplicateRecordFields #-}
2+{-# language FlexibleContexts #-}
3+{-# language GADTs #-}
4+{-# language LambdaCase #-}
5+{-# language NamedFieldPuns #-}
6+{-# language RecordWildCards #-}
7+{-# language StandaloneKindSignatures #-}
8+{-# language StrictData #-}
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−56
@@ -1,39 +1,37 @@
1+{-# language DuplicateRecordFields #-}
12{-# language GADTs #-}
23{-# language NamedFieldPuns #-}
3−{-# language ScopedTypeVariables #-}
4+{-# language RecordWildCards #-}
45{-# language StandaloneKindSignatures #-}
5−{-# language TypeApplications #-}
6+{-# language StrictData #-}
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
23+-- pretty
24+import Text.PrettyPrint ( Doc, (<+>), ($$), text )
2725
2826-- rel8
2927import Rel8.Expr ( Expr )
30−import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
28+import Rel8.Query ( Query )
3129import Rel8.Schema.Name ( Selects )
32−import Rel8.Schema.Table ( TableSchema )
33−import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) )
34−import Rel8.Table ( fromColumns, toColumns )
35−import Rel8.Table.Opaleye ( castTable, table, unpackspec )
36−import Rel8.Table.Serialize ( Serializable, parse )
30+import Rel8.Schema.Table ( TableSchema(..), ppTable )
31+import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )
32+import Rel8.Statement.Set ( ppSet )
33+import Rel8.Statement.Using ( ppFrom )
34+import Rel8.Statement.Where ( ppWhere )
3735
3836-- text
3937import qualified Data.Text as Text
@@ -46,9 +44,12 @@ data Update a where
4644 Update :: Selects names exprs =>
4745 { target :: TableSchema names
4846 -- ^ Which table to update.
49− , set :: exprs -> exprs
47+ , from :: Query from
48+ -- ^ @FROM@ clause — this can be used to join against other tables,
49+ -- and its results can be referenced in the @SET@ and @WHERE@ clauses.
50+ , set :: from -> exprs -> exprs
5051 -- ^ How to update each selected row.
51− , updateWhere :: exprs -> Expr Bool
52+ , updateWhere :: from -> exprs -> Expr Bool
5253 -- ^ Which rows to select for update.
5354 , returning :: Returning names a
5455 -- ^ What to return from the @UPDATE@ statement.
@@ -56,46 +57,27 @@ data Update a where
5657 -> Update a
5758
5859
59−-- | Run an @UPDATE@ statement.
60−update :: Connection -> Update a -> IO a
61−update c Update {target, set, updateWhere, returning} =
62− case returning of
63− NumberOfRowsAffected -> Hasql.run session c >>= either throwIO pure
64− where
65− session = Hasql.statement () statement
66− statement = Hasql.Statement bytes params decode prepare
67− bytes = encodeUtf8 $ Text.pack sql
68− params = Hasql.noParams
69− decode = Hasql.rowsAffected
70− prepare = False
71− sql = Opaleye.arrangeUpdateSql target' set' where'
72− where
73− target' = table $ toColumns <$> target
74− set' = toColumns . set . fromColumns
75− where' = toColumn . toPrimExpr . updateWhere . fromColumns
60+ppUpdate :: Update a -> Doc
61+ppUpdate Update {..} = case ppFrom from of
62+ Nothing ->
63+ text "UPDATE" <+> ppTable target $$
64+ ppSet target id $$
65+ text "WHERE false"
66+ Just (fromDoc, i) ->
67+ text "UPDATE" <+> ppTable target $$
68+ ppSet target (set i) $$
69+ fromDoc $$
70+ ppWhere target (updateWhere i) $$
71+ ppReturning target returning
7672
77− Projection project -> Hasql.run session c >>= either throwIO pure
78− where
79− session = Hasql.statement () statement
80− statement = Hasql.Statement bytes params decode prepare
81− bytes = encodeUtf8 $ Text.pack sql
82− params = Hasql.noParams
83− decode = decoder project
84− prepare = False
85− sql =
86− Opaleye.arrangeUpdateReturningSql
87− unpackspec
88− target'
89− set'
90− where'
91− project'
92− where
93− target' = table $ toColumns <$> target
94− set' = toColumns . set . fromColumns
95− where' = toColumn . toPrimExpr . updateWhere . fromColumns
96− project' = castTable . toColumns . project . fromColumns
9773
74+-- | Run an @UPDATE@ statement.
75+update :: Update a -> Hasql.Statement () a
76+update u@Update {returning} = Hasql.Statement bytes params decode prepare
9877 where
99− decoder :: forall exprs projection a. Serializable projection a
100− => (exprs -> projection) -> Hasql.Result [a]
101− decoder _ = Hasql.rowList (parse @projection @a)
78+ bytes = encodeUtf8 $ Text.pack sql
79+ params = Hasql.noParams
80+ decode = decodeReturning returning
81+ prepare = False
82+ sql = show doc
83+ doc = ppUpdate u
src/Rel8/Statement/Using.hsnew file+36
@@ -0,0 +1,36 @@
1+module Rel8.Statement.Using
2+ ( ppFrom
3+ , ppUsing
4+ )
5+where
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+83−313
@@ -1,83 +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
1814 ( Table
19− ( Columns, Context, toColumns, fromColumns
20− , Unreify, reify, unreify, coherence, congruence
15+ ( Columns, Context, fromColumns, toColumns
16+ , FromExprs, fromResult, toResult
17+ , Transpose
2118 )
2219 , Congruent
23− , TTable, TColumns, TContext, TUnreify
20+ , TTable, TColumns, TContext, TFromExprs, TTranspose
21+ , TSerialize
2422 )
2523where
2624
2725-- base
28−import Data.Functor ( ($>) )
2926import Data.Functor.Identity ( Identity( Identity ) )
3027import Data.Kind ( Constraint, Type )
31−import Data.List.NonEmpty ( NonEmpty )
32−import Data.Proxy ( Proxy( Proxy ) )
33−import Data.Type.Equality ( (:~:)( Refl ) )
3428import GHC.Generics ( Generic, Rep, from, to )
3529import Prelude hiding ( null )
3630
3731-- rel8
3832import Rel8.FCF ( Eval, Exp )
39−import Rel8.Kind.Algebra
40− ( SAlgebra( SSum, SProduct )
41− , KnownAlgebra, algebraSing
42− )
43−import Rel8.Generic.Coherence ( GCoherent, gcoherence, gcongruence )
44−import Rel8.Generic.Map ( GMap, GMappable, gmap, gunmap )
45−import Rel8.Generic.Table
46− ( GGTable, GGColumns, GGContext, ggfromColumns, ggtoColumns
47− , GAlgebra
33+import Rel8.Generic.Map ( Map )
34+import Rel8.Generic.Table.Record
35+ ( GTable, GColumns, GContext, gfromColumns, gtoColumns
36+ , GSerialize, gfromResult, gtoResult
4837 )
4938import Rel8.Generic.Record ( Record(..) )
50−import Rel8.Generic.Reify ( ARep )
5139import Rel8.Schema.HTable ( HTable )
52−import Rel8.Schema.HTable.Either ( HEitherTable(..) )
53−import Rel8.Schema.HTable.Identity ( HIdentity(..), HType )
54−import Rel8.Schema.HTable.Label ( hlabel, hrelabel, hunlabel )
55−import Rel8.Schema.HTable.List ( HListTable )
56−import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
57−import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
58−import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify )
59−import Rel8.Schema.HTable.These ( HTheseTable(..) )
60−import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )
40+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
6141import qualified Rel8.Schema.Kind as K
6242import Rel8.Schema.Null ( Sql )
63−import Rel8.Schema.Reify
64− ( Reify, Col( Reify ), hreify, hunreify
65− , UnwrapReify
66− , notReify
67− )
68−import Rel8.Schema.Result
69− ( Col( R ), Result
70− , NotResult
71− , null, nullifier, unnullifier
72− , vectorizer, unvectorizer
73− )
74−import Rel8.Schema.Spec ( KnownSpec )
43+import Rel8.Schema.Result ( Result )
7544import Rel8.Type ( DBType )
76−import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )
77−
78−-- these
79−import Data.These ( These( This, That, These ) )
80−import Data.These.Combinators ( justHere, justThere )
8145
8246
8347-- | @Table@s are one of the foundational elements of Rel8, and describe data
@@ -92,130 +56,102 @@ import Data.These.Combinators ( justHere, justThere )
9256-- yourself, as anything that's an instance of 'Rel8.Rel8able' is always a
9357-- 'Table'.
9458type Table :: K.Context -> Type -> Constraint
95−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
9666 -- | The 'HTable' functor that describes the schema of this table.
9767 type Columns a :: K.HTable
9868
9969 -- | The common context that all columns use as an interpretation.
10070 type Context a :: K.Context
10171
102− 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
10375
104− toColumns :: a -> Columns a (Col context)
105− fromColumns :: Columns a (Col context) -> a
76+ type Transpose (context' :: K.Context) a :: Type
10677
107− reify :: context :~: Reify ctx -> Unreify a -> a
108− unreify :: context :~: Reify ctx -> a -> Unreify a
109− coherence :: context :~: Reify ctx -> NotResult ctx -> Context (Unreify a) :~: ctx
110− congruence :: context :~: Reify ctx -> NotResult ctx -> Columns a :~: Columns (Unreify a)
11178
79+ toColumns :: a -> Columns a context
80+ fromColumns :: Columns a context -> a
11281
113− type Columns a = Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))
114− type Context a = Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))
115− 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
11689
11790 default toColumns ::
11891 ( Generic (Record a)
119− , KnownAlgebra (GAlgebra (Rep (Record a)))
120− , Eval (GGTable (GAlgebra (Rep (Record a))) (TTable context) TColumns (Col context) (Rep (Record a)))
121− , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))
122− , 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))
12394 )
124− => a -> Columns a (Col context)
95+ => a -> Columns a context
12596 toColumns =
126− ggtoColumns
127− @(GAlgebra (Rep (Record a)))
128− @(TTable context)
129− @TColumns
130− id
131− id
132− toColumns .
97+ gtoColumns @(TTable context) @TColumns toColumns .
13398 from .
13499 Record
135100
136101 default fromColumns ::
137102 ( Generic (Record a)
138− , KnownAlgebra (GAlgebra (Rep (Record a)))
139− , Eval (GGTable (GAlgebra (Rep (Record a))) (TTable context) TColumns (Col context) (Rep (Record a)))
140− , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))
141− , 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))
142105 )
143− => Columns a (Col context) -> a
106+ => Columns a context -> a
144107 fromColumns =
145108 unrecord .
146109 to .
147− ggfromColumns
148− @(GAlgebra (Rep (Record a)))
149− @(TTable context)
150− @TColumns
151− id
152− id
153− fromColumns
110+ gfromColumns @(TTable context) @TColumns fromColumns
154111
155− default reify ::
156− ( Generic (Record a)
157− , Generic (Record (Unreify a))
158− , GMappable (TTable context) (Rep (Record a))
159− , 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))
160116 )
161− => context :~: Reify ctx -> Unreify a -> a
162− reify Refl =
163− unrecord .
164− to .
165− 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) .
166125 from .
167126 Record
168127
169− default unreify ::
170− ( Generic (Record a)
171− , Generic (Record (Unreify a))
172− , GMappable (TTable context) (Rep (Record a))
173− , 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))
174132 )
175− => context :~: Reify ctx -> a -> Unreify a
176− unreify Refl =
133+ => Columns a Result -> FromExprs a
134+ fromResult =
177135 unrecord .
178136 to .
179− gmap @(TTable context) (Proxy @TUnreify) (unreify Refl) .
180− from .
181− Record
137+ gfromResult
138+ @TSerialize
139+ @TColumns
140+ @(Rep (Record a))
141+ @(Rep (Record (FromExprs a)))
142+ (\(_ :: proxy x) -> fromResult @(Context x) @x)
182143
183− default coherence ::
184− ( KnownAlgebra (GAlgebra (Rep (Record a)))
185− , GCoherent (TTable context) (Rep (Record a))
186− , Context a ~ Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))
187− , Context (Unreify a) ~ Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record (Unreify a))))
188− , Rep (Record (Unreify a)) ~ GMap TUnreify (Rep (Record a))
189− )
190− => context :~: Reify ctx -> NotResult ctx -> Context (Unreify a) :~: ctx
191− coherence = case algebraSing @(GAlgebra (Rep (Record a))) of
192− SSum -> notReify
193− SProduct -> \proof abstract ->
194− gcoherence
195− @(TTable context)
196− @(Rep (Record a))
197− (Proxy @TContext)
198− (Proxy @TUnreify)
199− (\(_ :: _proxy x) -> coherence @context @x proof abstract)
200−
201− default congruence ::
202− ( KnownAlgebra (GAlgebra (Rep (Record a)))
203− , GCoherent (TTable context) (Rep (Record a))
204− , Context a ~ Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))
205− , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))
206− , Columns (Unreify a) ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record (Unreify a))))
207− , Rep (Record (Unreify a)) ~ GMap TUnreify (Rep (Record a))
208− )
209− => context :~: Reify ctx -> NotResult ctx -> Columns a :~: Columns (Unreify a)
210− congruence = case algebraSing @(GAlgebra (Rep (Record a))) of
211− SSum -> notReify
212− SProduct -> \proof abstract ->
213− gcongruence
214− @(TTable context)
215− @(Rep (Record a))
216− (Proxy @TColumns)
217− (Proxy @TUnreify)
218− (\(_ :: _proxy x) -> congruence @context @x proof abstract)
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
219155
220156
221157data TTable :: K.Context -> Type -> Exp Constraint
@@ -230,185 +166,19 @@ data TContext :: Type -> Exp K.Context
230166type instance Eval (TContext a) = Context a
231167
232168
233−data TUnreify :: Type -> Exp Type
234−type instance Eval (TUnreify a) = Unreify a
169+data TFromExprs :: Type -> Exp Type
170+type instance Eval (TFromExprs a) = FromExprs a
235171
236172
237−type DefaultUnreify :: Type -> Type
238−type family DefaultUnreify a where
239− DefaultUnreify (t a b c d e f g) =
240− t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e) (Unreify f) (Unreify g)
241− DefaultUnreify (t a b c d e f) =
242− t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e) (Unreify f)
243− DefaultUnreify (t a b c d e) =
244− t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e)
245− DefaultUnreify (t a b c d) =
246− t (Unreify a) (Unreify b) (Unreify c) (Unreify d)
247− DefaultUnreify (t a b c) = t (Unreify a) (Unreify b) (Unreify c)
248− DefaultUnreify (t a b) = t (Unreify a) (Unreify b)
249− DefaultUnreify (t a) = t (Unreify a)
250− DefaultUnreify a = ARep (GMap TUnreify (Rep a))
173+data TTranspose :: K.Context -> Type -> Exp Type
174+type instance Eval (TTranspose context a) = Transpose context a
251175
252176
253−-- | Any 'HTable' is also a 'Table'.
254−instance HTable t => Table context (t (Col context)) where
255− type Columns (t (Col context)) = t
256− type Context (t (Col context)) = context
257− type Unreify (t (Col context)) = t (Col (UnwrapReify context))
258−
259− toColumns = id
260− fromColumns = id
261−
262− reify Refl = hreify
263− unreify Refl = hunreify
264− coherence Refl _ = Refl
265− congruence Refl _ = Refl
266−
267−
268−-- | Any context is trivially a table.
269−instance KnownSpec spec => Table context (Col context spec) where
270− type Columns (Col context spec) = HIdentity spec
271− type Context (Col context spec) = context
272− type Unreify (Col context spec) = Col (UnwrapReify context) spec
273−
274− toColumns = HIdentity
275− fromColumns = unHIdentity
276−
277− reify Refl = Reify
278− unreify Refl (Reify a) = a
279− coherence Refl _ = Refl
280− congruence Refl _ = Refl
281−
282−
283−instance Sql DBType a => Table Result (Identity a) where
284− type Columns (Identity a) = HType a
285− type Context (Identity a) = Result
286−
287− toColumns (Identity a) = HType (R a)
288− fromColumns (HType (R a)) = Identity a
289−
290− reify = notReify
291− unreify = notReify
292− coherence = notReify
293− congruence = notReify
294−
295−
296−instance (context ~ Result, Table context a, Table context b) =>
297− Table context (Either a b)
298− where
299− type Columns (Either a b) = HEitherTable (Columns a) (Columns b)
300− type Context (Either a b) = Context a
301−
302− toColumns = \case
303− Left table -> HEitherTable
304− { htag = hlabel (HType (R IsLeft))
305− , hleft = hlabel (hnullify nullifier (toColumns table))
306− , hright = hlabel (hnulls (const null))
307− }
308− Right table -> HEitherTable
309− { htag = hlabel (HType (R IsRight))
310− , hleft = hlabel (hnulls (const null))
311− , hright = hlabel (hnullify nullifier (toColumns table))
312− }
313−
314− fromColumns HEitherTable {htag, hleft, hright} = case hunlabel htag of
315− HType (R tag) -> case tag of
316− IsLeft -> maybe err (Left . fromColumns) $ hunnullify unnullifier (hunlabel hleft)
317− IsRight -> maybe err (Right . fromColumns) $ hunnullify unnullifier (hunlabel hright)
318− where
319− err = error "Either.fromColumns: mismatch between tag and data"
320−
321− coherence = notReify
322− congruence = notReify
323−
324−
325−instance (context ~ Result, Table context a) => Table context [a] where
326− type Columns [a] = HListTable (Columns a)
327− type Context [a] = Context a
328−
329− toColumns = hvectorize vectorizer . fmap toColumns
330− fromColumns = fmap fromColumns . hunvectorize unvectorizer
331−
332− coherence = notReify
333− congruence = notReify
334−
335−
336−instance (context ~ Result, Table context a) => Table context (Maybe a) where
337− type Columns (Maybe a) = HMaybeTable (Columns a)
338− type Context (Maybe a) = Context a
339−
340− toColumns = \case
341− Nothing -> HMaybeTable
342− { htag = hlabel (HIdentity (R Nothing))
343− , hjust = hlabel (hnulls (const null))
344− }
345− Just table -> HMaybeTable
346− { htag = hlabel (HIdentity (R (Just IsJust)))
347− , hjust = hlabel (hnullify nullifier (toColumns table))
348− }
349−
350− fromColumns HMaybeTable {htag, hjust} = case hunlabel htag of
351− HType (R tag) -> tag $>
352− case hunnullify unnullifier (hunlabel hjust) of
353− Nothing -> error "Maybe.fromColumns: mismatch between tag and data"
354− Just just -> fromColumns just
355−
356− coherence = notReify
357− congruence = notReify
358−
359−
360−instance (context ~ Result, Table context a) => Table context (NonEmpty a)
361− where
362− type Columns (NonEmpty a) = HNonEmptyTable (Columns a)
363− type Context (NonEmpty a) = Context a
364−
365− toColumns = hvectorize vectorizer . fmap toColumns
366− fromColumns = fmap fromColumns . hunvectorize unvectorizer
367−
368− coherence = notReify
369− congruence = notReify
370−
371−
372−instance (context ~ Result, Table context a, Table context b) =>
373− Table context (These a b)
374− where
375− type Columns (These a b) = HTheseTable (Columns a) (Columns b)
376− type Context (These a b) = Context a
377−
378− toColumns tables = HTheseTable
379− { hhereTag = hrelabel hhereTag
380− , hhere = hrelabel (toColumns hhere)
381− , hthereTag = hrelabel hthereTag
382− , hthere = hrelabel (toColumns hthere)
383− }
384− where
385− HMaybeTable
386− { htag = hhereTag
387− , hjust = hhere
388− } = toColumns (justHere tables)
389− HMaybeTable
390− { htag = hthereTag
391− , hjust = hthere
392− } = toColumns (justThere tables)
393−
394− fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} =
395− case (fromColumns mhere, fromColumns mthere) of
396− (Just a, Nothing) -> This (fromColumns a)
397− (Nothing, Just b) -> That (fromColumns b)
398− (Just a, Just b) -> These (fromColumns a) (fromColumns b)
399− _ -> error "These.fromColumns: mismatch between tags and data"
400− where
401− mhere = HMaybeTable
402− { htag = hrelabel hhereTag
403− , hjust = hrelabel hhere
404− }
405− mthere = HMaybeTable
406− { htag = hrelabel hthereTag
407− , hjust = hrelabel hthere
408− }
409−
410− coherence = notReify
411− congruence = notReify
177+data TSerialize :: Type -> Type -> Exp Constraint
178+type instance Eval (TSerialize expr a) =
179+ ( Table (Context expr) expr
180+ , a ~ FromExprs expr
181+ )
412182
413183
414184instance (Table context a, Table context b) => Table context (a, b)
src/Rel8/Table/ADT.hs+33−65
@@ -7,13 +7,13 @@
77{-# language ScopedTypeVariables #-}
88{-# language StandaloneKindSignatures #-}
99{-# language TypeApplications #-}
10−{-# language TypeFamilies #-}
10+{-# language TypeFamilyDependencies #-}
1111{-# language UndecidableInstances #-}
1212{-# language UndecidableSuperClasses #-}
1313
1414module Rel8.Table.ADT
1515 ( ADT( ADT )
16− , ADTable, fromADT, toADT
16+ , ADTable
1717 , BuildableADT
1818 , BuildADT, buildADT
1919 , ConstructableADT
@@ -27,9 +27,7 @@ where
2727
2828-- base
2929import Data.Kind ( Constraint, Type )
30−import Data.Proxy ( Proxy( Proxy ) )
31−import Data.Type.Equality ( (:~:)( Refl ) )
32−import GHC.Generics ( Generic, Rep, from, to )
30+import GHC.Generics ( Generic, from, to )
3331import GHC.TypeLits ( Symbol )
3432import Prelude
3533
@@ -46,95 +44,65 @@ import Rel8.Generic.Construction
4644 , GGName, ggname
4745 , GGAggregate, ggaggregate
4846 )
49−import Rel8.Generic.Map ( GMappable, GMap, gmap, gunmap )
50−import Rel8.Generic.Record ( GRecordable, GRecord, grecord, gunrecord )
47+import Rel8.Generic.Record ( Record( Record ), unrecord )
5148import Rel8.Generic.Rel8able
5249 ( Rel8able
5350 , GRep, GColumns, gfromColumns, gtoColumns
54− , greify, gunreify
51+ , GFromExprs, gfromResult, gtoResult
52+ , TSerialize, deserialize, serialize
5553 )
5654import qualified Rel8.Generic.Table.ADT as G
5755import qualified Rel8.Kind.Algebra as K
58−import Rel8.Schema.Context ( Col )
5956import Rel8.Schema.HTable ( HTable )
6057import qualified Rel8.Schema.Kind as K
6158import Rel8.Schema.Name ( Name )
62−import Rel8.Schema.Reify ( Col( Reify ), Reify, hreify, hunreify )
6359import Rel8.Schema.Result ( Result )
64−import Rel8.Table
65− ( Table
66− , fromColumns, toColumns, reify, unreify
67− , TTable, TColumns, TUnreify
68− )
60+import Rel8.Table ( Table, TColumns )
6961
7062
7163type ADT :: K.Rel8able -> K.Rel8able
72−newtype ADT t context = ADT (GColumnsADT t (Col context))
64+newtype ADT t context = ADT (GColumnsADT t context)
7365
7466
7567instance ADTable t => Rel8able (ADT t) where
7668 type GColumns (ADT t) = GColumnsADT t
69+ type GFromExprs (ADT t) = t Result
7770
78− gfromColumns = ADT
79− gtoColumns (ADT a) = a
80−
81− greify (ADT a) = ADT (hreify a)
82− gunreify (ADT a) = ADT (hunreify a)
83−
71+ gfromColumns _ = ADT
72+ gtoColumns _ (ADT a) = a
8473
85−instance (ADTable t, context ~ Result) => Generic (ADT t context) where
86− type Rep (ADT t context) = Rep (t context)
87−
88− from =
89− gmap @(TTable (Reify Result)) (Proxy @TUnreify) (unreify Refl) .
90− gunrecord @(Rep (t (Reify Result))) .
91− G.gfromColumnsADT
92− @(TTable (Reify Result))
93− @TColumns
94− (\(Reify a) -> a)
95− Reify
96− fromColumns .
97− hreify .
98− (\(ADT a) -> a)
99−
100− to =
101− ADT .
102− hunreify .
103− G.gtoColumnsADT
104− @(TTable (Reify Result))
74+ gfromResult =
75+ unrecord .
76+ to .
77+ G.gfromResultADT
78+ @TSerialize
10579 @TColumns
106− (\(Reify a) -> a)
107− Reify
108− toColumns .
109− grecord @(Rep (t (Reify Result))) .
110− gunmap @(TTable (Reify Result)) (Proxy @TUnreify) (reify Refl)
80+ @(Eval (ADTRep t Expr))
81+ @(Eval (ADTRep t Result))
82+ (\(_ :: proxy x) -> deserialize @_ @x)
11183
112−
113−fromADT :: ADTable t => ADT t Result -> t Result
114−fromADT = to . from
115−
116−
117−toADT :: ADTable t => t Result -> ADT t Result
118−toADT = to . from
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
11993
12094
12195type ADTable :: K.Rel8able -> Constraint
12296class
123− ( Generic (t Result)
97+ ( Generic (Record (t Result))
12498 , HTable (GColumnsADT t)
125− , G.GTableADT (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRecord (Rep (t (Reify Result))))
126− , GRecordable (Rep (t (Reify Result)))
127− , GMappable (TTable (Reify Result)) (Rep (t (Reify Result)))
128− , GMap TUnreify (Rep (t (Reify Result))) ~ Rep (t Result)
99+ , G.GSerializeADT TSerialize TColumns (Eval (ADTRep t Expr)) (Eval (ADTRep t Result))
129100 )
130101 => ADTable t
131102instance
132− ( Generic (t Result)
103+ ( Generic (Record (t Result))
133104 , HTable (GColumnsADT t)
134− , G.GTableADT (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRecord (Rep (t (Reify Result))))
135− , GRecordable (Rep (t (Reify Result)))
136− , GMappable (TTable (Reify Result)) (Rep (t (Reify Result)))
137− , GMap TUnreify (Rep (t (Reify Result))) ~ Rep (t Result)
105+ , G.GSerializeADT TSerialize TColumns (Eval (ADTRep t Expr)) (Eval (ADTRep t Result))
138106 )
139107 => ADTable t
140108
@@ -202,4 +170,4 @@ type instance Eval (ADTRep t context) = GRep t context
202170
203171
204172type GColumnsADT :: K.Rel8able -> K.HTable
205−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+20−10
@@ -16,8 +16,8 @@ import Data.Functor.Identity ( Identity( Identity ) )
1616import Prelude
1717
1818-- rel8
19−import Rel8.Aggregate ( Aggregate, Aggregates, Col( A ) )
20−import Rel8.Expr ( Expr, Col( E ) )
19+import Rel8.Aggregate ( Aggregate, Aggregates )
20+import Rel8.Expr ( Expr )
2121import Rel8.Expr.Aggregate
2222 ( groupByExpr
2323 , slistAggExpr
@@ -27,8 +27,7 @@ import Rel8.Schema.Dict ( Dict( Dict ) )
2727import Rel8.Schema.HTable ( HTable, hfield, htabulate )
2828import Rel8.Schema.HTable.Vectorize ( hvectorize )
2929import Rel8.Schema.Null ( Sql )
30−import Rel8.Schema.Spec ( SSpec( SSpec, info ) )
31−import Rel8.Schema.Spec.Constrain ( ConstrainSpec )
30+import Rel8.Schema.Spec ( Spec( Spec, info ) )
3231import Rel8.Table ( toColumns, fromColumns )
3332import Rel8.Table.Eq ( EqTable, eqTable )
3433import Rel8.Table.List ( ListTable )
@@ -38,17 +37,28 @@ import Rel8.Type.Eq ( DBEq )
3837
3938-- | Group equal tables together. This works by aggregating each column in the
4039-- given table with 'groupByExpr'.
40+--
41+-- For example, if we have a table of items, we could group the items by the
42+-- order they belong to:
43+--
44+-- @
45+-- itemsByOrder :: Query (OrderId Expr, ListTable Expr (Item Expr))
46+-- itemsByOrder = aggregate $ do
47+-- item <- each itemSchema
48+-- let orderId = groupBy (itemOrderId item)
49+-- let orderItems = listAgg item
50+-- pure (orderId, orderItems)
51+-- @
4152groupBy :: forall exprs aggregates. (EqTable exprs, Aggregates aggregates exprs)
4253 => exprs -> aggregates
4354groupBy = fromColumns . hgroupBy (eqTable @exprs) . toColumns
4455
4556
46−hgroupBy :: HTable t
47− => t (Dict (ConstrainSpec (Sql DBEq))) -> t (Col Expr) -> t (Col Aggregate)
48−hgroupBy eqs exprs = fromColumns $ htabulate $ \field ->
57+hgroupBy :: HTable t => t (Dict (Sql DBEq)) -> t Expr -> t Aggregate
58+hgroupBy eqs exprs = htabulate $ \field ->
4959 case hfield eqs field of
5060 Dict -> case hfield exprs field of
51− E expr -> A $ groupByExpr expr
61+ expr -> groupByExpr expr
5262
5363
5464-- | Aggregate rows into a single row containing an array of all aggregated
@@ -70,7 +80,7 @@ hgroupBy eqs exprs = fromColumns $ htabulate $ \field ->
7080listAgg :: Aggregates aggregates exprs => exprs -> ListTable Aggregate aggregates
7181listAgg (toColumns -> exprs) = fromColumns $
7282 hvectorize
73− (\SSpec {info} (Identity (E a)) -> A $ slistAggExpr info a)
83+ (\Spec {info} (Identity a) -> slistAggExpr info a)
7484 (pure exprs)
7585
7686
@@ -78,5 +88,5 @@ listAgg (toColumns -> exprs) = fromColumns $
7888nonEmptyAgg :: Aggregates aggregates exprs => exprs -> NonEmptyTable Aggregate aggregates
7989nonEmptyAgg (toColumns -> exprs) = fromColumns $
8090 hvectorize
81− (\SSpec {info} (Identity (E a)) -> A $ snonEmptyAggExpr info a)
91+ (\Spec {info} (Identity a) -> snonEmptyAggExpr info a)
8292 (pure exprs)
src/Rel8/Table/Bool.hs+5−6
@@ -13,7 +13,7 @@ where
1313import Prelude
1414
1515-- rel8
16−import Rel8.Expr ( Expr, Col( E, unE ) )
16+import Rel8.Expr ( Expr )
1717import Rel8.Expr.Bool ( boolExpr, caseExpr )
1818import Rel8.Expr.Null ( isNull, unsafeUnnullify )
1919import Rel8.Schema.HTable ( htabulate, hfield )
@@ -28,8 +28,7 @@ bool :: Table Expr a => a -> a -> Expr Bool -> a
2828bool (toColumns -> false) (toColumns -> true) condition =
2929 fromColumns $ htabulate $ \field ->
3030 case (hfield false field, hfield true field) of
31− (E falseExpr, E trueExpr) ->
32− E (boolExpr falseExpr trueExpr condition)
31+ (falseExpr, trueExpr) -> boolExpr falseExpr trueExpr condition
3332{-# INLINABLE bool #-}
3433
3534
@@ -39,9 +38,9 @@ bool (toColumns -> false) (toColumns -> true) condition =
3938case_ :: Table Expr a => [(Expr Bool, a)] -> a -> a
4039case_ (map (fmap toColumns) -> branches) (toColumns -> fallback) =
4140 fromColumns $ htabulate $ \field -> case hfield fallback field of
42− E fallbackExpr ->
43− case map (fmap (unE . (`hfield` field))) branches of
44− branchExprs -> E (caseExpr branchExprs fallbackExpr)
41+ fallbackExpr ->
42+ case map (fmap (`hfield` field)) branches of
43+ branchExprs -> caseExpr branchExprs fallbackExpr
4544
4645
4746-- | Like 'maybe', but to eliminate @null@.
src/Rel8/Table/Cols.hsnew file+50
@@ -0,0 +1,50 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleInstances #-}
3+{-# language MultiParamTypeClasses #-}
4+{-# language StandaloneKindSignatures #-}
5+{-# language TypeFamilies #-}
6+{-# language UndecidableInstances #-}
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+58−66
@@ -3,6 +3,7 @@
33{-# language DerivingStrategies #-}
44{-# language FlexibleContexts #-}
55{-# language FlexibleInstances #-}
6+{-# language LambdaCase #-}
67{-# language MultiParamTypeClasses #-}
78{-# language NamedFieldPuns #-}
89{-# language ScopedTypeVariables #-}
@@ -23,40 +24,38 @@ module Rel8.Table.Either
2324where
2425
2526-- base
26−import Control.Category ( id )
2727import Data.Bifunctor ( Bifunctor, bimap )
28+import Data.Functor.Identity ( Identity( Identity ) )
2829import Data.Kind ( Type )
29−import Data.Type.Equality ( apply )
30−import Prelude hiding ( id, undefined )
30+import Prelude hiding ( undefined )
3131
3232-- comonad
3333import Control.Comonad ( extract )
3434
3535-- rel8
36−import Rel8.Aggregate ( Col( A ), Aggregate )
37−import Rel8.Expr ( Col( E ), Expr )
36+import Rel8.Aggregate ( Aggregate )
37+import Rel8.Expr ( Expr )
3838import Rel8.Expr.Aggregate ( groupByExpr )
3939import Rel8.Expr.Serialize ( litExpr )
4040import Rel8.Kind.Context ( Reifiable )
41−import Rel8.Schema.Context.Abstract ( Abstract )
4241import Rel8.Schema.Context.Nullify ( Nullifiable )
4342import Rel8.Schema.Dict ( Dict( Dict ) )
4443import Rel8.Schema.HTable.Either ( HEitherTable(..) )
4544import Rel8.Schema.HTable.Identity ( HIdentity(..) )
4645import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
4746import qualified Rel8.Schema.Kind as K
48−import Rel8.Schema.Name ( Col( N ), Name )
49−import Rel8.Schema.Spec ( Spec( Spec ) )
47+import Rel8.Schema.Name ( Name )
5048import Rel8.Table
5149 ( Table, Columns, Context, fromColumns, toColumns
52− , reify, unreify, coherence, congruence
50+ , FromExprs, fromResult, toResult
51+ , Transpose
5352 )
5453import Rel8.Table.Bool ( bool )
5554import Rel8.Table.Eq ( EqTable, eqTable )
5655import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )
5756import Rel8.Table.Ord ( OrdTable, ordTable )
58−import Rel8.Table.Recontextualize ( Recontextualize )
59−import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
57+import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )
58+import Rel8.Table.Serialize ( ToExprs )
6059import Rel8.Table.Undefined ( undefined )
6160import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
6261
@@ -73,20 +72,29 @@ import Data.Functor.Bind ( Bind, (>>-) )
7372-- adapted to work with Rel8.
7473type EitherTable :: K.Context -> Type -> Type -> Type
7574data EitherTable context a b = EitherTable
76− { tag :: Col context ('Spec EitherTag)
75+ { tag :: context EitherTag
7776 , left :: Nullify context a
7877 , right :: Nullify context b
7978 }
8079 deriving stock Functor
8180
8281
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+
8387instance Nullifiable context => Bifunctor (EitherTable context) where
8488 bimap f g (EitherTable tag a b) = EitherTable tag (fmap f a) (fmap g b)
8589
8690
91+instance Projectable (EitherTable context a) where
92+ project f (EitherTable tag a b) = EitherTable tag a (project f b)
93+
94+
8795instance (context ~ Expr, Table Expr a) => Apply (EitherTable context a) where
88− EitherTable (E tag) l1 f <.> EitherTable (E tag') l2 a =
89− EitherTable (E (tag <> tag')) (bool l1 l2 (isLeft tag)) (f <.> a)
96+ EitherTable tag l1 f <.> EitherTable tag' l2 a =
97+ EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f <.> a)
9098
9199
92100instance (context ~ Expr, Table Expr a) => Applicative (EitherTable context a) where
@@ -95,9 +103,9 @@ instance (context ~ Expr, Table Expr a) => Applicative (EitherTable context a) w
95103
96104
97105instance (context ~ Expr, Table Expr a) => Bind (EitherTable context a) where
98− EitherTable (E tag) l1 a >>- f = case f (extract a) of
99− EitherTable (E tag') l2 b ->
100− EitherTable (E (tag <> tag')) (bool l1 l2 (isRight tag)) b
106+ EitherTable tag l1 a >>- f = case f (extract a) of
107+ EitherTable tag' l2 b ->
108+ EitherTable (tag <> tag') (bool l1 l2 (isRight tag)) b
101109
102110
103111instance (context ~ Expr, Table Expr a) => Monad (EitherTable context a) where
@@ -112,15 +120,18 @@ instance (context ~ Expr, Table Expr a, Table Expr b) =>
112120
113121instance
114122 ( Table context a, Table context b
115− , Reifiable context, Abstract context, context ~ context'
123+ , Reifiable context, context ~ context'
116124 )
117125 => Table context' (EitherTable context a b)
118126 where
119127 type Columns (EitherTable context a b) = HEitherTable (Columns a) (Columns b)
120128 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)
121132
122133 toColumns EitherTable {tag, left, right} = HEitherTable
123− { htag = hlabel $ HType tag
134+ { htag = hlabel $ HIdentity tag
124135 , hleft = hlabel $ guard tag (== IsLeft) isLeft $ toColumns left
125136 , hright = hlabel $ guard tag (== IsRight) isRight $ toColumns right
126137 }
@@ -131,39 +142,31 @@ instance
131142 , right = fromColumns $ hunlabel hright
132143 }
133144
134− reify proof EitherTable {tag, left, right} = EitherTable
135− { tag
136− , left = reify proof left
137− , right = reify proof right
138− }
139−
140− unreify proof EitherTable {tag, left, right} = EitherTable
141− { tag
142− , left = unreify proof left
143− , right = unreify proof right
144− }
145−
146− coherence = coherence @context @a
147− congruence proof abstract =
148− id `apply`
149− congruence @context @a proof abstract `apply`
150− congruence @context @b proof abstract
151−
152−
153−instance
154− ( Reifiable from, Abstract from, from ~ from'
155− , Reifiable to, Abstract to, to ~ to'
156− , Recontextualize from to a1 b1
157− , Recontextualize from to a2 b2
158− )
159− => Recontextualize from to (EitherTable from' a1 a2) (EitherTable to' b1 b2)
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"
160163
161164
162165instance (EqTable a, EqTable b, context ~ Expr) =>
163166 EqTable (EitherTable context a b)
164167 where
165168 eqTable = HEitherTable
166− { htag = hlabel (HType Dict)
169+ { htag = hlabel (HIdentity Dict)
167170 , hleft = hlabel (eqTable @(Nullify context a))
168171 , hright = hlabel (eqTable @(Nullify context b))
169172 }
@@ -173,53 +176,42 @@ instance (OrdTable a, OrdTable b, context ~ Expr) =>
173176 OrdTable (EitherTable context a b)
174177 where
175178 ordTable = HEitherTable
176− { htag = hlabel (HType Dict)
179+ { htag = hlabel (HIdentity Dict)
177180 , hleft = hlabel (ordTable @(Nullify context a))
178181 , hright = hlabel (ordTable @(Nullify context b))
179182 }
180183
181184
182−type instance FromExprs (EitherTable _context a b) =
183− Either (FromExprs a) (FromExprs b)
184−
185−
186185instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable Expr exprs1 exprs2) =>
187186 ToExprs x (Either a b)
188− where
189− fromResult =
190− bimap (fromResult @exprs1) (fromResult @exprs2) .
191− fromColumns
192− toResult =
193− toColumns .
194− bimap (toResult @exprs1) (toResult @exprs2)
195187
196188
197189-- | Test if an 'EitherTable' is a 'leftTable'.
198190isLeftTable :: EitherTable Expr a b -> Expr Bool
199−isLeftTable EitherTable {tag = E tag} = isLeft tag
191+isLeftTable EitherTable {tag} = isLeft tag
200192
201193
202194-- | Test if an 'EitherTable' is a 'rightTable'.
203195isRightTable :: EitherTable Expr a b -> Expr Bool
204−isRightTable EitherTable {tag = E tag} = isRight tag
196+isRightTable EitherTable {tag} = isRight tag
205197
206198
207199-- | Pattern match/eliminate an 'EitherTable', by providing mappings from a
208200-- 'leftTable' and 'rightTable'.
209201eitherTable :: Table Expr c
210202 => (a -> c) -> (b -> c) -> EitherTable Expr a b -> c
211−eitherTable f g EitherTable {tag = E tag, left, right} =
203+eitherTable f g EitherTable {tag, left, right} =
212204 bool (f (extract left)) (g (extract right)) (isRight tag)
213205
214206
215207-- | Construct a left 'EitherTable'. Like 'Left'.
216208leftTable :: Table Expr b => a -> EitherTable Expr a b
217−leftTable a = EitherTable (E (litExpr IsLeft)) (pure a) undefined
209+leftTable a = EitherTable (litExpr IsLeft) (pure a) undefined
218210
219211
220212-- | Construct a right 'EitherTable'. Like 'Right'.
221213rightTable :: Table Expr a => b -> EitherTable Expr a b
222−rightTable = EitherTable (E (litExpr IsRight)) undefined . pure
214+rightTable = EitherTable (litExpr IsRight) undefined . pure
223215
224216
225217-- | Lift a pair of aggregating functions to operate on an 'EitherTable'.
@@ -229,8 +221,8 @@ aggregateEitherTable :: ()
229221 -> (exprs' -> aggregates')
230222 -> EitherTable Expr exprs exprs'
231223 -> EitherTable Aggregate aggregates aggregates'
232−aggregateEitherTable f g (EitherTable (E tag) a b) = EitherTable
233− { tag = A (groupByExpr tag)
224+aggregateEitherTable f g (EitherTable tag a b) = EitherTable
225+ { tag = groupByExpr tag
234226 , left = aggregateNullify f a
235227 , right = aggregateNullify g b
236228 }
@@ -248,4 +240,4 @@ nameEitherTable
248240 -> b
249241 -- ^ Names of the columns in the @b@ table.
250242 -> EitherTable Name a b
251−nameEitherTable tag left right = EitherTable (N tag) (pure left) (pure right)
243+nameEitherTable tag left right = EitherTable tag (pure left) (pure right)
src/Rel8/Table/Eq.hs+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( E ) )
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.Constrain ( ConstrainSpec )
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 (ConstrainSpec (Sql 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 (ConstrainSpec (Sql 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 (ConstrainSpec (Sql DBEq)))
66− eqTable =
67− ggtable
68− @(GAlgebra (Rep (Record a)))
69− @TEqTable
70− @TColumns
71− @(Rep (Record a))
72− table
73− (\_ Dict -> Dict)
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 (ConstrainSpec (Sql DBEq))
86− )
87− => EqTable (t f)
88− where
89− eqTable = hdicts @(Columns (t f)) @(ConstrainSpec (Sql 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− (E a, E 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− (E a, E 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+65−107
@@ -13,7 +13,7 @@
1313
1414module Rel8.Table.HKD
1515 ( HKD( HKD )
16− , HKDable, fromHKD, toHKD, HKDT(..)
16+ , HKDable
1717 , BuildableHKD
1818 , BuildHKD, buildHKD
1919 , ConstructableHKD
@@ -27,9 +27,6 @@ where
2727
2828-- base
2929import Data.Kind ( Constraint, Type )
30−import Data.Proxy ( Proxy( Proxy ) )
31−import Data.Type.Equality ( (:~:)( Refl ) )
32−import Data.Void ( Void )
3330import GHC.Generics ( Generic, Rep, from, to )
3431import GHC.TypeLits ( Symbol )
3532import Prelude
@@ -49,165 +46,126 @@ import Rel8.Generic.Construction
4946 , GGName, ggname
5047 , GGAggregate, ggaggregate
5148 )
52−import Rel8.Generic.Map ( GMap, GMappable, gmap, gunmap )
53−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+ )
5454import Rel8.Generic.Rel8able
5555 ( Rel8able
5656 , GColumns, gfromColumns, gtoColumns
57− , greify, gunreify
58− , TUnreifyContext
57+ , GFromExprs, gfromResult, gtoResult
5958 )
6059import Rel8.Generic.Table
61− ( GGTable, GGColumns, GGContext, ggfromColumns, ggtoColumns
62− , GAlgebra
60+ ( GGSerialize, GGColumns, GAlgebra, ggfromResult, ggtoResult
6361 )
64−import Rel8.Schema.Context ( Col )
62+import Rel8.Generic.Table.Record ( GTable, GContext )
63+import qualified Rel8.Generic.Table.Record as G
6564import qualified Rel8.Schema.Kind as K
6665import Rel8.Schema.HTable ( HTable )
6766import Rel8.Schema.Name ( Name )
68−import Rel8.Schema.Reify ( Col( Reify ), Reify, hreify, hunreify, notReify )
6967import Rel8.Schema.Result ( Result )
7068import Rel8.Table
71− ( Table, Columns, Context, fromColumns, toColumns
72− , Unreify, reify, unreify, coherence, congruence
73− , TTable, TColumns, TUnreify
69+ ( Table, fromColumns, toColumns, fromResult, toResult
70+ , TTable, TColumns, TContext
71+ , TSerialize
7472 )
75−import Rel8.Table.Serialize ( ToExprs, fromResult, toResult )
7673
7774
7875type GColumnsHKD :: Type -> K.HTable
7976type GColumnsHKD a =
80− 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))))
8178
8279
8380type HKD :: Type -> K.Rel8able
84−newtype HKD a f = HKD (GColumnsHKD a (Col f))
81+newtype HKD a f = HKD (GColumnsHKD a f)
8582
8683
8784instance HKDable a => Rel8able (HKD a) where
8885 type GColumns (HKD a) = GColumnsHKD a
86+ type GFromExprs (HKD a) = a
8987
90− gfromColumns = HKD
91− gtoColumns (HKD a) = a
88+ gfromColumns _ = HKD
89+ gtoColumns _ (HKD a) = a
9290
93− greify (HKD a) = HKD (hreify a)
94− gunreify (HKD a) = HKD (hunreify 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)
101+
102+ gtoResult =
103+ ggtoResult
104+ @(GAlgebra (Rep a))
105+ @TSerialize
106+ @TColumns
107+ @(Eval (HKDRep a Expr))
108+ @(Eval (HKDRep a Result))
109+ (\(_ :: proxy x) -> toResult @_ @x) .
110+ from .
111+ Record
95112
96113
97114instance
98− ( KnownAlgebra (GAlgebra (Rep a))
99− , HTable (GColumnsHKD a)
100− , Eval (GGTable (GAlgebra (Rep a)) (TTable (Reify f)) TColumns (Col (Reify f)) (GRecord (GMap (TColumn (Reify f)) (Rep a))))
101− , Eval (GGColumns (GAlgebra (Rep a)) TColumns (GRecord (GMap (TColumn (Reify f)) (Rep a)))) ~ GColumnsHKD a
102− , Eval (GGContext (GAlgebra (Rep a)) TUnreifyContext (GRecord (GMap (TColumn (Reify f)) (Rep a)))) ~ f
103− , GRecordable (GMap (TColumn (Reify f)) (Rep a))
104− , GMappable (TTable (Reify f)) (GMap (TColumn (Reify f)) (Rep a))
105− , GMap TUnreify (GMap (TColumn (Reify f)) (Rep a)) ~ GMap (TColumn f) (Rep a)
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))
106119 )
107120 => Generic (HKD a f)
108121 where
109122 type Rep (HKD a f) = GMap (TColumn f) (Rep a)
110123
111124 from =
112− gmap @(TTable (Reify f)) (Proxy @TUnreify) (unreify Refl) .
113− gunrecord @(GMap (TColumn (Reify f)) (Rep a)) .
114− ggfromColumns
115− @(GAlgebra (Rep a))
116− @(TTable (Reify f))
125+ gunrecord @(GMap (TColumn f) (Rep a)) .
126+ G.gfromColumns
127+ @(TTable f)
117128 @TColumns
118− (\(Reify a) -> a)
119− Reify
120129 fromColumns .
121− hreify .
122130 (\(HKD a) -> a)
123131
124132 to =
125133 HKD .
126− hunreify .
127− ggtoColumns
128− @(GAlgebra (Rep a))
129− @(TTable (Reify f))
134+ G.gtoColumns
135+ @(TTable f)
130136 @TColumns
131− (\(Reify a) -> a)
132− Reify
133137 toColumns .
134− grecord @(GMap (TColumn (Reify f)) (Rep a)) .
135− gunmap @(TTable (Reify f)) (Proxy @TUnreify) (reify Refl)
136−
137−
138−type HKDT :: Type -> Type
139−newtype HKDT a = HKDT
140− { unHKDT :: a
141− }
142−
143−
144−instance HKDable a => Table Result (HKDT a) where
145− type Columns (HKDT a) = GColumnsHKD a
146− type Context (HKDT a) = Result
147− type Unreify (HKDT a) = Void
148−
149− fromColumns = HKDT . fromHKD . HKD
150− toColumns = (\(HKD a) -> a) . toHKD . (\(HKDT a) -> a)
151− reify = notReify
152− unreify = notReify
153− coherence = notReify
154− congruence = notReify
155−
156−
157−instance
158− ( Table Expr (HKD a Expr)
159− , Columns (HKD a Expr) ~ GColumns (HKD a)
160− , HKDable a
161− , x ~ HKD a Expr
162− )
163− => ToExprs x (HKDT a)
164− where
165− toResult = (\(HKD a) -> a) . toHKD . (\(HKDT a) -> a)
166− fromResult = HKDT . fromHKD . HKD
167−
168−
169−fromHKD :: HKDable a => HKD a Result -> a
170−fromHKD = to . gunmap @Top (Proxy @(TColumn Result)) id . from
171−
172−
173−toHKD :: HKDable a => a -> HKD a Result
174−toHKD = to . gmap @Top (Proxy @(TColumn Result)) id . from
175−
176−
177−class Top_
178−instance Top_
179−
180−
181−data Top :: Type -> Exp Constraint
182−type instance Eval (Top _) = Top_
138+ grecord @(GMap (TColumn f) (Rep a))
183139
184140
141+type HKDable :: Type -> Constraint
185142class
186− ( Generic a
143+ ( Generic (Record a)
187144 , HTable (GColumns (HKD a))
188145 , KnownAlgebra (GAlgebra (Rep a))
189− , Eval (GGTable (GAlgebra (Rep a)) (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRecord (GMap (TColumn (Reify Result)) (Rep a))))
190− , Eval (GGContext (GAlgebra (Rep a)) TUnreifyContext (GRecord (GMap (TColumn (Reify Result)) (Rep a)))) ~ Result
191− , GRecordable (GMap (TColumn (Reify Result)) (Rep a))
192− , GMappable Top (Rep a)
193− , GMappable (TTable (Reify Result)) (GMap (TColumn (Reify Result)) (Rep a))
194− , GMap TUnreify (GMap (TColumn (Reify Result)) (Rep a)) ~ GMap (TColumn Result) (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)
195148 )
196149 => HKDable a
197150instance
198− ( Generic a
151+ ( Generic (Record a)
199152 , HTable (GColumns (HKD a))
200153 , KnownAlgebra (GAlgebra (Rep a))
201− , Eval (GGTable (GAlgebra (Rep a)) (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRecord (GMap (TColumn (Reify Result)) (Rep a))))
202− , Eval (GGContext (GAlgebra (Rep a)) TUnreifyContext (GRecord (GMap (TColumn (Reify Result)) (Rep a)))) ~ Result
203− , GRecordable (GMap (TColumn (Reify Result)) (Rep a))
204− , GMappable Top (Rep a)
205− , GMappable (TTable (Reify Result)) (GMap (TColumn (Reify Result)) (Rep a))
206− , GMap TUnreify (GMap (TColumn (Reify Result)) (Rep a)) ~ GMap (TColumn Result) (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)
207156 )
208157 => HKDable a
209158
210159
160+type Top_ :: Constraint
161+class Top_
162+instance Top_
163+
164+
165+data Top :: Type -> Exp Constraint
166+type instance Eval (Top _) = Top_
167+
168+
211169type BuildableHKD :: Type -> Symbol -> Constraint
212170class GGBuildable (GAlgebra (Rep a)) name (HKDRep a) => BuildableHKD a name
213171instance GGBuildable (GAlgebra (Rep a)) name (HKDRep a) => BuildableHKD a name
src/Rel8/Table/List.hs+43−55
@@ -11,32 +11,36 @@
1111
1212module Rel8.Table.List
1313 ( ListTable(..)
14− , listTable, nameListTable
14+ , ($*)
15+ , listTable
16+ , nameListTable
1517 )
1618where
1719
1820-- base
19−import Control.Category ( id )
2021import Data.Functor.Identity ( Identity( Identity ) )
2122import Data.Kind ( Type )
22−import Data.Type.Equality ( (:~:)( Refl ), apply )
23−import Prelude hiding ( id )
23+import Prelude
2424
2525-- rel8
26−import Rel8.Expr ( Expr, Col( E, unE ) )
26+import Rel8.Expr ( Expr )
2727import Rel8.Expr.Array ( sappend, sempty, slistOf )
28−import Rel8.Schema.Context.Abstract ( Abstract, exclusivity, virtual )
2928import Rel8.Schema.Dict ( Dict( Dict ) )
3029import Rel8.Schema.HTable.List ( HListTable )
31−import Rel8.Schema.HTable.Vectorize ( happend, hempty, hvectorize )
30+import Rel8.Schema.HTable.Vectorize
31+ ( hvectorize, hunvectorize
32+ , happend, hempty
33+ , hproject, hcolumn
34+ )
3235import qualified Rel8.Schema.Kind as K
33−import Rel8.Schema.Name ( Col( N ), Name( Name ) )
36+import Rel8.Schema.Name ( Name( Name ) )
3437import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
35−import Rel8.Schema.Spec ( SSpec(..) )
36−import Rel8.Schema.Reify ( hreify, hunreify )
38+import Rel8.Schema.Result ( vectorizer, unvectorizer )
39+import Rel8.Schema.Spec ( Spec(..) )
3740import Rel8.Table
3841 ( Table, Context, Columns, fromColumns, toColumns
39− , reify, unreify, coherence, congruence
42+ , FromExprs, fromResult, toResult
43+ , Transpose
4044 )
4145import Rel8.Table.Alternative
4246 ( AltTable, (<|>:)
@@ -44,56 +48,41 @@ import Rel8.Table.Alternative
4448 )
4549import Rel8.Table.Eq ( EqTable, eqTable )
4650import Rel8.Table.Ord ( OrdTable, ordTable )
47−import Rel8.Table.Recontextualize ( Recontextualize )
48−import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
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'.
5359type ListTable :: K.Context -> Type -> Type
5460newtype ListTable context a =
55− ListTable (HListTable (Columns a) (Col (Context a)))
61+ ListTable (HListTable (Columns a) (Context a))
62+
63+
64+instance Projectable (ListTable context) where
65+ project f (ListTable a) = ListTable (hproject (apply f) a)
5666
5767
58−instance (Table context a, Abstract context, context ~ context') =>
68+instance (Table context a, context ~ context') =>
5969 Table context' (ListTable context a)
6070 where
6171 type Columns (ListTable context a) = HListTable (Columns a)
6272 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)
6375
6476 fromColumns = ListTable
6577 toColumns (ListTable a) = a
66−
67− reify proof@Refl (ListTable a) =
68− case coherence @context @a proof abstract of
69− Refl -> case congruence @context @a proof abstract of
70− Refl -> ListTable (hreify a)
71− where
72− abstract = exclusivity virtual
73−
74− unreify proof@Refl (ListTable a) =
75− case coherence @context @a proof abstract of
76− Refl -> case congruence @context @a proof abstract of
77− Refl -> ListTable (hunreify a)
78− where
79− abstract = exclusivity virtual
80−
81− coherence = coherence @context @a
82− congruence proof abstract = id `apply` congruence @context @a proof abstract
83−
84−
85−instance
86− ( Recontextualize from to a b
87− , Abstract from, from ~ from'
88− , Abstract to, to ~ to'
89− )
90− => Recontextualize from to (ListTable from' a) (ListTable to' b)
78+ fromResult = fmap (fromResult @_ @a) . hunvectorize unvectorizer
79+ toResult = hvectorize vectorizer . fmap (toResult @_ @a)
9180
9281
9382instance (EqTable a, context ~ Expr) => EqTable (ListTable context a) where
9483 eqTable =
9584 hvectorize
96− (\SSpec {nullity} (Identity Dict) -> case nullity of
85+ (\Spec {nullity} (Identity Dict) -> case nullity of
9786 Null -> Dict
9887 NotNull -> Dict)
9988 (Identity (eqTable @a))
@@ -102,20 +91,14 @@ instance (EqTable a, context ~ Expr) => EqTable (ListTable context a) where
10291instance (OrdTable a, context ~ Expr) => OrdTable (ListTable context a) where
10392 ordTable =
10493 hvectorize
105− (\SSpec {nullity} (Identity Dict) -> case nullity of
94+ (\Spec {nullity} (Identity Dict) -> case nullity of
10695 Null -> Dict
10796 NotNull -> Dict)
10897 (Identity (ordTable @a))
10998
11099
111−type instance FromExprs (ListTable _context a) = [FromExprs a]
112−
113−
114100instance (ToExprs exprs a, context ~ Expr) =>
115101 ToExprs (ListTable context exprs) [a]
116− where
117− fromResult = fmap (fromResult @exprs) . fromColumns
118− toResult = toColumns . fmap (toResult @exprs)
119102
120103
121104instance context ~ Expr => AltTable (ListTable context) where
@@ -126,24 +109,29 @@ instance context ~ Expr => AlternativeTable (ListTable context) where
126109 emptyTable = mempty
127110
128111
129−instance (context ~ Expr, Table Expr a) =>
130− Semigroup (ListTable context a)
112+instance (context ~ Expr, Table Expr a) => Semigroup (ListTable context a)
131113 where
132− ListTable as <> ListTable bs = ListTable $
133− happend (\_ _ (E a) (E b) -> E (sappend a b)) as bs
114+ ListTable as <> ListTable bs = ListTable $ happend (const sappend) as bs
134115
135116
136117instance (context ~ Expr, Table Expr a) =>
137118 Monoid (ListTable context a)
138119 where
139− mempty = ListTable $ hempty $ \_ -> E . sempty
120+ mempty = ListTable $ hempty $ \Spec {info} -> sempty info
121+
122+
123+-- | Project a single expression out of a 'ListTable'.
124+($*) :: Projecting a (Expr b)
125+ => Projection a (Expr b) -> ListTable Expr a -> Expr [b]
126+f $* ListTable a = hcolumn $ hproject (apply f) a
127+infixl 4 $*
140128
141129
142130-- | Construct a @ListTable@ from a list of expressions.
143131listTable :: Table Expr a => [a] -> ListTable Expr a
144132listTable =
145133 ListTable .
146− hvectorize (\SSpec {info} -> E . slistOf info . fmap unE) .
134+ hvectorize (\Spec {info} -> slistOf info) .
147135 fmap toColumns
148136
149137
@@ -156,6 +144,6 @@ nameListTable
156144 -> ListTable Name a
157145nameListTable =
158146 ListTable .
159− hvectorize (\_ (Identity (N (Name a))) -> N (Name a)) .
147+ hvectorize (\_ (Identity (Name a)) -> Name a) .
160148 pure .
161149 toColumns
src/Rel8/Table/Maybe.hs+48−49
@@ -15,6 +15,7 @@ module Rel8.Table.Maybe
1515 ( MaybeTable(..)
1616 , maybeTable, nothingTable, justTable
1717 , isNothingTable, isJustTable
18+ , fromMaybeTable
1819 , ($?)
1920 , aggregateMaybeTable
2021 , nameMaybeTable
@@ -22,35 +23,34 @@ module Rel8.Table.Maybe
2223where
2324
2425-- base
25−import Control.Category ( id )
26+import Data.Functor ( ($>) )
27+import Data.Functor.Identity ( Identity( Identity ) )
2628import Data.Kind ( Type )
27−import Data.Maybe ( isJust )
28−import Data.Type.Equality ( apply )
29−import Prelude hiding ( id, null, undefined )
29+import Data.Maybe ( fromMaybe, isJust )
30+import Prelude hiding ( null, undefined )
3031
3132-- comonad
3233import Control.Comonad ( extract )
3334
3435-- rel8
35−import Rel8.Aggregate ( Col( A ), Aggregate )
36−import Rel8.Expr ( Col( E ), Expr )
36+import Rel8.Aggregate ( Aggregate )
37+import Rel8.Expr ( Expr )
3738import Rel8.Expr.Aggregate ( groupByExpr )
3839import Rel8.Expr.Bool ( boolExpr )
3940import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )
4041import Rel8.Kind.Context ( Reifiable )
41−import Rel8.Schema.Context.Abstract ( Abstract )
4242import Rel8.Schema.Dict ( Dict( Dict ) )
4343import qualified Rel8.Schema.Kind as K
4444import Rel8.Schema.HTable.Identity ( HIdentity(..) )
4545import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
4646import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
47−import Rel8.Schema.Name ( Col( N ), Name )
47+import Rel8.Schema.Name ( Name )
4848import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
4949import qualified Rel8.Schema.Null as N
50−import Rel8.Schema.Spec ( Spec( Spec ) )
5150import Rel8.Table
5251 ( Table, Columns, Context, fromColumns, toColumns
53− , coherence, congruence, reify, unreify
52+ , FromExprs, fromResult, toResult
53+ , Transpose
5454 )
5555import Rel8.Table.Alternative
5656 ( AltTable, (<|>:)
@@ -59,12 +59,12 @@ import Rel8.Table.Alternative
5959import Rel8.Table.Bool ( bool )
6060import Rel8.Table.Eq ( EqTable, eqTable )
6161import Rel8.Table.Ord ( OrdTable, ordTable )
62+import Rel8.Table.Projection ( Projectable, project )
6263import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )
63−import Rel8.Table.Recontextualize ( Recontextualize )
64−import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
64+import Rel8.Table.Serialize ( ToExprs )
6565import Rel8.Table.Undefined ( undefined )
6666import Rel8.Type ( DBType )
67−import Rel8.Type.Tag ( MaybeTag )
67+import Rel8.Type.Tag ( MaybeTag( IsJust ) )
6868
6969-- semigroupoids
7070import Data.Functor.Apply ( Apply, (<.>) )
@@ -81,15 +81,18 @@ import Data.Functor.Bind ( Bind, (>>-) )
8181-- a "nullTag" - to track whether or not the outer join produced any rows.
8282type MaybeTable :: K.Context -> Type -> Type
8383data MaybeTable context a = MaybeTable
84− { tag :: Col context ('Spec (Maybe MaybeTag))
84+ { tag :: context (Maybe MaybeTag)
8585 , just :: Nullify context a
8686 }
8787 deriving stock Functor
8888
8989
90+instance Projectable (MaybeTable context) where
91+ project f (MaybeTable tag a) = MaybeTable tag (project f a)
92+
93+
9094instance context ~ Expr => Apply (MaybeTable context) where
91− MaybeTable (E tag) f <.> MaybeTable (E tag') a =
92− MaybeTable (E (tag <> tag')) (f <.> a)
95+ MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f <.> a)
9396
9497
9598-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:
@@ -100,8 +103,8 @@ instance context ~ Expr => Applicative (MaybeTable context) where
100103
101104
102105instance context ~ Expr => Bind (MaybeTable context) where
103− MaybeTable (E tag) a >>- f = case f (extract a) of
104− MaybeTable (E tag') b -> MaybeTable (E (tag <> tag')) b
106+ MaybeTable tag a >>- f = case f (extract a) of
107+ MaybeTable tag' b -> MaybeTable (tag <> tag') b
105108
106109
107110-- | Has the same behavior as the @Monad@ instance for @Maybe@.
@@ -129,14 +132,13 @@ instance (context ~ Expr, Table Expr a, Semigroup a) =>
129132 mempty = nothingTable
130133
131134
132−instance
133− ( Table context a
134− , Reifiable context, Abstract context, context ~ context'
135− )
136− => Table context' (MaybeTable context a)
135+instance (Table context a, Reifiable context, context ~ context') =>
136+ Table context' (MaybeTable context a)
137137 where
138138 type Columns (MaybeTable context a) = HMaybeTable (Columns a)
139139 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)
140142
141143 toColumns MaybeTable {tag, just} = HMaybeTable
142144 { htag = hlabel $ HIdentity tag
@@ -148,52 +150,44 @@ instance
148150 , just = fromColumns $ hunlabel hjust
149151 }
150152
151− reify proof (MaybeTable tag a) = MaybeTable tag (reify proof a)
152− unreify proof (MaybeTable tag a) = MaybeTable tag (unreify proof a)
153− coherence = coherence @context @a
154− congruence proof abstract = id `apply` congruence @context @a proof abstract
155−
153+ toResult ma = HMaybeTable
154+ { htag = hlabel (HIdentity (Identity (IsJust <$ ma)))
155+ , hjust = hlabel (toResult @_ @(Nullify context a) ma)
156+ }
156157
157−instance
158− ( Recontextualize from to a b
159− , Reifiable from, Abstract from, from ~ from'
160− , Reifiable to, Abstract to, to ~ to'
161− )
162− => Recontextualize from to (MaybeTable from' a) (MaybeTable to' b)
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"
163163
164164
165165instance (EqTable a, context ~ Expr) => EqTable (MaybeTable context a) where
166166 eqTable = HMaybeTable
167− { htag = hlabel (HType Dict)
167+ { htag = hlabel (HIdentity Dict)
168168 , hjust = hlabel (eqTable @(Nullify context a))
169169 }
170170
171171
172172instance (OrdTable a, context ~ Expr) => OrdTable (MaybeTable context a) where
173173 ordTable = HMaybeTable
174− { htag = hlabel (HType Dict)
174+ { htag = hlabel (HIdentity Dict)
175175 , hjust = hlabel (ordTable @(Nullify context a))
176176 }
177177
178178
179−type instance FromExprs (MaybeTable _context a) = Maybe (FromExprs a)
180−
181−
182179instance (ToExprs exprs a, context ~ Expr) =>
183180 ToExprs (MaybeTable context exprs) (Maybe a)
184− where
185− fromResult = fmap (fromResult @exprs) . fromColumns
186− toResult = toColumns . fmap (toResult @exprs)
187181
188182
189183-- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.
190184isNothingTable :: MaybeTable Expr a -> Expr Bool
191−isNothingTable (MaybeTable (E tag) _) = isNull tag
185+isNothingTable (MaybeTable tag _) = isNull tag
192186
193187
194188-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.
195189isJustTable :: MaybeTable Expr a -> Expr Bool
196−isJustTable (MaybeTable (E tag) _) = isNonNull tag
190+isJustTable (MaybeTable tag _) = isNonNull tag
197191
198192
199193-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.
@@ -204,13 +198,18 @@ maybeTable b f ma@(MaybeTable _ a) = bool (f (extract a)) b (isNothingTable ma)
204198
205199-- | The null table. Like 'Nothing'.
206200nothingTable :: Table Expr a => MaybeTable Expr a
207−nothingTable = MaybeTable (E null) (pure undefined)
201+nothingTable = MaybeTable null (pure undefined)
208202
209203
210204-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use
211205-- 'pure'.
212206justTable :: a -> MaybeTable Expr a
213−justTable = MaybeTable (E mempty) . pure
207+justTable = MaybeTable mempty . pure
208+
209+
210+-- | 'Data.Maybe.fromMaybe' for 'MaybeTable's.
211+fromMaybeTable :: Table Expr a => a -> MaybeTable Expr a -> a
212+fromMaybeTable fallback = maybeTable fallback id
214213
215214
216215-- | Project a single expression out of a 'MaybeTable'. You can think of this
@@ -230,8 +229,8 @@ aggregateMaybeTable :: ()
230229 => (exprs -> aggregates)
231230 -> MaybeTable Expr exprs
232231 -> MaybeTable Aggregate aggregates
233−aggregateMaybeTable f (MaybeTable (E tag) a) =
234− MaybeTable (A (groupByExpr tag)) (aggregateNullify f a)
232+aggregateMaybeTable f (MaybeTable tag a) =
233+ MaybeTable (groupByExpr tag) (aggregateNullify f a)
235234
236235
237236-- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you
@@ -244,4 +243,4 @@ nameMaybeTable
244243 -> a
245244 -- ^ Names of the columns in @a@.
246245 -> MaybeTable Name a
247−nameMaybeTable tag = MaybeTable (N tag) . pure
246+nameMaybeTable tag = MaybeTable tag . pure
src/Rel8/Table/Name.hs+11−20
@@ -1,14 +1,17 @@
1+{-# language DataKinds #-}
12{-# language FlexibleContexts #-}
3+{-# language FlexibleInstances #-}
4+{-# language MultiParamTypeClasses #-}
25{-# language NamedFieldPuns #-}
36{-# language ScopedTypeVariables #-}
47{-# language TypeApplications #-}
58{-# language TypeFamilies #-}
9+{-# language UndecidableInstances #-}
610{-# language ViewPatterns #-}
711
812module Rel8.Table.Name
913 ( namesFromLabels
1014 , namesFromLabelsWith
11− , showExprs
1215 , showLabels
1316 , showNames
1417 )
@@ -21,16 +24,11 @@ import Data.List.NonEmpty ( NonEmpty, intersperse, nonEmpty )
2124import Data.Maybe ( fromMaybe )
2225import Prelude
2326
24−-- opaleye
25−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
26−
2727-- rel8
28−import Rel8.Expr ( Expr, Col( E ) )
29−import Rel8.Expr.Opaleye ( toPrimExpr )
3028import Rel8.Schema.HTable ( htabulate, htabulateA, hfield, hspecs )
31−import Rel8.Schema.Name ( Name( Name ), Col( N ) )
32−import Rel8.Schema.Spec ( SSpec(..) )
33−import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
29+import Rel8.Schema.Name ( Name( Name ) )
30+import Rel8.Schema.Spec ( Spec(..) )
31+import Rel8.Table ( Table(..) )
3432
3533
3634-- | Construct a table in the 'Name' context containing the names of all
@@ -62,26 +60,19 @@ namesFromLabelsWith :: Table Name a
6260 => (NonEmpty String -> String) -> a
6361namesFromLabelsWith f = fromColumns $ htabulate $ \field ->
6462 case hfield hspecs field of
65− SSpec {labels} -> N (Name (f (renderLabels labels)))
66−
67−
68−showExprs :: Table Expr a => a -> [(String, Opaleye.PrimExpr)]
69−showExprs as = case (namesFromLabels, toColumns as) of
70− (names, exprs) -> getConst $ htabulateA $ \field ->
71− case (hfield names field, hfield exprs field) of
72− (N (Name name), E expr) -> Const [(name, toPrimExpr expr)]
63+ Spec {labels} -> Name (f (renderLabels labels))
7364
7465
7566showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]
7667showLabels _ = getConst $
7768 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
78− SSpec {labels} -> Const [renderLabels labels]
69+ Spec {labels} -> Const (pure (renderLabels labels))
7970
8071
81−showNames :: forall a. Table Name a => a -> [String]
72+showNames :: forall a. Table Name a => a -> NonEmpty String
8273showNames (toColumns -> names) = getConst $
8374 htabulateA @(Columns a) $ \field -> case hfield names field of
84− N (Name name) -> Const [name]
75+ Name name -> Const (pure name)
8576
8677
8778renderLabels :: [String] -> NonEmpty String
src/Rel8/Table/NonEmpty.hs+42−52
@@ -11,81 +11,71 @@
1111
1212module Rel8.Table.NonEmpty
1313 ( NonEmptyTable(..)
14− , nonEmptyTable, nameNonEmptyTable
14+ , ($+)
15+ , nonEmptyTable
16+ , nameNonEmptyTable
1517 )
1618where
1719
1820-- base
19−import Control.Category ( id )
2021import Data.Functor.Identity ( Identity( Identity ) )
2122import Data.Kind ( Type )
2223import Data.List.NonEmpty ( NonEmpty )
23−import Data.Type.Equality ( (:~:)( Refl ), apply )
2424import Prelude hiding ( id )
2525
2626-- rel8
27−import Rel8.Expr ( Expr, Col( E, unE ) )
27+import Rel8.Expr ( Expr )
2828import Rel8.Expr.Array ( sappend1, snonEmptyOf )
29−import Rel8.Schema.Context.Abstract ( Abstract, exclusivity, virtual )
3029import Rel8.Schema.Dict ( Dict( Dict ) )
3130import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
32−import Rel8.Schema.HTable.Vectorize ( happend, hvectorize )
31+import Rel8.Schema.HTable.Vectorize
32+ ( hvectorize, hunvectorize
33+ , happend
34+ , hproject, hcolumn
35+ )
3336import qualified Rel8.Schema.Kind as K
34−import Rel8.Schema.Name ( Col( N ), Name( Name ) )
37+import Rel8.Schema.Name ( Name( Name ) )
3538import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
36−import Rel8.Schema.Reify ( hreify, hunreify )
37−import Rel8.Schema.Spec ( SSpec(..) )
39+import Rel8.Schema.Result ( vectorizer, unvectorizer )
40+import Rel8.Schema.Spec ( Spec(..) )
3841import Rel8.Table
3942 ( Table, Context, Columns, fromColumns, toColumns
40− , reify, unreify, coherence, congruence
43+ , FromExprs, fromResult, toResult
44+ , Transpose
4145 )
4246import Rel8.Table.Alternative ( AltTable, (<|>:) )
4347import Rel8.Table.Eq ( EqTable, eqTable )
4448import Rel8.Table.Ord ( OrdTable, ordTable )
45−import Rel8.Table.Recontextualize ( Recontextualize )
46−import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
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'.
5157type NonEmptyTable :: K.Context -> Type -> Type
5258newtype NonEmptyTable context a =
53− NonEmptyTable (HNonEmptyTable (Columns a) (Col (Context a)))
59+ NonEmptyTable (HNonEmptyTable (Columns a) (Context a))
60+
61+
62+instance Projectable (NonEmptyTable context) where
63+ project f (NonEmptyTable a) = NonEmptyTable (hproject (apply f) a)
5464
5565
56−instance (Table context a, Abstract context, context ~ context') =>
66+instance (Table context a, context ~ context') =>
5767 Table context' (NonEmptyTable context a)
5868 where
5969 type Columns (NonEmptyTable context a) = HNonEmptyTable (Columns a)
6070 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 proof@Refl (NonEmptyTable a) =
66− case coherence @context @a proof abstract of
67− Refl -> case congruence @context @a proof abstract of
68− Refl -> NonEmptyTable (hreify a)
69− where
70− abstract = exclusivity virtual
71−
72− unreify proof@Refl (NonEmptyTable a) =
73− case coherence @context @a proof abstract of
74− Refl -> case congruence @context @a proof abstract of
75− Refl -> NonEmptyTable (hunreify a)
76− where
77− abstract = exclusivity virtual
78−
79− coherence = coherence @context @a
80− congruence proof abstract = id `apply` congruence @context @a proof abstract
81−
82−
83−instance
84− ( Recontextualize from to a b
85− , Abstract from, from ~ from'
86− , Abstract to, to ~ to'
87− )
88− => Recontextualize from to (NonEmptyTable from' a) (NonEmptyTable to' b)
77+ fromResult = fmap (fromResult @_ @a) . hunvectorize unvectorizer
78+ toResult = hvectorize vectorizer . fmap (toResult @_ @a)
8979
9080
9181instance (EqTable a, context ~ Expr) =>
@@ -93,7 +83,7 @@ instance (EqTable a, context ~ Expr) =>
9383 where
9484 eqTable =
9585 hvectorize
96− (\SSpec {nullity} (Identity Dict) -> case nullity of
86+ (\Spec {nullity} (Identity Dict) -> case nullity of
9787 Null -> Dict
9888 NotNull -> Dict)
9989 (Identity (eqTable @a))
@@ -104,38 +94,38 @@ instance (OrdTable a, context ~ Expr) =>
10494 where
10595 ordTable =
10696 hvectorize
107− (\SSpec {nullity} (Identity Dict) -> case nullity of
97+ (\Spec {nullity} (Identity Dict) -> case nullity of
10898 Null -> Dict
10999 NotNull -> Dict)
110100 (Identity (ordTable @a))
111101
112102
113−type instance FromExprs (NonEmptyTable _context a) = NonEmpty (FromExprs a)
114−
115−
116103instance (ToExprs exprs a, context ~ Expr) =>
117104 ToExprs (NonEmptyTable context exprs) (NonEmpty a)
118− where
119− fromResult = fmap (fromResult @exprs) . fromColumns
120− toResult = toColumns . fmap (toResult @exprs)
121105
122106
123107instance context ~ Expr => AltTable (NonEmptyTable context) where
124108 (<|>:) = (<>)
125109
126110
127−instance (Table Expr a, context ~ Expr) =>
128− Semigroup (NonEmptyTable context a)
111+instance (Table Expr a, context ~ Expr) => Semigroup (NonEmptyTable context a)
129112 where
130113 NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $
131− happend (\_ _ (E a) (E b) -> E (sappend1 a b)) as bs
114+ happend (const sappend1) as bs
115+
116+
117+-- | Project a single expression out of a 'NonEmptyTable'.
118+($+) :: Projecting a (Expr b)
119+ => Projection a (Expr b) -> NonEmptyTable Expr a -> Expr (NonEmpty b)
120+f $+ NonEmptyTable a = hcolumn $ hproject (apply f) a
121+infixl 4 $+
132122
133123
134124-- | Construct a @NonEmptyTable@ from a non-empty list of expressions.
135125nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable Expr a
136126nonEmptyTable =
137127 NonEmptyTable .
138− hvectorize (\SSpec {info} -> E . snonEmptyOf info . fmap unE) .
128+ hvectorize (\Spec {info} -> snonEmptyOf info) .
139129 fmap toColumns
140130
141131
@@ -148,6 +138,6 @@ nameNonEmptyTable
148138 -> NonEmptyTable Name a
149139nameNonEmptyTable =
150140 NonEmptyTable .
151− hvectorize (\_ (Identity (N (Name a))) -> N (Name a)) .
141+ hvectorize (\_ (Identity (Name a)) -> Name a) .
152142 pure .
153143 toColumns
src/Rel8/Table/Null.hsnew file+147
@@ -0,0 +1,147 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language FlexibleInstances #-}
4+{-# language MultiParamTypeClasses #-}
5+{-# language ScopedTypeVariables #-}
6+{-# language StandaloneKindSignatures #-}
7+{-# language TypeApplications #-}
8+{-# language TypeFamilies #-}
9+{-# language UndecidableInstances #-}
10+
11+module Rel8.Table.Null
12+ ( NullTable(..)
13+ , nullableTable, nullTable, nullifyTable, unsafeUnnullifyTable
14+ , isNullTable, isNonNullTable
15+ , nameNullTable
16+ , toMaybeTable, toNullTable
17+ )
18+where
19+
20+-- base
21+import Data.Kind ( Type )
22+import Prelude hiding ( null, undefined )
23+
24+-- comonad
25+import Control.Comonad ( extract )
26+
27+-- rel8
28+import Rel8.Expr ( Expr )
29+import Rel8.Expr.Bool ( not_ )
30+import Rel8.Kind.Context ( Reifiable )
31+import qualified Rel8.Schema.Kind as K
32+import Rel8.Schema.Name ( Name )
33+import Rel8.Table
34+ ( Table, Columns, Context, fromColumns, toColumns
35+ , FromExprs, fromResult, toResult
36+ , Transpose
37+ )
38+import Rel8.Table.Alternative
39+ ( AltTable, (<|>:)
40+ , AlternativeTable, emptyTable
41+ )
42+import Rel8.Table.Bool ( bool )
43+import Rel8.Table.Eq ( EqTable, eqTable )
44+import Rel8.Table.Maybe ( MaybeTable, justTable, maybeTable, nothingTable )
45+import Rel8.Table.Nullify ( Nullify, isNull )
46+import Rel8.Table.Ord ( OrdTable, ordTable )
47+import Rel8.Table.Projection ( Projectable, project )
48+import Rel8.Table.Serialize ( ToExprs )
49+import Rel8.Table.Undefined ( undefined )
50+
51+
52+-- | @NullTable t@ is the table @t@, but where all the columns in @t@ have the
53+-- possibility of being 'Rel8.null'. This is very similar to
54+-- 'Rel8.MaybeTable', except that it does not use an extra tag field, so it
55+-- cannot distinguish between @Nothing@ and @Just Nothing@ if nested. In other
56+-- words, if all of the columns of the @t@ passed to @NullTable@ are already
57+-- nullable, then @NullTable@ has no effect.
58+type NullTable :: K.Context -> Type -> Type
59+newtype NullTable context a = NullTable (Nullify context a)
60+
61+
62+instance Projectable (NullTable context) where
63+ project f (NullTable a) = NullTable (project f a)
64+
65+
66+instance context ~ Expr => AltTable (NullTable context) where
67+ ma <|>: mb = bool ma mb (isNullTable ma)
68+
69+
70+instance context ~ Expr => AlternativeTable (NullTable context) where
71+ emptyTable = nullTable
72+
73+
74+instance (Table context a, Reifiable context, context ~ context') =>
75+ Table context' (NullTable context a)
76+ where
77+ type Columns (NullTable context a) = Columns (Nullify context a)
78+ type Context (NullTable context a) = Context (Nullify context a)
79+ type FromExprs (NullTable context a) = FromExprs (Nullify context a)
80+ type Transpose to (NullTable context a) = NullTable to (Transpose to a)
81+
82+ toColumns (NullTable a) = toColumns a
83+ fromColumns = NullTable . fromColumns
84+
85+ toResult = toResult @_ @(Nullify context a)
86+ fromResult = fromResult @_ @(Nullify context a)
87+
88+
89+instance (EqTable a, context ~ Expr) => EqTable (NullTable context a) where
90+ eqTable = eqTable @(Nullify context a)
91+
92+
93+instance (OrdTable a, context ~ Expr) => OrdTable (NullTable context a) where
94+ ordTable = ordTable @(Nullify context a)
95+
96+
97+instance (ToExprs exprs a, context ~ Expr) =>
98+ ToExprs (NullTable context exprs) (Maybe a)
99+
100+
101+-- | Check if any of the non-nullable fields of @a@ are 'Rel8.null' under the
102+-- 'NullTable'. Returns 'Rel8.false' if @a@ has no non-nullable fields.
103+isNullTable :: Table Expr a => NullTable Expr a -> Expr Bool
104+isNullTable (NullTable a) = isNull a
105+
106+
107+-- | The inverse of 'isNullTable'.
108+isNonNullTable :: Table Expr a => NullTable Expr a -> Expr Bool
109+isNonNullTable = not_ . isNullTable
110+
111+
112+-- | Like 'Rel8.nullable'.
113+nullableTable :: (Table Expr a, Table Expr b)
114+ => b -> (a -> b) -> NullTable Expr a -> b
115+nullableTable b f ma@(NullTable a) = bool (f (extract a)) b (isNullTable ma)
116+
117+
118+-- | The null table. Like 'Rel8.null'.
119+nullTable :: Table Expr a => NullTable Expr a
120+nullTable = NullTable (pure undefined)
121+
122+
123+-- | Lift any table into 'NullTable'. Like 'Rel8.nullify'.
124+nullifyTable :: a -> NullTable Expr a
125+nullifyTable = NullTable . pure
126+
127+
128+unsafeUnnullifyTable :: NullTable Expr a -> a
129+unsafeUnnullifyTable (NullTable a) = extract a
130+
131+
132+-- | Construct a 'NullTable' in the 'Name' context. This can be useful if you
133+-- have a 'NullTable' that you are storing in a table and need to construct a
134+-- 'TableSchema'.
135+nameNullTable :: a -> NullTable Name a
136+nameNullTable = NullTable . pure
137+
138+
139+-- | Convert a 'NullTable' to a 'MaybeTable'.
140+toMaybeTable :: Table Expr a => NullTable Expr a -> MaybeTable Expr a
141+toMaybeTable = nullableTable nothingTable justTable
142+
143+
144+-- | Convert a 'MaybeTable' to a 'NullTable'. Note that if the underlying @a@
145+-- has no non-nullable fields, this is a lossy conversion.
146+toNullTable :: Table Expr a => MaybeTable Expr a -> NullTable Expr a
147+toNullTable = maybeTable nullTable nullifyTable
src/Rel8/Table/Nullify.hs+57−50
@@ -1,7 +1,9 @@
11{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
23{-# language FlexibleInstances #-}
34{-# language LambdaCase #-}
45{-# language MultiParamTypeClasses #-}
6+{-# language NamedFieldPuns #-}
57{-# language ScopedTypeVariables #-}
68{-# language StandaloneKindSignatures #-}
79{-# language TypeApplications #-}
@@ -12,16 +14,16 @@ module Rel8.Table.Nullify
1214 ( Nullify
1315 , aggregateNullify
1416 , guard
17+ , isNull
1518 )
1619where
1720
1821-- base
1922import Control.Applicative ( liftA2 )
20−import Control.Category ( id )
23+import Data.Functor.Const ( Const( Const ), getConst )
2124import Data.Functor.Identity ( runIdentity )
2225import Data.Kind ( Type )
23−import Data.Type.Equality ( (:~:)( Refl ), apply )
24−import Prelude hiding ( id )
26+import Prelude
2527
2628-- comonad
2729import Control.Comonad ( Comonad, duplicate, extract, ComonadApply, (<@>) )
@@ -29,12 +31,12 @@ import Control.Comonad ( Comonad, duplicate, extract, ComonadApply, (<@>) )
2931-- rel8
3032import Rel8.Aggregate ( Aggregate )
3133import Rel8.Expr ( Expr )
34+import Rel8.Expr.Bool ( (||.), false )
35+import qualified Rel8.Expr.Null as Expr
3236import Rel8.Kind.Context ( Reifiable, contextSing )
33−import Rel8.Schema.Context ( Col )
34−import Rel8.Schema.Context.Abstract ( Abstract, exclusivity, virtual )
3537import Rel8.Schema.Context.Nullify
3638 ( Nullifiability( NAggregate, NExpr )
37− , NonNullifiability( NNReify )
39+ , NonNullifiability
3840 , Nullifiable, nullifiability
3941 , nullifiableOrNot, absurd
4042 , guarder
@@ -43,17 +45,23 @@ import Rel8.Schema.Context.Nullify
4345 )
4446import Rel8.Schema.Dict ( Dict( Dict ) )
4547import Rel8.Schema.HTable ( HTable )
46−import Rel8.Schema.HTable.Nullify ( HNullify, hnullify, hunnullify, hguard )
48+import Rel8.Schema.HTable.Nullify
49+ ( HNullify, hnulls, hnullify, hunnullify
50+ , hguard
51+ , hproject
52+ )
4753import qualified Rel8.Schema.Kind as K
48−import Rel8.Schema.Reify ( hreify, hunreify )
49−import Rel8.Schema.Spec ( Spec( Spec ) )
54+import Rel8.Schema.Null ( Nullity( NotNull, Null ) )
55+import qualified Rel8.Schema.Result as R
5056import Rel8.Table
5157 ( Table, Columns, Context, toColumns, fromColumns
52− , reify, unreify, coherence, congruence
58+ , FromExprs, fromResult, toResult
59+ , Transpose
5360 )
61+import Rel8.Schema.Spec ( Spec( Spec, nullity ) )
5462import Rel8.Table.Eq ( EqTable, eqTable )
5563import Rel8.Table.Ord ( OrdTable, ordTable )
56−import Rel8.Table.Recontextualize ( Recontextualize )
64+import Rel8.Table.Projection ( Projectable, apply, project )
5765
5866-- semigroupoids
5967import Data.Functor.Apply ( Apply, (<.>), liftF2 )
@@ -64,7 +72,13 @@ import Data.Functor.Extend ( Extend, duplicated )
6472type Nullify :: K.Context -> Type -> Type
6573data Nullify context a
6674 = Table (Nullifiability context) a
67− | Fields (NonNullifiability context) (HNullify (Columns a) (Col (Context a)))
75+ | Fields (NonNullifiability context) (HNullify (Columns a) (Context a))
76+
77+
78+instance Projectable (Nullify context) where
79+ project f = \case
80+ Table nullifiable a -> Table nullifiable (fromColumns (apply f (toColumns a)))
81+ Fields nonNullifiable a -> Fields nonNullifiable (hproject (apply f) a)
6882
6983
7084instance Nullifiable context => Functor (Nullify context) where
@@ -124,14 +138,13 @@ instance Nullifiable context => ComonadApply (Nullify context) where
124138 (<@>) = (<.>)
125139
126140
127−instance
128− ( Table context a
129− , Reifiable context, Abstract context, context ~ context'
130− )
131− => Table context' (Nullify context a)
141+instance (Table context a, Reifiable context, context ~ context') =>
142+ Table context' (Nullify context a)
132143 where
133144 type Columns (Nullify context a) = HNullify (Columns a)
134145 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)
135148
136149 fromColumns = case nullifiableOrNot contextSing of
137150 Left notNullifiable -> Fields notNullifiable
@@ -145,36 +158,11 @@ instance
145158 Table nullifiable a -> hnullify (nullifier nullifiable) (toColumns a)
146159 Fields _ a -> a
147160
148− reify proof@Refl = \case
149− Table nullifiable a -> Table nullifiable (reify proof a)
150− Fields notNullifiable a -> case notNullifiable of
151− NNReify (_ :: NonNullifiability ctx) ->
152− case coherence @context @a proof abstract of
153− Refl -> case congruence @context @a proof abstract of
154− Refl -> Fields notNullifiable (hreify a)
155− where
156− abstract = exclusivity (virtual @ctx)
157−
158− unreify proof@Refl = \case
159− Table nullifiable a -> Table nullifiable (unreify proof a)
160− Fields notNullifiable a -> case notNullifiable of
161− NNReify (_ :: NonNullifiability ctx) ->
162− case coherence @context @a proof abstract of
163− Refl -> case congruence @context @a proof abstract of
164− Refl -> Fields notNullifiable (hunreify a)
165− where
166− abstract = exclusivity (virtual @ctx)
167−
168− coherence = coherence @context @a
169− congruence proof abstract = id `apply` congruence @context @a proof abstract
170−
171−
172−instance
173− ( Recontextualize from to a b
174− , Reifiable from, Abstract from, from ~ from'
175− , Reifiable to, Abstract to, to ~ to'
176− )
177− => Recontextualize from' to' (Nullify from a) (Nullify to b)
161+ fromResult = fmap (fromResult @_ @a) . hunnullify R.unnullifier
162+
163+ toResult =
164+ maybe (hnulls (const R.null)) (hnullify R.nullifier) .
165+ fmap (toResult @_ @a)
178166
179167
180168instance (EqTable a, context ~ Expr) => EqTable (Nullify context a) where
@@ -195,10 +183,29 @@ aggregateNullify f = \case
195183
196184
197185guard :: (Reifiable context, HTable t)
198− => Col context ('Spec tag)
186+ => context tag
199187 -> (tag -> Bool)
200188 -> (Expr tag -> Expr Bool)
201− -> HNullify t (Col context)
202− -> HNullify t (Col context)
189+ -> HNullify t context
190+ -> HNullify t context
203191guard tag isNonNull isNonNullExpr =
204192 hguard (guarder contextSing tag isNonNull isNonNullExpr)
193+
194+
195+isNull :: forall a. Table Expr a => Nullify Expr a -> Expr Bool
196+isNull =
197+ maybe false getAny .
198+ getConst .
199+ hunnullify (\Spec {nullity} a -> Const $ case nullity of
200+ NotNull -> Just $ Any $ Expr.isNull a
201+ Null -> Nothing) .
202+ toColumns
203+
204+
205+newtype Any = Any
206+ { getAny :: Expr Bool
207+ }
208+
209+
210+instance Semigroup Any where
211+ Any a <> Any b = Any (a ||. b)
src/Rel8/Table/Opaleye.hs+78−64
@@ -1,136 +1,150 @@
11{-# language BlockArguments #-}
2+{-# language DataKinds #-}
23{-# language DisambiguateRecordFields #-}
34{-# language FlexibleContexts #-}
4−{-# language LambdaCase #-}
55{-# language NamedFieldPuns #-}
6+{-# language RankNTypes #-}
67{-# language TypeFamilies #-}
78{-# language ViewPatterns #-}
89
10+{-# options_ghc -Wno-deprecations #-}
11+
912module Rel8.Table.Opaleye
1013 ( aggregator
14+ , attributes
1115 , binaryspec
1216 , distinctspec
17+ , exprs
18+ , exprsWithNames
1319 , table
1420 , tableFields
1521 , unpackspec
1622 , valuesspec
23+ , view
1724 , castTable
1825 )
1926where
2027
2128-- base
22−import Prelude hiding ( undefined )
29+import Data.Functor.Const ( Const( Const ), getConst )
30+import Data.List.NonEmpty ( NonEmpty )
31+import Prelude
2332
2433-- opaleye
34+import qualified Opaleye.Adaptors as Opaleye
35+import qualified Opaleye.Field as Opaleye ( Field_ )
2536import qualified Opaleye.Internal.Aggregate as Opaleye
26−import qualified Opaleye.Internal.Binary as Opaleye
27−import qualified Opaleye.Internal.Distinct as Opaleye
2837import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
29−import qualified Opaleye.Internal.PackMap as Opaleye
30−import qualified Opaleye.Internal.Unpackspec as Opaleye
3138import qualified Opaleye.Internal.Values as Opaleye
32−import qualified Opaleye.Internal.Table as Opaleye
39+import qualified Opaleye.Table as Opaleye
3340
3441-- profunctors
3542import Data.Profunctor ( dimap, lmap )
3643
3744-- rel8
38−import Rel8.Aggregate ( Col( A ), Aggregate( Aggregate ), Aggregates )
39−import Rel8.Expr ( Expr, Col(..) )
45+import Rel8.Aggregate ( Aggregate( Aggregate ), Aggregates )
46+import Rel8.Expr ( Expr )
4047import Rel8.Expr.Opaleye
4148 ( fromPrimExpr, toPrimExpr
42− , traversePrimExpr
43− , fromColumn, toColumn
44− , scastExpr
49+ , scastExpr, traverseFieldP
4550 )
46−import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs, htabulate )
47−import Rel8.Schema.Name ( Col( N ), Name( Name ), Selects )
48−import Rel8.Schema.Spec ( SSpec(..) )
49−import Rel8.Schema.Table ( TableSchema(..) )
51+import Rel8.Schema.HTable ( htabulateA, hfield, hspecs, htabulate,
52+ htraverseP, htraversePWithField )
53+import Rel8.Schema.Name ( Name( Name ), Selects, ppColumn )
54+import Rel8.Schema.Spec ( Spec(..) )
55+import Rel8.Schema.Table ( TableSchema(..), ppTable )
5056import Rel8.Table ( Table, fromColumns, toColumns )
51−import Rel8.Table.Undefined ( undefined )
57+import Rel8.Type.Information ( typeName )
5258
5359-- semigroupoids
5460import Data.Functor.Apply ( WrappedApplicative(..) )
61+import Data.Profunctor.Product ( ProductProfunctor )
5562
5663
5764aggregator :: Aggregates aggregates exprs => Opaleye.Aggregator aggregates exprs
58−aggregator = Opaleye.Aggregator $ Opaleye.PackMap $ \f aggregates ->
59− fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->
60− WrapApplicative $ case hfield (toColumns aggregates) field of
61− A (Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner))) ->
62− E <$> inner f ()
65+aggregator = dimap toColumns fromColumns $
66+ htraverseP $
67+ lmap (\(Aggregate a) -> (a, ())) Opaleye.aggregatorApply
68+
69+
70+attributes :: Selects names exprs => TableSchema names -> exprs
71+attributes schema@TableSchema {columns} = fromColumns $ htabulate $ \field ->
72+ case hfield (toColumns columns) field of
73+ Name column -> fromPrimExpr $ Opaleye.ConstExpr $
74+ Opaleye.OtherLit $
75+ show (ppTable schema) <> "." <> show (ppColumn column)
76+
77+
78+fromOpaleyespec :: (ProductProfunctor p, Table Expr a)
79+ => p (Opaleye.Field_ n x) (Opaleye.Field_ n x)
80+ -> p a a
81+fromOpaleyespec x =
82+ dimap toColumns fromColumns (htraverseP (traverseFieldP x))
6383
6484
6585binaryspec :: Table Expr a => Opaleye.Binaryspec a a
66−binaryspec = Opaleye.Binaryspec $ Opaleye.PackMap $ \f (as, bs) ->
67− fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->
68− WrapApplicative $
69− case (hfield (toColumns as) field, hfield (toColumns bs) field) of
70− (E a, E b) -> E . fromPrimExpr <$> f (toPrimExpr a, toPrimExpr b)
86+binaryspec = fromOpaleyespec Opaleye.binaryspecField
7187
7288
7389distinctspec :: Table Expr a => Opaleye.Distinctspec a a
74−distinctspec =
75− Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap $ \f ->
76− fmap fromColumns .
77− unwrapApplicative .
78− htraverse
79− (\(E a) ->
80− WrapApplicative $ E . fromPrimExpr <$> f (Nothing, toPrimExpr a)) .
81− toColumns
90+distinctspec = fromOpaleyespec Opaleye.distinctspecField
91+
92+
93+exprs :: Table Expr a => a -> NonEmpty Opaleye.PrimExpr
94+exprs (toColumns -> as) = getConst $ htabulateA $ \field ->
95+ case hfield as field of
96+ expr -> Const (pure (toPrimExpr expr))
97+
98+
99+exprsWithNames :: Selects names exprs
100+ => names -> exprs -> NonEmpty (String, Opaleye.PrimExpr)
101+exprsWithNames names as = getConst $ htabulateA $ \field ->
102+ case (hfield (toColumns names) field, hfield (toColumns as) field) of
103+ (Name name, expr) -> Const (pure (name, toPrimExpr expr))
82104
83105
84−table ::Selects names exprs => TableSchema names -> Opaleye.Table exprs exprs
106+table :: Selects names exprs => TableSchema names -> Opaleye.Table exprs exprs
85107table (TableSchema name schema columns) =
86108 case schema of
87− Nothing -> Opaleye.Table name (tableFields columns)
88− Just schemaName -> Opaleye.TableWithSchema schemaName name (tableFields columns)
109+ Nothing -> Opaleye.table name (tableFields columns)
110+ Just schemaName -> Opaleye.tableWithSchema schemaName name (tableFields columns)
89111
90112
91−tableFields ::Selects names exprs
113+tableFields :: Selects names exprs
92114 => names -> Opaleye.TableFields exprs exprs
93115tableFields (toColumns -> names) = dimap toColumns fromColumns $
94116 unwrapApplicative $ htabulateA $ \field -> WrapApplicative $
95117 case hfield names field of
96118 name -> lmap (`hfield` field) (go name)
97119 where
98− go :: Col Name spec -> Opaleye.TableFields (Col Expr spec) (Col Expr spec)
99− go (N (Name name)) =
100− lmap (\(E a) -> toColumn $ toPrimExpr a) $
101− E . fromPrimExpr . fromColumn <$>
102− Opaleye.requiredTableField name
120+ go :: Name a -> Opaleye.TableFields (Expr a) (Expr a)
121+ go (Name name) =
122+ traverseFieldP $
123+ Opaleye.requiredTableField name
103124
104125
105126unpackspec :: Table Expr a => Opaleye.Unpackspec a a
106−unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->
107− fmap fromColumns .
108− unwrapApplicative .
109− htraverse (\(E a) -> WrapApplicative $ E <$> traversePrimExpr f a) .
110− toColumns
127+unpackspec = fromOpaleyespec Opaleye.unpackspecField
111128{-# INLINABLE unpackspec #-}
112129
113130
114−valuesspec :: Table Expr a => Opaleye.ValuesspecSafe a a
115−valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec
131+valuesspec :: Table Expr a => Opaleye.Valuesspec a a
132+valuesspec = dimap toColumns fromColumns $
133+ htraversePWithField (traverseFieldP . Opaleye.valuesspecFieldType . typeName)
134+ where typeName = Rel8.Type.Information.typeName . info . hfield hspecs
116135
117136
118−toPackMap :: Table Expr a
119− => a -> Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () a
120−toPackMap as = Opaleye.PackMap $ \f () ->
121− fmap fromColumns $
122− unwrapApplicative .
123− htraverse (\(E a) -> WrapApplicative $ E <$> traversePrimExpr f a) $
124− toColumns as
137+view :: Selects names exprs => names -> exprs
138+view columns = fromColumns $ htabulate $ \field ->
139+ case hfield (toColumns columns) field of
140+ Name column -> fromPrimExpr $ Opaleye.BaseTableAttrExpr column
125141
126142
127143-- | Transform a table by adding 'CAST' to all columns. This is most useful for
128144-- finalising a SELECT or RETURNING statement, guaranteed that the output
129145-- matches what is encoded in each columns TypeInformation.
130146castTable :: Table Expr a => a -> a
131−castTable (toColumns -> as) = fromColumns $ htabulate \i ->
132− case hfield hspecs i of
133− SSpec{info} ->
134− case hfield as i of
135− E expr ->
136− E (scastExpr info expr)
147+castTable (toColumns -> as) = fromColumns $ htabulate \field ->
148+ case hfield hspecs field of
149+ Spec {info} -> case hfield as field of
150+ expr -> scastExpr info expr
src/Rel8/Table/Ord.hs+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( E ) )
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.Constrain ( ConstrainSpec )
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 (ConstrainSpec (Sql 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 (ConstrainSpec (Sql 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 (ConstrainSpec (Sql DBOrd)))
67− ordTable =
68− ggtable
69− @(GAlgebra (Rep (Record a)))
70− @TOrdTable
71− @TColumns
72− @(Rep (Record a))
73− table
74− (\_ Dict -> Dict)
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 (ConstrainSpec (Sql DBEq))
87− , HConstrainTable t (ConstrainSpec (Sql DBOrd))
88− )
89− => OrdTable (t f)
90− where
91− ordTable = hdicts @(Columns (t f)) @(ConstrainSpec (Sql 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− (E a, E 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− (E a, E 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− (E a, E 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− (E a, E 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+5−6
@@ -16,13 +16,12 @@ import Data.Functor.Contravariant ( (>$<), contramap )
1616import Prelude
1717
1818-- rel8
19−import Rel8.Expr ( unE )
2019import Rel8.Expr.Order ( asc, desc, nullsFirst, nullsLast )
2120import Rel8.Order ( Order )
2221import Rel8.Schema.Dict ( Dict( Dict ) )
2322import Rel8.Schema.HTable (htabulateA, hfield, hspecs)
2423import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
25−import Rel8.Schema.Spec ( SSpec( SSpec, nullity ) )
24+import Rel8.Schema.Spec ( Spec( Spec, nullity ) )
2625import Rel8.Table ( Columns, toColumns )
2726import Rel8.Table.Ord ( OrdTable, ordTable )
2827
@@ -32,8 +31,8 @@ import Rel8.Table.Ord ( OrdTable, ordTable )
3231ascTable :: forall a. OrdTable a => Order a
3332ascTable = contramap toColumns $ getConst $
3433 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
35− SSpec {nullity} -> case hfield (ordTable @a) field of
36− Dict -> Const $ unE . (`hfield` field) >$<
34+ Spec {nullity} -> case hfield (ordTable @a) field of
35+ Dict -> Const $ (`hfield` field) >$<
3736 case nullity of
3837 Null -> nullsFirst asc
3938 NotNull -> asc
@@ -44,8 +43,8 @@ ascTable = contramap toColumns $ getConst $
4443descTable :: forall a. OrdTable a => Order a
4544descTable = contramap toColumns $ getConst $
4645 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
47− SSpec {nullity} -> case hfield (ordTable @a) field of
48− Dict -> Const $ unE . (`hfield` field) >$<
46+ Spec {nullity} -> case hfield (ordTable @a) field of
47+ Dict -> Const $ (`hfield` field) >$<
4948 case nullity of
5049 Null -> nullsLast desc
5150 NotNull -> desc
src/Rel8/Table/Projection.hsnew file+73
@@ -0,0 +1,73 @@
1+{-# language FlexibleContexts #-}
2+{-# language FlexibleInstances #-}
3+{-# language MonoLocalBinds #-}
4+{-# language MultiParamTypeClasses #-}
5+{-# language StandaloneKindSignatures #-}
6+{-# language UndecidableInstances #-}
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−143
@@ -1,143 +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 Data.List.NonEmpty ( NonEmpty)
18−import Prelude
19−
20−-- rel8
21−import Rel8.Schema.Context ( Col )
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.Schema.Spec ( KnownSpec )
27−import Rel8.Table ( Table, Congruent )
28−import Rel8.Type ( DBType )
29−
30−-- these
31−import Data.These ( These)
32−
33−
34−-- | @Recontextualize from to a b@ is evidence that the types @a@ and @b@ are
35−-- related, and that @b@ is the same type as @a@, but after changing the
36−-- context from the initial context @from@, to the new context @to@.
37−type Recontextualize :: K.Context -> K.Context -> Type -> Type -> Constraint
38−class
39− ( Table from a
40− , Table to b
41− , Congruent a b
42− , Recontextualize from from a a
43− , Recontextualize to to b b
44− , Recontextualize to from b a
45− ) => Recontextualize from to a b
46− | a -> from
47− , b -> to
48− , a to -> b
49− , b from -> a
50−
51−
52−instance Sql DBType a => Recontextualize Result Result (Identity a) (Identity a)
53−
54−
55−instance KnownSpec spec => Recontextualize from to (Col from spec) (Col to spec)
56−
57−
58−instance HTable t => Recontextualize from to (t (Col from)) (t (Col to))
59−
60−
61−instance
62− ( Recontextualize from to a1 b1
63− , Recontextualize from to a2 b2
64− , from ~ Result, to ~ Result
65− )
66− => Recontextualize from to (Either a1 a2) (Either b1 b2)
67−
68−
69−instance (Recontextualize from to a b, from ~ Result, to ~ Result) =>
70− Recontextualize from to [a] [b]
71−
72−
73−instance (Recontextualize from to a b, from ~ Result, to ~ Result) =>
74− Recontextualize from to (Maybe a) (Maybe b)
75−
76−
77−instance (Recontextualize from to a b, from ~ Result, to ~ Result) =>
78− Recontextualize from to (NonEmpty a) (NonEmpty b)
79−
80−
81−instance
82− ( Recontextualize from to a1 b1
83− , Recontextualize from to a2 b2
84− , from ~ Result, to ~ Result
85− )
86− => Recontextualize from to (These a1 a2) (These b1 b2)
87−
88−
89−instance
90− ( Recontextualize from to a1 b1
91− , Recontextualize from to a2 b2
92− )
93− => Recontextualize from to (a1, a2) (b1, b2)
94−
95−
96−instance
97− ( Recontextualize from to a1 b1
98− , Recontextualize from to a2 b2
99− , Recontextualize from to a3 b3
100− )
101− => Recontextualize from to (a1, a2, a3) (b1, b2, b3)
102−
103−
104−instance
105− ( Recontextualize from to a1 b1
106− , Recontextualize from to a2 b2
107− , Recontextualize from to a3 b3
108− , Recontextualize from to a4 b4
109− )
110− => Recontextualize from to (a1, a2, a3, a4) (b1, b2, b3, b4)
111−
112−
113−instance
114− ( Recontextualize from to a1 b1
115− , Recontextualize from to a2 b2
116− , Recontextualize from to a3 b3
117− , Recontextualize from to a4 b4
118− , Recontextualize from to a5 b5
119− )
120− => Recontextualize from to (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5)
121−
122−
123−instance
124− ( Recontextualize from to a1 b1
125− , Recontextualize from to a2 b2
126− , Recontextualize from to a3 b3
127− , Recontextualize from to a4 b4
128− , Recontextualize from to a5 b5
129− , Recontextualize from to a6 b6
130− )
131− => Recontextualize from to (a1, a2, a3, a4, a5, a6) (b1, b2, b3, b4, b5, b6)
132−
133−
134−instance
135− ( Recontextualize from to a1 b1
136− , Recontextualize from to a2 b2
137− , Recontextualize from to a3 b3
138− , Recontextualize from to a4 b4
139− , Recontextualize from to a5 b5
140− , Recontextualize from to a6 b6
141− , Recontextualize from to a7 b7
142− )
143− => Recontextualize from to (a1, a2, a3, a4, a5, a6, a7) (b1, b2, b3, b4, b5, b6, b7)
src/Rel8/Table/Rel8able.hs+28−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,135 +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− , 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.Dict ( Dict( Dict ) )
3729import qualified Rel8.Schema.Kind as K
3830import Rel8.Schema.HTable ( HConstrainTable, hdicts )
3931import Rel8.Schema.Null ( Sql )
40−import Rel8.Schema.Reify ( hreify, hunreify, UnwrapReify )
4132import Rel8.Schema.Result ( Result )
4233import Rel8.Table
43− ( Table, Columns, Context, Congruent, fromColumns, toColumns
44− , Unreify, reify, unreify, coherence, congruence
34+ ( Table, Columns, Context, fromColumns, toColumns
35+ , FromExprs, fromResult, toResult
36+ , Transpose
4537 )
46−import Rel8.Schema.Spec.Constrain ( ConstrainSpec )
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, 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 sReifiable context of
69− Dict -> greify
70−
71− unreify Refl = case contextSing @context of
72− SReify context -> case sReifiable context of
73− Dict -> gunreify
74−
75− coherence Refl _ = Refl
76− congruence Refl _ = Refl
51+ type FromExprs (t context) = GFromExprs t
52+ type Transpose to (t context) = t to
7753
78−
79−instance
80− ( Rel8able t
81− , Reifiable from
82− , Reifiable to
83− , Congruent (t from) (t to)
84− )
85− => Recontextualize from to (t from) (t to)
54+ fromColumns = gfromColumns contextSing
55+ toColumns = gtoColumns contextSing
56+ fromResult = gfromResult @t
57+ toResult = gtoResult @t
8658
8759
8860instance
8961 ( context ~ Expr
9062 , Rel8able t
91− , HConstrainTable (Columns (t context)) (ConstrainSpec (Sql DBEq))
63+ , HConstrainTable (Columns (t context)) (Sql DBEq)
9264 )
9365 => EqTable (t context)
9466 where
95− eqTable = hdicts @(Columns (t context)) @(ConstrainSpec (Sql DBEq))
67+ eqTable = hdicts @(Columns (t context)) @(Sql DBEq)
9668
9769
9870instance
9971 ( context ~ Expr
10072 , Rel8able t
101− , HConstrainTable (Columns (t context)) (ConstrainSpec (Sql DBEq))
102− , HConstrainTable (Columns (t context)) (ConstrainSpec (Sql DBOrd))
73+ , HConstrainTable (Columns (t context)) (Sql DBEq)
74+ , HConstrainTable (Columns (t context)) (Sql DBOrd)
10375 )
10476 => OrdTable (t context)
10577 where
106− ordTable = hdicts @(Columns (t context)) @(ConstrainSpec (Sql DBOrd))
107−
108−
109−type instance FromExprs (t Expr) = FromExprs' t
78+ ordTable = hdicts @(Columns (t context)) @(Sql DBOrd)
11079
11180
11281instance
113− ( x ~ t' Expr
82+ ( Rel8able t', t' ~ Choose (Algebra t) t
83+ , x ~ t' Expr
11484 , result ~ Result
115− , ToExprs' (Algebra t) t' t
11685 )
11786 => ToExprs x (t result)
118− where
119− fromResult = fromResult' @(Algebra t) @t'
120− toResult = toResult' @(Algebra t) @t'
121−
122−
123−type FromExprs' :: K.Rel8able -> Type
124−type family FromExprs' t where
125− FromExprs' (ADT t) = t Result
126− FromExprs' (HKD a) = a
127− FromExprs' t = t Result
128−
129−
130−type ToExprs' :: K.Algebra -> K.Rel8able -> K.Rel8able -> Constraint
131−class (algebra ~ Algebra t, Rel8able t') =>
132− ToExprs' algebra t' t | algebra t -> t'
133− where
134− fromResult' :: GColumns t' (Col Result) -> t Result
135− toResult' :: t Result -> GColumns t' (Col Result)
136−
13787
138−instance (Algebra t ~ 'K.Product, Rel8able t, t ~ t') =>
139− ToExprs' 'K.Product t' t
140− where
141− fromResult' = fromColumns
142− toResult' = toColumns
14388
144−
145−instance (Algebra t ~ 'K.Sum, ADTable t, t' ~ ADT t) =>
146− ToExprs' 'K.Sum t' t
147− where
148− fromResult' = fromADT . ADT
149− 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+22−122
@@ -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,41 +7,31 @@
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( E ) )
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( R ), 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
@@ -53,71 +40,21 @@ import Data.Functor.Apply ( WrappedApplicative(..) )
5340
5441-- | @ToExprs exprs a@ is evidence that the types @exprs@ and @a@ describe
5542-- essentially the same type, but @exprs@ is in the 'Expr' context, and @a@ is
56−-- in the 'Result' context.
43+-- a normal Haskell type.
5744type ToExprs :: Type -> Type -> Constraint
58−class Table Expr exprs => ToExprs exprs a where
59− fromResult :: Columns exprs (Col Result) -> a
60− toResult :: a -> Columns exprs (Col Result)
61−
62− default fromResult ::
63− ( Generic (Record a)
64− , KnownAlgebra (GAlgebra (Rep (Record exprs)))
65− , Eval (GGToExprs (GAlgebra (Rep (Record exprs))) TToExprs TColumns (Rep (Record exprs)) (Rep (Record a)))
66− , Columns exprs ~ Eval (GGColumns (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs)))
67− )
68− => Columns exprs (Col Result) -> a
69− fromResult =
70− unrecord .
71− to .
72− ggfromResult
73− @(GAlgebra (Rep (Record exprs)))
74− @TToExprs
75− @TColumns
76− @(Rep (Record exprs))
77− (\(_ :: proxy expr) -> fromResult @expr)
78−
79− default toResult ::
80− ( Generic (Record a)
81− , KnownAlgebra (GAlgebra (Rep (Record exprs)))
82− , Eval (GGToExprs (GAlgebra (Rep (Record exprs))) TToExprs TColumns (Rep (Record exprs)) (Rep (Record a)))
83− , Columns exprs ~ Eval (GGColumns (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs)))
84− )
85− => a -> Columns exprs (Col Result)
86− toResult =
87− ggtoResult
88− @(GAlgebra (Rep (Record exprs)))
89− @TToExprs
90− @TColumns
91− @(Rep (Record exprs))
92− (\(_ :: proxy expr) -> toResult @expr) .
93− from .
94− Record
95−
96−
97−data TToExprs :: Type -> Type -> Exp Constraint
98−type instance Eval (TToExprs exprs a) = ToExprs exprs a
99−
100−
101−instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a where
102− fromResult (HType (R a)) = a
103− toResult = HType . R
104−
105−
106−instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a] where
107− fromResult (HType (R a)) = a
108− toResult = HType . R
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]
10952
11053
11154instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a)
112− where
113− fromResult (HType (R a)) = a
114− toResult = HType . R
11555
11656
11757instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a)
118− where
119− fromResult (HType (R a)) = a
120− toResult = HType . R
12158
12259
12360instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>
@@ -179,43 +116,6 @@ instance
179116 => ToExprs x (a, b, c, d, e, f, g)
180117
181118
182−instance (HTable t, result ~ Col Result, x ~ t (Col Expr)) =>
183− ToExprs x (t result)
184− where
185− fromResult = id
186− toResult = id
187−
188−
189−instance (KnownSpec spec, x ~ Col Expr spec) =>
190− ToExprs x (Col Result spec)
191− where
192− fromResult = fromColumns
193− toResult = toColumns
194−
195−
196−-- | The @FromExprs@ type function maps a type in the @Expr@ context to the
197−-- corresponding type in the @Result@ context.
198−type FromExprs :: Type -> Type
199−type family FromExprs a
200−type instance FromExprs (Expr a) = a
201−type instance FromExprs (Col Expr spec) = Col Result spec
202−type instance FromExprs (a, b) = (FromExprs a, FromExprs b)
203−type instance FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)
204−type instance FromExprs (a, b, c, d) =
205− (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
206−type instance FromExprs (a, b, c, d, e) =
207− (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
208−type instance FromExprs (a, b, c, d, e, f) =
209− ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e
210− , FromExprs f
211− )
212−type instance FromExprs (a, b, c, d, e, f, g) =
213− ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e
214− , FromExprs f, FromExprs g
215− )
216−type instance FromExprs (t (Col Expr)) = t (Col Result)
217−
218−
219119-- | @Serializable@ witnesses the one-to-one correspondence between the type
220120-- @sql@, which contains SQL expressions, and the type @haskell@, which
221121-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
@@ -228,21 +128,21 @@ instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a
228128-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is
229129-- capable of lifting single @Expr@s to full tables.
230130lit :: forall exprs a. Serializable exprs a => a -> exprs
231−lit = fromColumns . litHTable . toResult @exprs
131+lit = fromColumns . litHTable . toResult @_ @exprs
232132
233133
234134parse :: forall exprs a. Serializable exprs a => Hasql.Row a
235−parse = fromResult @exprs <$> parseHTable
135+parse = fromResult @_ @exprs <$> parseHTable
236136
237137
238−litHTable :: HTable t => t (Col Result) -> t (Col Expr)
138+litHTable :: HTable t => t Result -> t Expr
239139litHTable as = htabulate $ \field ->
240140 case hfield hspecs field of
241− SSpec {nullity, info} -> case hfield as field of
242− R value -> E (slitExpr nullity info value)
141+ Spec {nullity, info} -> case hfield as field of
142+ Identity value -> slitExpr nullity info value
243143
244144
245−parseHTable :: HTable t => Hasql.Row (t (Col Result))
145+parseHTable :: HTable t => Hasql.Row (t Result)
246146parseHTable = unwrapApplicative $ htabulateA $ \field ->
247147 WrapApplicative $ case hfield hspecs field of
248− SSpec {nullity, info} -> R <$> sparseValue nullity info
148+ Spec {nullity, info} -> Identity <$> sparseValue nullity info
src/Rel8/Table/These.hs+71−49
@@ -20,36 +20,36 @@ module Rel8.Table.These
2020 , isThisTable, isThatTable, isThoseTable
2121 , hasHereTable, hasThereTable
2222 , justHereTable, justThereTable
23+ , alignMaybeTable
2324 , aggregateTheseTable
2425 , nameTheseTable
2526 )
2627where
2728
2829-- base
29−import Control.Category ( id )
3030import Data.Bifunctor ( Bifunctor, bimap )
3131import Data.Kind ( Type )
3232import Data.Maybe ( isJust )
33−import Data.Type.Equality ( apply )
34−import Prelude hiding ( id, undefined )
33+import Prelude hiding ( null, undefined )
3534
3635-- rel8
3736import Rel8.Aggregate ( Aggregate )
3837import Rel8.Expr ( Expr )
39−import Rel8.Expr.Bool ( (&&.), not_ )
40−import Rel8.Expr.Null ( isNonNull )
38+import Rel8.Expr.Bool ( (&&.), (||.), boolExpr, not_ )
39+import Rel8.Expr.Null ( null, isNonNull )
4140import Rel8.Kind.Context ( Reifiable )
42−import Rel8.Schema.Context.Abstract ( Abstract )
4341import Rel8.Schema.Context.Nullify ( Nullifiable )
4442import Rel8.Schema.Dict ( Dict( Dict ) )
45−import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
43+import Rel8.Schema.HTable.Label ( hlabel, hrelabel, hunlabel )
4644import Rel8.Schema.HTable.Identity ( HIdentity(..) )
45+import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
4746import Rel8.Schema.HTable.These ( HTheseTable(..) )
4847import qualified Rel8.Schema.Kind as K
4948import Rel8.Schema.Name ( Name )
5049import Rel8.Table
5150 ( Table, Columns, Context, fromColumns, toColumns
52− , coherence, congruence, reify, unreify
51+ , FromExprs, fromResult, toResult
52+ , Transpose
5353 )
5454import Rel8.Table.Eq ( EqTable, eqTable )
5555import Rel8.Table.Maybe
@@ -61,8 +61,8 @@ import Rel8.Table.Maybe
6161 )
6262import Rel8.Table.Nullify ( Nullify, guard )
6363import Rel8.Table.Ord ( OrdTable, ordTable )
64−import Rel8.Table.Recontextualize ( Recontextualize )
65−import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
64+import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )
65+import Rel8.Table.Serialize ( ToExprs )
6666import Rel8.Table.Undefined ( undefined )
6767import Rel8.Type.Tag ( MaybeTag )
6868
@@ -71,7 +71,8 @@ import Data.Functor.Apply ( Apply, (<.>) )
7171import Data.Functor.Bind ( Bind, (>>-) )
7272
7373-- these
74−import Data.These ( These )
74+import Data.These ( These( This, That, These ) )
75+import Data.These.Combinators ( justHere, justThere )
7576
7677
7778-- | @TheseTable a b@ is a Rel8 table that contains either the table @a@, the
@@ -89,10 +90,18 @@ data TheseTable context a b = TheseTable
8990 deriving stock Functor
9091
9192
93+instance Biprojectable (TheseTable context) where
94+ biproject f g (TheseTable a b) = TheseTable (project f a) (project g b)
95+
96+
9297instance Nullifiable context => Bifunctor (TheseTable context) where
9398 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
9499
95100
101+instance Projectable (TheseTable context a) where
102+ project f (TheseTable a b) = TheseTable a (project f b)
103+
104+
96105instance (context ~ Expr, Table Expr a, Semigroup a) =>
97106 Apply (TheseTable context a)
98107 where
@@ -139,12 +148,16 @@ instance (context ~ Expr, Table Expr a, Table Expr b, Semigroup a, Semigroup b)
139148
140149instance
141150 ( Table context a, Table context b
142− , Reifiable context, Abstract context, context ~ context'
151+ , Reifiable context, context ~ context'
143152 )
144153 => Table context' (TheseTable context a b)
145154 where
146155 type Columns (TheseTable context a b) = HTheseTable (Columns a) (Columns b)
147156 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)
148161
149162 toColumns TheseTable {here, there} = HTheseTable
150163 { hhereTag = hlabel $ HIdentity $ tag here
@@ -166,38 +179,48 @@ instance
166179 }
167180 }
168181
169− reify proof TheseTable {here, there} = TheseTable
170− { here = reify proof here
171− , there = reify proof there
172− }
173− unreify proof TheseTable {here, there} = TheseTable
174− { here = unreify proof here
175− , there = unreify proof there
182+ toResult tables = HTheseTable
183+ { hhereTag = hrelabel hhereTag
184+ , hhere = hrelabel hhere
185+ , hthereTag = hrelabel hthereTag
186+ , hthere = hrelabel hthere
176187 }
177−
178− coherence = coherence @context @a
179− congruence proof abstract =
180− id `apply`
181− congruence @context @a proof abstract `apply`
182− congruence @context @b proof abstract
183−
184−
185−instance
186− ( Reifiable from, Abstract from, from ~ from'
187− , Reifiable to, Abstract to, to ~ to'
188− , Recontextualize from to a1 b1
189− , Recontextualize from to a2 b2
190− )
191− => Recontextualize from to (TheseTable from' a1 a2) (TheseTable to' b1 b2)
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+ }
192215
193216
194217instance (EqTable a, EqTable b, context ~ Expr) =>
195218 EqTable (TheseTable context a b)
196219 where
197220 eqTable = HTheseTable
198− { hhereTag = hlabel (HType Dict)
221+ { hhereTag = hlabel (HIdentity Dict)
199222 , hhere = hlabel (eqTable @(Nullify context a))
200− , hthereTag = hlabel (HType Dict)
223+ , hthereTag = hlabel (HIdentity Dict)
201224 , hthere = hlabel (eqTable @(Nullify context b))
202225 }
203226
@@ -206,26 +229,15 @@ instance (OrdTable a, OrdTable b, context ~ Expr) =>
206229 OrdTable (TheseTable context a b)
207230 where
208231 ordTable = HTheseTable
209− { hhereTag = hlabel (HType Dict)
232+ { hhereTag = hlabel (HIdentity Dict)
210233 , hhere = hlabel (ordTable @(Nullify context a))
211− , hthereTag = hlabel (HType Dict)
234+ , hthereTag = hlabel (HIdentity Dict)
212235 , hthere = hlabel (ordTable @(Nullify context b))
213236 }
214237
215238
216−type instance FromExprs (TheseTable _context a b) =
217− These (FromExprs a) (FromExprs b)
218−
219−
220239instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable Expr exprs1 exprs2) =>
221240 ToExprs x (These a b)
222− where
223− fromResult =
224− bimap (fromResult @exprs1) (fromResult @exprs2) .
225− fromColumns
226− toResult =
227− toColumns .
228− bimap (toResult @exprs1) (toResult @exprs2)
229241
230242
231243-- | Test if a 'TheseTable' was constructed with 'thisTable'.
@@ -277,6 +289,16 @@ justThereTable :: TheseTable context a b -> MaybeTable context b
277289justThereTable = there
278290
279291
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+
280302-- | Construct a @TheseTable@. Corresponds to 'This'.
281303thisTable :: Table Expr b => a -> TheseTable Expr a b
282304thisTable a = TheseTable (justTable a) nothingTable
src/Rel8/Table/Transpose.hsnew file+46
@@ -0,0 +1,46 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleInstances #-}
3+{-# language FunctionalDependencies #-}
4+{-# language StandaloneKindSignatures #-}
5+{-# language TypeFamilies #-}
6+{-# language UndecidableInstances #-}
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( E ) )
14+import Rel8.Expr ( Expr )
1515import Rel8.Expr.Null ( snull, unsafeUnnullify )
1616import Rel8.Schema.HTable ( htabulate, hfield, hspecs )
1717import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
18−import Rel8.Schema.Spec ( SSpec(..) )
18+import Rel8.Schema.Spec ( Spec(..) )
1919import Rel8.Table ( Table, fromColumns )
2020
2121
2222undefined :: Table Expr a => a
2323undefined = fromColumns $ htabulate $ \field -> case hfield hspecs field of
24− SSpec {nullity, info} -> case nullity of
25− Null -> E (snull info)
26− NotNull -> E (unsafeUnnullify (snull info))
24+ Spec {nullity, info} -> case nullity of
25+ Null -> snull info
26+ NotNull -> unsafeUnnullify (snull info)
src/Rel8/Table/Window.hsnew file+43
@@ -0,0 +1,43 @@
1+{-# language MonoLocalBinds #-}
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.hsnew file+640
@@ -0,0 +1,640 @@
1+{-# language FlexibleContexts #-}
2+{-# language MonoLocalBinds #-}
3+{-# language ScopedTypeVariables #-}
4+{-# language StandaloneKindSignatures #-}
5+{-# language TypeApplications #-}
6+{-# language TupleSections #-}
7+{-# language UndecidableInstances #-}
8+
9+-- | "Rel8.Tabulate" provides an alternative API ('Tabulation') for writing
10+-- queries that complements the main "Rel8" API ('Query').
11+
12+module Rel8.Tabulate
13+ (
14+ Tabulation
15+
16+ -- * Interfacing with 'Query's
17+ , fromQuery
18+ , toQuery
19+ , liftQuery
20+ , through
21+ , lookup
22+
23+ -- * Aggregation and Ordering
24+ , aggregate
25+ , distinct
26+ , order
27+
28+ -- ** Magic 'Tabulation's
29+ -- $magic
30+ , count
31+ , optional
32+ , many
33+ , some
34+ , exists
35+ , present
36+ , absent
37+
38+ -- * Natural joins
39+ , align
40+ , alignWith
41+ , leftAlign
42+ , leftAlignWith
43+ , rightAlign
44+ , rightAlignWith
45+ , zip
46+ , zipWith
47+ , similarity
48+ , difference
49+ )
50+where
51+
52+-- base
53+import Control.Applicative ( (<|>), empty, liftA2 )
54+import Control.Monad ( liftM2 )
55+import Data.Bifunctor ( Bifunctor, bimap, first, second )
56+import Data.Foldable ( traverse_ )
57+import Data.Function ( on )
58+import Data.Functor.Contravariant ( Contravariant, (>$<), contramap )
59+import Data.Int ( Int64 )
60+import Data.Kind ( Type )
61+import Data.Maybe ( fromJust, fromMaybe )
62+import Prelude hiding ( lookup, zip, zipWith )
63+
64+-- bifunctors
65+import Data.Bifunctor.Clown ( Clown( Clown ), runClown )
66+
67+-- comonad
68+import Control.Comonad ( extract )
69+
70+-- opaleye
71+import qualified Opaleye.Aggregate as Opaleye
72+import qualified Opaleye.Order as Opaleye ( orderBy, distinctOnExplicit )
73+
74+-- profunctors
75+import Data.Profunctor ( dimap, lmap )
76+
77+-- product-profunctors
78+import Data.Profunctor.Product
79+ ( ProductProfunctor, (***!)
80+ , SumProfunctor, (+++!)
81+ )
82+import qualified Data.Profunctor.Product as PP
83+
84+-- rel8
85+import Rel8.Aggregate ( Aggregates )
86+import Rel8.Expr ( Expr )
87+import Rel8.Expr.Aggregate ( countStar )
88+import Rel8.Expr.Bool ( true )
89+import Rel8.Order ( Order( Order ) )
90+import Rel8.Query ( Query )
91+import qualified Rel8.Query.Exists as Q ( exists, present, absent )
92+import Rel8.Query.Filter ( where_ )
93+import Rel8.Query.List ( catNonEmptyTable )
94+import qualified Rel8.Query.Maybe as Q ( optional )
95+import Rel8.Query.Opaleye ( mapOpaleye, unsafePeekQuery )
96+import Rel8.Query.Rebind ( rebind )
97+import Rel8.Query.These ( alignBy )
98+import Rel8.Table ( Table, fromColumns, toColumns )
99+import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )
100+import Rel8.Table.Alternative
101+ ( AltTable, (<|>:)
102+ , AlternativeTable, emptyTable
103+ )
104+import Rel8.Table.Cols ( fromCols, toCols )
105+import Rel8.Table.Eq ( EqTable, (==:), eqTable )
106+import Rel8.Table.List ( ListTable( ListTable ) )
107+import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), maybeTable )
108+import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )
109+import Rel8.Table.Opaleye ( aggregator, unpackspec )
110+import Rel8.Table.Ord ( OrdTable )
111+import Rel8.Table.Order ( ascTable )
112+import Rel8.Table.Projection
113+ ( Biprojectable, biproject
114+ , Projectable, project
115+ , apply
116+ )
117+import Rel8.Table.These ( TheseTable( TheseTable ), theseTable )
118+
119+-- semigroupoids
120+import Data.Functor.Apply ( Apply, liftF2 )
121+import Data.Functor.Bind ( Bind, (>>-) )
122+
123+
124+type Key :: Type -> Type
125+type Key = Maybe
126+
127+
128+cat :: Table Expr k => Key k -> Query k
129+cat = maybe emptyTable pure
130+
131+
132+key :: (ProductProfunctor p, SumProfunctor p)
133+ => p a b -> p (Key a) (Key b)
134+key a = dimap from to (PP.empty +++! a)
135+ where
136+ from = maybe (Left ()) Right
137+ to = either (const Nothing) Just
138+
139+
140+keyed :: (ProductProfunctor p, SumProfunctor p)
141+ => p k l -> p a b -> p (Key k, a) (Key l, b)
142+keyed k a = key k ***! a
143+
144+
145+type Predicate :: Type -> Type
146+newtype Predicate a = Predicate (Maybe (a -> Expr Bool))
147+
148+
149+instance Contravariant Predicate where
150+ contramap f (Predicate a) = Predicate (lmap f <$> a)
151+
152+
153+instance Semigroup (Predicate k) where
154+ Predicate ma <> Predicate mb = Predicate $ ma <|> mb
155+
156+
157+instance Monoid (Predicate k) where
158+ mempty = Predicate Nothing
159+
160+
161+match :: EqTable k => Key k -> Predicate k
162+match = Predicate . fmap (==:)
163+
164+
165+ensure :: Predicate k -> Key k -> Query ()
166+ensure (Predicate mp) = traverse_ (\k -> traverse_ (\p -> where_ (p k)) mp)
167+
168+
169+-- | A @'Tabulation' k a@ is like a @'Query' a@, except that each row also
170+-- has a key @k@ in addition to the value @a@. 'Tabulation's can be composed
171+-- monadically just like 'Query's, but the resulting join is more like a
172+-- @NATURAL JOIN@ (based on the common key column(s) @k@) than the
173+-- @CROSS JOIN@ given by 'Query'.
174+--
175+-- Another way to think of @'Tabulation' k a@ is as analogous to @Map k a@ in
176+-- the same way @'Query' a@ is analogous to @[a]@. However, there's nothing
177+-- stopping a 'Tabulation' from containing multiple rows with the same key, so
178+-- technically @Map k (NonEmpty a)@ is more accurate.
179+--
180+-- 'Tabulation's can be created from 'Query's with 'fromQuery' and 'liftQuery'
181+-- and converted back to 'Query's with 'lookup' and 'toQuery' (though note the
182+-- caveats that come with the latter).
183+type Tabulation :: Type -> Type -> Type
184+newtype Tabulation k a = Tabulation (Predicate k -> Query (Key k, a))
185+
186+
187+instance Biprojectable Tabulation where
188+ biproject f g =
189+ bimap
190+ (fromColumns . apply f . toColumns)
191+ (fromColumns . apply g . toColumns)
192+
193+
194+instance Bifunctor Tabulation where
195+ bimap f g (Tabulation a) = Tabulation $ \p ->
196+ bimap (fmap f) g <$> a (f >$< p)
197+
198+
199+instance Functor (Tabulation k) where
200+ fmap = second
201+
202+
203+instance Projectable (Tabulation k) where
204+ project f = fmap (fromColumns . apply f . toColumns)
205+
206+
207+-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<.>)@ is
208+-- @intersectionWith (liftA2 (<*>))@
209+instance EqTable k => Apply (Tabulation k) where
210+ liftF2 = liftA2
211+
212+
213+-- | @pure = 'liftQuery' . pure@
214+instance EqTable k => Applicative (Tabulation k) where
215+ pure = liftQuery . pure
216+ liftA2 = liftM2
217+
218+
219+instance EqTable k => Bind (Tabulation k) where
220+ Tabulation as >>- f = Tabulation $ \p -> do
221+ (k, a) <- as p
222+ case f a of
223+ Tabulation bs -> do
224+ let p' = match k
225+ (k', b) <- bs (p' <> p)
226+ ensure p' k'
227+ pure (k' <|> k, b)
228+
229+
230+instance EqTable k => Monad (Tabulation k) where
231+ (>>=) = (>>-)
232+
233+
234+-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<|>:)@ is
235+-- @unionWith (<>)@.
236+instance EqTable k => AltTable (Tabulation k) where
237+ tas <|>: tbs = do
238+ eas <- peek tas
239+ ebs <- peek tbs
240+ case (eas, ebs) of
241+ (Left as, Left bs) -> liftQuery $ as <|>: bs
242+ (Right as, Right bs) -> fromQuery $ as <|>: bs
243+ _ -> catNonEmptyTable `through` ((<>) `on` some) tas tbs
244+
245+
246+instance EqTable k => AlternativeTable (Tabulation k) where
247+ emptyTable = Tabulation $ const $ fmap (empty,) emptyTable
248+
249+
250+-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<>)@ is
251+-- @unionWith (liftA2 (<>))@.
252+instance (EqTable k, Table Expr a, Semigroup a) => Semigroup (Tabulation k a)
253+ where
254+ (<>) = alignWith (theseTable id id (<>))
255+
256+
257+instance (EqTable k, Table Expr a, Semigroup a) => Monoid (Tabulation k a)
258+ where
259+ mempty = emptyTable
260+
261+
262+-- | Any 'Query' of key-value pairs @(k, a)@ can be a @'Tabulation' k a@.
263+fromQuery :: Query (k, a) -> Tabulation k a
264+fromQuery = Tabulation . const . fmap (first pure)
265+
266+
267+-- | Convert a @'Tabulation' k a@ back into a 'Query' of key-value pairs.
268+--
269+-- Note that the result of a 'toQuery' is undefined (will always return zero
270+-- rows) on 'Tabulation's constructed with 'liftQuery' or 'pure'. So while
271+-- @toQuery . fromQuery@ is always @id@, @fromQuery . toQuery@ is not.
272+--
273+-- A safer, more predictable alternative to 'toQuery' is to use 'lookup' with
274+-- an explicit set of keys:
275+--
276+-- @
277+-- do
278+-- k <- keys
279+-- a <- lookup k tabulation
280+-- pure (k, a)
281+-- @
282+--
283+-- Having said that, in practice, most legitimate uses of 'Tabulation' will
284+-- have a well-defined 'toQuery'. It would be possible in theory to encode
285+-- the necessary invariants at the type level using an indexed monad, but we
286+-- would lose the ability to use @do@-notation, which is the main benefit
287+-- of having 'Tabulation' as a monad in the first place.
288+--
289+-- In particular, @'toQuery' t@ is well-defined for any 'Tabulation' @t@
290+-- defined as @t = fromQuery _@. @'toQuery' t@ is also well-defined for any
291+-- 'Tabulation' @t@ defined as @t = t' >>= _@ or @t = t' *> _@ where
292+-- @'toQuery' t'@ is well-defined. There are other valid permutations too.
293+-- Generally, anything that uses 'fromQuery' at some point, unless wrapped in
294+-- a top-level 'present' or 'absent', will have a well-defined 'toQuery'.
295+toQuery :: Table Expr k => Tabulation k a -> Query (k, a)
296+toQuery (Tabulation f) = do
297+ (mk, a) <- f mempty
298+ k <- cat mk
299+ pure (k, a)
300+
301+
302+-- | A @'Query' a@ can be treated as a @'Tabulation' k a@ where the given @a@
303+-- values exist at every possible key @k@.
304+liftQuery :: Query a -> Tabulation k a
305+liftQuery = Tabulation . const . fmap (empty,)
306+
307+
308+-- | Run a Kleisli arrow in the the 'Query' monad \"through\" a 'Tabulation'.
309+-- Useful for 'Rel8.filter'ing a 'Tabulation'.
310+--
311+-- @
312+-- 'Rel8.filter' ((>=. 30) . userAge) `'through'` usersById
313+-- @
314+through :: (a -> Query b) -> Tabulation k a -> Tabulation k b
315+through f (Tabulation as) = Tabulation $ \p -> do
316+ (k, a) <- as p
317+ b <- f a
318+ pure (k, b)
319+infixr 1 `through`
320+
321+
322+-- | @'lookup' k t@ returns the value(s) at the key @k@ in the tabulation @t@.
323+lookup :: EqTable k => k -> Tabulation k a -> Query a
324+lookup k (Tabulation f) = do
325+ (k', a) <- f p
326+ ensure p k'
327+ pure a
328+ where
329+ p = match (pure k)
330+
331+
332+-- | 'aggregate' aggregates the values within each key of a
333+-- 'Tabulation'. There is an implicit @GROUP BY@ on all the key columns.
334+aggregate :: forall k aggregates exprs.
335+ ( EqTable k
336+ , Aggregates aggregates exprs
337+ )
338+ => Tabulation k aggregates -> Tabulation k exprs
339+aggregate (Tabulation f) = Tabulation $
340+ mapOpaleye (Opaleye.aggregate (keyed haggregator aggregator)) .
341+ fmap (first (fmap (hgroupBy (eqTable @k) . toColumns))) .
342+ f
343+ where
344+ haggregator = dimap fromColumns fromCols aggregator
345+
346+
347+-- | 'distinct' ensures a 'Tabulation' has at most one value for
348+-- each key, i.e., it drops duplicates. In general it keeps only the
349+-- \"first\" value it encounters for each key, but note that \"first\" is
350+-- undefined unless you first call 'order'.
351+distinct :: EqTable k => Tabulation k a -> Tabulation k a
352+distinct (Tabulation f) = Tabulation $
353+ mapOpaleye (Opaleye.distinctOnExplicit (key unpackspec) fst) . f
354+
355+
356+-- | 'order' orders the /values/ of a 'Tabulation' within their
357+-- respective keys. This specifies a defined order for 'distinct'.
358+-- It also defines the order of the lists produced by 'many' and
359+-- 'some'.
360+order :: OrdTable k => Order a -> Tabulation k a -> Tabulation k a
361+order ordering (Tabulation f) =
362+ Tabulation $ mapOpaleye (Opaleye.orderBy ordering') . f
363+ where
364+ Order ordering' = runClown (keyed (Clown ascTable) (Clown ordering))
365+
366+
367+-- $magic
368+--
369+-- Some of the following combinators produce \"magic\" 'Tabulation's. Let's
370+-- use 'count' as an example to demonstrate this concept. Consider
371+-- the following:
372+--
373+-- @
374+-- count $ fromQuery $ values
375+-- [ (lit 'a', lit True)
376+-- , (lit 'a', lit False)
377+-- , (lit 'b', lit True)
378+-- ]
379+-- @
380+--
381+-- You might expect this to be equivalent to the following 'Tabulation':
382+--
383+-- @
384+-- fromQuery $ values
385+-- [ (lit 'a', 2)
386+-- , (lit 'b', 1)
387+-- ]
388+-- @
389+--
390+-- However, it isn't quite. While the resulting 'Tabulation' does effectively
391+-- contain the above entries, it also behaves as though it contained the value
392+-- @0@ at every other possible key.
393+--
394+-- This means you can do:
395+--
396+-- @
397+-- do
398+-- user <- usersById
399+-- orderCount <- count ordersByUserId
400+-- @
401+--
402+-- To see how many orders a user has (getting @0@ if they have no orders).
403+
404+
405+-- | 'count' returns a count of how many entries are in the given
406+-- 'Tabulation' at each key.
407+--
408+-- The resulting 'Tabulation' is \"magic\" in that the value @0@ exists at
409+-- every possible key that wasn't in the given 'Tabulation'.
410+count :: EqTable k => Tabulation k a -> Tabulation k (Expr Int64)
411+count =
412+ fmap (maybeTable 0 id) .
413+ optional .
414+ aggregate .
415+ fmap (const countStar)
416+
417+
418+-- | 'optional' produces a \"magic\" 'Tabulation' whereby each
419+-- entry in the given 'Tabulation' is wrapped in 'Rel8.justTable', and every
420+-- other possible key contains a single 'Rel8.nothingTable'.
421+--
422+-- This is used to implement 'leftAlignWith'.
423+optional :: Tabulation k a -> Tabulation k (MaybeTable Expr a)
424+optional (Tabulation f) = Tabulation $ \p -> case p of
425+ Predicate Nothing -> fmap pure <$> f p
426+ _ -> fmap (\m -> (empty, snd <$> m)) $ Q.optional $ do
427+ (k, a) <- f p
428+ ensure p k
429+ pure (k, a)
430+
431+
432+-- | 'many' aggregates each entry with a particular key into a
433+-- single entry with all of the values contained in a 'ListTable'.
434+--
435+-- 'order' can be used to give this 'ListTable' a defined order.
436+--
437+-- The resulting 'Tabulation' is \"magic\" in that the value
438+-- @'Rel8.listTable []'@ exists at every possible key that wasn't in the given
439+-- 'Tabulation'.
440+many :: (EqTable k, Table Expr a)
441+ => Tabulation k a -> Tabulation k (ListTable Expr a)
442+many =
443+ fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .
444+ optional .
445+ aggregate .
446+ fmap (listAgg . toCols)
447+
448+
449+-- | 'some' aggregates each entry with a particular key into a
450+-- single entry with all of the values contained in a 'NonEmptyTable'.
451+--
452+-- 'order' can be used to give this 'NonEmptyTable' a defined order.
453+some :: (EqTable k, Table Expr a)
454+ => Tabulation k a -> Tabulation k (NonEmptyTable Expr a)
455+some =
456+ fmap (\(NonEmptyTable a) -> NonEmptyTable a) .
457+ aggregate .
458+ fmap (nonEmptyAgg . toCols)
459+
460+
461+-- | 'exists' produces a \"magic\" 'Tabulation' which contains the
462+-- value 'Rel8.true' at each key in the given 'Tabulation', and the value
463+-- 'Rel8.false' at every other possible key.
464+exists :: Tabulation k a -> Tabulation k (Expr Bool)
465+exists (Tabulation f) = Tabulation $ \p -> case p of
466+ Predicate Nothing -> (true <$) <$> f p
467+ _ -> fmap (empty,) $ Q.exists $ do
468+ (k, _) <- f p
469+ ensure p k
470+
471+
472+-- | 'present' produces a 'Tabulation' where a single @()@ row
473+-- exists for every key that was present in the given 'Tabulation'.
474+--
475+-- This is used to implement 'similarity'.
476+present :: Tabulation k a -> Tabulation k ()
477+present (Tabulation f) = Tabulation $ \p -> do
478+ Q.present $ do
479+ (k, _) <- f p
480+ ensure p k
481+ pure (empty, ())
482+
483+
484+-- | 'absent' produces a 'Tabulation' where a single @()@ row exists
485+-- at every possible key that absent from the given 'Tabulation'.
486+--
487+-- This is used to implement 'difference'.
488+absent :: Tabulation k a -> Tabulation k ()
489+absent (Tabulation f) = Tabulation $ \p -> do
490+ Q.absent $ do
491+ (k, _) <- f p
492+ ensure p k
493+ pure (empty, ())
494+
495+
496+-- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns.
497+--
498+-- Analogous to 'Data.Semialign.align'.
499+align :: EqTable k
500+ => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable Expr a b)
501+align = alignWith id
502+
503+
504+-- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns.
505+--
506+-- Analogous to 'Data.Semialign.alignWith'.
507+alignWith :: EqTable k
508+ => (TheseTable Expr a b -> c)
509+ -> Tabulation k a -> Tabulation k b -> Tabulation k c
510+alignWith f (Tabulation as) (Tabulation bs) = Tabulation $ \p -> do
511+ tkab <- liftF2 (alignBy condition) as bs p
512+ k <- traverse (rebind "key") $ recover $ bimap fst fst tkab
513+ let
514+ tab = bimap snd snd tkab
515+ pure (k, f tab)
516+ where
517+ condition (k, _) (k', _) = fromMaybe true (liftA2 (==:) k k')
518+ recover (TheseTable mma@(MaybeTable _ ma) mmb@(MaybeTable _ mb)) =
519+ case extract ma of
520+ Nothing -> extract mb
521+ Just a -> case extract mb of
522+ Nothing -> extract ma
523+ Just b -> case a <$ mma <|>: b <$ mmb of
524+ MaybeTable _ c -> pure (extract c)
525+
526+
527+-- | Performs a @NATURAL LEFT OUTER JOIN@ based on the common key columns.
528+--
529+-- Analogous to 'Data.Semialign.rpadZip'.
530+--
531+-- Note that you can achieve the same effect with 'optional' and the
532+-- 'Applicative' instance for 'Tabulation', i.e., this is just
533+-- @\left right -> liftA2 (,) left (optional right). You can also
534+-- use @do@-notation.
535+leftAlign :: EqTable k
536+ => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable Expr b)
537+leftAlign = leftAlignWith (,)
538+
539+
540+-- | Performs a @NATURAL LEFT OUTER JOIN@ based on the common key columns.
541+--
542+-- Analogous to 'Data.Semialign.rpadZipWith'.
543+--
544+-- Note that you can achieve the same effect with 'optional' and the
545+-- 'Applicative' instance for 'Tabulation', i.e., this is just
546+-- @\f left right -> liftA2 f left (optional right). You can also
547+-- use @do@-notation.
548+leftAlignWith :: EqTable k
549+ => (a -> MaybeTable Expr b -> c)
550+ -> Tabulation k a -> Tabulation k b -> Tabulation k c
551+leftAlignWith f left right = liftA2 f left (optional right)
552+
553+
554+-- | Performs a @NATURAL RIGHT OUTER JOIN@ based on the common key columns.
555+--
556+-- Analogous to 'Data.Semialign.lpadZip'.
557+--
558+-- Note that you can achieve the same effect with 'optional' and the
559+-- 'Applicative' instance for 'Tabulation', i.e., this is just
560+-- @\left right -> liftA2 (flip (,)) right (optional left). You can
561+-- also use @do@-notation.
562+rightAlign :: EqTable k
563+ => Tabulation k a -> Tabulation k b -> Tabulation k (MaybeTable Expr a, b)
564+rightAlign = rightAlignWith (,)
565+
566+
567+-- | Performs a @NATURAL RIGHT OUTER JOIN@ based on the common key columns.
568+--
569+-- Analogous to 'Data.Semialign.lpadZipWith'.
570+--
571+-- Note that you can achieve the same effect with 'optional' and the
572+-- 'Applicative' instance for 'Tabulation', i.e., this is just
573+-- @\f left right -> liftA2 (flip f) right (optional left). You can
574+-- also use @do@-notation.
575+rightAlignWith :: EqTable k
576+ => (MaybeTable Expr a -> b -> c)
577+ -> Tabulation k a -> Tabulation k b -> Tabulation k c
578+rightAlignWith f left right = liftA2 (flip f) right (optional left)
579+
580+
581+-- | Performs a @NATURAL INNER JOIN@ based on the common key columns.
582+--
583+-- Analagous to 'Data.Semialign.zip'.
584+--
585+-- Note that you can achieve the same effect with the 'Applicative' instance
586+-- of 'Tabulation', i.e., this is just @'liftA2 (,)'@. You can also use
587+-- @do@-notation.
588+zip :: EqTable k
589+ => Tabulation k a -> Tabulation k b -> Tabulation k (a, b)
590+zip = zipWith (,)
591+
592+
593+-- | Performs a @NATURAL INNER JOIN@ based on the common key columns.
594+--
595+-- Analagous to 'Data.Semialign.zipWith'.
596+--
597+-- Note that you can achieve the same effect with the 'Applicative' instance
598+-- of 'Tabulation', i.e., this is just @'liftA2'@. You can also use
599+-- @do@-notation.
600+zipWith :: EqTable k
601+ => (a -> b -> c) -> Tabulation k a -> Tabulation k b -> Tabulation k c
602+zipWith = liftA2
603+
604+
605+-- | Performs a [@NATURAL SEMI JOIN@](https://en.wikipedia.org/wiki/Relational_algebra#Semijoin_%28%E2%8B%89%29%28%E2%8B%8A%29)
606+-- based on the common key columns.
607+--
608+-- The result is a subset of the left tabulation where only entries which have
609+-- a corresponding entry in the right tabulation are kept.
610+--
611+-- Note that you can achieve a similar effect with 'present' and the
612+-- 'Applicative' instance of 'Tabulation', i.e., this is just
613+-- @\left right -> left <* present right@. You can also use
614+-- @do@-notation.
615+similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
616+similarity a b = a <* present b
617+
618+
619+-- | Performs a [@NATURAL ANTI JOIN@](https://en.wikipedia.org/wiki/Relational_algebra#Antijoin_%28%E2%96%B7%29)
620+-- based on the common key columns.
621+--
622+-- The result is a subset of the left tabulation where only entries which do
623+-- not have a corresponding entry in the right tabulation are kept.
624+--
625+-- Note that you can achieve a similar effect with 'absent' and the
626+-- 'Applicative' instance of 'Tabulation', i.e., this is just
627+-- @\left right -> left <* absent right@. You can also use
628+-- @do@-notation.
629+difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
630+difference a b = a <* absent b
631+
632+
633+-- | 'Tabulation's can be produced with either 'fromQuery' or 'liftQuery', and
634+-- in some cases we might want to treat these differently. 'peek' uses
635+-- 'unsafePeekQuery' to determine which type of 'Tabulation' we have.
636+peek :: Tabulation k a -> Tabulation k (Either (Query a) (Query (k, a)))
637+peek (Tabulation f) = Tabulation $ \p ->
638+ pure $ (empty,) $ case unsafePeekQuery (f p) of
639+ (Nothing, _) -> Left $ fmap snd (f p)
640+ (Just _, _) -> Right $ fmap (first fromJust) (f p)
src/Rel8/Type.hs+9−8
@@ -1,3 +1,4 @@
1+{-# language FlexibleContexts #-}
12{-# language FlexibleInstances #-}
23{-# language MonoLocalBinds #-}
34{-# language MultiWayIf #-}
@@ -127,10 +128,10 @@ instance DBType Int64 where
127128instance DBType Float where
128129 typeInformation = TypeInformation
129130 { encode = \x -> Opaleye.ConstExpr
130− if | x == (1 /0) -> Opaleye.OtherLit "'Infinity'"
131− | isNaN x -> Opaleye.OtherLit "'NaN'"
132− | x == (-1/0) -> Opaleye.OtherLit "'-Infinity'"
133− | otherwise -> Opaleye.NumericLit $ realToFrac x
131+ if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'"
132+ | isNaN x -> Opaleye.OtherLit "'NaN'"
133+ | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"
134+ | otherwise -> Opaleye.NumericLit $ realToFrac x
134135 , decode = Hasql.float4
135136 , typeName = "float4"
136137 }
@@ -140,10 +141,10 @@ instance DBType Float where
140141instance DBType Double where
141142 typeInformation = TypeInformation
142143 { encode = \x -> Opaleye.ConstExpr
143− if | x == (1 /0) -> Opaleye.OtherLit "'Infinity'"
144− | isNaN x -> Opaleye.OtherLit "'NaN'"
145− | x == (-1/0) -> Opaleye.OtherLit "'-Infinity'"
146− | otherwise -> Opaleye.NumericLit $ realToFrac x
144+ if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'"
145+ | isNaN x -> Opaleye.OtherLit "'NaN'"
146+ | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"
147+ | otherwise -> Opaleye.NumericLit $ realToFrac x
147148 , decode = Hasql.float8
148149 , typeName = "float8"
149150 }
src/Rel8/Type/Composite.hs+20−19
@@ -20,6 +20,7 @@ where
2020
2121-- base
2222import Data.Functor.Const ( Const( Const ), getConst )
23+import Data.Functor.Identity ( Identity( Identity ) )
2324import Data.Kind ( Constraint, Type )
2425import Prelude
2526
@@ -30,19 +31,19 @@ import qualified Hasql.Decoders as Hasql
3031import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
3132
3233-- rel8
33−import Rel8.Expr ( Col( E ), Expr )
34+import Rel8.Expr ( Expr )
3435import Rel8.Expr.Opaleye ( castExpr, fromPrimExpr, toPrimExpr )
35−import Rel8.Schema.HTable ( hfield, hspecs, htabulate, htabulateA )
36−import Rel8.Schema.Name ( Col( N ), Name( Name ) )
36+import Rel8.Schema.HTable ( HTable, hfield, hspecs, htabulate, htabulateA )
37+import Rel8.Schema.Name ( Name( Name ) )
3738import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
38−import Rel8.Schema.Result ( Col( R ), Result )
39−import Rel8.Schema.Spec ( SSpec( SSpec, nullity, info ) )
40−import Rel8.Table ( Table, fromColumns, toColumns )
39+import Rel8.Schema.Result ( Result )
40+import Rel8.Schema.Spec ( Spec( Spec, nullity, info ) )
41+import Rel8.Table ( fromColumns, toColumns, fromResult, toResult )
4142import Rel8.Table.Eq ( EqTable )
42−import Rel8.Table.HKD ( HKD, HKDable, fromHKD, toHKD )
43+import Rel8.Table.HKD ( HKD, HKDable )
4344import Rel8.Table.Ord ( OrdTable )
4445import Rel8.Table.Rel8able ()
45−import Rel8.Table.Serialize ( lit )
46+import Rel8.Table.Serialize ( litHTable )
4647import Rel8.Type ( DBType, typeInformation )
4748import Rel8.Type.Eq ( DBEq )
4849import Rel8.Type.Information ( TypeInformation(..) )
@@ -67,8 +68,8 @@ newtype Composite a = Composite
6768
6869instance DBComposite a => DBType (Composite a) where
6970 typeInformation = TypeInformation
70− { decode = Hasql.composite (Composite . fromHKD <$> decoder)
71− , encode = encoder . lit . toColumns . toHKD . unComposite
71+ { decode = Hasql.composite (Composite . fromResult @_ @(HKD a Expr) <$> decoder)
72+ , encode = encoder . litHTable . toResult @_ @(HKD a Expr) . unComposite
7273 , typeName = compositeTypeName @a
7374 }
7475
@@ -103,7 +104,7 @@ class (DBType a, HKDable a) => DBComposite a where
103104-- single column expression, by combining them into a PostgreSQL composite
104105-- type.
105106compose :: DBComposite a => HKD a Expr -> Expr a
106−compose = castExpr . fromPrimExpr . encoder
107+compose = castExpr . fromPrimExpr . encoder . toColumns
107108
108109
109110-- | Expand a composite type into a 'HKD'.
@@ -112,23 +113,23 @@ compose = castExpr . fromPrimExpr . encoder
112113decompose :: forall a. DBComposite a => Expr a -> HKD a Expr
113114decompose (toPrimExpr -> a) = fromColumns $ htabulate \field ->
114115 case hfield names field of
115− N (Name name) -> case hfield hspecs field of
116− SSpec {} -> E $ fromPrimExpr $ Opaleye.CompositeExpr a name
116+ Name name -> case hfield hspecs field of
117+ Spec {} -> fromPrimExpr $ Opaleye.CompositeExpr a name
117118 where
118119 names = toColumns (compositeFields @a)
119120
120121
121−decoder :: Table Result a => Hasql.Composite a
122−decoder = fmap fromColumns $ unwrapApplicative $ htabulateA \field ->
122+decoder :: HTable t => Hasql.Composite (t Result)
123+decoder = unwrapApplicative $ htabulateA \field ->
123124 case hfield hspecs field of
124− SSpec {nullity, info} -> WrapApplicative $ R <$>
125+ Spec {nullity, info} -> WrapApplicative $ Identity <$>
125126 case nullity of
126127 Null -> Hasql.field $ Hasql.nullable $ decode info
127128 NotNull -> Hasql.field $ Hasql.nonNullable $ decode info
128129
129130
130−encoder :: Table Expr a => a -> Opaleye.PrimExpr
131−encoder (toColumns -> a) = Opaleye.FunExpr "ROW" exprs
131+encoder :: HTable t => t Expr -> Opaleye.PrimExpr
132+encoder a = Opaleye.FunExpr "ROW" exprs
132133 where
133134 exprs = getConst $ htabulateA \field -> case hfield a field of
134− E (toPrimExpr -> expr) -> Const [expr]
135+ expr -> Const [toPrimExpr expr]
src/Rel8/Type/Enum.hs+1
@@ -106,6 +106,7 @@ class (DBType a, Enumable a) => DBEnum a where
106106
107107-- | Types that are sum types, where each constructor is unary (that is, has no
108108-- fields).
109+type Enumable :: Type -> Constraint
109110class (Generic a, GEnumable (Rep a)) => Enumable a
110111instance (Generic a, GEnumable (Rep a)) => Enumable a
111112
src/Rel8/Type/JSONBEncoded.hs+4
@@ -1,3 +1,5 @@
1+{-# language StandaloneKindSignatures #-}
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/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/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+288−178
@@ -1,12 +1,11 @@
1+{-# language BangPatterns #-}
12{-# language BlockArguments #-}
2−{-# language DataKinds #-}
33{-# language DeriveAnyClass #-}
44{-# language DeriveGeneric #-}
55{-# language DerivingStrategies #-}
6−{-# language DisambiguateRecordFields #-}
76{-# language FlexibleContexts #-}
87{-# language FlexibleInstances #-}
9−{-# language GADTs #-}
8+{-# language MonoLocalBinds #-}
109{-# language NamedFieldPuns #-}
1110{-# language OverloadedStrings #-}
1211{-# language RecordWildCards #-}
@@ -14,17 +13,15 @@
1413{-# language StandaloneDeriving #-}
1514{-# language TypeApplications #-}
1615
17−{-# options_ghc -fno-warn-redundant-constraints #-}
18−
1916module Main
2017 ( main
2118 )
2219where
2320
2421-- base
25−import Control.Applicative ( liftA2, liftA3 )
26−import Control.Monad (void)
27−import Control.Monad.IO.Class ( MonadIO, liftIO )
22+import Control.Applicative ( empty, liftA2, liftA3 )
23+import Control.Exception ( bracket, throwIO )
24+import Control.Monad ( (>=>), void )
2825import Data.Bifunctor ( bimap )
2926import Data.Foldable ( for_ )
3027import Data.Int ( Int32, Int64 )
@@ -38,25 +35,27 @@ import GHC.Generics ( Generic )
3835import qualified Data.ByteString.Lazy
3936
4037-- case-insensitive
41−import Data.CaseInsensitive (mk)
38+import Data.CaseInsensitive ( mk )
4239
4340-- containers
41+import Data.Containers.ListUtils ( nubOrdOn )
4442import qualified Data.Map.Strict as Map
4543
4644-- hasql
47−import Hasql.Connection ( Connection, acquire, release )
45+import Hasql.Connection ( Connection, acquire, release )
4846import Hasql.Session ( sql, run )
4947
48+-- hasql-transaction
49+import Hasql.Transaction ( Transaction, condemn, statement )
50+import qualified Hasql.Transaction.Sessions as Hasql
51+
5052-- hedgehog
5153import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )
5254import qualified Hedgehog.Gen as Gen
5355import qualified Hedgehog.Range as Range
5456
55−-- lifted-base
56−import Control.Exception.Lifted ( bracket, throwIO, bracket_ )
57−
58−-- monad-control
59−import Control.Monad.Trans.Control ( MonadBaseControl )
57+-- mmorph
58+import Control.Monad.Morph ( hoist )
6059
6160-- rel8
6261import Rel8 ( Result )
@@ -72,12 +71,16 @@ import Test.Tasty
7271import Test.Tasty.Hedgehog ( testProperty )
7372
7473-- text
75−import Data.Text (Text, pack)
74+import Data.Text ( Text, pack, unpack )
7675import qualified Data.Text.Lazy
76+import Data.Text.Encoding ( decodeUtf8 )
7777
7878-- time
7979import Data.Time
8080
81+-- transformers
82+import Control.Monad.Trans.Class ( lift )
83+
8184-- tmp-postgres
8285import qualified Database.Postgres.Temp as TmpPostgres
8386
@@ -113,11 +116,13 @@ tests =
113116 , testCatMaybeTable getTestDatabase
114117 , testCatMaybe getTestDatabase
115118 , testMaybeTable getTestDatabase
119+ , testAggregateMaybeTable getTestDatabase
116120 , testNestedTables getTestDatabase
117121 , testMaybeTableApplicative getTestDatabase
118122 , testLogicalFixities getTestDatabase
119123 , testUpdate getTestDatabase
120124 , testDelete getTestDatabase
125+ , testUpsert getTestDatabase
121126 , testSelectNestedPairs getTestDatabase
122127 , testSelectArray getTestDatabase
123128 , testNestedMaybeTable getTestDatabase
@@ -133,6 +138,7 @@ tests =
133138 flip run conn do
134139 sql "CREATE EXTENSION citext"
135140 sql "CREATE TABLE test_table ( column1 text not null, column2 bool not null )"
141+ sql "CREATE TABLE unique_table ( \"key\" text not null unique, \"value\" text not null )"
136142 sql "CREATE SEQUENCE test_seq"
137143
138144 return db
@@ -140,19 +146,21 @@ tests =
140146 stopTestDatabase = TmpPostgres.stop
141147
142148
149+connect :: TmpPostgres.DB -> IO Connection
150+connect = acquire . TmpPostgres.toConnectionString >=> either (maybe empty (fail . unpack . decodeUtf8)) pure
151+
152+
143153databasePropertyTest
144154 :: TestName
145− -> (((Connection -> TestT IO ()) -> PropertyT IO ()) -> PropertyT IO ())
155+ -> ((TestT Transaction () -> PropertyT IO ()) -> PropertyT IO ())
146156 -> IO TmpPostgres.DB -> TestTree
147157databasePropertyTest testName f getTestDatabase =
148− withResource connect release $ \c ->
158+ withResource (connect =<< getTestDatabase) release $ \c ->
149159 testProperty testName $ property do
150− connection <- liftIO c
151− f \g -> test $ rollingBack connection $ g connection
152−
153− where
154−
155− connect = either (error . show) return =<< acquire . TmpPostgres.toConnectionString =<< getTestDatabase
160+ connection <- lift c
161+ f $ test . hoist \m -> do
162+ e <- run (Hasql.transaction Hasql.Serializable Hasql.Write (m <* condemn)) connection
163+ either throwIO pure e
156164
157165
158166data TestTable f = TestTable
@@ -184,18 +192,17 @@ testSelectTestTable :: IO TmpPostgres.DB -> TestTree
184192testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do
185193 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
186194
187− transaction \connection -> do
188− void do
189− liftIO $ Rel8.insert connection
190− Rel8.Insert
191− { into = testTableSchema
192− , rows = map Rel8.lit rows
193− , onConflict = Rel8.DoNothing
194− , returning = Rel8.NumberOfRowsAffected
195− }
195+ transaction do
196+ selected <- lift do
197+ statement () $ Rel8.insert Rel8.Insert
198+ { into = testTableSchema
199+ , rows = Rel8.values $ map Rel8.lit rows
200+ , onConflict = Rel8.DoNothing
201+ , returning = pure ()
202+ }
196203
197− selected <- liftIO $ Rel8.select connection do
198− Rel8.each testTableSchema
204+ statement () $ Rel8.select do
205+ Rel8.each testTableSchema
199206
200207 sort selected === sort rows
201208
@@ -212,11 +219,12 @@ testWhere_ = databasePropertyTest "WHERE (Rel8.where_)" \transaction -> do
212219
213220 let expected = filter (\t -> testTableColumn2 t == magicBool) rows
214221
215− transaction \connection -> do
216− selected <- liftIO $ Rel8.select connection do
217− t <- Rel8.values $ Rel8.lit <$> rows
218− Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool
219− return t
222+ transaction do
223+ selected <- lift do
224+ statement () $ Rel8.select do
225+ t <- Rel8.values $ Rel8.lit <$> rows
226+ Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool
227+ return t
220228
221229 sort selected === sort expected
222230
@@ -229,11 +237,12 @@ testFilter :: IO TmpPostgres.DB -> TestTree
229237testFilter = databasePropertyTest "filter" \transaction -> do
230238 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable
231239
232− transaction \connection -> do
240+ transaction do
233241 let expected = filter testTableColumn2 rows
234242
235− selected <- liftIO $ Rel8.select connection
236− $ Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)
243+ selected <- lift do
244+ statement () $ Rel8.select do
245+ Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)
237246
238247 sort selected === sort expected
239248
@@ -248,9 +257,10 @@ testLimit = databasePropertyTest "LIMIT (Rel8.limit)" \transaction -> do
248257
249258 n <- forAll $ Gen.integral (Range.linear 0 10)
250259
251− transaction \connection -> do
252− selected <- liftIO $ Rel8.select connection do
253− Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)
260+ transaction do
261+ selected <- lift do
262+ statement () $ Rel8.select do
263+ Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)
254264
255265 diff (length selected) (<=) (fromIntegral n)
256266
@@ -268,9 +278,10 @@ testUnion = databasePropertyTest "UNION (Rel8.union)" \transaction -> evalM do
268278 left <- forAll $ Gen.list (Range.linear 0 10) genTestTable
269279 right <- forAll $ Gen.list (Range.linear 0 10) genTestTable
270280
271− transaction \connection -> do
272− selected <- liftIO $ Rel8.select connection do
273− Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)
281+ transaction do
282+ selected <- lift do
283+ statement () $ Rel8.select do
284+ Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)
274285
275286 sort selected === sort (nub (left ++ right))
276287
@@ -279,9 +290,11 @@ testDistinct :: IO TmpPostgres.DB -> TestTree
279290testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do
280291 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
281292
282− transaction \connection -> do
283− selected <- liftIO $ Rel8.select connection $ Rel8.distinct do
284− Rel8.values (Rel8.lit <$> rows)
293+ transaction do
294+ selected <- lift do
295+ statement () $ Rel8.select do
296+ Rel8.distinct do
297+ Rel8.values (Rel8.lit <$> rows)
285298
286299 sort selected === nub (sort rows)
287300
@@ -294,8 +307,10 @@ testExists :: IO TmpPostgres.DB -> TestTree
294307testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do
295308 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
296309
297− transaction \connection -> do
298− exists <- liftIO $ Rel8.select connection $ Rel8.exists $ Rel8.values $ Rel8.lit <$> rows
310+ transaction do
311+ exists <- lift do
312+ statement () $ Rel8.select do
313+ Rel8.exists $ Rel8.values $ Rel8.lit <$> rows
299314
300315 case rows of
301316 [] -> exists === [False]
@@ -306,9 +321,10 @@ testOptional :: IO TmpPostgres.DB -> TestTree
306321testOptional = databasePropertyTest "Rel8.optional" \transaction -> do
307322 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
308323
309− transaction \connection -> do
310− selected <- liftIO $ Rel8.select connection do
311− Rel8.optional $ Rel8.values (Rel8.lit <$> rows)
324+ transaction do
325+ selected <- lift do
326+ statement () $ Rel8.select do
327+ Rel8.optional $ Rel8.values (Rel8.lit <$> rows)
312328
313329 case rows of
314330 [] -> selected === [Nothing]
@@ -319,9 +335,10 @@ testAnd :: IO TmpPostgres.DB -> TestTree
319335testAnd = databasePropertyTest "AND (&&.)" \transaction -> do
320336 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
321337
322− transaction \connection -> do
323− [result] <- liftIO $ Rel8.select connection $ pure $
324− Rel8.lit x Rel8.&&. Rel8.lit y
338+ transaction do
339+ [result] <- lift do
340+ statement () $ Rel8.select do
341+ pure $ Rel8.lit x Rel8.&&. Rel8.lit y
325342
326343 result === (x && y)
327344
@@ -330,9 +347,10 @@ testOr :: IO TmpPostgres.DB -> TestTree
330347testOr = databasePropertyTest "OR (||.)" \transaction -> do
331348 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
332349
333− transaction \connection -> do
334− [result] <- liftIO $ Rel8.select connection $ pure $
335− Rel8.lit x Rel8.||. Rel8.lit y
350+ transaction do
351+ [result] <- lift do
352+ statement () $ Rel8.select $ pure $
353+ Rel8.lit x Rel8.||. Rel8.lit y
336354
337355 result === (x || y)
338356
@@ -341,9 +359,10 @@ testLogicalFixities :: IO TmpPostgres.DB -> TestTree
341359testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do
342360 (u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool
343361
344− transaction \connection -> do
345− [result] <- liftIO $ Rel8.select connection $ pure $
346− Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x
362+ transaction do
363+ [result] <- lift do
364+ statement () $ Rel8.select do
365+ pure $ Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x
347366
348367 result === (u || v && w == x)
349368
@@ -352,9 +371,10 @@ testNot :: IO TmpPostgres.DB -> TestTree
352371testNot = databasePropertyTest "NOT (not_)" \transaction -> do
353372 x <- forAll Gen.bool
354373
355− transaction \connection -> do
356− [result] <- liftIO $ Rel8.select connection $ pure $
357− Rel8.not_ $ Rel8.lit x
374+ transaction do
375+ [result] <- lift do
376+ statement () $ Rel8.select do
377+ pure $ Rel8.not_ $ Rel8.lit x
358378
359379 result === not x
360380
@@ -363,9 +383,10 @@ testBool :: IO TmpPostgres.DB -> TestTree
363383testBool = databasePropertyTest "ifThenElse_" \transaction -> do
364384 (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool
365385
366− transaction \connection -> do
367− [result] <- liftIO $ Rel8.select connection $ pure $
368− Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)
386+ transaction do
387+ [result] <- lift do
388+ statement () $ Rel8.select do
389+ pure $ Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)
369390
370391 result === if x then y else z
371392
@@ -377,9 +398,10 @@ testAp = databasePropertyTest "Cartesian product (<*>)" \transaction -> do
377398 (Gen.list (Range.linear 1 10) genTestTable)
378399 (Gen.list (Range.linear 1 10) genTestTable)
379400
380− transaction \connection -> do
381− result <- liftIO $ Rel8.select connection $ do
382− liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))
401+ transaction do
402+ result <- lift do
403+ statement () $ Rel8.select do
404+ liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))
383405
384406 sort result === sort (liftA2 (,) rows1 rows2)
385407
@@ -408,21 +430,22 @@ testDBType getTestDatabase = testGroup "DBType instances"
408430 where
409431 dbTypeTest :: (Eq a, Show a, Rel8.DBType a) => TestName -> Gen a -> TestTree
410432 dbTypeTest name generator = testGroup name
411− [ databasePropertyTest name (t (==) generator) getTestDatabase
412− , databasePropertyTest ("Maybe " <> name) (t (==) (Gen.maybe generator)) getTestDatabase
433+ [ databasePropertyTest name (t generator) getTestDatabase
434+ , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase
413435 ]
414436
415− t :: forall a b. (Show a, Rel8.Sql Rel8.DBType a)
416− => (a -> a -> Bool)
417− -> Gen a
418− -> ((Connection -> TestT IO ()) -> PropertyT IO b)
437+ t :: forall a b. (Eq a, Show a, Rel8.Sql Rel8.DBType a)
438+ => Gen a
439+ -> (TestT Transaction () -> PropertyT IO b)
419440 -> PropertyT IO b
420− t eq generator transaction = do
441+ t generator transaction = do
421442 x <- forAll generator
422443
423− transaction \connection -> do
424− [res] <- liftIO $ Rel8.select connection $ pure (Rel8.litExpr x)
425− diff res eq x
444+ transaction do
445+ [res] <- lift do
446+ statement () $ Rel8.select do
447+ pure (Rel8.litExpr x)
448+ diff res (==) x
426449
427450 genDay :: Gen Day
428451 genDay = do
@@ -464,13 +487,15 @@ testDBEq getTestDatabase = testGroup "DBEq instances"
464487
465488 t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBEq a)
466489 => Gen a
467− -> ((Connection -> TestT IO ()) -> PropertyT IO ())
490+ -> (TestT Transaction () -> PropertyT IO ())
468491 -> PropertyT IO ()
469492 t generator transaction = do
470493 (x, y) <- forAll (liftA2 (,) generator generator)
471494
472− transaction \connection -> do
473− [res] <- liftIO $ Rel8.select connection $ pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y
495+ transaction do
496+ [res] <- lift do
497+ statement () $ Rel8.select do
498+ pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y
474499 res === (x == y)
475500
476501
@@ -478,9 +503,10 @@ testTableEquality :: IO TmpPostgres.DB -> TestTree
478503testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do
479504 (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable
480505
481− transaction \connection -> do
482− [eq] <- liftIO $ Rel8.select connection do
483− pure $ Rel8.lit x Rel8.==: Rel8.lit y
506+ transaction do
507+ [eq] <- lift do
508+ statement () $ Rel8.select do
509+ pure $ Rel8.lit x Rel8.==: Rel8.lit y
484510
485511 eq === (x == y)
486512
@@ -489,8 +515,10 @@ testFromString :: IO TmpPostgres.DB -> TestTree
489515testFromString = databasePropertyTest "FromString" \transaction -> do
490516 str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode
491517
492− transaction \connection -> do
493− [result] <- liftIO $ Rel8.select connection $ pure $ fromString str
518+ transaction do
519+ [result] <- lift do
520+ statement () $ Rel8.select do
521+ pure $ fromString str
494522 result === pack str
495523
496524
@@ -498,10 +526,11 @@ testCatMaybeTable :: IO TmpPostgres.DB -> TestTree
498526testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do
499527 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
500528
501− transaction \connection -> do
502− selected <- liftIO $ Rel8.select connection do
503− testTable <- Rel8.values $ Rel8.lit <$> rows
504− Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)
529+ transaction do
530+ selected <- lift do
531+ statement () $ Rel8.select do
532+ testTable <- Rel8.values $ Rel8.lit <$> rows
533+ Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)
505534
506535 sort selected === sort (filter testTableColumn2 rows)
507536
@@ -510,9 +539,10 @@ testCatMaybe :: IO TmpPostgres.DB -> TestTree
510539testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do
511540 rows <- forAll $ Gen.list (Range.linear 0 10) $ Gen.maybe Gen.bool
512541
513− transaction \connection -> do
514− selected <- evalM $ liftIO $ Rel8.select connection do
515− Rel8.catNull =<< Rel8.values (map Rel8.lit rows)
542+ transaction do
543+ selected <- lift do
544+ statement () $ Rel8.select do
545+ Rel8.catNull =<< Rel8.values (map Rel8.lit rows)
516546
517547 sort selected === sort (catMaybes rows)
518548
@@ -521,15 +551,38 @@ testMaybeTable :: IO TmpPostgres.DB -> TestTree
521551testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do
522552 (rows, def) <- forAll $ liftA2 (,) (Gen.list (Range.linear 0 10) genTestTable) genTestTable
523553
524− transaction \connection -> do
525− selected <- liftIO $ Rel8.select connection $
526− Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))
554+ transaction do
555+ selected <- lift do
556+ statement () $ Rel8.select do
557+ Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))
527558
528559 case rows of
529560 [] -> selected === [def]
530561 _ -> sort selected === sort rows
531562
532563
564+testAggregateMaybeTable :: IO TmpPostgres.DB -> TestTree
565+testAggregateMaybeTable = databasePropertyTest "aggregateMaybeTable" \transaction -> evalM do
566+ rows <- forAll $ Gen.list (Range.linear 0 10) (Gen.maybe (Gen.int64 (Range.linear 0 10)))
567+
568+ let
569+ aggregate = go 0 False False
570+ where
571+ go !n nothing _ (Just a : as) = go (n + a) nothing True as
572+ go n _ just (Nothing : as) = go n True just as
573+ go _ False False [] = []
574+ go _ True False [] = [Nothing]
575+ go n False True [] = [Just n]
576+ go n True True [] = [Nothing, Just n]
577+
578+ transaction do
579+ selected <- lift do
580+ statement () $ Rel8.select do
581+ Rel8.aggregate $ Rel8.aggregateMaybeTable Rel8.sum <$> Rel8.values (Rel8.lit <$> rows)
582+
583+ sort selected === aggregate rows
584+
585+
533586data TwoTestTables f =
534587 TwoTestTables
535588 { testTable1 :: TestTable f
@@ -550,9 +603,10 @@ testNestedTables = databasePropertyTest "Nested TestTables" \transaction -> eval
550603 Gen.list (Range.linear 0 10) $
551604 liftA2 TwoTestTables genTestTable genTestTable
552605
553− transaction \connection -> do
554− selected <- liftIO $ Rel8.select connection do
555− Rel8.values (Rel8.lit <$> rows)
606+ transaction do
607+ selected <- lift do
608+ statement () $ Rel8.select do
609+ Rel8.values (Rel8.lit <$> rows)
556610
557611 sort selected === sort rows
558612
@@ -562,11 +616,12 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction
562616 rows1 <- genRows
563617 rows2 <- genRows
564618
565− transaction \connection -> do
566− selected <- liftIO $ Rel8.select connection do
567− as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))
568− bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))
569− pure $ liftA2 (,) as bs
619+ transaction do
620+ selected <- lift do
621+ statement () $ Rel8.select do
622+ as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))
623+ bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))
624+ pure $ liftA2 (,) as bs
570625
571626 case (rows1, rows2) of
572627 ([], []) -> selected === [Nothing]
@@ -578,14 +633,6 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction
578633 genRows = forAll do
579634 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)
580635
581−rollingBack
582− :: (MonadBaseControl IO m, MonadIO m)
583− => Connection -> m a -> m a
584−rollingBack connection =
585− bracket_
586− (liftIO (run (sql "BEGIN") connection))
587− (liftIO (run (sql "ROLLBACK") connection))
588−
589636
590637genTestTable :: Gen (TestTable Result)
591638genTestTable = do
@@ -598,19 +645,19 @@ testUpdate :: IO TmpPostgres.DB -> TestTree
598645testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do
599646 rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable
600647
601− transaction \connection -> do
602− void $ liftIO $ Rel8.insert connection
603− Rel8.Insert
648+ transaction do
649+ selected <- lift do
650+ statement () $ Rel8.insert Rel8.Insert
604651 { into = testTableSchema
605− , rows = map Rel8.lit $ Map.keys rows
652+ , rows = Rel8.values $ map Rel8.lit $ Map.keys rows
606653 , onConflict = Rel8.DoNothing
607− , returning = Rel8.NumberOfRowsAffected
654+ , returning = pure ()
608655 }
609656
610− void $ liftIO $ Rel8.update connection
611− Rel8.Update
657+ statement () $ Rel8.update Rel8.Update
612658 { target = testTableSchema
613− , set = \r ->
659+ , from = pure ()
660+ , set = \_ r ->
614661 let updates = map (bimap Rel8.lit Rel8.lit) $ Map.toList rows
615662 in
616663 foldl
@@ -624,12 +671,12 @@ testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do
624671 )
625672 r
626673 updates
627− , updateWhere = \_ -> Rel8.lit True
628− , returning = Rel8.NumberOfRowsAffected
674+ , updateWhere = \_ _ -> Rel8.lit True
675+ , returning = pure ()
629676 }
630677
631− selected <- liftIO $ Rel8.select connection do
632− Rel8.each testTableSchema
678+ statement () $ Rel8.select do
679+ Rel8.each testTableSchema
633680
634681 sort selected === sort (Map.elems rows)
635682
@@ -642,29 +689,96 @@ testDelete :: IO TmpPostgres.DB -> TestTree
642689testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do
643690 rows <- forAll $ Gen.list (Range.linear 0 5) genTestTable
644691
645− transaction \connection -> do
646− void $ liftIO $ Rel8.insert connection
647− Rel8.Insert
692+ transaction do
693+ (deleted, selected) <- lift do
694+ statement () $ Rel8.insert Rel8.Insert
648695 { into = testTableSchema
649− , rows = map Rel8.lit rows
696+ , rows = Rel8.values $ map Rel8.lit rows
650697 , onConflict = Rel8.DoNothing
651− , returning = Rel8.NumberOfRowsAffected
698+ , returning = pure ()
652699 }
653700
654− deleted <-
655− liftIO $ Rel8.delete connection
656− Rel8.Delete
701+ deleted <- statement () $ Rel8.delete Rel8.Delete
657702 { from = testTableSchema
658− , deleteWhere = testTableColumn2
703+ , using = pure ()
704+ , deleteWhere = const testTableColumn2
659705 , returning = Rel8.Projection id
660706 }
661707
662− selected <- liftIO $ Rel8.select connection do
663− Rel8.each testTableSchema
708+ selected <- statement () $ Rel8.select do
709+ Rel8.each testTableSchema
710+
711+ pure (deleted, selected)
664712
665713 sort (deleted <> selected) === sort rows
666714
667715
716+data UniqueTable f = UniqueTable
717+ { uniqueTableKey :: Rel8.Column f Text
718+ , uniqueTableValue :: Rel8.Column f Text
719+ }
720+ deriving stock Generic
721+ deriving anyclass Rel8.Rel8able
722+
723+
724+deriving stock instance Eq (UniqueTable Result)
725+deriving stock instance Ord (UniqueTable Result)
726+deriving stock instance Show (UniqueTable Result)
727+
728+
729+uniqueTableSchema :: Rel8.TableSchema (UniqueTable Rel8.Name)
730+uniqueTableSchema =
731+ Rel8.TableSchema
732+ { name = "unique_table"
733+ , schema = Nothing
734+ , columns = UniqueTable
735+ { uniqueTableKey = "key"
736+ , uniqueTableValue = "value"
737+ }
738+ }
739+
740+
741+genUniqueTable :: Gen (UniqueTable Result)
742+genUniqueTable = do
743+ uniqueTableKey <- Gen.text (Range.linear 0 5) Gen.alphaNum
744+ uniqueTableValue <- Gen.text (Range.linear 0 5) Gen.alphaNum
745+ pure UniqueTable {..}
746+
747+
748+testUpsert :: IO TmpPostgres.DB -> TestTree
749+testUpsert = databasePropertyTest "Can UPSERT UniqueTable" \transaction -> do
750+ as <- unique $ forAll $ Gen.list (Range.linear 0 20) genUniqueTable
751+ bs <- unique $ forAll $ Gen.list (Range.linear 0 20) genUniqueTable
752+
753+ transaction do
754+ selected <- lift do
755+ statement () $ Rel8.insert Rel8.Insert
756+ { into = uniqueTableSchema
757+ , rows = Rel8.values $ Rel8.lit <$> as
758+ , onConflict = Rel8.DoNothing
759+ , returning = pure ()
760+ }
761+
762+ statement () $ Rel8.insert Rel8.Insert
763+ { into = uniqueTableSchema
764+ , rows = Rel8.values $ Rel8.lit <$> bs
765+ , onConflict = Rel8.DoUpdate Rel8.Upsert
766+ { index = uniqueTableKey
767+ , set = \UniqueTable {uniqueTableValue} old -> old {uniqueTableValue}
768+ , updateWhere = \_ _ -> Rel8.true
769+ }
770+ , returning = pure ()
771+ }
772+
773+ statement () $ Rel8.select do
774+ Rel8.each uniqueTableSchema
775+
776+ fromUniqueTables selected === fromUniqueTables bs <> fromUniqueTables as
777+ where
778+ unique = fmap (nubOrdOn uniqueTableKey)
779+ fromUniqueTables = Map.fromList . map \(UniqueTable key value) -> (key, value)
780+
781+
668782newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }
669783 deriving stock Generic
670784 deriving anyclass Rel8.Rel8able
@@ -678,9 +792,10 @@ testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree
678792testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do
679793 rows <- forAll $ Gen.list (Range.linear 0 10) $ HKNestedPair <$> liftA2 (,) genTestTable genTestTable
680794
681− transaction \connection -> do
682− selected <- liftIO $ Rel8.select connection do
683− Rel8.values $ map Rel8.lit rows
795+ transaction do
796+ selected <- lift do
797+ statement () $ Rel8.select do
798+ Rel8.values $ map Rel8.lit rows
684799
685800 sort selected === sort rows
686801
@@ -689,18 +804,20 @@ testSelectArray :: IO TmpPostgres.DB -> TestTree
689804testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do
690805 rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool
691806
692− transaction \connection -> do
693− selected <- liftIO $ Rel8.select connection do
694− Rel8.many $ Rel8.values (map Rel8.lit rows)
807+ transaction do
808+ selected <- lift do
809+ statement () $ Rel8.select do
810+ Rel8.many $ Rel8.values (map Rel8.lit rows)
695811
696812 selected === [foldMap pure rows]
697813
698− selected' <- liftIO $ Rel8.select connection $ do
699− a <- Rel8.catListTable =<< do
700− Rel8.many $ Rel8.values (map Rel8.lit rows)
701− b <- Rel8.catListTable =<< do
702− Rel8.many $ Rel8.values (map Rel8.lit rows)
703− pure (a, b)
814+ selected' <- lift do
815+ statement () $ Rel8.select do
816+ a <- Rel8.catListTable =<< do
817+ Rel8.many $ Rel8.values (map Rel8.lit rows)
818+ b <- Rel8.catListTable =<< do
819+ Rel8.many $ Rel8.values (map Rel8.lit rows)
820+ pure (a, b)
704821
705822 selected' === liftA2 (,) rows rows
706823
@@ -722,10 +839,11 @@ testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree
722839testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do
723840 let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) }
724841
725− transaction \connection -> do
726− selected <- liftIO $ Rel8.select connection do
727− x <- Rel8.values [Rel8.lit example]
728− pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)
842+ transaction do
843+ selected <- lift do
844+ statement () $ Rel8.select do
845+ x <- Rel8.values [Rel8.lit example]
846+ pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)
729847
730848 selected === [True]
731849
@@ -733,11 +851,12 @@ testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other ta
733851testEvaluate :: IO TmpPostgres.DB -> TestTree
734852testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect" \transaction -> do
735853
736− transaction \connection -> do
737− selected <- liftIO $ Rel8.select connection do
738− x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
739− y <- Rel8.evaluate (Rel8.nextval "test_seq")
740− pure (x, (y, y))
854+ transaction do
855+ selected <- lift do
856+ statement () $ Rel8.select do
857+ x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
858+ y <- Rel8.evaluate (Rel8.nextval "test_seq")
859+ pure (x, (y, y))
741860
742861 normalize selected ===
743862 [ ('a', (0, 0))
@@ -745,11 +864,12 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect
745864 , ('c', (2, 2))
746865 ]
747866
748− selected' <- liftIO $ Rel8.select connection do
749− x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
750− y <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])
751− z <- Rel8.evaluate (Rel8.nextval "test_seq")
752− pure ((x, y), (z, z))
867+ selected' <- lift do
868+ statement () $ Rel8.select do
869+ x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
870+ y <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])
871+ z <- Rel8.evaluate (Rel8.nextval "test_seq")
872+ pure ((x, y), (z, z))
753873
754874 normalize selected' ===
755875 [ (('a', 'd'), (0, 0))
@@ -767,13 +887,3 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect
767887 normalize :: [(x, (Int64, Int64))] -> [(x, (Int64, Int64))]
768888 normalize [] = []
769889 normalize xs@((_, (i, _)) : _) = map (fmap (\(a, b) -> (a - i, b - i))) xs
770−
771−{-
772− selected <- liftIO $ Rel8.select connection do
773− x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
774− x <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])
775− y <- Rel8.evaluate (Rel8.nextval "test_seq")
776− pure (x, y, y)
777−
778− selected === [('a', 1, 1), ('b', 2, 2), ('c', 3, 3)]
779−-}
tests/Rel8/Generic/Rel8able/Test.hs+46−15
@@ -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
@@ -98,24 +98,14 @@ data S3Object = S3Object
9898 deriving stock Generic
9999
100100
101−deriving via HKDT S3Object
102− instance Table Result S3Object
103−
104−
105−deriving via HKDT S3Object
106− instance x ~ HKD S3Object Expr => ToExprs x S3Object
101+instance x ~ HKD S3Object Expr => ToExprs x S3Object
107102
108103
109104data 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
@@ -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