git.iko.soy/rel8
on d2347c1 help sign in
6c038ec
swap
0 ahead, 337 behind
184 files changed+6784−11288
since splitsnapshots
unifiedsplit
.github/workflows/build.yaml−26 Changelog.md−159 Doctest.hs+53 LICENSE+1−1 README.md−17 Setup.hs+6 cabal.project.haskell-nix−4 default.nix+5−7 docs/Makefile−19 docs/concepts/dbtype.rst−175 docs/concepts/expr.rst−74 docs/concepts/insert.rst−181 docs/concepts/queries.rst−274 docs/concepts/tables.rst−60 docs/conf.py−36 docs/cookbook.rst−169 docs/index.rst−53 docs/requirements.txt−4 docs/tutorial.rst−387 jobs.nix+5 nix/sources.json+36−36 nix/sources.nix+20−66 rel8.cabal+56−83 shell.nix+4−4 src/Rel8.hs+397−391 src/Rel8/Aggregate.hs+49−59 src/Rel8/Column.hs−31 src/Rel8/Column/ADT.hs−23 src/Rel8/Column/Either.hs−26 src/Rel8/Column/Lift.hs−23 src/Rel8/Column/List.hs−25 src/Rel8/Column/Maybe.hs−26 src/Rel8/Column/NonEmpty.hs−27 src/Rel8/Column/Null.hs−26 src/Rel8/Column/These.hs−29 src/Rel8/Expr.hs+19−57 src/Rel8/Expr.hs-boot+4−5 src/Rel8/Expr/Aggregate.hs+87−58 src/Rel8/Expr/Array.hs+14−19 src/Rel8/Expr/Bool.hs+42−8 src/Rel8/Expr/Default.hs−35 src/Rel8/Expr/Eq.hs+60−29 src/Rel8/Expr/Function.hs+33−2 src/Rel8/Expr/Null.hs+39−26 src/Rel8/Expr/Num.hs+15−68 src/Rel8/Expr/Opaleye.hs+13−27 src/Rel8/Expr/Ord.hs+53−33 src/Rel8/Expr/Order.hs+12 src/Rel8/Expr/Sequence.hs−22 src/Rel8/Expr/Serialize.hs+15−16 src/Rel8/Expr/Text.hs+11−66 src/Rel8/Expr/Time.hs+24−36 src/Rel8/Expr/Window.hs−121 src/Rel8/FCF.hs+1−9 src/Rel8/Generic/Construction.hs−352 src/Rel8/Generic/Construction/ADT.hs−478 src/Rel8/Generic/Construction/Record.hs−168 src/Rel8/Generic/Map.hs−49 src/Rel8/Generic/Record.hs−155 src/Rel8/Generic/Rel8able.hs−281 src/Rel8/Generic/Table.hs−103 src/Rel8/Generic/Table/ADT.hs−221 src/Rel8/Generic/Table/Record.hs−181 src/Rel8/Kind/Algebra.hs−38 src/Rel8/Kind/Context.hs−56 src/Rel8/Kind/Labels.hs+61 src/Rel8/Kind/Necessity.hs+38 src/Rel8/Opaque.hs+20 src/Rel8/Order.hs+14−5 src/Rel8/Query.hs+5−188 src/Rel8/Query.hs-boot+1−3 src/Rel8/Query/Aggregate.hs+3−36 src/Rel8/Query/Distinct.hs+12−4 src/Rel8/Query/Each.hs+9−5 src/Rel8/Query/Either.hs+30−34 src/Rel8/Query/Evaluate.hs−49 src/Rel8/Query/Exists.hs+49−21 src/Rel8/Query/Filter.hs+11 src/Rel8/Query/Indexed.hs−21 src/Rel8/Query/Limit.hs+6 src/Rel8/Query/List.hs+14−93 src/Rel8/Query/Maybe.hs+101−33 src/Rel8/Query/Null.hs+18−18 src/Rel8/Query/Opaleye.hs+5−41 src/Rel8/Query/Optimize.hs+200 src/Rel8/Query/Rebind.hs−27 src/Rel8/Query/SQL.hs+59−5 src/Rel8/Query/Set.hs+26−8 src/Rel8/Query/These.hs+53−62 src/Rel8/Query/Values.hs+7−1 src/Rel8/Query/Window.hs−26 src/Rel8/Schema/Column.hs+169 src/Rel8/Schema/Context.hs+75 src/Rel8/Schema/Context/Identity.hs+198 src/Rel8/Schema/Context/Label.hs+82 src/Rel8/Schema/Context/Nullify.hs+121−107 src/Rel8/Schema/Field.hs+21−37 src/Rel8/Schema/Generic.hs+1047 src/Rel8/Schema/Generic/Test.hs+79 src/Rel8/Schema/HTable.hs+38−68 src/Rel8/Schema/HTable/Either.hs+6−5 src/Rel8/Schema/HTable/Identity.hs+17−16 src/Rel8/Schema/HTable/Label.hs+51−36 src/Rel8/Schema/HTable/MapTable.hs+15−37 src/Rel8/Schema/HTable/Maybe.hs+10−5 src/Rel8/Schema/HTable/Nullify.hs+45−55 src/Rel8/Schema/HTable/Pair.hs+20 src/Rel8/Schema/HTable/Product.hs−17 src/Rel8/Schema/HTable/Quartet.hs+29 src/Rel8/Schema/HTable/Quintet.hs+30 src/Rel8/Schema/HTable/These.hs+6−5 src/Rel8/Schema/HTable/Trio.hs+28 src/Rel8/Schema/HTable/Type.hs+55 src/Rel8/Schema/HTable/Vectorize.hs+69−51 src/Rel8/Schema/Kind.hs+14−8 src/Rel8/Schema/Name.hs−77 src/Rel8/Schema/Null.hs−110 src/Rel8/Schema/Nullability.hs+106 src/Rel8/Schema/Result.hs−54 src/Rel8/Schema/Spec.hs+61−18 src/Rel8/Schema/Spec/ConstrainDBType.hs+34 src/Rel8/Schema/Spec/ConstrainType.hs+31 src/Rel8/Schema/Structure.hs+54 src/Rel8/Schema/Table.hs+14−21 src/Rel8/Statement/Delete.hs+67−36 src/Rel8/Statement/Insert.hs+81−44 src/Rel8/Statement/OnConflict.hs−106 src/Rel8/Statement/Returning.hs+11−115 src/Rel8/Statement/SQL.hs−29 src/Rel8/Statement/Select.hs+36−122 src/Rel8/Statement/Set.hs−33 src/Rel8/Statement/Update.hs+81−39 src/Rel8/Statement/Using.hs−36 src/Rel8/Statement/View.hs+29−48 src/Rel8/Statement/Where.hs−31 src/Rel8/Table.hs+168−144 src/Rel8/Table/ADT.hs−173 src/Rel8/Table/Aggregate.hs+30−40 src/Rel8/Table/Alternative.hs+2−2 src/Rel8/Table/Bool.hs+6−19 src/Rel8/Table/Cols.hs−50 src/Rel8/Table/Either.hs+91−161 src/Rel8/Table/Eq.hs+35−65 src/Rel8/Table/HKD.hs−228 src/Rel8/Table/Insert.hs+51 src/Rel8/Table/Lifted.hs+57 src/Rel8/Table/List.hs+21−106 src/Rel8/Table/Maybe.hs+90−132 src/Rel8/Table/Name.hs+22−37 src/Rel8/Table/NonEmpty.hs+19−109 src/Rel8/Table/Null.hs−147 src/Rel8/Table/Nullify.hs−211 src/Rel8/Table/Opaleye.hs+73−93 src/Rel8/Table/Ord.hs+49−70 src/Rel8/Table/Order.hs+20−16 src/Rel8/Table/Projection.hs−73 src/Rel8/Table/Recontextualize.hs+218 src/Rel8/Table/Rel8able.hs−92 src/Rel8/Table/Serialize.hs+373−69 src/Rel8/Table/These.hs+108−233 src/Rel8/Table/Transpose.hs−46 src/Rel8/Table/Undefined.hs+6−5 src/Rel8/Table/Window.hs−43 src/Rel8/Tabulate.hs+140−549 src/Rel8/Type.hs+51−26 src/Rel8/Type/Array.hs+36−56 src/Rel8/Type/Array1D.hs+136 src/Rel8/Type/Composite.hs−135 src/Rel8/Type/Enum.hs−139 src/Rel8/Type/Eq.hs+37−6 src/Rel8/Type/Information.hs+34−11 src/Rel8/Type/JSONBEncoded.hs+2−5 src/Rel8/Type/JSONEncoded.hs+13−4 src/Rel8/Type/Monoid.hs+11−8 src/Rel8/Type/Num.hs+2−18 src/Rel8/Type/Ord.hs+13−8 src/Rel8/Type/ReadShow.hs+14−14 src/Rel8/Type/Semigroup.hs+13−10 src/Rel8/Type/String.hs−3 src/Rel8/Type/Sum.hs+3−6 src/Rel8/Type/Tag.hs+1−14 src/Rel8/Window.hs−97 tests/Main.hs+193−341 tests/Rel8/Generic/Rel8able/Test.hs−188
.github/workflows/build.yamldeleted−26
@@ -1,26 +0,0 @@
1−name: Build
2−on: [push, pull_request, release]
3−jobs:
4− build:
5− runs-on: ubuntu-latest
6− steps:
7− - uses: actions/checkout@v2.3.4
8− with:
9− persist-credentials: false
10− submodules: true
11−
12− - uses: cachix/install-nix-action@v14.1
13− with:
14− nix_path: nixpkgs=channel:nixos-unstable
15− extra_nix_config: |
16− trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ=
17− substituters = https://cache.nixos.org/ https://cache.iog.io
18−
19− - uses: cachix/cachix-action@v10
20− with:
21− name: rel8
22− authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}'
23−
24− - run: nix-build -A hsPkgs.rel8.components.library
25− - run: nix-build -A hsPkgs.rel8.checks.tests
26− - run: nix-build shell.nix
Changelog.mddeleted−159
@@ -1,159 +0,0 @@
1−# 1.4.0.0 (2002-08-17)
2−
3−## Breaking changes
4−
5−* The behavior of `greatest`/`least` has been corrected, and was previously flipped. ([#183](https://github.com/circuithub/rel8/pull/183))
6−
7−## New features
8−
9−* `NullTable`/`HNull` have been added. This is an alternative to `MaybeTable` that doesn't use a tag columns. It's less flexible (no `Functor` or `Applicative` instance) and is meaningless when used with a table that has no non-nullable columns (so nesting `NullTable` is redundant). But in situations where the underlying `Table` does have non-nullable columns, it can losslessly converted to and from `MaybeTable`. It is useful for embedding into a base table when you don't want to store the extra tag column in your schema. ([#173](https://github.com/circuithub/rel8/pull/173))
10−* Add `fromMaybeTable`. ([#179](https://github.com/circuithub/rel8/pull/179))
11−* Add `alignMaybeTable`. ([#196](https://github.com/circuithub/rel8/pull/196))
12−
13−## Improvements
14−
15−* Optimize implementation of `AltTable` for `Tabulation` ([#178](https://github.com/circuithub/rel8/pull/178))
16−
17−## Other
18−
19−* Documentation improvements for `HADT`. ([#177](https://github.com/circuithub/rel8/pull/177))
20−* Document example usage of `groupBy`. ([#184](https://github.com/circuithub/rel8/pull/184))
21−* Build with and require Opaleye >= 0.9.3.3. ([#190](https://github.com/circuithub/rel8/pull/190))
22−* Build with `hasql` 1.6. ([#195](https://github.com/circuithub/rel8/pull/195))
23−
24−# 1.3.1.0 (2022-01-20)
25−
26−## Other
27−
28−* Rel8 now requires Opaleye >= 0.9.1. ([#165](https://github.com/circuithub/rel8/pull/165))
29−
30−# 1.3.0.0 (2022-01-31)
31−
32−## Breaking changes
33−
34−* `div` and `mod` have been changed to match Haskell semantics. If you need the PostgreSQL `div()` and `mod()` functions, use `quot` and `rem`. While this is not an API change, we feel this is a breaking change in semantics and have bumped the major version number. ([#155](https://github.com/circuithub/rel8/pull/155))
35−
36−## New features
37−
38−* `divMod` and `quotRem` functions have been added, matching Haskell's `Prelude` functions. ([#155](https://github.com/circuithub/rel8/pull/155))
39−* `avg` and `mode` aggregation functions to find the mean value of an expression, or the most common row in a query, respectively. ([#152](https://github.com/circuithub/rel8/pull/152))
40−* The full `EqTable` and `OrdTable` classes have been exported, allowing for instances to be manually created. ([#157](https://github.com/circuithub/rel8/pull/157))
41−* Added `like` and `ilike` (for the `LIKE` and `ILIKE` operators). ([#146](https://github.com/circuithub/rel8/pull/146))
42−
43−## Other
44−
45−* Rel8 now requires Opaleye 0.9. ([#158](https://github.com/circuithub/rel8/pull/158))
46−* Rel8's test suite supports Hedgehog 1.1. ([#160](https://github.com/circuithub/rel8/pull/160))
47−* The documentation for binary operations has been corrected. ([#162](https://github.com/circuithub/rel8/pull/162))
48−
49−# 1.2.2.0 (2021-11-21)
50−
51−## Other
52−
53−* Support GHC 9.2 ([#145](https://github.com/circuithub/rel8/pull/145))
54−* Correct the documentation for `except` ([#147](https://github.com/circuithub/rel8/pull/147))
55−* Support `hasql` 1.5 ([#149](https://github.com/circuithub/rel8/pull/149))
56−
57−# 1.2.1.0 (2021-11-21)
58−
59−## New features
60−
61−* `castTable` has been added, which casts all columns selected from in `Query` according to the types of columns. This can occasionally be useful when using `many`/`some` on older PostgreSQL versions. ([#137](https://github.com/circuithub/rel8/pull/137))
62−
63−* Added `<:`, `<=:`, `>:`, `>=:`, `greatest` and `least`, which sort all columns in a table lexicographically. These operators are like the `<.` operators which operate on `Expr`s, but the `<:` operate on entire tables. ([#139](https://github.com/circuithub/rel8/pull/139))
64−
65−## Other
66−
67−* Support opaleye-0.8 ([#142](https://github.com/circuithub/rel8/pull/142))
68−
69−# 1.2.0.0 (2021-10-22)
70−
71−## New features
72−
73−* New `$*` and `$+` operators for projecting out of `ListTable` and `NonEmptyTable` respectively (analogous to the existing `$?` for `MaybeTable`). ([#125](https://github.com/circuithub/rel8/pull/125))
74−
75−## Bug fixes
76−
77−* Fix `UPSERT` support (and add tests), which was broken due to a typo inside Rel8 that made it impossible to construct `Projection`s which are needed by `UPSERT`. ([#134](https://github.com/circuithub/rel8/pull/134))
78−
79−* Remove `DBMin` and `DBMax` instances for `Bool`, which are invalid as far as Postgres is concerned. `and` and `or` can be used to achieve the same thing. ([#126](https://github.com/circuithub/rel8/pull/126))
80−
81−* Fix `aggregateMaybeTable`, `aggregateEitherTable` and `aggregateTheseTable`, which generated invalid SQL previously. ([#127](https://github.com/circuithub/rel8/pull/127))
82−
83−## Breaking changes
84−
85−* `rebind` now takes an additional argument for the "name" of the binding. ([#128](https://github.com/circuithub/rel8/pull/128))
86−
87−# 1.1.0.0 (2021-07-16)
88−
89−## New features
90−
91−* You can derive `Rel8able` for "vanilla" higher-kinded data types - data types that don't use the `Column` type family. For example, the following is now possible:
92−
93− ```haskell
94− data MyTable f = MyTable
95− { myTableX :: f Int32
96− , myTableY :: f Text
97− } deriving (Generic, Rel8able)
98− ```
99−
100−* The `Projectable` and `Biprojectable` type classes have been introduced. These classes model a type of functors and bifunctors (respectively) on tables, where the mapping function is only able to rearrange columns. For example, the following is now possible:
101−
102− ```haskell
103− x <- project myTableX <$> many ...
104− ```
105−
106−* `Insert`'s `onConflict` field now has a new option - `DoUpdate`. This maps to PostgreSQL's `ON CONFLICT DO UPDATE` syntax, which provides upsert support. ([#85](https://github.com/circuithub/rel8/pull/85))
107−
108−* `Insert`, `Update` and `Delete` has all been expanded to work with `Query`s. In particular:
109−
110− * `Delete` now supports a `USING` sub-query
111− * `Update` now supports a `FROM` sub-query
112− * `Insert` can delete the result of any arbitrary `Query` (providing the types match)
113−
114−* The new `Rel8.Tabulate` module has been added, which gives a `Map`-esque interface to writing and composing queries. ([#70](https://github.com/circuithub/rel8/pull/70))
115−
116−* The new `indexed` `Query -> Query` function was added. This function augments each row in a query with it's 0-based index. ([#117](https://github.com/circuithub/rel8/pull/117))
117−
118−## Breaking changes
119−
120−* `Insert`, `Delete` and `Update` have all changed. In particular, for `Insert` users should now replace `rows = xs` with `rows = values xs`. ([#85](https://github.com/circuithub/rel8/pull/85))
121−
122−* Rename `whereExists` and `whereNotExists` to `present` and `absent` respectively. ([#57](https://github.com/circuithub/rel8/pull/57))
123−
124−* Simplify `evaluate` to run directly inside the `Query` monad, rendering the `Evaluate` monad unnecessary. ([#56](https://github.com/circuithub/rel8/pull/56))
125−
126−* The `Labelable` type class has been removed as it's no longer necessary. This class was mostly internal, though was visible in some public API functions. ([#76](https://github.com/circuithub/rel8/pull/76))
127−
128−* `EitherTable`, `ListTable`, `MaybeTable`, `NonEmptyTable` and `TheseTable` now all have an extra parameter which tracks the context of the table. If you manually specified any types before, you need to provide this parameter - usually `Expr` will be the correct choice. ([#101](https://github.com/circuithub/rel8/pull/101))
129−
130−* We've done a lot of work to simplify the internals of Rel8, but some of these are breaking changes. However, most of these API changes shouldn't affect users as they are mostly types used in type inference, or affect classes where users don't need to define their own instances.
131−
132− * The kind of a `Rel8able` is now `(Type -> Type) -> Type`. Previously it was `(X -> Type) -> Type`.
133− * `Table` has a new associated type - `FromExprs`. This was previously an open type family.
134− * `Table` has a new associated type - `Transpose` - and `Recontextualise` has been renamed to `Transposes`. This `Transposes` class now operates in terms of `Transpose`.
135−
136−* `select`, `insert`, `update` and `delete` now produce Hasql `Statement`s, rather than actually running the statement as IO. This allows Rel8 to be used with transaction/connection-managing monads like [`hasql-transaction`](https://hackage.haskell.org/package/hasql-transaction). ([#94](https://github.com/circuithub/rel8/pull/94))
137−
138−## Bug fixes
139−
140−* Fixes a bug where cartesian products of queries using `catListTable`, `catNonEmptyTable`, `catList` and `catNonEmpty` would incorrectly be zipped instead. ([#61](https://github.com/circuithub/rel8/pull/61))
141−
142−* Require Opaleye 0.7.3.0. This version has better support for lateral queries, which can improve query plans, especially in `optional`/`LEFT JOIN` ([#72](https://github.com/circuithub/rel8/pull/72))
143−
144−* Rel8 now compiles with GHC 9. ([#97](https://github.com/circuithub/rel8/pull/97))
145−
146−## Other changes
147−
148−* `exists` is now implemented in terms of the SQL `EXISTS` keyword. ([#69](https://github.com/circuithub/rel8/pull/69))
149−
150−* `alignBy` no longer requires `Table`s. ([#67](https://github.com/circuithub/rel8/pull/67))
151−
152−
153−# 1.0.0.1 (2021-06-21)
154−
155−This release contains various fixes for documentation.
156−
157−# 1.0.0.0 (2021-06-18)
158−
159−* Initial release.
Doctest.hsnew file+53
@@ -0,0 +1,53 @@
1+{-# language BlockArguments #-}
2+{-# language OverloadedStrings #-}
3+
4+module Main where
5+
6+-- base
7+import Control.Exception ( bracket, throwIO )
8+import Data.Foldable ( traverse_ )
9+import System.Environment ( lookupEnv, setEnv )
10+
11+-- base-compat
12+import System.Environment.Compat ( unsetEnv )
13+
14+-- bytestring
15+import Data.ByteString.Char8 ( unpack )
16+
17+-- doctest
18+import Test.DocTest ( doctest )
19+
20+-- hasql
21+import Hasql.Connection ( acquire, release )
22+import Hasql.Session ( run, sql )
23+
24+-- rel8
25+import Build_doctests ( flags, module_sources, pkgs )
26+
27+-- tmp-postgres
28+import Database.Postgres.Temp ( toConnectionString, verboseConfig, with, withConfig )
29+
30+
31+main :: IO ()
32+main = do
33+ nixGhcLibdir <- lookupEnv "NIX_GHC_LIBDIR"
34+ unsetEnv "GHC_ENVIRONMENT"
35+ either throwIO return =<< with \db -> do
36+ setEnv "TEST_DATABASE_URL" (unpack (toConnectionString db))
37+ bracket (either (error . show) return =<< acquire (toConnectionString db)) release \conn -> do
38+ flip run conn do
39+ sql "create table author ( author_id serial primary key, name text not null, url text )"
40+ sql "create table project ( author_id int not null references author (author_id), name text not null )"
41+
42+ sql "insert into author ( name, url ) values ( 'Ollie', 'https://ocharles.org.uk' )"
43+ sql "insert into author ( name, url ) values ( 'Bryan O''Sullivan', null )"
44+ sql "insert into author ( name, url ) values ( 'Emily Pillmore', 'https://cohomolo.gy' )"
45+ sql "insert into project ( author_id, name ) values ( 1, 'rel8' )"
46+ sql "insert into project ( author_id, name ) values ( 2, 'aeson' )"
47+ sql "insert into project ( author_id, name ) values ( 2, 'text' )"
48+
49+ doctest (args nixGhcLibdir)
50+
51+ where
52+ args nixGhcLibdir =
53+ flags ++ pkgs ++ foldMap (\x -> ["-package-db" <> x <> "/package.conf.d"]) nixGhcLibdir ++ module_sources
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright 2021 Oliver Charles
1+Copyright 2020 Oliver Charles
22
33All rights reserved.
44
README.mddeleted−17
@@ -1,17 +0,0 @@
1−# Welcome!
2−
3−Welcome to Rel8! Rel8 is a Haskell library for interacting with PostgreSQL databases, built on top of the fantastic Opaleye library.
4−
5−The main objectives of Rel8 are:
6−
7−* *Conciseness*: Users using Rel8 should not need to write boiler-plate code. By using expressive types, we can provide sufficient information for the compiler to infer code whenever possible.
8−
9−* *Inferrable*: Despite using a lot of type level magic, Rel8 aims to have excellent and predictable type inference.
10−
11−* *Familiar*: writing Rel8 queries should feel like normal Haskell programming.
12−
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−
17−For more details, check out the [official documentation](https://rel8.readthedocs.io/en/latest/).
Setup.hsnew file+6
@@ -0,0 +1,6 @@
1+module Main where
2+
3+import Distribution.Extra.Doctest (defaultMainWithDoctests)
4+
5+main :: IO ()
6+main = defaultMainWithDoctests "doctests"
cabal.project.haskell-nixdeleted−4
@@ -1,4 +0,0 @@
1−-- Haskell.nix overrides. We don't put these in cabal.project, because Cabal
2−-- will interpret them as local packages, and try to build them when we cabal
3−-- build. The only reason we have to specify these is for Haskell.nix to know to
4−-- override these packages by fetching them rather than using Hackage.
default.nix+5−7
@@ -1,26 +1,24 @@
1−let
1+let
22 haskellNix = import (import ./nix/sources.nix)."haskell.nix" {};
33
4− nixpkgsSrc = haskellNix.sources.nixpkgs-unstable;
4+ nixpkgsSrc = haskellNix.sources.nixpkgs-2009;
55
66 nixpkgsArgs = haskellNix.nixpkgsArgs;
77
8− compiler-nix-name = "ghc924";
8+ compiler-nix-name = "ghc8103";
99
1010 pkgs = import nixpkgsSrc nixpkgsArgs;
1111
12−in
12+in
1313pkgs.haskell-nix.project {
1414 inherit compiler-nix-name;
1515
16− cabalProjectLocal = builtins.readFile ./cabal.project.haskell-nix;
17−
1816 src = pkgs.haskell-nix.haskellLib.cleanGit {
1917 name = "rel8";
2018 src = ./.;
2119 };
2220
23− modules = [
21+ modules = [
2422 { packages.rel8 = {
2523 preCheck = ''
2624 export PATH="${pkgs.postgresql}/bin:${"$PATH"}"
docs/Makefiledeleted−19
@@ -1,19 +0,0 @@
1−# Minimal makefile for Sphinx documentation
2−#
3−
4−# You can set these variables from the command line.
5−SPHINXOPTS =
6−SPHINXBUILD = sphinx-build
7−SOURCEDIR = .
8−BUILDDIR = _build
9−
10−# Put it first so that "make" without argument is like "make help".
11−help:
12− @$(SPHINXBUILD) -M help "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O)
13−
14−.PHONY: help Makefile
15−
16−# Catch-all target: route all unknown targets to Sphinx using the new
17−# "make mode" option. $(O) is meant as a shortcut for $(SPHINXOPTS).
18−%: Makefile
19− @$(SPHINXBUILD) -M $@ "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O)
docs/concepts/dbtype.rstdeleted−175
@@ -1,175 +0,0 @@
1−``DBType``
2−==========
3−
4−The ``DBType`` type class provides a bridge between database expression values
5−and Haskell values. Rel8 comes with stock instances for most types that come
6−predefined with PostgreSQL, such as `int4` (which is represented as by
7−``Data.Int.Int32``) and timestamptz (which is ``UTCTime`` from ``Data.Time``).
8−This means that you need at least one ``DBType`` instance per database type,
9−though most of these primitive ``DBType``\s should already be available.
10−
11−Combining ``newtype`` and ``DBType``
12−------------------------------------
13−
14−You can define new instances of ``DBType`` by using Haskell "generalized
15−newtype deriving" strategy. This is useful when you have a common database
16−type, but need to interpret this type differently in different contexts. A very
17−common example here is with auto-incrementing ``id`` counters. In PostgreSQL,
18−it's common for a table to have a primary key that uses the ``serial`` type,
19−which means the key is an ``int8`` with a default value for ``INSERT``. In
20−Rel8, we could use ``Int64`` (as ``Int64`` is the ``DBType`` instance for
21−``int8``), but we can be even clearer if we make a ``newtype`` for each *type*
22−of id.
23−
24−If our database has users and orders, these tables might both have ids, but
25−they are clearly not meant to be treated as a common type. Instead, we can make
26−these types clearly different by writing::
27−
28− newtype UserId = UserId { getUserId :: Int64 }
29− deriving newtype DBType
30−
31− newtype OrderId = OrderId { getOrderId :: Int64 }
32− deriving newtype DBType
33−
34−Now we can use ``UserId`` and ``OrderId`` in our Rel8 queries and definitions,
35−and Haskell will make sure we don't accidentally use an ``OrderId`` when we're
36−looking up a user.
37−
38−If you would like to use this approach but can't use generalized newtype
39−deriving, the same can be achived by using ``mapTypeInformation``::
40−
41− instance DBType UserId where
42− typeInformation = mapTypeInformation UserId getUserId typeInformation
43−
44−Parsing with ``DBType``
45−-----------------------
46−
47−``DBType``\s can also *refine* database types with parsing, which allows you to
48−map more structured Haskell types to a PostgreSQL database. This allows you to
49−use the capabalities of Haskell's rich type system to make it harder to write
50−incorrect queries. For example, we might have a database where we need to store
51−the status of an order. In Haskell, we might write:
52−
53−.. code-block:: haskell
54−
55− data OrderStatus = PaymentPending | Paid | Packed | Shipped
56−
57−In our PostgreSQL we have a few choices, but for now we'll assume that they are
58−stored as ``text`` values.
59−
60−In order to use this type in Rel8 queries, we need to write an instance of
61−``DBType`` for ``OrderStatus``. One approach is to use
62−``parseTypeInformation``, which allows you to refine an existing ``DBType``::
63−
64− instance DBType OrderStatus where
65− typeInformation = parseTypeInformation parser printer typeInformation
66− where
67− parser :: Text -> Either String OrderStatus
68− parser "PaymentPending" = Right PaymentPending
69− parser "Paid" = Right Paid
70− parser "Packed" = Right Packed
71− parser "Shipped" = Right Shipped
72− parser other = Left $ "Unknown OrderStatus: " <> unpack other
73−
74− printer :: OrderStatus -> Text
75− printer PaymentPending = "PaymentPending"
76− printer Paid = "Paid"
77− printer Packed = "Packed"
78− printer Shipped = "Shipped"
79−
80−Deriving ``DBType`` via ``ReadShow``
81−------------------------------------
82−
83−The ``DBType`` definition for ``OrderStatus`` above is a perfectly reasonable
84−definition, though it is quite verbose and tedious. Rel8 makes it easy to map
85−Haskell types that are encoded using ``Read``/``Show`` via the ``ReadShow``
86−wrapper. An equivalent ``DBType`` definition using ``ReadShow`` is::
87−
88− data OrderStatus = PaymentPending | Paid | Packed | Shipped
89− deriving stock (Read, Show)
90− deriving DBType via ReadShow OrderStatus
91−
92−Storing structured data with ``JSONEncoded``
93−--------------------------------------------
94−
95−It can occasionally be useful to treat PostgreSQL more like a document store,
96−storing structured documents as JSON objects. Rel8 comes with support for
97−serializing values into structured representations through the ``JSONEncoded``
98−and ``JSONBEncoded`` deriving-via helpers.
99−
100−There usage is very similar to ``ReadShow`` - simply derive ``DBType via
101−JSONEncoded``, and Rel8 will use ``ToJSON`` and ``FromJSON`` instances (from
102−``aeson``) to serialize the given type.
103−
104−For example, a project might use event sourcing with a table of events. Each
105−row in this table is an event, but this event is stored as a JSON object. We
106−can use this type with Rel8 by writing::
107−
108− data Event = UserCreated UserCreatedData | OrderCreated OrderCreatedData
109− deriving stock Generic
110− deriving anyclass (ToJSON, FromJSON)
111− deriving DBType via JSONBEncoded Event
112−
113−Here we used ``JSONBEncoded``, which will serialize to PostgreSQL ``jsonb``
114−(binary JSON) type, which is generally the best choice.
115−
116−The ``DBType`` subtypes
117−-----------------------
118−
119−``DBEq``
120−^^^^^^^^
121−
122−The ``DBEq`` type class represents the subclass of database types that support
123−equality. By supporting equality, we mean that a type supports the ``=``
124−operator, and also has a suitable notion of equality for operations like
125−``GROUP BY`` and ``DISTINCT``. On the one hand, this class is like Haskell's
126−``Eq`` type class. The main difference is that this class has no methods.
127−
128−``DBOrd``
129−^^^^^^^^^
130−
131−The ``DBOrd`` type class represents the subclass of database types that support
132−the normal comparison operators - ``<``, ``<=``, ``>=`` and ``>``.
133−
134−``DBMax`` and ``DBMin``
135−^^^^^^^^^^^^^^^^^^^^^^^
136−
137−The type classes indicate that a database type supports the ``min()`` and
138−``max()`` aggregation functions.
139−
140−``DBSemigroup`` and ``DBMonoid``
141−^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
142−
143−These type classes exist to give Rel8's API a similar feel to Haskell
144−programming. Many database types have a sensible monoid structure, with the
145−presence of a ``mempty``-like expression, and an associative operation to
146−combine ``Expr``\s.
147−
148−``DBNum``, ``DBIntegral`` and ``DBFractional``
149−^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
150−
151−These type classes are used to present a familiar numeric type hierarchy for
152−Haskell programmers.
153−
154−``DBNum``
155− This class indicates that a type supports the ``+``, ``-``, and ``*``
156− operators, along with the ``abs()``, ``negate()`` and ``sign()`` functions.
157− Database types that are instances of ``DBNum`` allow ``Num (Expr a)`` to be
158− used (allowing you to combine expressions with Haskell's normal ``+``
159− function).
160−
161−``DBIntegral``
162− If a type is an instance of ``DBIntegral``, it means that the type stores
163− integral (whole) numbers. The ``Rel8.Expr.Num`` module provides familiar
164− ``Expr`` functions like ``fromIntegral`` to convert between types.
165−
166−``DBFractional``
167− If a type is an instance of ``DBFraction``, it means that the type supports
168− the ``/`` operator, and literals can be created via Haskell's ``Rational``
169− type class. This type class provides the ``Fracitonal (Expr a)`` instance.
170−
171−``DBString``
172−^^^^^^^^^^^^
173−
174−This type class indicates that a database type supports the ``string_agg()``
175−aggregation function.
docs/concepts/expr.rstdeleted−74
@@ -1,74 +0,0 @@
1−``Expr`` and ``Sql``
2−====================
3−
4−``Expr``
5−--------
6−
7−Now that we've seen how types are bridged between a database and Haskell via
8−``DBType``, we can start looking at how expressions are modelled. In Rel8, any
9−expression will be a value of the form ``Expr a``, where ``a`` is the type of
10−the expression. For example, the SQL expression ``user.id = 42`` is an ``Expr
11−Bool``, and the subexpressions ``user.id`` and ``42`` might be ``Expr
12−UserId``\s.
13−
14−``Expr``\s are usually created by combining other ``Expr``\s together, like
15−using numeric operations like `+` and `*`, or by quoting Haskell values into
16−queries with ``lit``. Continuing with the example of ``user.id = 42``, we can
17−write this in Rel8 as::
18−
19− userId ==. lit (UserId 42)
20−
21−Here it's assumed that a ``userId :: Expr UserId`` expression is already in
22−scope, and we can compare that against another ``Expr UserId`` using the ``==.``
23−operator (which is like Haskell's normal ``==`` operator, but lifted to work on
24−``Expr``). The expression ``lit (UserId 42)`` quotes the Haskell term ``UserId
25−42`` literally as the SQL expression ``42``. This particular encoding is chosen
26−because ``UserId`` is simply a ``newtype`` around ``Int64``.
27−
28−``null``
29−--------
30−
31−So far we've only talked about ``DBType``, which represents database types
32−*excluding* ``null``. Rel8 chooses this encoding because ``null`` is rather
33−special in SQL, and doesn't really constitute a distinct type. For example,
34−there is no SQL notion of "stacking" nulls - which is to say a type like ``Maybe
35−(Maybe UserId))`` has no real analogous type in SQL.
36−
37−Of course, as ``null`` is pervasive in SQL queries, Rel8 does support ``null`` -
38−simply wrap up your type in ``Maybe``. ``Nothing`` will be translated as
39−``null``, and ``Just`` is used to represent non-null values.
40−
41−Rel8 comes with a set of functions to work with ``null`` values thash should
42−feel familiar to Haskell programmers:
43−
44−* ``null`` creates null values (you can also use ``lit Nothing``).
45−* ``nullify`` turns an ``Expr a`` into a ``Expr (Maybe a)`` (like ``Just``).
46−* ``nullable`` allows you to eliminate null values, like the ``maybe`` function.
47−* ``isNull`` and ``isNonNull`` work like ``isNothing`` and ``isJust``,
48− respectively.
49−* ``mapNullable`` is like ``fmap`` for ``Maybe``, and allows you to map over
50− non-null values.
51−* ``liftOpNullable`` is like ``liftA2`` for ``Maybe``, and allows you to combine
52− expressions together, given a way to combine non-null expressions.
53−
54−``SQL`` and null-polymorphic expressions
55−----------------------------------------
56−
57−Through the API reference documentation for Rel8, you might encounter the
58−``Sql`` type class. For example, if we look at the type of ``litExpr``, we
59−have::
60−
61− litExpr :: Sql DBType a => a -> Expr a
62−
63−Here ``Sql DBType a`` means that ``a`` can either be literally a type that has
64−an instance of ``DBType`` (like ``UserId`` or ``Bool``), *or* that same type
65−wrapped in ``Maybe`` (so ``Maybe UserId`` or ``Maybe Bool``). ``Maybe`` here
66−encodes the SQL concept of ``null``.
67−
68−Some functions work regardless of whether or not a value is null, and in these
69−cases you'll see ``Sql DBType a``. ``Sql`` can be used with any ``DBType``
70−subtype. For example, the type of ``div`` is::
71−
72− div :: Sql DBIntegral a => Expr a -> Expr a -> Expr a
73−
74−Which means ``div`` works on any ``DBIntegral a``, including ``Maybe a``.
docs/concepts/insert.rstdeleted−181
@@ -1,181 +0,0 @@
1−``INSERT``, ``UPDATE`` and ``DELETE``
2−=====================================
3−
4−While the majority of Rel8 is about building and executing ``SELECT``
5−statement, Rel8 also has support for ``INSERT``, ``UPDATE`` and ``DELETE``.
6−These statements are all executed using the ``insert``, ``update`` and
7−``delete`` functions, all of which take a record of parameters.
8−
9−.. note::
10−
11− This part of Rel8's API uses the ``DuplicateRecordFields`` language
12− extension. In code that needs to use this API, you should also enable this
13− language extension, or you may get errors about ambiguous field names.
14−
15−``DELETE``
16−----------
17−
18−To perform a ``DELETE`` statement, construct a ``Delete`` value and execute it
19−using ``delete``. ``Delete`` takes:
20−
21−``from``
22− The ``TableSchema`` for the table to delete rows from.
23−
24−``using``
25− This is a simple ``Query`` that forms the ``USING`` clause of the ``DELETE``
26− statement. This can be used to join against other tables, and the results
27− can be referenced in the ``deleteWhere`` parameter. For simple ``DELETE``\s
28− where you don't need to do this, you can set ``using = pure ()``.
29−
30−``deleteWhere``
31− The ``WHERE`` clause of the ``DELETE`` statement. This is a function that
32− takes two inputs: the result of the ``using`` query, and the current value
33− of the row.
34−
35−``returning``
36− What to return - see :ref:`returning`.
37−
38−``UPDATE``
39−----------
40−
41−To perform a ``UPDATE`` statement, construct a ``Update`` value and execute it
42−using ``update``. ``Update`` takes:
43−
44−``target``
45− The ``TableSchema`` for the table to update rows in.
46−
47−``from``
48− This is a simple ``Query`` that forms the ``FROM`` clause of the ``UPDATE``
49− statement. This can be used to join against other tables, and the results
50− can be referenced in the ``set`` and ``updateWhere`` parameters. For simple
51− ``UPDATE``\s where you don't need to do this, you can set ``from = pure ()``.
52−
53−``set``
54− A row to row transformation function, indicating how to update selected rows.
55− This function takes rows of the same shape as ``target`` but in the ``Expr``
56− context. One way to write this function is to use record update syntax::
57−
58− set = \from row -> row { rowName = "new name" }
59−
60−``updateWhere``
61− The ``WHERE`` clause of the ``UPDATE`` statement. This is a function that
62− takes two inputs: the result of the ``from`` query, and the current value of
63− the row.
64−
65−``returning``
66− What to return - see :ref:`returning`.
67−
68−``INSERT``
69−----------
70−
71−To perform a ``INSERT`` statement, construct a ``Insert`` value and execute it
72−using ``insert``. ``Insert`` takes:
73−
74−``into``
75− The ``TableSchema`` for the table to insert rows into.
76−
77−``rows``
78− The rows to insert. These are the same as ``into``, but in the ``Expr``
79− context. You can construct rows from their individual fields::
80−
81− rows = values [ MyTable { myTableA = lit "A", myTableB = lit 42 }
82−
83− or you can use ``lit`` on a table value in the ``Result`` context::
84−
85− rows = values [ lit MyTable { myTableA = "A", myTableB = 42 }
86−
87−``onConflict``
88− What should happen if an insert clashes with rows that already exist. This
89− corresponds to PostgreSQL's ``ON CONFLICT`` clause. You can specify:
90−
91− ``Abort``
92− PostgreSQL should abort the ``INSERT`` with an exception
93−
94− ``DoNothing``
95− PostgreSQL should not insert the duplicate rows.
96−
97− ``DoUpdate``
98− PostgreSQL should instead try to update any existing rows that conflict
99− with rows proposed for insertion.
100−
101−``returning``
102− What to return - see :ref:`returning`.
103−
104−.. _returning:
105−
106−``RETURNING``
107−-------------
108−
109−PostgreSQL has the ability to return extra information after a ``DELETE``,
110−``INSERT`` or ``UPDATE`` statement by attaching a ``RETURNING`` clause. A common
111−use of this clause is to return any automatically generated sequence values for
112−primary key columns. Rel8 supports ``RETURNING`` clauses by filling in the
113−``returning`` field and specifying a ``Projection``. A ``Projection`` is a row
114−to row transformation, allowing you to project out a subset of fields.
115−
116−For example, if we are inserting orders, we might want the order ids returned::
117−
118− insert Insert
119− { into = orderSchema
120− , rows = values [ order ]
121− , onConflict = Abort
122− , returning = Projection orderId
123− }
124−
125−If we don't want to return anything, we can use ``pure ()``::
126−
127− insert Insert
128− { into = orderSchema
129− , rows = values [ order ]
130− , onConflict = Abort
131− , returning = pure ()
132− }
133−
134−Default values
135−--------------
136−
137−It is fairly common to define tables with default values. While Rel8 does not
138−have specific functionality for ``DEFAULT``, there are a few options:
139−
140−``unsafeDefault``
141−~~~~~~~~~~~~~~~~~~~~~~~~~~~
142−
143−Rel8 does not have any special support for ``DEFAULT``. If you need to use
144−default column values in inserts, you can use ``unsafeDefault`` to
145−construct the ``DEFAULT`` expression::
146−
147− insert Insert
148− { into = orderSchema
149− , rows = values [ Order { orderId = unsafeDefault, ... } ]
150− , onConflict = Abort
151− , returning = Projection orderId
152− }
153−
154−.. warning::
155− As the name suggests, this is an unsafe operation. In particular, Rel8 is not
156− able to prove that this column does have a default value, so it may be
157− possible to introduce a runtime error. Furthermore, ``DEFAULT`` is fairly
158− special in SQL, and cannot be combined like other expressions. For example,
159− the innocuous expression::
160−
161− unsafeDefault + 1
162−
163− will lead to a runtime crash.
164−
165−Reimplement default values in Rel8
166−~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
167−
168−If you only need to access default values in Rel8, another option is to specify
169−them in Rel8, rather than in your database schema.
170−
171−.. hint::
172− A common default value for primary keys is to use `nextval` to obtain the
173− next value from a sequence. This can be done in Rel8 by using the ``nextval``
174− function::
175−
176− insert Insert
177− { into = orderSchema
178− , rows = values [ Order { orderId = nextval "order_id_seq", ... } ]
179− , onConflict = Abort
180− , returning = Projection orderId
181− }
docs/concepts/queries.rstdeleted−274
@@ -1,274 +0,0 @@
1−Writing queries with ``Query``
2−==============================
3−
4−To fetch data from a database, Rel8 allows you to write ``SELECT`` queries using
5−the ``Query`` monad. While this monad might look a little different from
6−ordinary SQL, it is equal in expressivity, but due to Haskell's ``do`` notation
7−we get to benefit from all the means of abstraction available.
8−
9−Understanding the ``Query`` monad
10−---------------------------------
11−
12−Before we look at special functions for working with ``Query``, we'll first take
13−a moment to understand how the ``Query`` monad works. First, what does the type
14−``Query a`` *mean*? To be a ``Query a`` means to be a SQL ``SELECT`` query that
15−selects rows of type ``a``. Usually ``a`` will be an instance of ``Table Expr``,
16−such as ``Expr Text``, or maybe ``BlogPostComment Expr``.
17−
18−As ``Query`` is an instance of ``Monad`` means that we already have three
19−familiar APIs to work with: ``Functor``, ``Applicative``, and ``Monad``.
20−
21−``Functor Query``
22−^^^^^^^^^^^^^^^^^
23−
24−The ``Functor`` instance gives us access to ``fmap``, and its type is::
25−
26− fmap :: (a -> b) -> Query a -> Query b
27−
28−``fmap`` uniformly transforms rows of one type into rows of another type. In
29−SQL, this is corresponds to a *projection*. For example, if we have a ``Query
30−(User Expr)``, we might do ``fmap userId`` to transform this into a ``Query
31−(Expr UserId)``.
32−
33−``Applicative Query``
34−^^^^^^^^^^^^^^^^^^^^^
35−
36−The ``Applicative`` instance for ``Query`` gives us::
37−
38− pure :: a -> Query a
39− (<*>) :: Query (a -> b) -> Query a -> Query b
40−
41−``pure`` constructs a ``Query`` that returns exactly one row - a row containing
42−the ``a`` that was given. This might seem fairly pointless, but it's an
43−important ``Query`` when compared with ``(<*>)``. The ``<*>`` combines two
44−``Query``\s by taking their *cartesian product*, followed by a projection that
45−combines each row into a new row.
46−
47−One example of using the ``Applicative`` operators is to combine two ``Query``\s
48−into a tuple::
49−
50− pure (,) <*> queryA <*> queryB
51−
52−``Monad Query``
53−^^^^^^^^^^^^^^^
54−
55−The final type class to discuss is ``Monad Query``. ``Monad Query`` has two
56−methods::
57−
58− return :: a -> Query a
59− (>>=) :: Query a -> (a -> Query b) -> Query b
60−
61−``return`` is the same ``pure``, so we won't discuss this further. The much more
62−interesting operation is ``>>=`` - commonly referred to as "bind". This operator
63−allows you to *extend* a ``Query`` with a new query. In SQL this is also similar
64−to a cartesian product, but uses the ``LATERAL`` modifier to allow the second
65−query to refer to columns from the first.
66−
67−This extension operator allows you to expand each row in the first query into
68−zero, one, or many rows, according to the given function. For example, if we
69−have a database of orders, we might write::
70−
71− getAllOrders >>= \order -> getUserById (orderUserId order)
72−
73−This ``Query`` will return, for each ``Order``, the ``User`` who placed that
74−order. In this case, this is a one-to-one relationship, so we get back exactly
75−as many rows as there are orders.
76−
77−Going in the other direction, we have::
78−
79− getAllUsers >>= \user -> getOrdersForUser (userId user)
80−
81−This is a different query, as we start by fetching all ``User``\s, and for each
82−user find all ``Order``\s they have placed. This ``Query`` has a different
83−cardinality, as we're following a one-to-many relationship: any ``User`` may
84−have zero, one, or many orders.
85−
86−Haskell has special syntax for working with monads - ``do`` notation. ``do``
87−notation allows you to write these queries in a simpler form, where we don't
88−have to introduce functions. Expanding on the latter query, we could write::
89−
90− do user <- getAllUsers
91− order <- getOrdersForUser user
92− return (user, order)
93−
94−Now we have a query that, for each ``User``, fetches all orders for that user.
95−The final ``return`` means that for each ``User`` and ``Order``, we'll return a
96−single row.
97−
98−Selecting rows from tables
99−--------------------------
100−
101−With the more theoretical side of ``Query`` considered, we can start looking at
102−the more pragmatic side, and how ``Query`` can express some common SQL idioms.
103−
104−First, one of the most common operations is to select all rows from a *base
105−table*. In SQL, this is a ``SELECT * FROM x`` query, and in Rel8 we use ``each``
106−with a ``TableSchema``.
107−
108−Limit and offset
109−----------------
110−
111−The SQL ``LIMIT`` and ``OFFSET`` keywords are available in Rel8 as ``limit``
112−and ``offset``. Note that, like SQL, the order of these operations matters.
113−Usually, the correct thing to do is to first apply an offset with ``offset``,
114−and then use ``limit`` to limit the number of rows returned::
115−
116− limit n . offset m . orderBy anOrdering
117−
118−These operations are similar to Haskell's ``take`` and ``drop`` operations.
119−
120−Filtering queries
121−-----------------
122−
123−Rel8 offers a few different ways to filter the rows selected by a query.
124−Perhaps the most familiar operation is to apply a ``WHERE`` clause to a query.
125−In Rel8, this is done using ``where_``, which takes any ``Expr Bool``, and
126−returns rows where that ``Expr`` is true. For example, to select all public
127−blog posts, we could write::
128−
129− blogPost <- each blogPostSchema
130− where_ $ blogPostIsPublic blogPost
131−
132−An alternative way to write ``WHERE`` clauses is to use ``filter``. This
133−operator is similar to the ``guard`` function in ``Control.Monad``, but also
134−returns the tested row. This allows us to easily chain a filtering operation on
135−a query. The above query could thus be written as::
136−
137− blogPost <- filter blogPostIsPublic =<< each blogPostSchema
138−
139−``where_`` and ``filter`` allow you to filter rows based on an expression, but
140−sometimes we want to filter based on another query. For this, Rel8 offers
141−``present`` and ``absent``. For example, if all blog posts have a
142−list of tags, we could use ``present`` to find all blog posts that have been
143−tagged as "Haskell"::
144−
145− blogPost <- each blogPostSchema
146− present do
147− filter (("Haskell" ==.) . tagName) =<< tagFromBlogPost blogPost
148−
149−Notice that this example uses ``present`` with a query that itself uses
150−``filter``. For each blog post, ``present`` causes that row to be selected
151−only if the associated query finds a tag for that blog post with the ``tagName``
152−"Haskell".
153−
154−Like ``filter`` there is also a chaining variant of ``present`` - ``with``.
155−We could rewrite the above query using ``with`` as::
156−
157− haskellBlogPost <-
158− each blogPostSchema >>=
159− with (filter (("Haskell" ==.) . tagName) <=< tagFromBlogPost)
160−
161−Inner joins
162−-----------
163−
164−Inner joins are SQL queries of the form ``SELECT .. FROM x JOIN y ON ..``. Rel8
165−doesn't offer a special function for these queries, as the same query can be
166−expressed by selecting from two tables (this is called taking the *cartesian
167−product* of two queries) and then filtering the result.
168−
169−If we wanted to join each blog post with the author of the blog post, we would
170−write the SQL::
171−
172− SELECT * FROM blog_post JOIN author ON author.id = blog_post.id
173−
174−The alternative way to write this query with ``WHERE`` is::
175−
176− SELECT * FROM blog_post, author WHERE author.id = blog_post.id
177−
178−and this query can be written in Rel8 as::
179−
180− blogPost <- each blogPostSchema
181− author <- each authorSchema
182− where_ $ blogPostAuthorId blogPost ==. authorId author
183−
184−.. hint::
185−
186− A good pattern to adopt is to abstract out these joins as functions. A
187− suggested way to write the above would be to extract out an "author for blog
188− post" function::
189−
190− blogPost <- each blogPostSchema
191− author <- authorForBlogPost blogPost
192−
193− where::
194−
195− authorForBlogPost :: BlogPost Expr -> Query (Author Expr)
196− authorForBlogPost blogPost =
197− filter ((blogPostAuthorId blogPost ==.) . authorId) =<<
198− each authorSchema
199−
200− While this is a little more code over all, in our experience this style
201− dramatically increases the readability of queries using joins.
202−
203−Left (outer) joins with ``optional``
204−------------------------------------
205−
206−A left join is like an inner join, but allows for the possibility of the join to
207−"fail". You use left joins when you want to join optional information against a
208−row.
209−
210−In Rel8, a ``LEFT JOIN`` is introduced by converting an inner join with
211−``optional``. While this approach might seem a little foreign at first, it has a
212−strong similarity with the ``Control.Applicative.optional`` function, and allows
213−you to reuse previous code.
214−
215−To see an example of this, let's assume that we want to get the latest comment
216−for each blog post. Not all blog posts are popular though, so some blog posts
217−might have no comment at all. To write this in Rel8, we could write::
218−
219− blogPost <- each blogPostSchema
220−
221− latestComment <-
222− optional $ limit 1 $
223− orderBy (commentCreatedAt >$< desc) $
224− commentsForBlogPost blogPost
225−
226−``optional`` will transform a ``Query a`` into a ``Query (MaybeTable a)``.
227−``MaybeTable`` is similar to the normal ``Maybe`` data type in Haskell, and
228−represents the choice between a ``justTable x`` and a ``nothingTable`` (like
229−``Just x`` and ``Nothing``, respectively). When you execute a query containing
230−``MaybeTable x`` with ``select``, Rel8 will return ``Maybe x``. ``MaybeTable``
231−comes with a library of routines, similar to the functions that can be used to
232−operate on ``Maybe``. For more details, see the API documentation.
233−
234−.. hint::
235−
236− ``optional`` converts an inner join into a ``LEFT JOIN``, but you can also go
237− the other way - and turn a ``LEFT JOIN`` back into an inner join! To do this,
238− you can use ``catMaybeTable``, which will select only the rows when the left
239− join was successful.
240−
241−Ordering results
242−----------------
243−
244−Rel8 supports ordering the results returned by a ``Query``, using SQL's ``ORDER
245−BY`` syntax. To specify an ordering, you use ``orderBy`` and supply an
246−appropriate ``Order`` value.
247−
248−An ``Order`` is built by combining the order of individual columns, each of
249−which can be either ascending or descending. To order a single column, you
250−combine ``asc`` or ``desc`` with ``Order``\s *contravariant* interface. For
251−example, if we have a table with a ``orderId`` column, we can order a ``Query
252−(Order Expr)`` by ``orderId`` with::
253−
254− orderBy (orderId >$< asc)
255−
256−To order by multiple columns, combine the individual orders with ``Order``\s
257−``Monoid`` instance. We could extend the above example to order by the order
258−date first (with the most recent orders first) with::
259−
260− orderBy (mconcat [orderDate >$< desc, orderId >$< asc])
261−
262−Aggregating queries
263−-------------------
264−
265−.. todo::
266−
267− Write this
268−
269−Set operations
270−--------------
271−
272−.. todo::
273−
274− Write this
docs/concepts/tables.rstdeleted−60
@@ -1,60 +0,0 @@
1−Tables
2−======
3−
4−So far we've seen that ``DBType`` bridges Haskell types to database types, and
5−``Expr`` lets us write SQL expressions using these types. The next concept is to
6−understand how tables are mapped into Rel8.
7−
8−In Rel8, we understand a table to be a list of columns. Each column has some
9−associated metadata - a column has a type, but it also has information as to
10−whether it can store ``null``, the name of the column, and whether this column
11−has a default value. All of this metadata can be configured when you define
12−custom table types, but first we'll look at some built in tables.
13−
14−``Expr`` is a single-column table
15−---------------------------------
16−
17−Any time you have an ``Expr``, you also have a table. All ``Expr``\s are tables
18−that consist of exactly one column. This means that whenever a table is
19−expected, you can usually use an ``Expr`` as well.
20−
21−Tuples combine tables
22−---------------------
23−
24−You can use Haskell's normal tuple syntax to combine tables into larger tables.
25−Now that we know that an ``Expr`` is a table with one column, we can use tuples
26−to build larger tables. For example, if we have ``userId :: Expr UserId`` and a
27−``name :: Expr Text``, we can pair these together as ``(userId, name) :: (Expr
28−UserId, Expr Text)``.
29−
30−Rel8 supports tuples with two, three, four and five elements. Beyond that, we
31−suggest writing a custom table type (though you can also nest tuples).
32−
33−Custom table types
34−------------------
35−
36−The primary way to define a table in Rel8 is to use the higher-kinded data
37−pattern. Rel8 advocates this system because it means you can define your data
38−type once, but use it in the context of Haskell expressions (for example, to
39−serialize it as JSON to use as a REST API call response type), and also within
40−Rel8 queries. This allows developers to share their understanding of a type in
41−multiple domains, while also reducing the amount of code that has to be written
42−and maintained.
43−
44−To define a custom table using this pattern, you define a Haskell data type that
45−has a single parameter (conventionally called ``f``). Next, we suggest using
46−record syntax to define the fields of your data type, and for each field use the
47−``Column`` type family to define the type of the column. Once all fields have
48−been defined, you can bridge this type with Rel8 by deriving ``Generic`` and
49−``Rel8able`` instance.
50−
51−A typical table definition might look like this::
52−
53− data User f = User
54− { userId :: Column f UserId
55− , userName :: Column f Text
56− , userCreatedAt :: Column f UTCTime
57− , userEmail :: Column f (Maybe EmailAddress)
58− }
59− deriving stock (Generic)
60− deriving anyclass (Rel8able)
docs/conf.pydeleted−36
@@ -1,36 +0,0 @@
1−import sys
2−import os
3−import sphinx_rtd_theme
4−
5−# Support for :base-ref:, etc.
6−sys.path.insert(0, os.path.abspath('.'))
7−
8−version = "1.0.0"
9−
10−extensions = ['sphinx.ext.extlinks', 'sphinx.ext.todo', 'sphinx_rtd_theme']
11−
12−templates_path = ['_templates']
13−source_suffix = '.rst'
14−source_encoding = 'utf-8-sig'
15−master_doc = 'index'
16−
17−project = u'Rel8'
18−copyright = u'2021 CircuitHub'
19−release = version
20−
21−highlight_language = 'haskell'
22−primary_domain = 'haskell'
23−
24−exclude_patterns = ['.build', "*.gen.rst"]
25−
26−html_theme = 'sphinx_rtd_theme'
27−html_theme_options = {
28− 'logo_only': True,
29− 'navigation_depth': 5,
30−}
31−html_context = {}
32−
33−# on_rtd is whether we are on readthedocs.org, this line of code grabbed from docs.readthedocs.org
34−on_rtd = os.environ.get('READTHEDOCS', None) == 'True'
35−
36−todo_include_todos = True
docs/cookbook.rstdeleted−169
@@ -1,169 +0,0 @@
1−Cookbook
2−========
3−
4−This cookbook exists to help you easily form Rel8 queries. It's main purpose is
5−to help those familiar with SQL to translate their queries into Rel8
6−``Query``\s.
7−
8−``SELECT * FROM table``
9−-----------------------
10−
11−To select from a table, use ``each``.
12−
13−Inner joins
14−-----------
15−
16−To perform an inner join against two queries, use ``where_`` with a join
17−condition. For example, the following SQL:
18−
19−.. code-block:: sql
20−
21− SELECT * FROM table_a JOIN table_b ON table_a.x = table_b.y
22−
23−can be written as::
24−
25− myQuery = do
26− a <- each tableA
27− b <- each tableB
28− where_ $ tableAX a ==. tableBY b
29−
30−Left (outer) joins
31−------------------
32−
33−A ``LEFT JOIN`` query is performed by using ``optional``.
34−
35−For example, the query:
36−
37−.. code-block:: sql
38−
39− SELECT * FROM table_a LEFT JOIN table_b ON table_a.x = table_b.y
40−
41−can be written as::
42−
43− myQuery = do
44− a <- each tableA
45−
46− maybeB <- optional do
47− b <- each tableB
48− where_ $ tableAX a ==. tableBY b
49−
50− return (a, maybeB)
51−
52−Note that ``maybeB`` here will be a ``MaybeTable``, which is the Rel8
53−``Query``-equivalent of ``Maybe``. This allows you to observe if a left join
54−has succeeded or failed.
55−
56−Ordering results
57−----------------
58−
59−A ``Query`` by default has no ordering - just like in SQL. If you rows back in
60−a certain order, you can use ``orderBy`` with an ``Order``.
61−
62−For example, the query:
63−
64−.. code-block:: sql
65−
66− SELECT * FROM my_table ORDER BY my_table.id ASC, my_table.x DESC NULLS FIRST
67−
68−can be written as::
69−
70− myQuery =
71− orderBy (mconcat [ myTableId >$< asc, myTableX >$< nullsFirst desc ]) $
72− each myTableSchema
73−
74−Note that we use ``>$<`` (from ``Data.Functor.Contravariant``) to select table
75−columns, and we can use ``mconcat`` to combine orderings.
76−
77−If all columns of a table have an ordering, you can also use ``ascTable`` and
78−``descTable``. For example::
79−
80− myQuery = orderBy ascTable $ each myTableSchema
81−
82−Aggregations
83−------------
84−
85−Aggregations in Rel8 work by using ``aggregate``, which takes a ``Query
86−(Aggregate a)`` and gives you back a ``Query a``.
87−
88−The following query:
89−
90−.. code-block:: sql
91−
92− SELECT sum(foo), count(distinct bar) FROM table_a
93−
94−can be written as::
95−
96− myQuery = aggregate do
97− a <- each tableA
98− return $ liftF2 (,) (sum (foo a)) (countDistinct (bar a))
99−
100−where ``liftF2`` comes from ``Data.Functor.Apply`` from the ``semigroupoids``
101−library.
102−
103−Combining aggregations
104−----------------------
105−
106−As ``Aggregate`` is an instance of ``Apply`` (which is very similar to
107−``Applicative``), individual aggregations can be combined. For example, one way
108−to take the average rating would be to write the query:
109−
110−.. code-block:: sql
111−
112− SELECT sum(rating.score) / count(rating.score) FROM rating
113−
114−In Rel8, we can write this as::
115−
116− myQuery = aggregate do
117− rating <- each ratingSchema
118− return $ liftF2 (/) (sum (score rating)) (count (score rating))
119−
120−You can also use ``RebindableSyntax`` and ``ApplicativeDo``::
121−
122− {-# language ApplicativeDo, RebindableSyntax #-}
123−
124− import Data.Functor.Apply ((<.>))
125−
126− myQuery = aggregate do
127− rating <- each ratingSchema
128− return do
129− scoreSum <- sum (score rating)
130− numberOfRatings <- count (score rating)
131− return (scoreSum / numberOfRatings)
132− where (<*>) = (<.>)
133−
134−For large aggregations, this can often make queries easier to read.
135−
136−Tree-like queries
137−-----------------
138−
139−Rel8 has a fairly unique feature in that it's able to return not just lists of
140−rows, but can also return *tree*\s.
141−
142−To understand what this means, we'll consider a small example query for blog
143−posts. We want our query to return:
144−
145−1. The latest 5 blog posts that have at least one tag each.
146−2. For each blog post, all tags.
147−3. For each blog post, the latest 3 comments if they exist.
148−
149−In Rel8, we can write this query as::
150−
151− latestBlogPosts = do
152− post <- each postSchema
153−
154− -- Returns a `NonEmptyTable a` which ends up as a `Data.List.NonEmpty a` after the query is run
155− tags <- some $ do
156− tag <- each tagSchema
157− where_ (tagPostId tag ==. postId post)
158− return (tagName tag)
159−
160− -- Returns a `ListTable a` which ends up as a `[a]` after the query is run
161− latestComments <-
162− many $
163− limit 3 $
164− orderBy (commentCreatedAt >$< desc) do
165− comment <- each commentSchema
166− where_ (commentPostId comment ==. postId post)
167−
168− return (post, tags, latestComments)
169−
docs/index.rstdeleted−53
@@ -1,53 +0,0 @@
1−Welcome to Rel8!
2−================
3−
4−Welcome to Rel8! Rel8 is a Haskell library for interacting with PostgreSQL
5−databases, built on top of the fantastic `Opaleye
6−<https://hackage.haskell.org/package/opaleye>`_ library.
7−
8−The main objectives of Rel8 are:
9−
10−* *Conciseness*: Users using Rel8 should not need to write boiler-plate code.
11− By using expressive types, we can provide sufficient information for the
12− compiler to infer code whenever possible.
13−
14−* *Inferrable*: Despite using a lot of type level magic, Rel8 aims to have
15− excellent and predictable type inference.
16−
17−* *Familiar*: writing Rel8 queries should feel like normal Haskell programming.
18−
19−.. toctree::
20− :caption: Getting Started
21− :maxdepth: 2
22−
23− tutorial
24−
25−.. toctree::
26− :caption: Rel8 concepts
27− :maxdepth: 2
28−
29− concepts/dbtype
30− concepts/expr
31− concepts/tables
32− concepts/queries
33− concepts/insert
34−
35−.. toctree::
36− :caption: Tips and tricks
37− :maxdepth: 1
38−
39− cookbook
40−
41−
42−More Resources
43−==============
44−
45−* The `Haskell API documentation <https://hackage.haskell.org/package/rel8>`_
46− describes how individual functions are types are to be used.
47−
48−* If you have a question about how to use Rel8, feel free to open a `GitHub
49− discussion <https://github.com/circuithub/rel8/discussions>`_.
50−
51−* If you think you've found a bug, confusing behavior, or have a feature
52− request, please raise an issue at `Rel8's issue tracker
53− <https://github.com/circuithub/rel8>`_.
docs/requirements.txtdeleted−4
@@ -1,4 +0,0 @@
1−docutils == 0.16.*
2−sphinx == 3.5.*
3−sphinx_rtd_theme
4−
docs/tutorial.rstdeleted−387
@@ -1,387 +0,0 @@
1−.. highlight:: haskell
2−
3−Getting Started
4−===============
5−
6−In this section, we'll take a look at using Rel8 to work with a small database
7−for Haskell packages. We'll take a look at idiomatic usage of Rel8, mapping
8−tables to Haskell, and then look at writing some simple queries.
9−
10−Before we get started, we'll be using the following language extensions and
11−imports throughout this guide::
12−
13− {-# language BlockArguments #-}
14− {-# language DeriveAnyClass #-}
15− {-# language DeriveGeneric #-}
16− {-# language DerivingStrategies #-}
17− {-# language DerivingVia #-}
18− {-# language DuplicateRecordFields #-}
19− {-# language GeneralizedNewtypeDeriving #-}
20− {-# language OverloadedStrings #-}
21− {-# language StandaloneDeriving #-}
22− {-# language TypeApplications #-}
23− {-# language TypeFamilies #-}
24−
25− import Prelude
26− import Rel8
27−
28−The Example Schema
29−------------------
30−
31−Before we start writing any Haskell, let's take a look at the schema we'll work
32−with. The `author` table has three columns:
33−
34−+-----------------+-------------+----------+
35−| Column Name | Type | Nullable |
36−+=================+=============+==========+
37−| ``author_id`` | ``integer`` | not null |
38−+-----------------+-------------+----------+
39−| ``name`` | ``text`` | not null |
40−+-----------------+-------------+----------+
41−| ``url`` | ``text`` | |
42−+-----------------+-------------+----------+
43−
44−and the `project` table has two:
45−
46−+-----------------+-------------+----------+
47−| Column Name | Type | Nullable |
48−+=================+=============+==========+
49−| ``author_id`` | ``integer`` | not null |
50−+-----------------+-------------+----------+
51−| ``name`` | ``text`` | not null |
52−+-----------------+-------------+----------+
53−
54−A ``project`` always has an ``author``, but not all ``author``\s have projects.
55−Each ``author`` has a name and (maybe) an associated website, and each project
56−has a name.
57−
58−Mapping Schemas to Haskell
59−--------------------------
60−
61−Now that we've seen our schema, we can begin writing a mapping in Rel8. The
62−idiomatic way to map a table is to use a record that is parameterised what Rel8
63−calls an *interpretation functor*, and to define each field with ``Column``.
64−For this type to be usable with Rel8 we need it to be an instance of
65−``Rel8able``, which can be derived with a combination of ``DeriveAnyClass`` and
66−``DeriveGeneric`` language extensions.
67−
68−Following these steps for ``author``, we have::
69−
70− data Author f = Author
71− { authorId :: Column f Int64
72− , name :: Column f Text
73− , url :: Column f (Maybe Text)
74− }
75− deriving stock (Generic)
76− deriving anyclass (Rel8able)
77−
78−This is a perfectly reasonable definition, but cautious readers might notice a
79−problem - in particular, with the type of the ``authorId`` field. While
80−``Int64`` is correct, it's not the best type. If we had other identifier types
81−in our project, it would be too easy to accidentally mix them up and create
82−nonsensical joins. As Haskell programmers, we often solve this problem by
83−creating ``newtype`` wrappers, and we can also use this technique with Rel8::
84−
85− newtype AuthorId = AuthorId { toInt64 :: Int64 }
86− deriving newtype (DBEq, DBType, Eq, Show)
87−
88−Now we can write our final schema mapping. First, the ``author`` table::
89−
90− data Author f = Author
91− { authorId :: Column f AuthorId
92− , authorName :: Column f Text
93− , authorUrl :: Column f (Maybe Text)
94− }
95− deriving stock (Generic)
96− deriving anyclass (Rel8able)
97−
98−And similarly, the ``project`` table::
99−
100− data Project f = Project
101− { projectAuthorId :: Column f AuthorId
102− , projectName :: Column f Text
103− }
104− deriving stock (Generic)
105− deriving anyclass (Rel8able)
106−
107−To show query results in this documentation, we'll also need ``Show`` instances:
108−Unfortunately these definitions look a bit scary, but they are essentially just
109−``deriving (Show)``::
110−
111− deriving stock instance f ~ Result => Show (Author f)
112− deriving stock instance f ~ Result => Show (Project f)
113−
114−These data types describe the structural mapping of the tables, but we also
115−need to specify a ``TableSchema`` for each table. A ``TableSchema`` contains
116−the name of the table and the name of all columns in the table, which will
117−ultimately allow us to ``SELECT`` and ``INSERT`` rows for these tables.
118−
119−To define a ``TableSchema``, we just need to fill construct appropriate
120−``TableSchema`` values. When it comes to the ``tableColumns`` field, we
121−construct values of our data types above, and set each field to the name of the
122−column that it maps to.
123−
124−First, ``authorSchema`` describes the column names of the ``author`` table when
125−associated with the ``Author`` type::
126−
127− authorSchema :: TableSchema (Author Name)
128− authorSchema = TableSchema
129− { name = "author"
130− , schema = Nothing
131− , columns = Author
132− { authorId = "author_id"
133− , authorName = "name"
134− , authorUrl = "url"
135− }
136− }
137−
138−And likewise for ``project`` and ``Project``::
139−
140− projectSchema :: TableSchema (Project Name)
141− projectSchema = TableSchema
142− { name = "project"
143− , schema = Nothing
144− , columns = Project
145− { projectAuthorId = "author_id"
146− , projectName = "name"
147− }
148− }
149−
150−There is also some generics machinery available if you want to grab the field
151−information from your ``Rel8able`` type::
152−
153− projectSchema :: TableSchema (Project Name)
154− projectSchema = TableSchema
155− { name = "project"
156− , schema = Nothing
157− , columns = namesFromLabels @(Project Name)
158− }
159−
160−This will create a ``TableSchema`` for ``Project`` where every column name
161−corresponds exactly to the name of the field. If you need more flexibility, you
162−can use ``namesFromLabelsWith``, which takes a transformation function.
163−
164−.. note::
165−
166− You might be wondering why this information isn't in the definitions of
167− ``Author`` and ``Project`` above. Rel8 decouples ``TableSchema`` from the data
168− types themselves, as not all tables you define will necessarily have a schema.
169− For example, Rel8 allows you to define helper types to simplify the types of
170− queries - these tables only exist at query time, but there is no corresponding
171− base table. We'll see more on this idea later!
172−
173−With these table definitions, we can now start writing some queries!
174−
175−Writing Queries
176−---------------
177−
178−Simple Queries
179−~~~~~~~~~~~~~~
180−
181−First, we'll take a look at ``SELECT`` statements - usually the bulk of most
182−database heavy applications.
183−
184−In Rel8, ``SELECT`` statements are built using the ``Query`` monad. You can
185−think of this monad like the ordinary ``[]`` (List) monad - but this isn't
186−required knowledge.
187−
188−To start, we'll look at one of the simplest queries possible - a basic ``SELECT
189−* FROM`` statement. To select all rows from a table, we use ``each``, and
190−supply a ``TableSchema``. So to select all ``project`` rows, we can write::
191−
192− >>> :t each projectSchema
193− each projectSchema :: Query (Project Expr)
194−
195−Notice that ``each`` gives us a ``Query`` that yields ``Project Expr`` rows. To
196−see what this means, let's have a look at a single field of a ``Project Expr``::
197−
198− >>> let aProjectExpr = undefined :: Project Expr
199− >>> :t projectAuthorId aProjectExpr
200− projectAuthorId aProjectExpr :: Expr AuthorId
201−
202−Recall we defined ``projectAuthorId`` as ``Column f AuthorId``. Now we have
203−``f`` is ``Expr``, and ``Column Expr AuthorId`` reduces to ``Expr AuthorId``.
204−We'll see more about ``Expr`` soon, but you can think of ``Expr a`` as "SQL
205−expressions of type ``a``\".
206−
207−To execute this ``Query``, we pass it to ``select``. This function takes both a
208−database connection (which can be obtained using hasql's ``acquire`` function),
209−and the ``Query`` to run::
210−
211− >>> Right conn <- acquire "user=postgres"
212− >>> :t select conn (each projectSchema)
213− select conn (each projectSchema) :: MonadIO m => m [Project Result]
214−
215−When we ``select`` things containing ``Expr``\s, Rel8 builds a new response
216−table with the ``Result`` interpretation. This means you'll get back plain
217−Haskell values. Studying ``projectAuthorId`` again, we have::
218−
219− >>> let aProjectResult = undefined :: Project Result
220− >>> :t projectAuthorId aProjectResult
221− projectAuthorId aProjectResult :: AuthorId
222−
223−Here ``Column Result AuthorId`` reduces to just ``AuthorId``, with no
224−wrappping type at all.
225−
226−Putting this all together, we can run our first query::
227−
228− >>> select conn (each projectSchema) >>= mapM_ print
229− Project {projectAuthorId = 1, projectName = "rel8"}
230− Project {projectAuthorId = 2, projectName = "aeson"}
231− Project {projectAuthorId = 2, projectName = "text"}
232−
233−We now know that ``each`` is the equivalent of a ``SELECT *`` query, but
234−sometimes we're only interested in a subset of the columns of a table. To
235−restrict the returned columns, we can specify a projection by using ``Query``\s
236−``Functor`` instance::
237−
238− >>> select conn $ projectName <$> each projectSchema
239− ["rel8","aeson","text"]
240−
241−Joins
242−~~~~~
243−
244−Another common operation in relational databases is to take the ``JOIN`` of
245−multiple tables. Rel8 doesn't have a specific join operation, but we can
246−recover the functionality of a join by selecting all rows of two tables, and
247−then using ``where_`` to filter them.
248−
249−To see how this works, first let's look at taking the product of two tables.
250−We can do this by simply calling ``each`` twice, and then returning a tuple of
251−their results::
252−
253− >>> :{
254− mapM_ print =<< select conn do
255− author <- each authorSchema
256− project <- each projectSchema
257− return (projectName project, authorName author)
258− :}
259− ("rel8","Ollie")
260− ("rel8","Bryan O'Sullivan")
261− ("rel8","Emily Pillmore")
262− ("aeson","Ollie")
263− ("aeson","Bryan O'Sullivan")
264− ("aeson","Emily Pillmore")
265− ("text","Ollie")
266− ("text","Bryan O'Sullivan")
267− ("text","Emily Pillmore")
268−
269−This isn't quite right, though, as we have ended up pairing up the wrong
270−projects and authors. To fix this, we can use ``where_`` to restrict the
271−returned rows. We could write::
272−
273− select conn $ do
274− author <- each authorSchema
275− project <- each projectSchema
276− where_ $ projectAuthorId project ==. authorId author
277− return (project, author)
278−
279−but doing this every time you need a join can obscure the meaning of the
280−query you're writing. A good practice is to introduce specialised functions
281−for the particular joins in your database. In our case, this would be::
282−
283− projectsForAuthor :: Author Expr -> Query (Project Expr)
284− projectsForAuthor a = each projectSchema >>= filter \p ->
285− projectAuthorId p ==. authorId a
286−
287−Our final query is then::
288−
289− >>> :{
290− mapM_ print =<< select conn do
291− author <- each authorSchema
292− project <- projectsForAuthor author
293− return (projectName project, authorName author)
294− :}
295− ("rel8","Ollie")
296− ("aeson","Bryan O'Sullivan")
297− ("text","Bryan O'Sullivan")
298−
299−Left Joins
300−~~~~~~~~~~
301−
302−Rel8 is also capable of performing ``LEFT JOIN``\s. To perform ``LEFT JOIN``\s,
303−we follow the same approach as before, but use the ``optional`` query
304−transformer to allow for the possibility of the join to fail.
305−
306−In our test database, we can see that there's another author who we haven't
307−seen yet::
308−
309− >>> select conn $ authorName <$> each authorSchema
310− ["Ollie","Bryan O'Sullivan","Emily Pillmore"]
311−
312−Emily wasn't returned in our earlier query because - in our database - she
313−doesn't have any registered projects. We can account for this partiality in our
314−original query by wrapping the ``projectsForAuthor`` call with ``optional``::
315−
316− >>> :{
317− mapM_ print =<< select conn do
318− author <- each authorSchema
319− mproject <- optional $ projectsForAuthor author
320− return (authorName author, projectName <$> mproject)
321− :}
322− ("Ollie",Just "rel8")
323− ("Bryan O'Sullivan",Just "aeson")
324− ("Bryan O'Sullivan",Just "text")
325− ("Emily Pillmore",Nothing)
326−
327−
328−Aggregation
329−~~~~~~~~~~~
330−
331−Aggregations are operations like ``sum`` and ``count`` - operations that reduce
332−multiple rows to single values. To perform aggregations in Rel8, we can use the
333−``aggregate`` function, which takes a ``Query`` of aggregated expressions, runs
334−the aggregation, and returns aggregated rows.
335−
336−To start, let's look at a simple aggregation that tells us how many projects
337−exist:
338−
339−.. todo::
340−
341− >>> error "TODO"
342−
343−Rel8 is also capable of aggregating multiple rows into a single row by
344−concatenating all rows as a list. This aggregation allows us to break free of
345−the row-orientated nature of SQL and write queries that return tree-like
346−structures. Earlier we saw an example of returning authors with their projects,
347−but the query didn't do a great job of describing the one-to-many relationship
348−between authors and their projects.
349−
350−Let's look again at a query that returns authors and their projects, and
351−focus on the /type/ of that query::
352−
353− projectsForAuthor a = each projectSchema >>= filter \p ->
354− projectAuthorId p ==. authorId a
355−
356− let authorsAndProjects = do
357− author <- each authorSchema
358− project <- projectsForAuthor author
359− return (author, project)
360− where
361−
362− >>> :t select conn authorsAndProjects
363− select conn authorsAndProjects
364− :: MonadIO m => m [(Author Result, Project Result)]
365−
366−
367−Our query gives us a single list of pairs of authors and projects. However,
368−with our domain knowledge of the schema, this isn't a great type - what we'd
369−rather have is a list of pairs of authors and /lists/ of projects. That is,
370−what we'd like is::
371−
372− [(Author Result, [Project Result])]
373−
374−This would be a much better type! Rel8 can produce a query with this type by
375−simply wrapping the call to ``projectsForAuthor`` with either ``some`` or
376−``many``. Here we'll use ``many``, which allows for the possibility of an
377−author to have no projects::
378−
379− >>> :{
380− mapM_ print =<< select conn do
381− author <- each authorSchema
382− projectNames <- many $ projectName <$> projectsForAuthor author
383− return (authorName author, projectNames)
384− :}
385− ("Ollie",["rel8"])
386− ("Bryan O'Sullivan",["aeson","text"])
387− ("Emily Pillmore",[])
jobs.nixnew file+5
@@ -0,0 +1,5 @@
1+let rel8 = (import ./.).hsPkgs.rel8;
2+in {
3+ rel8 = rel8.components.library;
4+ tests = rel8.checks.tests;
5+}
nix/sources.json+36−36
@@ -1,38 +1,38 @@
11{
2− "haskell.nix": {
3− "branch": "master",
4− "description": "Alternative Haskell Infrastructure for Nixpkgs",
5− "homepage": "https://input-output-hk.github.io/haskell.nix",
6− "owner": "input-output-hk",
7− "repo": "haskell.nix",
8− "rev": "0837156c56cb5350dd9bd84eb424187e00aa1e8a",
9− "sha256": "1djmv5a0vfj78csw2cad6nicrs8iqrp928b9b3v4h7lwwhhzliwl",
10− "type": "tarball",
11− "url": "https://github.com/input-output-hk/haskell.nix/archive/0837156c56cb5350dd9bd84eb424187e00aa1e8a.tar.gz",
12− "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
13− },
14− "niv": {
15− "branch": "master",
16− "description": "Easy dependency management for Nix projects",
17− "homepage": "https://github.com/nmattia/niv",
18− "owner": "nmattia",
19− "repo": "niv",
20− "rev": "acdb1726783637852c01e0ad639ac9cbec28d8c8",
21− "sha256": "1wszl8q70z6wfgkh2dvgmhhry6qp9nar421qq2ifd17hq2jj9ck3",
22− "type": "tarball",
23− "url": "https://github.com/nmattia/niv/archive/acdb1726783637852c01e0ad639ac9cbec28d8c8.tar.gz",
24− "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
25− },
26− "nixpkgs": {
27− "branch": "nixos-20.09",
28− "description": "Nix Packages collection",
29− "homepage": null,
30− "owner": "nixos",
31− "repo": "nixpkgs",
32− "rev": "1c1f5649bb9c1b0d98637c8c365228f57126f361",
33− "sha256": "0f2nvdijyxfgl5kwyb4465pppd5vkhqxddx6v40k2s0z9jfhj0xl",
34− "type": "tarball",
35− "url": "https://github.com/nixos/nixpkgs/archive/1c1f5649bb9c1b0d98637c8c365228f57126f361.tar.gz",
36− "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
37− }
2+ "haskell.nix": {
3+ "branch": "circuithub",
4+ "description": "Alternative Haskell Infrastructure for Nixpkgs",
5+ "homepage": "https://input-output-hk.github.io/haskell.nix",
6+ "owner": "circuithub",
7+ "repo": "haskell.nix",
8+ "rev": "2902f9b49484a87afb0e1a33b1d88a2c7b8ca0a0",
9+ "sha256": "0a01g5b46z5yaf2mnl415hc4lciwiyqhj22qhgwgwd261w4068iy",
10+ "type": "tarball",
11+ "url": "https://github.com/circuithub/haskell.nix/archive/2902f9b49484a87afb0e1a33b1d88a2c7b8ca0a0.tar.gz",
12+ "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
13+ },
14+ "niv": {
15+ "branch": "master",
16+ "description": "Easy dependency management for Nix projects",
17+ "homepage": "https://github.com/nmattia/niv",
18+ "owner": "nmattia",
19+ "repo": "niv",
20+ "rev": "ba57d5a29b4e0f2085917010380ef3ddc3cf380f",
21+ "sha256": "1kpsvc53x821cmjg1khvp1nz7906gczq8mp83664cr15h94sh8i4",
22+ "type": "tarball",
23+ "url": "https://github.com/nmattia/niv/archive/ba57d5a29b4e0f2085917010380ef3ddc3cf380f.tar.gz",
24+ "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
25+ },
26+ "nixpkgs": {
27+ "branch": "nixos-20.09",
28+ "description": "Nix Packages collection",
29+ "homepage": null,
30+ "owner": "nixos",
31+ "repo": "nixpkgs",
32+ "rev": "6e7f25001fe6874f7ae271891f709bbf50a22c45",
33+ "sha256": "1x04j4351pqiqbpkq6g308mxcvb5aqnwv8l2vmlxkgvq5phzky7z",
34+ "type": "tarball",
35+ "url": "https://github.com/nixos/nixpkgs/archive/6e7f25001fe6874f7ae271891f709bbf50a22c45.tar.gz",
36+ "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
37+ }
3838}
nix/sources.nix+20−66
@@ -6,53 +6,25 @@ let
66 # The fetchers. fetch_<type> fetches specs of type <type>.
77 #
88
9− fetch_file = pkgs: name: spec:
10− let
11− name' = sanitizeName name + "-src";
12− in
13− if spec.builtin or true then
14− builtins_fetchurl { inherit (spec) url sha256; name = name'; }
15− else
16− pkgs.fetchurl { inherit (spec) url sha256; name = name'; };
9+ fetch_file = pkgs: spec:
10+ if spec.builtin or true then
11+ builtins_fetchurl { inherit (spec) url sha256; }
12+ else
13+ pkgs.fetchurl { inherit (spec) url sha256; };
1714
1815 fetch_tarball = pkgs: name: spec:
1916 let
20− name' = sanitizeName name + "-src";
17+ ok = str: ! builtins.isNull (builtins.match "[a-zA-Z0-9+-._?=]" str);
18+ # sanitize the name, though nix will still fail if name starts with period
19+ name' = stringAsChars (x: if ! ok x then "-" else x) "${name}-src";
2120 in
2221 if spec.builtin or true then
2322 builtins_fetchTarball { name = name'; inherit (spec) url sha256; }
2423 else
2524 pkgs.fetchzip { name = name'; inherit (spec) url sha256; };
2625
27− fetch_git = name: spec:
28− let
29− ref =
30− if spec ? ref then spec.ref else
31− if spec ? branch then "refs/heads/${spec.branch}" else
32− if spec ? tag then "refs/tags/${spec.tag}" else
33− abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!";
34− submodules = if spec ? submodules then spec.submodules else false;
35− submoduleArg =
36− let
37− nixSupportsSubmodules = builtins.compareVersions builtins.nixVersion "2.4" >= 0;
38− emptyArgWithWarning =
39− if submodules == true
40− then
41− builtins.trace
42− (
43− "The niv input \"${name}\" uses submodules "
44− + "but your nix's (${builtins.nixVersion}) builtins.fetchGit "
45− + "does not support them"
46− )
47− {}
48− else {};
49− in
50− if nixSupportsSubmodules
51− then { inherit submodules; }
52− else emptyArgWithWarning;
53− in
54− builtins.fetchGit
55− ({ url = spec.repo; inherit (spec) rev; inherit ref; } // submoduleArg);
26+ fetch_git = spec:
27+ builtins.fetchGit { url = spec.repo; inherit (spec) rev ref; };
5628
5729 fetch_local = spec: spec.path;
5830
@@ -68,21 +40,11 @@ let
6840 # Various helpers
6941 #
7042
71− # https://github.com/NixOS/nixpkgs/pull/83241/files#diff-c6f540a4f3bfa4b0e8b6bafd4cd54e8bR695
72− sanitizeName = name:
73− (
74− concatMapStrings (s: if builtins.isList s then "-" else s)
75− (
76− builtins.split "[^[:alnum:]+._?=-]+"
77− ((x: builtins.elemAt (builtins.match "\\.*(.*)" x) 0) name)
78− )
79− );
80−
8143 # The set of packages used when specs are fetched using non-builtins.
82− mkPkgs = sources: system:
44+ mkPkgs = sources:
8345 let
8446 sourcesNixpkgs =
85− import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; };
47+ import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) {};
8648 hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath;
8749 hasThisAsNixpkgsPath = <nixpkgs> == ./.;
8850 in
@@ -102,9 +64,9 @@ let
10264
10365 if ! builtins.hasAttr "type" spec then
10466 abort "ERROR: niv spec ${name} does not have a 'type' attribute"
105− else if spec.type == "file" then fetch_file pkgs name spec
67+ else if spec.type == "file" then fetch_file pkgs spec
10668 else if spec.type == "tarball" then fetch_tarball pkgs name spec
107− else if spec.type == "git" then fetch_git name spec
69+ else if spec.type == "git" then fetch_git spec
10870 else if spec.type == "local" then fetch_local spec
10971 else if spec.type == "builtin-tarball" then fetch_builtin-tarball name
11072 else if spec.type == "builtin-url" then fetch_builtin-url name
@@ -118,10 +80,7 @@ let
11880 saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name;
11981 ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}";
12082 in
121− if ersatz == "" then drv else
122− # this turns the string into an actual Nix path (for both absolute and
123− # relative paths)
124− if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}";
83+ if ersatz == "" then drv else ersatz;
12584
12685 # Ports of functions for older nix versions
12786
@@ -139,29 +98,25 @@ let
13998
14099 # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269
141100 stringAsChars = f: s: concatStrings (map f (stringToCharacters s));
142− concatMapStrings = f: list: concatStrings (map f list);
143101 concatStrings = builtins.concatStringsSep "";
144102
145− # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331
146− optionalAttrs = cond: as: if cond then as else {};
147−
148103 # fetchTarball version that is compatible between all the versions of Nix
149− builtins_fetchTarball = { url, name ? null, sha256 }@attrs:
104+ builtins_fetchTarball = { url, name, sha256 }@attrs:
150105 let
151106 inherit (builtins) lessThan nixVersion fetchTarball;
152107 in
153108 if lessThan nixVersion "1.12" then
154− fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; }))
109+ fetchTarball { inherit name url; }
155110 else
156111 fetchTarball attrs;
157112
158113 # fetchurl version that is compatible between all the versions of Nix
159− builtins_fetchurl = { url, name ? null, sha256 }@attrs:
114+ builtins_fetchurl = { url, sha256 }@attrs:
160115 let
161116 inherit (builtins) lessThan nixVersion fetchurl;
162117 in
163118 if lessThan nixVersion "1.12" then
164− fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; }))
119+ fetchurl { inherit url; }
165120 else
166121 fetchurl attrs;
167122
@@ -180,8 +135,7 @@ let
180135 mkConfig =
181136 { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null
182137 , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile)
183− , system ? builtins.currentSystem
184− , pkgs ? mkPkgs sources system
138+ , pkgs ? mkPkgs sources
185139 }: rec {
186140 # The sources, i.e. the attribute set of spec name to spec
187141 inherit sources;
rel8.cabal+56−83
@@ -1,36 +1,30 @@
11cabal-version: 2.0
22name: rel8
3−version: 1.4.0.0
3+version: 0.1.0.0
44synopsis: Hey! Hey! Can u rel8?
55license: BSD3
66license-file: LICENSE
77author: Oliver Charles
88maintainer: ollie@ocharles.org.uk
9−homepage: https://github.com/circuithub/rel8
10−bug-reports: https://github.com/circuithub/rel8/issues
11−build-type: Simple
12−extra-doc-files:
13− README.md
14− Changelog.md
9+build-type: Custom
1510
16−source-repository head
17− type: git
18− location: https://github.com/circuithub/rel8
11+custom-setup
12+ setup-depends:
13+ base >= 4 && <5,
14+ Cabal,
15+ cabal-doctest >= 1 && <1.1
1916
2017library
2118 build-depends:
2219 aeson
23− , base ^>= 4.14 || ^>=4.15 || ^>=4.16
24− , bifunctors
20+ , base ^>=4.12 || ^>= 4.13 || ^>= 4.14
2521 , bytestring
2622 , case-insensitive
27− , comonad
23+ , casing
2824 , contravariant
29− , hasql ^>= 1.4.5.1 || ^>= 1.5.0.0 || ^>= 1.6.0.0
30− , opaleye ^>= 0.9.6.1
31− , pretty
25+ , hasql
26+ , opaleye ^>= 0.7.1.0
3227 , profunctors
33− , product-profunctors
3428 , scientific
3529 , semialign
3630 , semigroupoids
@@ -41,63 +35,36 @@ library
4135 default-language:
4236 Haskell2010
4337 ghc-options:
44− -Werror=missing-methods -Werror=incomplete-patterns -Werror=missing-fields
4538 -Weverything -Wno-unsafe -Wno-safe -Wno-missing-safe-haskell-mode
4639 -Wno-missing-import-lists -Wno-prepositive-qualified-module
4740 -Wno-monomorphism-restriction
48− -Wno-missing-local-signatures
49− -Wno-missing-kind-signatures
41+ -Wno-missing-local-signatures
5042 hs-source-dirs:
5143 src
5244 exposed-modules:
5345 Rel8
54− Rel8.Expr.Num
55− Rel8.Expr.Text
56− Rel8.Expr.Time
57− Rel8.Tabulate
58−
5946 other-modules:
6047 Rel8.Aggregate
6148
62− Rel8.Column
63− Rel8.Column.ADT
64− Rel8.Column.Either
65− Rel8.Column.Lift
66− Rel8.Column.List
67− Rel8.Column.Maybe
68− Rel8.Column.NonEmpty
69− Rel8.Column.Null
70− Rel8.Column.These
71−
7249 Rel8.Expr
7350 Rel8.Expr.Aggregate
7451 Rel8.Expr.Array
7552 Rel8.Expr.Bool
76− Rel8.Expr.Default
7753 Rel8.Expr.Eq
7854 Rel8.Expr.Function
7955 Rel8.Expr.Null
56+ Rel8.Expr.Num
8057 Rel8.Expr.Opaleye
8158 Rel8.Expr.Ord
8259 Rel8.Expr.Order
83− Rel8.Expr.Sequence
8460 Rel8.Expr.Serialize
85− Rel8.Expr.Window
61+ Rel8.Expr.Text
62+ Rel8.Expr.Time
8663
8764 Rel8.FCF
8865
89− Rel8.Kind.Algebra
90− Rel8.Kind.Context
91−
92− Rel8.Generic.Construction
93− Rel8.Generic.Construction.ADT
94− Rel8.Generic.Construction.Record
95− Rel8.Generic.Map
96− Rel8.Generic.Record
97− Rel8.Generic.Rel8able
98− Rel8.Generic.Table
99− Rel8.Generic.Table.ADT
100− Rel8.Generic.Table.Record
66+ Rel8.Kind.Labels
67+ Rel8.Kind.Necessity
10168
10269 Rel8.Order
10370
@@ -106,26 +73,29 @@ library
10673 Rel8.Query.Distinct
10774 Rel8.Query.Each
10875 Rel8.Query.Either
109− Rel8.Query.Evaluate
11076 Rel8.Query.Exists
11177 Rel8.Query.Filter
112− Rel8.Query.Indexed
11378 Rel8.Query.Limit
11479 Rel8.Query.List
11580 Rel8.Query.Maybe
11681 Rel8.Query.Null
11782 Rel8.Query.Opaleye
83+ Rel8.Query.Optimize
11884 Rel8.Query.Order
119− Rel8.Query.Rebind
12085 Rel8.Query.Set
12186 Rel8.Query.SQL
12287 Rel8.Query.These
12388 Rel8.Query.Values
124− Rel8.Query.Window
12589
90+ Rel8.Schema.Column
91+ Rel8.Schema.Context
92+ Rel8.Schema.Context.Identity
93+ Rel8.Schema.Context.Label
12694 Rel8.Schema.Context.Nullify
12795 Rel8.Schema.Dict
12896 Rel8.Schema.Field
97+ Rel8.Schema.Generic
98+ Rel8.Schema.Generic.Test
12999 Rel8.Schema.HTable
130100 Rel8.Schema.HTable.Either
131101 Rel8.Schema.HTable.Identity
@@ -135,59 +105,53 @@ library
135105 Rel8.Schema.HTable.Maybe
136106 Rel8.Schema.HTable.NonEmpty
137107 Rel8.Schema.HTable.Nullify
138− Rel8.Schema.HTable.Product
108+ Rel8.Schema.HTable.Pair
109+ Rel8.Schema.HTable.Quartet
110+ Rel8.Schema.HTable.Quintet
139111 Rel8.Schema.HTable.These
112+ Rel8.Schema.HTable.Trio
113+ Rel8.Schema.HTable.Type
140114 Rel8.Schema.HTable.Vectorize
141115 Rel8.Schema.Kind
142− Rel8.Schema.Name
143− Rel8.Schema.Null
144− Rel8.Schema.Result
116+ Rel8.Schema.Nullability
145117 Rel8.Schema.Spec
118+ Rel8.Schema.Spec.ConstrainDBType
119+ Rel8.Schema.Spec.ConstrainType
146120 Rel8.Schema.Table
147121
148122 Rel8.Statement.Delete
149123 Rel8.Statement.Insert
150− Rel8.Statement.OnConflict
151124 Rel8.Statement.Returning
152125 Rel8.Statement.Select
153− Rel8.Statement.Set
154− Rel8.Statement.SQL
155126 Rel8.Statement.Update
156− Rel8.Statement.Using
157127 Rel8.Statement.View
158− Rel8.Statement.Where
159128
160129 Rel8.Table
161− Rel8.Table.ADT
162130 Rel8.Table.Aggregate
163131 Rel8.Table.Alternative
164132 Rel8.Table.Bool
165− Rel8.Table.Cols
166133 Rel8.Table.Either
167134 Rel8.Table.Eq
168− Rel8.Table.HKD
135+ Rel8.Table.Insert
136+ Rel8.Table.Lifted
169137 Rel8.Table.List
170138 Rel8.Table.Maybe
171139 Rel8.Table.Name
172140 Rel8.Table.NonEmpty
173− Rel8.Table.Null
174− Rel8.Table.Nullify
175141 Rel8.Table.Opaleye
176142 Rel8.Table.Ord
177143 Rel8.Table.Order
178− Rel8.Table.Projection
179− Rel8.Table.Rel8able
144+ Rel8.Table.Recontextualize
180145 Rel8.Table.Serialize
181146 Rel8.Table.These
182− Rel8.Table.Transpose
183147 Rel8.Table.Undefined
184− Rel8.Table.Window
148+
149+ Rel8.Tabulate
185150
186151 Rel8.Type
187152 Rel8.Type.Array
188− Rel8.Type.Composite
153+ Rel8.Type.Array1D
189154 Rel8.Type.Eq
190− Rel8.Type.Enum
191155 Rel8.Type.Information
192156 Rel8.Type.JSONEncoded
193157 Rel8.Type.JSONBEncoded
@@ -200,8 +164,8 @@ library
200164 Rel8.Type.Sum
201165 Rel8.Type.Tag
202166
203− Rel8.Window
204−
167+ Rel8.Opaque
168+ Rel8.Schema.Structure
205169
206170test-suite tests
207171 type: exitcode-stdio-1.0
@@ -211,9 +175,9 @@ test-suite tests
211175 , case-insensitive
212176 , containers
213177 , hasql
214− , hasql-transaction
215− , hedgehog ^>= 1.0 || ^>= 1.1
216− , mmorph
178+ , hedgehog ^>=1.0.2
179+ , lifted-base ^>=0.2.3.12
180+ , monad-control ^>=1.0.2.3
217181 , rel8
218182 , scientific
219183 , tasty
@@ -221,12 +185,8 @@ test-suite tests
221185 , text
222186 , time
223187 , tmp-postgres ^>=1.34.1.0
224− , transformers
225188 , uuid
226189
227− other-modules:
228− Rel8.Generic.Rel8able.Test
229−
230190 main-is: Main.hs
231191 hs-source-dirs: tests
232192 default-language: Haskell2010
@@ -235,3 +195,16 @@ test-suite tests
235195 -Wno-missing-import-lists -Wno-prepositive-qualified-module
236196 -Wno-deprecations -Wno-monomorphism-restriction
237197 -Wno-missing-local-signatures -Wno-implicit-prelude
198+
199+test-suite doctests
200+ type: exitcode-stdio-1.0
201+ build-depends:
202+ base
203+ , base-compat
204+ , bytestring
205+ , doctest
206+ , hasql
207+ , tmp-postgres
208+
209+ main-is: Doctest.hs
210+ default-language: Haskell2010
shell.nix+4−4
@@ -1,11 +1,11 @@
11let
22 sources = import ./nix/sources.nix;
3− pkgs = import sources.nixpkgs {overlays = [];};
3+ pkgs = import sources.nixpkgs {};
44 hsPkgs = import ./default.nix;
55in
66 hsPkgs.shellFor {
7− withHoogle = false;
8− tools = { cabal = "latest"; };
7+ withHoogle = true;
8+ tools = { cabal = "3.2.0.0"; haskell-language-server = "latest"; };
99 exactDeps = false;
10− buildInputs = [ pkgs.postgresql pkgs.pythonPackages.sphinx ];
10+ buildInputs = [ pkgs.postgresql ];
1111 }
src/Rel8.hs+397−391
@@ -1,7 +1,19 @@
11{-# language DuplicateRecordFields #-}
22
33module Rel8
4− ( -- * Database types
4+ ( -- * Getting Started
5+ -- $setup
6+
7+ -- ** Writing Queries
8+ -- $guideQueries
9+
10+ -- ** Joins
11+ -- $guideJoins
12+
13+ -- ** Aggregation
14+ -- $guideAggregation
15+
16+ -- * Database types
517 -- ** @DBType@
618 DBType(..)
719
@@ -13,10 +25,6 @@ module Rel8
1325 -- **** @ReadShow@
1426 , ReadShow(..)
1527
16− -- **** Generic
17− , Composite(..), DBComposite(..), compose, decompose
18− , Enum(..), DBEnum(..), Enumable
19−
2028 -- *** @TypeInformation@
2129 , TypeInformation(..)
2230 , mapTypeInformation
@@ -26,44 +34,32 @@ module Rel8
2634 , DBSemigroup(..)
2735 , DBMonoid(..)
2836 , DBNum
29− , DBIntegral
3037 , DBFractional
31− , DBFloating
3238
3339 -- * Tables and higher-kinded tables
34− , Rel8able, KRel8able
40+ , Rel8able
3541 , Column
36− , HADT
37− , HEither
3842 , HMaybe
3943 , HList
4044 , HNonEmpty
41− , HNull
4245 , HThese
43− , Lift
4446
45− , Table(..)
46− , HTable
47− , Transposes
47+ , Table
4848 , AltTable((<|>:))
49− , AlternativeTable( emptyTable )
50− , EqTable(..), (==:), (/=:)
51− , OrdTable(..), (<:), (<=:), (>:), (>=:), ascTable, descTable, greatest, least
49+ , EqTable, (==:), (/=:)
50+ , OrdTable, ascTable, descTable
5251 , lit
5352 , bool
5453 , case_
55− , castTable
5654
5755 -- ** @MaybeTable@
5856 , MaybeTable
59− , maybeTable, ($?), nothingTable, justTable
57+ , maybeTable, nothingTable, justTable
6058 , isNothingTable, isJustTable
61− , fromMaybeTable
6259 , optional
6360 , catMaybeTable
61+ , bindMaybeTable
6462 , traverseMaybeTable
65− , aggregateMaybeTable
66− , nameMaybeTable
6763
6864 -- ** @EitherTable@
6965 , EitherTable
@@ -71,9 +67,8 @@ module Rel8
7167 , isLeftTable, isRightTable
7268 , keepLeftTable
7369 , keepRightTable
70+ , bindEitherTable
7471 , bitraverseEitherTable
75− , aggregateEitherTable
76− , nameEitherTable
7772
7873 -- ** @TheseTable@
7974 , TheseTable
@@ -81,100 +76,39 @@ module Rel8
8176 , isThisTable, isThatTable, isThoseTable
8277 , hasHereTable, hasThereTable
8378 , justHereTable, justThereTable
84− , alignMaybeTable
8579 , alignBy
8680 , keepHereTable, loseHereTable
8781 , keepThereTable, loseThereTable
8882 , keepThisTable, loseThisTable
8983 , keepThatTable, loseThatTable
9084 , keepThoseTable, loseThoseTable
85+ , bindTheseTable
9186 , bitraverseTheseTable
92− , aggregateTheseTable
93− , nameTheseTable
9487
9588 -- ** @ListTable@
9689 , ListTable
97− , listTable, ($*)
98− , nameListTable
9990 , many
100− , manyExpr
101− , catListTable
102− , catList
10391
10492 -- ** @NonEmptyTable@
10593 , NonEmptyTable
106− , nonEmptyTable, ($+)
107− , nameNonEmptyTable
10894 , some
109− , someExpr
110− , catNonEmptyTable
111− , catNonEmpty
112−
113− -- ** @NullTable@
114− , NullTable
115− , nullableTable, nullTable, nullifyTable
116− , isNullTable, isNonNullTable
117− , catNullTable
118− , nameNullTable
119− , toNullTable, toMaybeTable
120−
121− -- ** Algebraic data types / sum types
122− -- $adts
123−
124− -- *** Naming of ADTs
125− -- $naming
126− , NameADT, nameADT
127− , ADT, ADTable
128−
129− -- *** Deconstruction of ADTs
130− -- $deconstruction
131− , DeconstructADT, deconstructADT
132−
133− -- *** Construction of ADTs
134− -- $construction
135− , BuildADT, buildADT
136− , ConstructADT, constructADT
137−
138− -- *** Other ADT operations
139− , AggregateADT, aggregateADT
140−
141− -- *** Miscellaneous notes
142− -- $misc-notes
143−
144− -- ** @HKD@
145− , HKD, HKDable
146− , BuildHKD, buildHKD
147− , ConstructHKD, constructHKD
148− , DeconstructHKD, deconstructHKD
149− , NameHKD, nameHKD
150− , AggregateHKD, aggregateHKD
15195
15296 -- ** Table schemas
15397 , TableSchema(..)
15498 , Name
155− , namesFromLabels
156− , namesFromLabelsWith
15799
158100 -- * Expressions
159101 , Expr
160102 , Sql
161103 , litExpr
162− , unsafeCastExpr
163− , unsafeLiteral
164104
165105 -- ** @null@
166− , NotNull
167− , Nullable
168− , Homonullable
169− , null
170106 , nullify
171107 , nullable
172108 , isNull
173109 , isNonNull
174− , mapNull
175− , liftOpNull
176− , catNull
177− , coalesce
110+ , mapNullable
111+ , catNullable
178112
179113 -- ** Boolean operations
180114 , DBEq
@@ -184,7 +118,6 @@ module Rel8
184118 , (==.), (/=.), (==?), (/=?)
185119 , in_
186120 , boolExpr, caseExpr
187− , like, ilike
188121
189122 -- ** Ordering
190123 , DBOrd
@@ -196,19 +129,11 @@ module Rel8
196129 , Function
197130 , function
198131 , nullaryFunction
199− , binaryOperator
200132
201133 -- * Queries
202134 , Query
203135 , showQuery
204136
205− -- ** Projection
206− , Projection
207− , Projectable( project )
208− , Biprojectable( biproject )
209− , Projecting
210− , Field
211−
212137 -- ** Selecting rows
213138 , Selects
214139 , each
@@ -217,8 +142,8 @@ module Rel8
217142 -- ** Filtering
218143 , filter
219144 , where_
220− , present
221− , absent
145+ , whereExists
146+ , whereNotExists
222147 , distinct
223148 , distinctOn
224149 , distinctOnBy
@@ -248,16 +173,13 @@ module Rel8
248173
249174 -- ** Aggregation
250175 , Aggregate
251− , Aggregates
252176 , aggregate
253− , countRows
177+ , listAgg
178+ , nonEmptyAgg
254179 , groupBy
255− , listAgg, listAggExpr
256− , mode
257− , nonEmptyAgg, nonEmptyAggExpr
258180 , DBMax, max
259181 , DBMin, min
260− , DBSum, sum, sumWhere, avg
182+ , DBSum, sum
261183 , DBString, stringAgg
262184 , count
263185 , countStar
@@ -274,71 +196,40 @@ module Rel8
274196 , nullsFirst
275197 , nullsLast
276198
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−
303199 -- * IO
304200 , Serializable
305− , ToExprs
306− , Result
307201
308202 -- * Running statements
309− -- $running
310−
311203 -- ** @SELECT@
312204 , select
313205
314206 -- ** @INSERT@
315207 , Insert(..)
316208 , OnConflict(..)
317− , Upsert(..)
318209 , insert
319− , unsafeDefault
320− , showInsert
210+ , toInsert
211+ , toInsertDefaults
321212
322213 -- ** @DELETE@
323214 , Delete(..)
324215 , delete
325− , showDelete
326216
327217 -- ** @UPDATE@
328− , Update(..)
329218 , update
330− , showUpdate
219+ , Update(..)
331220
332221 -- ** @.. RETURNING@
333222 , Returning(..)
334223
335− -- ** @CREATE VIEW@
336− , createView
337− , createOrReplaceView
338−
339− -- ** Sequences
340− , nextval
341− , evaluate
224+ -- * TODO
225+ -- TODO
226+ -- These need organizing, but are reachable from Rel8's documentation so we
227+ -- do need to export and document them.
228+ , Nullabilizes
229+ , HTable
230+ , Labelable
231+ , Context
232+ , IsMaybe
342233 ) where
343234
344235-- base
@@ -346,94 +237,64 @@ import Prelude ()
346237
347238-- rel8
348239import Rel8.Aggregate
349−import Rel8.Column
350−import Rel8.Column.ADT
351−import Rel8.Column.Either
352−import Rel8.Column.Lift
353−import Rel8.Column.List
354−import Rel8.Column.Maybe
355−import Rel8.Column.NonEmpty
356−import Rel8.Column.Null
357−import Rel8.Column.These
358240import Rel8.Expr
359241import Rel8.Expr.Aggregate
360242import Rel8.Expr.Bool
361−import Rel8.Expr.Default
362243import Rel8.Expr.Eq
363244import Rel8.Expr.Function
364245import Rel8.Expr.Null
365−import Rel8.Expr.Opaleye (unsafeCastExpr, unsafeLiteral)
366246import Rel8.Expr.Ord
367247import Rel8.Expr.Order
368248import Rel8.Expr.Serialize
369−import Rel8.Expr.Sequence
370−import Rel8.Expr.Text ( like, ilike )
371−import Rel8.Expr.Window hiding ( cumulative )
372−import Rel8.Generic.Rel8able ( KRel8able, Rel8able )
373249import Rel8.Order
374250import Rel8.Query
375251import Rel8.Query.Aggregate
376252import Rel8.Query.Distinct
377253import Rel8.Query.Each
378254import Rel8.Query.Either
379−import Rel8.Query.Evaluate
380255import Rel8.Query.Exists
381256import Rel8.Query.Filter
382−import Rel8.Query.Indexed
383257import Rel8.Query.Limit
384258import Rel8.Query.List
385259import Rel8.Query.Maybe
386260import Rel8.Query.Null
387261import Rel8.Query.Order
388−import Rel8.Query.Rebind
389262import Rel8.Query.SQL (showQuery)
390263import Rel8.Query.Set
391264import Rel8.Query.These
392265import Rel8.Query.Values
393−import Rel8.Query.Window
394−import Rel8.Schema.Field
266+import Rel8.Schema.Column
267+import Rel8.Schema.Context (Name)
268+import Rel8.Schema.Context.Label
269+import Rel8.Schema.Generic
395270import Rel8.Schema.HTable
396−import Rel8.Schema.Name
397−import Rel8.Schema.Null hiding ( nullable )
398−import Rel8.Schema.Result ( Result )
271+import Rel8.Schema.Nullability
399272import Rel8.Schema.Table
400273import Rel8.Statement.Delete
401274import Rel8.Statement.Insert
402−import Rel8.Statement.OnConflict
403275import Rel8.Statement.Returning
404276import Rel8.Statement.Select
405−import Rel8.Statement.SQL
406277import Rel8.Statement.Update
407−import Rel8.Statement.View
408278import Rel8.Table
409−import Rel8.Table.ADT
410279import Rel8.Table.Aggregate
411280import Rel8.Table.Alternative
412281import Rel8.Table.Bool
413282import Rel8.Table.Either
414283import Rel8.Table.Eq
415−import Rel8.Table.HKD
284+import Rel8.Table.Insert
416285import Rel8.Table.List
417286import Rel8.Table.Maybe
418−import Rel8.Table.Name
419287import Rel8.Table.NonEmpty
420−import Rel8.Table.Null
421−import Rel8.Table.Opaleye ( castTable )
422288import Rel8.Table.Ord
423289import Rel8.Table.Order
424−import Rel8.Table.Projection
425−import Rel8.Table.Rel8able ()
290+import Rel8.Table.Recontextualize
426291import Rel8.Table.Serialize
427292import Rel8.Table.These
428−import Rel8.Table.Transpose
429−import Rel8.Table.Window
430293import Rel8.Type
431−import Rel8.Type.Composite
432294import Rel8.Type.Eq
433−import Rel8.Type.Enum
434295import Rel8.Type.Information
435−import Rel8.Type.JSONBEncoded
436296import Rel8.Type.JSONEncoded
297+import Rel8.Type.JSONBEncoded
437298import Rel8.Type.Monoid
438299import Rel8.Type.Num
439300import Rel8.Type.Ord
@@ -441,216 +302,361 @@ import Rel8.Type.ReadShow
441302import Rel8.Type.Semigroup
442303import Rel8.Type.String
443304import Rel8.Type.Sum
444−import Rel8.Window
445305
446306
447−-- $running
448−-- To run queries and otherwise interact with a PostgreSQL database, Rel8
449−-- provides 'select', 'insert', 'update' and 'delete' functions. Note that
450−-- 'insert', 'update' and 'delete' will generally need the
451−-- `DuplicateRecordFields` language extension enabled.
452−
453−-- $adts
454−-- Algebraic data types can be modelled between Haskell and SQL.
307+-- $setup
308+--
309+-- In this section, we'll take a look at using Rel8 to work with a small
310+-- database for Haskell packages. We'll take a look at idiomatic usage of Rel8,
311+-- mapping tables to Haskell, and then look at writing some simple queries.
312+--
313+-- The documentation in this library uses the following language extensions:
314+--
315+-- >>> :set -XBlockArguments
316+-- >>> :set -XDeriveAnyClass
317+-- >>> :set -XDeriveGeneric
318+-- >>> :set -XDerivingStrategies
319+-- >>> :set -XDerivingVia
320+-- >>> :set -XDuplicateRecordFields
321+-- >>> :set -XGeneralizedNewtypeDeriving
322+-- >>> :set -XOverloadedStrings
323+-- >>> :set -XStandaloneDeriving
324+-- >>> :set -XTypeApplications
325+-- >>> :set -XTypeFamilies
326+--
327+-- Before we start writing any Haskell, let's take a look at the schema we'll
328+-- work with.
329+--
330+-- > author: project:
331+-- >
332+-- > Column │ Type │ Nullable Column │ Type │ Nullable
333+-- > ═══════════╪═════════╪══════════ ═══════════╪═════════╪══════════
334+-- > author_id │ integer │ not null author_id │ integer │ not null
335+-- > name │ text │ not null name │ text │ not null
336+-- > url │ text │
337+--
338+-- Our schema consists of two tables - @author@ and @project@. A @project@
339+-- always has an @author@, but not all @author@s have projects. Each @author@
340+-- has a name and (maybe) an associated website, and each project has a name.
341+--
342+-- Now that we've seen our schema, we can begin writing a mapping in Rel8. The
343+-- idiomatic way to map a table is to use a record that is parameterised what
344+-- Rel8 calls an /interpretation functor/, and to define each field with
345+-- 'Column'. For this type to be usable with Rel8 we need it to be an instance
346+-- of 'HigherKindedTable', which can be derived with a combination of
347+-- @DeriveAnyClass@ and @DeriveGeneric@.
348+--
349+-- Following these steps for @author@, we have:
350+--
351+-- > data Author f = Author
352+-- > { authorId :: Column f Int64
353+-- > , name :: Column f Text
354+-- > , url :: Column f (Maybe Text)
355+-- > } deriving (Generic, HigherKindedTable)
356+--
357+-- This is a perfectly reasonable definition, but cautious readers might notice
358+-- a problem - in particular, with the type of the @authorId@ field. While
359+-- @Int64@ is correct, it's not the best type. If we had other identifier types
360+-- in our project, it would be too easy to accidentally mix them up and create
361+-- nonsensical joins. As Haskell programmers, we often solve this problem by
362+-- creating @newtype@ wrappers, and we can also use this technique with Rel8:
363+--
364+-- >>> :{
365+-- newtype AuthorId = AuthorId { toInt64 :: Int64 }
366+-- deriving newtype (DBEq, DBType, Eq, Show)
367+-- :}
455368--
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.
369+-- Now we can write our final schema mapping. First, the @author@ table:
459370--
460−-- The documentation in this section will assume a set of database types like this:
371+-- >>> :{
372+-- data Author f = Author
373+-- { authorId :: Column f AuthorId
374+-- , authorName :: Column f Text
375+-- , authorUrl :: Column f (Maybe Text)
376+-- }
377+-- deriving stock Generic
378+-- deriving anyclass HigherKindedTable
379+-- :}
461380--
462−-- @
463−-- data Thing f = ThingEmployer (Employer f) | ThingPotato (Potato f) | Nullary
464−-- deriving stock Generic
381+-- And similarly, the @project@ table:
465382--
466−-- data Employer f = Employer { employerId :: f Int32, employerName :: f Text}
383+-- >>> :{
384+-- data Project f = Project
385+-- { projectAuthorId :: Column f AuthorId
386+-- , projectName :: Column f Text
387+-- }
467388-- deriving stock Generic
468−-- deriving anyclass Rel8able
389+-- deriving anyclass HigherKindedTable
390+-- :}
469391--
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−-- ]
392+-- To show query results in this documentation, we'll also need @Show@
393+-- instances: Unfortunately these definitions look a bit scary, but they are
394+-- essentially just @deriving (Show)@:
395+--
396+-- >>> deriving stock instance f ~ Identity => Show (Author f)
397+-- >>> deriving stock instance f ~ Identity => Show (Project f)
398+--
399+-- These data types describe the structural mapping of the tables, but we also
400+-- need to specify a 'TableSchema' for each table. A @TableSchema@ contains the
401+-- name of the table and the name of all columns in the table, which will
402+-- ultimately allow us to @SELECT@ and @INSERT@ rows for these tables.
403+--
404+-- To define a @TableSchema@, we just need to fill construct appropriate
405+-- @TableSchema@ values. When it comes to the @tableColumns@ field, we
406+-- construct values of our data types above, and set each field to the name of
407+-- the column that it maps to:
408+--
409+-- First, @authorSchema@ describes the column names of the @author@ table when
410+-- associated with the @Author@ type:
411+--
412+-- >>> :{
413+-- authorSchema :: TableSchema (Author ColumnSchema)
414+-- authorSchema = TableSchema
415+-- { tableName = "author"
416+-- , tableSchema = Nothing
417+-- , tableColumns = Author
418+-- { authorId = "author_id"
419+-- , authorName = "name"
420+-- , authorUrl = "url"
421+-- }
422+-- }
423+-- :}
424+--
425+-- And likewise for @project@ and @Project@:
426+--
427+-- >>> :{
428+-- projectSchema :: TableSchema (Project ColumnSchema)
429+-- projectSchema = TableSchema
430+-- { tableName = "project"
431+-- , tableSchema = Nothing
432+-- , tableColumns = Project
433+-- { projectAuthorId = "author_id"
434+-- , projectName = "name"
435+-- }
436+-- }
437+-- :}
438+--
439+-- Aside: you might be wondering why this information isn't in the definitions
440+-- of @Author@ and @Project@ above. Rel8 decouples @TableSchema@ from the data
441+-- types themselves, as not all tables you define will necessarily have a
442+-- schema. For example, Rel8 allows you to define helper types to simplify the
443+-- types of queries - these tables only exist at query time, but there is no
444+-- corresponding base table. We'll see more on this idea later!
445+--
446+-- With these table definitions, we can now start writing some queries! To
447+-- actually run a query, we'll need a database connection. Rel8 uses the
448+-- @hasql@ library, and for this documentation we'll get the connection string
449+-- from the @$TEST_DATABASE_URL@ environment variable.
450+--
451+-- >>> connectionString <- System.Environment.getEnv "TEST_DATABASE_URL"
452+-- >>> Right c <- Hasql.Connection.acquire (Data.ByteString.Char8.pack connectionString)
453+-- >>> Control.Monad.void $ Hasql.Session.run (Hasql.Session.sql "BEGIN") c
454+
455+-- $guideQueries
456+--
457+-- First, we'll take a look at @SELECT@ statements - usually the bulk of most
458+-- database heavy applications.
459+--
460+-- In Rel8, @SELECT@ statements are built using the 'Query' monad. You can
461+-- think of this monad like the ordinary @[]@ (List) monad - but this isn't
462+-- required knowledge.
463+--
464+-- To start, we'll look at one of the simplest queries possible - a basic
465+-- @SELECT * FROM@ statement. To select all rows from a table, we use 'each',
466+-- and supply a 'TableSchema'. So to select all @project@ rows, we can write:
467+--
468+-- >>> :t each projectSchema
469+-- each projectSchema :: Query (Project Expr)
470+--
471+-- Notice that @each@ gives us a @Query@ that yields @Project Expr@ rows. To
472+-- see what this means, let's have a look at a single field of a
473+-- @Project Expr@:
474+--
475+-- >>> let aProjectExpr = undefined :: Project Expr
476+-- >>> :t projectAuthorId aProjectExpr
477+-- projectAuthorId aProjectExpr :: Expr AuthorId
478+--
479+-- Recall we defined @projectAuthorId@ as @Column f AuthorId@. Now we have @f@
480+-- is @Expr@, and @Column Expr AuthorId@ reduces to @Expr AuthorId@. We'll see
481+-- more about @Expr@ soon, but you can think of @Expr a@ as "SQL expressions of
482+-- type @a@".
483+--
484+-- To execute this @Query@, we pass it to 'select':
485+--
486+-- >>> :t select c (each projectSchema)
487+-- select c (each projectSchema) :: MonadIO m => m [Project Identity]
488+--
489+-- When we @select@ things containing @Expr@s, Rel8 builds a new response table
490+-- with the @Identity@ interpretation. This means you'll get back plain Haskell
491+-- values. Studying @projectAuthorId@ again, we have:
492+--
493+-- >>> let aProjectIdentity = undefined :: Project Identity
494+-- >>> :t projectAuthorId aProjectIdentity
495+-- projectAuthorId aProjectIdentity :: AuthorId
496+--
497+-- Here @Column Identity AuthorId@ reduces to just @AuthorId@, with no
498+-- wrappping type at all.
499+--
500+-- Putting this all together, we can run our first query:
501+--
502+-- >>> select c (each projectSchema) >>= mapM_ print
503+-- Project {projectAuthorId = 1, projectName = "rel8"}
504+-- Project {projectAuthorId = 2, projectName = "aeson"}
505+-- Project {projectAuthorId = 2, projectName = "text"}
506+--
507+-- Cool!
508+--
509+-- We now know that 'each' is the equivalent of a @SELECT *@ query, but
510+-- sometimes we're only interested in a subset of the columns of a table. To
511+-- restrict the returned columns, we can specify a projection by using 'Query's
512+-- @Functor@ instance:
513+--
514+-- >>> select c $ projectName <$> each projectSchema
515+-- ["rel8","aeson","text"]
516+
517+-- $guideJoins
518+--
519+-- Another common operation in relational databases is to take the @JOIN@ of
520+-- multiple tables. Rel8 doesn't have a specific join operation, but we can
521+-- recover the functionality of a join by selecting all rows of two tables, and
522+-- then using 'where_' to filter them.
523+--
524+-- To see how this works, first let's look at taking the product of two tables.
525+-- We can do this by simply calling 'each' twice, and then returning a tuple of
526+-- their results.
527+--
528+-- >>> :{
529+-- mapM_ print =<< select c do
530+-- author <- each authorSchema
531+-- project <- each projectSchema
532+-- return (projectName project, authorName author)
533+-- :}
534+-- ("rel8","Ollie")
535+-- ("rel8","Bryan O'Sullivan")
536+-- ("rel8","Emily Pillmore")
537+-- ("aeson","Ollie")
538+-- ("aeson","Bryan O'Sullivan")
539+-- ("aeson","Emily Pillmore")
540+-- ("text","Ollie")
541+-- ("text","Bryan O'Sullivan")
542+-- ("text","Emily Pillmore")
543+--
544+-- This isn't quite right, though, as we have ended up pairing up the wrong
545+-- projects and authors. To fix this, we can use 'where_' to restrict the
546+-- returned rows. We could write:
547+--
548+-- > select c $ do
549+-- > author <- each authorSchema
550+-- > project <- each projectSchema
551+-- > where_ $ projectAuthorId project ==. authorId author
552+-- > return (project, author)
553+--
554+-- but doing this every time you need a join can obscure the meaning of the
555+-- query you're writing. A good practice is to introduce specialised functions
556+-- for the particular joins in your database. In our case, this would be:
557+--
558+-- >>> :{
559+-- projectsForAuthor :: Author Expr -> Query (Project Expr)
560+-- projectsForAuthor a = each projectSchema >>= filter \p ->
561+-- projectAuthorId p ==. authorId a
562+-- :}
563+--
564+-- Our final query is then:
565+--
566+-- >>> :{
567+-- mapM_ print =<< select c do
568+-- author <- each authorSchema
569+-- project <- projectsForAuthor author
570+-- return (projectName project, authorName author)
571+-- :}
572+-- ("rel8","Ollie")
573+-- ("aeson","Bryan O'Sullivan")
574+-- ("text","Bryan O'Sullivan")
575+--
576+-- == @LEFT JOIN@s
577+--
578+-- Rel8 is also capable of performing @LEFT JOIN@s. To perform @LEFT JOIN@s, we
579+-- follow the same approach as before, but use the 'optional' query transformer
580+-- to allow for the possibility of the join to fail.
581+--
582+-- In our test database, we can see that there's another author who we haven't
583+-- seen yet:
584+--
585+-- >>> select c $ authorName <$> each authorSchema
586+-- ["Ollie","Bryan O'Sullivan","Emily Pillmore"]
587+--
588+-- Emily wasn't returned in our earlier query because - in our database - she
589+-- doesn't have any registered projects. We can account for this partiality in
590+-- our original query by wrapping the @projectsForAuthor@ call with 'optional':
591+--
592+-- >>> :{
593+-- mapM_ print =<< select c do
594+-- author <- each authorSchema
595+-- mproject <- optional $ projectsForAuthor author
596+-- return (authorName author, projectName <$> mproject)
597+-- :}
598+-- ("Ollie",Just "rel8")
599+-- ("Bryan O'Sullivan",Just "aeson")
600+-- ("Bryan O'Sullivan",Just "text")
601+-- ("Emily Pillmore",Nothing)
602+
603+-- $guideAggregation
604+--
605+-- Aggregations are operations like @sum@ and @count@ - operations that reduce
606+-- multiple rows to single values. To perform aggregations in Rel8, we can use
607+-- the 'aggregate' function, which takes a 'Query' of aggregated expressions,
608+-- runs the aggregation, and returns aggregated rows.
609+--
610+-- To start, let's look at a simple aggregation that tells us how many projects
611+-- exist:
612+--
613+-- >>> error "TODO"
614+--
615+-- Rel8 is also capable of aggregating multiple rows into a single row by
616+-- concatenating all rows as a list. This aggregation allows us to break free
617+-- of the row-orientated nature of SQL and write queries that return tree-like
618+-- structures. Earlier we saw an example of returning authors with their
619+-- projects, but the query didn't do a great job of describing the one-to-many
620+-- relationship between authors and their projects.
621+--
622+-- Let's look again at a query that returns authors and their projects, and
623+-- focus on the /type/ of that query.
624+--
625+-- >>> :{
626+-- projectsForAuthor a = each projectSchema >>= filter \p ->
627+-- projectAuthorId p ==. authorId a
628+-- :}
629+--
630+-- >>> :{
631+-- let authorsAndProjects = do
632+-- author <- each authorSchema
633+-- project <- projectsForAuthor author
634+-- return (author, project)
635+-- where
636+-- :}
637+--
638+-- >>> :t select c authorsAndProjects
639+-- select c authorsAndProjects
640+-- :: MonadIO m => m [(Author Identity, Project Identity)]
641+--
642+-- Our query gives us a single list of pairs of authors and projects. However,
643+-- with our domain knowledge of the schema, this isn't a great type - what we'd
644+-- rather have is a list of pairs of authors and /lists/ of projects. That is,
645+-- what we'd like is:
646+--
647+-- > [(Author Identity, [Project Identity])]
648+--
649+-- This would be a much better type! Rel8 can produce a query with this type by
650+-- simply wrapping the call to @projectsForAuthor@ with either 'some' or
651+-- 'many'. Here we'll use 'many', which allows for the possibility of an author
652+-- to have no projects:
653+--
654+-- >>> :{
655+-- mapM_ print =<< select c do
656+-- author <- each authorSchema
657+-- projectNames <- many $ projectName <$> projectsForAuthor author
658+-- return (authorName author, projectNames)
586659-- :}
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.
660+-- ("Ollie",["rel8"])
661+-- ("Bryan O'Sullivan",["aeson","text"])
662+-- ("Emily Pillmore",[])
src/Rel8/Aggregate.hs+49−59
@@ -1,83 +1,73 @@
1−{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
3−{-# language FlexibleInstances #-}
4−{-# language MultiParamTypeClasses #-}
5−{-# language RankNTypes #-}
1+{-# language DerivingVia #-}
2+{-# language GeneralizedNewtypeDeriving #-}
3+{-# language NamedFieldPuns #-}
64{-# language StandaloneKindSignatures #-}
7−{-# language TypeFamilies #-}
8−{-# language UndecidableInstances #-}
95
106module Rel8.Aggregate
11− ( Aggregate(..), zipOutputs
12− , unsafeMakeAggregate
13− , Aggregates
7+ ( Aggregate(..), foldInputs, mapInputs
8+ , Aggregator(..), unsafeMakeAggregate
149 )
1510where
1611
1712-- base
18−import Control.Applicative ( liftA2 )
19−import Data.Functor.Identity ( Identity( Identity ) )
20−import Data.Kind ( Constraint, Type )
13+import Data.Functor.Const ( Const( Const ), getConst )
14+import Data.Kind ( Type )
2115import Prelude
2216
23−-- profunctors
24−import Data.Profunctor ( dimap )
25−
2617-- opaleye
27−import qualified Opaleye.Aggregate as Opaleye
18+import qualified Opaleye.Internal.Aggregate as Opaleye
2819import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
29−import qualified Opaleye.Internal.Column as Opaleye
30−
31−-- rel8
32−import Rel8.Expr ( Expr )
33−import Rel8.Schema.HTable.Identity ( HIdentity(..) )
34−import qualified Rel8.Schema.Kind as K
35−import Rel8.Schema.Null ( Sql )
36−import Rel8.Table
37− ( Table, Columns, Context, fromColumns, toColumns
38− , FromExprs, fromResult, toResult
39− , Transpose
40− )
41−import Rel8.Table.Transpose ( Transposes )
42−import Rel8.Type ( DBType )
20+import qualified Opaleye.Internal.PackMap as Opaleye
4321
22+-- semigroupoids
23+import Data.Functor.Apply ( Apply, WrappedApplicative(..) )
4424
45−-- | 'Aggregate' is a special context used by 'Rel8.aggregate'.
46−type Aggregate :: K.Context
47−newtype Aggregate a = Aggregate (Opaleye.Aggregator () (Expr a))
4825
26+-- | An @Aggregate a@ describes how to aggregate @Table@s of type @a@. You can
27+-- unpack an @Aggregate@ back to @a@ by running it with 'aggregate'. As
28+-- @Aggregate@ is almost an 'Applicative' functor - but there is no 'pure'
29+-- operation. This means 'Aggregate' is an instance of 'Apply', and you can
30+-- combine @Aggregate@s using the @<.>@ combinator.
31+type Aggregate :: Type -> Type
32+newtype Aggregate a = Aggregate (Opaleye.Aggregator () a)
33+ deriving newtype Functor
34+ deriving Apply via (WrappedApplicative (Opaleye.Aggregator ()))
4935
50−instance Sql DBType a => Table Aggregate (Aggregate a) where
51− type Columns (Aggregate a) = HIdentity a
52− type Context (Aggregate a) = Aggregate
53− type FromExprs (Aggregate a) = a
54− type Transpose to (Aggregate a) = to a
5536
56− toColumns = HIdentity
57− fromColumns (HIdentity a) = a
58− toResult = HIdentity . Identity
59− fromResult (HIdentity (Identity a)) = a
37+foldInputs :: Monoid b
38+ => (Maybe Aggregator -> Opaleye.PrimExpr -> b) -> Aggregate a -> b
39+foldInputs f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =
40+ getConst $ flip agg () $ \(aggregator, a) ->
41+ Const $ f (detuplize <$> aggregator) a
42+ where
43+ detuplize (operation, ordering, distinction) =
44+ Aggregator {operation, ordering, distinction}
6045
6146
62−-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate's
63−-- for the 'Expr' columns in @b@.
64−type Aggregates :: Type -> Type -> Constraint
65−class Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs
66−instance Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs
47+mapInputs :: ()
48+ => (Opaleye.PrimExpr -> Opaleye.PrimExpr) -> Aggregate a -> Aggregate a
49+mapInputs transform (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =
50+ Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ agg . \f input ->
51+ f (fmap transform input)
6752
6853
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)
54+type Aggregator :: Type
55+data Aggregator = Aggregator
56+ { operation :: Opaleye.AggrOp
57+ , ordering :: [Opaleye.OrderExpr]
58+ , distinction :: Opaleye.AggrDistinct
59+ }
7260
7361
74−unsafeMakeAggregate :: forall (input :: Type) (output :: Type) n n' a a'. ()
75− => (Expr input -> Opaleye.PrimExpr)
76− -> (Opaleye.PrimExpr -> Expr output)
77− -> Opaleye.Aggregator (Opaleye.Field_ n a) (Opaleye.Field_ n' a')
78− -> Expr input
62+unsafeMakeAggregate :: ()
63+ => (input -> Opaleye.PrimExpr)
64+ -> (Opaleye.PrimExpr -> output)
65+ -> Maybe Aggregator
66+ -> input
7967 -> Aggregate output
8068unsafeMakeAggregate input output aggregator expr =
81− Aggregate $ dimap in_ out aggregator
82− where out = output . Opaleye.unColumn
83− in_ = Opaleye.Column . input . const expr
69+ Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ \f _ ->
70+ output <$> f (tuplize <$> aggregator, input expr)
71+ where
72+ tuplize Aggregator {operation, ordering, distinction} =
73+ (operation, ordering, distinction)
src/Rel8/Column.hsdeleted−31
@@ -1,31 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language StandaloneKindSignatures #-}
3−{-# language TypeFamilies #-}
4−
5−module Rel8.Column
6− ( Column
7− , TColumn
8− )
9−where
10−
11−-- base
12−import Data.Kind ( Type )
13−import Prelude ()
14−
15−-- rel8
16−import Rel8.FCF ( Eval, Exp )
17−import qualified Rel8.Schema.Kind as K
18−import Rel8.Schema.Result ( Result )
19−
20−
21−-- | This type family is used to specify columns in 'Rel8able's. In @Column f
22−-- a@, @f@ is the context of the column (which should be left polymorphic in
23−-- 'Rel8able' definitions), and @a@ is the type of the column.
24−type Column :: K.Context -> Type -> Type
25−type family Column context a where
26− Column Result a = a
27− Column context a = context a
28−
29−
30−data TColumn :: K.Context -> Type -> Exp Type
31−type instance Eval (TColumn f a) = Column f a
src/Rel8/Column/ADT.hsdeleted−23
@@ -1,23 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language StandaloneKindSignatures #-}
3−{-# language TypeFamilies #-}
4−
5−module Rel8.Column.ADT
6− ( HADT
7− )
8−where
9−
10−-- base
11−import Data.Kind ( Type )
12−import Prelude ()
13−
14−-- rel8
15−import qualified Rel8.Schema.Kind as K
16−import Rel8.Schema.Result ( Result )
17−import Rel8.Table.ADT ( ADT )
18−
19−
20−type HADT :: K.Context -> K.Rel8able -> Type
21−type family HADT context t where
22− HADT Result t = t Result
23− HADT context t = ADT t context
src/Rel8/Column/Either.hsdeleted−26
@@ -1,26 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language StandaloneKindSignatures #-}
3−{-# language TypeFamilyDependencies #-}
4−
5−module Rel8.Column.Either
6− ( HEither
7− )
8−where
9−
10−-- base
11−import Data.Kind ( Type )
12−import Prelude
13−
14−-- rel8
15−import qualified Rel8.Schema.Kind as K
16−import Rel8.Schema.Result ( Result )
17−import Rel8.Table.Either ( EitherTable )
18−
19−
20−-- | Nest an 'Either' value within a 'Rel8able'. @HEither f a b@ will produce a
21−-- 'EitherTable' @a b@ in the 'Expr' context, and a 'Either' @a b@ in the
22−-- 'Result' context.
23−type HEither :: K.Context -> Type -> Type -> Type
24−type family HEither context = either | either -> context where
25− HEither Result = Either
26− HEither context = EitherTable context
src/Rel8/Column/Lift.hsdeleted−23
@@ -1,23 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language StandaloneKindSignatures #-}
3−{-# language TypeFamilies #-}
4−
5−module Rel8.Column.Lift
6− ( Lift
7− )
8−where
9−
10−-- base
11−import Data.Kind ( Type )
12−import Prelude ()
13−
14−-- rel8
15−import qualified Rel8.Schema.Kind as K
16−import Rel8.Schema.Result ( Result )
17−import Rel8.Table.HKD ( HKD )
18−
19−
20−type Lift :: K.Context -> Type -> Type
21−type family Lift context a where
22− Lift Result a = a
23− Lift context a = HKD a context
src/Rel8/Column/List.hsdeleted−25
@@ -1,25 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language StandaloneKindSignatures #-}
3−{-# language TypeFamilyDependencies #-}
4−
5−module Rel8.Column.List
6− ( HList
7− )
8−where
9−
10−-- base
11−import Data.Kind ( Type )
12−import Prelude ()
13−
14−-- rel8
15−import qualified Rel8.Schema.Kind as K
16−import Rel8.Schema.Result ( Result )
17−import Rel8.Table.List ( ListTable )
18−
19−
20−-- | Nest a list within a 'Rel8able'. @HList f a@ will produce a 'ListTable'
21−-- @a@ in the 'Expr' context, and a @[a]@ in the 'Result' context.
22−type HList :: K.Context -> Type -> Type
23−type family HList context = list | list -> context where
24− HList Result = []
25− HList context = ListTable context
src/Rel8/Column/Maybe.hsdeleted−26
@@ -1,26 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language StandaloneKindSignatures #-}
3−{-# language TypeFamilyDependencies #-}
4−
5−module Rel8.Column.Maybe
6− ( HMaybe
7− )
8−where
9−
10−-- base
11−import Data.Kind ( Type )
12−import Prelude
13−
14−-- rel8
15−import qualified Rel8.Schema.Kind as K
16−import Rel8.Schema.Result ( Result )
17−import Rel8.Table.Maybe ( MaybeTable )
18−
19−
20−-- | Nest a 'Maybe' value within a 'Rel8able'. @HMaybe f a@ will produce a
21−-- 'MaybeTable' @a@ in the 'Expr' context, and a 'Maybe' @a@ in the 'Result'
22−-- context.
23−type HMaybe :: K.Context -> Type -> Type
24−type family HMaybe context = maybe | maybe -> context where
25− HMaybe Result = Maybe
26− HMaybe context = MaybeTable context
src/Rel8/Column/NonEmpty.hsdeleted−27
@@ -1,27 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language StandaloneKindSignatures #-}
3−{-# language TypeFamilyDependencies #-}
4−
5−module Rel8.Column.NonEmpty
6− ( HNonEmpty
7− )
8−where
9−
10−-- base
11−import Data.Kind ( Type )
12−import Data.List.NonEmpty ( NonEmpty )
13−import Prelude ()
14−
15−-- rel8
16−import qualified Rel8.Schema.Kind as K
17−import Rel8.Schema.Result ( Result )
18−import Rel8.Table.NonEmpty ( NonEmptyTable )
19−
20−
21−-- | Nest a 'NonEmpty' list within a 'Rel8able'. @HNonEmpty f a@ will produce a
22−-- 'NonEmptyTable' @a@ in the 'Expr' context, and a 'NonEmpty' @a@ in the
23−-- 'Result' context.
24−type HNonEmpty :: K.Context -> Type -> Type
25−type family HNonEmpty context = nonEmpty | nonEmpty -> context where
26− HNonEmpty Result = NonEmpty
27− HNonEmpty context = NonEmptyTable context
src/Rel8/Column/Null.hsdeleted−26
@@ -1,26 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language StandaloneKindSignatures #-}
3−{-# language TypeFamilyDependencies #-}
4−
5−module Rel8.Column.Null
6− ( HNull
7− )
8−where
9−
10−-- base
11−import Data.Kind ( Type )
12−import Prelude
13−
14−-- rel8
15−import qualified Rel8.Schema.Kind as K
16−import Rel8.Schema.Result ( Result )
17−import Rel8.Table.Null ( NullTable )
18−
19−
20−-- | Nest a 'Null' value within a 'Rel8able'. @HNull f a@ will produce a
21−-- 'NullTable' @a@ in the 'Expr' context, and a @'Maybe' a@ in the 'Result'
22−-- context.
23−type HNull :: K.Context -> Type -> Type
24−type family HNull context = maybe | maybe -> context where
25− HNull Result = Maybe
26− HNull context = NullTable context
src/Rel8/Column/These.hsdeleted−29
@@ -1,29 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language StandaloneKindSignatures #-}
3−{-# language TypeFamilyDependencies #-}
4−
5−module Rel8.Column.These
6− ( HThese
7− )
8−where
9−
10−-- base
11−import Data.Kind ( Type )
12−import Prelude ()
13−
14−-- rel8
15−import qualified Rel8.Schema.Kind as K
16−import Rel8.Schema.Result ( Result )
17−import Rel8.Table.These ( TheseTable )
18−
19−-- these
20−import Data.These ( These )
21−
22−
23−-- | Nest an 'These' value within a 'Rel8able'. @HThese f a b@ will produce a
24−-- 'TheseTable' @a b@ in the 'Expr' context, and a 'These' @a b@ in the
25−-- 'Result' context.
26−type HThese :: K.Context -> Type -> Type -> Type
27−type family HThese context = these | these -> context where
28− HThese Result = These
29− HThese context = TheseTable context
src/Rel8/Expr.hs+19−57
@@ -1,12 +1,11 @@
11{-# language DataKinds #-}
22{-# language DerivingStrategies #-}
33{-# language FlexibleContexts #-}
4−{-# language FlexibleInstances #-}
5−{-# language MultiParamTypeClasses #-}
4+{-# language GADTs #-}
5+{-# language RoleAnnotations #-}
66{-# language ScopedTypeVariables #-}
77{-# language StandaloneKindSignatures #-}
88{-# language TypeApplications #-}
9−{-# language TypeFamilies #-}
109{-# language UndecidableInstances #-}
1110
1211module Rel8.Expr
@@ -15,7 +14,7 @@ module Rel8.Expr
1514where
1615
1716-- base
18−import Data.Functor.Identity ( Identity( Identity ) )
17+import Data.Kind ( Type )
1918import Data.String ( IsString, fromString )
2019import Prelude hiding ( null )
2120
@@ -23,8 +22,7 @@ import Prelude hiding ( null )
2322import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
2423
2524-- rel8
26−import Rel8.Expr.Function ( function, nullaryFunction )
27−import Rel8.Expr.Null ( liftOpNull, nullify )
25+import Rel8.Expr.Null ( liftOpNullable, nullify )
2826import Rel8.Expr.Opaleye
2927 ( castExpr
3028 , fromPrimExpr
@@ -32,44 +30,41 @@ import Rel8.Expr.Opaleye
3230 , zipPrimExprsWith
3331 )
3432import Rel8.Expr.Serialize ( litExpr )
35−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
36−import qualified Rel8.Schema.Kind as K
37−import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
38−import Rel8.Table
39− ( Table, Columns, Context, fromColumns, toColumns
40− , FromExprs, fromResult, toResult
41− , Transpose
33+import Rel8.Schema.Nullability
34+ ( Nullability( Nullable, NonNullable )
35+ , Sql, nullabilization
4236 )
4337import Rel8.Type ( DBType )
4438import Rel8.Type.Monoid ( DBMonoid, memptyExpr )
45−import Rel8.Type.Num ( DBFloating, DBFractional, DBNum )
39+import Rel8.Type.Num ( DBFractional, DBNum )
4640import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )
4741
4842
4943-- | Typed SQL expressions.
50−type Expr :: K.Context
44+type role Expr representational
45+type Expr :: Type -> Type
5146newtype Expr a = Expr Opaleye.PrimExpr
5247 deriving stock Show
5348
5449
5550instance Sql DBSemigroup a => Semigroup (Expr a) where
56− (<>) = case nullable @a of
57− Null -> liftOpNull (<>.)
58− NotNull -> (<>.)
51+ (<>) = case nullabilization @a of
52+ Nullable -> liftOpNullable (<>.)
53+ NonNullable -> (<>.)
5954 {-# INLINABLE (<>) #-}
6055
6156
6257instance Sql DBMonoid a => Monoid (Expr a) where
63− mempty = case nullable @a of
64− Null -> nullify memptyExpr
65− NotNull -> memptyExpr
58+ mempty = case nullabilization @a of
59+ Nullable -> nullify memptyExpr
60+ NonNullable -> memptyExpr
6661 {-# INLINABLE mempty #-}
6762
6863
6964instance (Sql IsString a, Sql DBType a) => IsString (Expr a) where
70− fromString = litExpr . case nullable @a of
71− Null -> Just . fromString
72− NotNull -> fromString
65+ fromString = litExpr . case nullabilization @a of
66+ Nullable -> Just . fromString
67+ NonNullable -> fromString
7368
7469
7570instance Sql DBNum a => Num (Expr a) where
@@ -90,36 +85,3 @@ instance Sql DBFractional a => Fractional (Expr a) where
9085
9186 fromRational =
9287 castExpr . Expr . Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac
93−
94−
95−instance Sql DBFloating a => Floating (Expr a) where
96− pi = nullaryFunction "PI"
97− exp = function "exp"
98− log = function "ln"
99− sqrt = function "sqrt"
100− (**) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:^))
101− logBase = function "log"
102− sin = function "sin"
103− cos = function "cos"
104− tan = function "tan"
105− asin = function "asin"
106− acos = function "acos"
107− atan = function "atan"
108− sinh = function "sinh"
109− cosh = function "cosh"
110− tanh = function "tanh"
111− asinh = function "asinh"
112− acosh = function "acosh"
113− atanh = function "atanh"
114−
115−
116−instance Sql DBType a => Table Expr (Expr a) where
117− type Columns (Expr a) = HIdentity a
118− type Context (Expr a) = Expr
119− type FromExprs (Expr a) = a
120− type Transpose to (Expr a) = to a
121−
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+4−5
@@ -1,4 +1,4 @@
1−{-# language DataKinds #-}
1+{-# language RoleAnnotations #-}
22{-# language StandaloneKindSignatures #-}
33
44module Rel8.Expr
@@ -7,14 +7,13 @@ module Rel8.Expr
77where
88
99-- base
10+import Data.Kind ( Type )
1011import Prelude ()
1112
1213-- opaleye
1314import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
1415
15−-- rel8
16−import Rel8.Schema.Kind ( Context )
1716
18−
19−type Expr :: Context
17+type role Expr representational
18+type Expr :: Type -> Type
2019newtype Expr a = Expr Opaleye.PrimExpr
src/Rel8/Expr/Aggregate.hs+87−58
@@ -1,6 +1,7 @@
11{-# language DataKinds #-}
22{-# language FlexibleContexts #-}
33{-# language ScopedTypeVariables #-}
4+{-# language TypeApplications #-}
45{-# language TypeFamilies #-}
56
67{-# options_ghc -fno-warn-redundant-constraints #-}
@@ -10,11 +11,10 @@ module Rel8.Expr.Aggregate
1011 , and, or
1112 , min, max
1213 , sum, sumWhere
13− , avg
1414 , stringAgg
1515 , groupByExpr
1616 , listAggExpr, nonEmptyAggExpr
17− , slistAggExpr, snonEmptyAggExpr
17+ , sgroupByExpr
1818 )
1919where
2020
@@ -24,12 +24,10 @@ import Data.List.NonEmpty ( NonEmpty )
2424import Prelude hiding ( and, max, min, null, or, sum )
2525
2626-- opaleye
27−import qualified Opaleye.Internal.Aggregate as Opaleye
28−import Opaleye.Internal.Column ( Field_( Column ) )
29−import qualified Opaleye.Aggregate as Opaleye
27+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
3028
3129-- rel8
32−import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )
30+import Rel8.Aggregate ( Aggregate, Aggregator(..), unsafeMakeAggregate )
3331import Rel8.Expr ( Expr )
3432import Rel8.Expr.Bool ( caseExpr )
3533import Rel8.Expr.Opaleye
@@ -40,11 +38,9 @@ import Rel8.Expr.Opaleye
4038 )
4139import Rel8.Expr.Null ( null )
4240import Rel8.Expr.Serialize ( litExpr )
43−import Rel8.Schema.Null ( Sql, Unnullify )
44−import Rel8.Type ( DBType, typeInformation )
45−import Rel8.Type.Array ( encodeArrayElement )
41+import Rel8.Schema.Nullability ( Nullability, Sql, nullabilization )
42+import Rel8.Type.Array ( fromPrimArray )
4643import Rel8.Type.Eq ( DBEq )
47−import Rel8.Type.Information ( TypeInformation )
4844import Rel8.Type.Num ( DBNum )
4945import Rel8.Type.Ord ( DBMax, DBMin )
5046import Rel8.Type.String ( DBString )
@@ -52,99 +48,132 @@ import Rel8.Type.Sum ( DBSum )
5248
5349
5450-- | Count the occurances of a single column. Corresponds to @COUNT(a)@
55−count :: Expr a -> Aggregate Int64
56−count = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.count
51+count :: Expr a -> Aggregate (Expr Int64)
52+count = unsafeMakeAggregate toPrimExpr fromPrimExpr $
53+ Just Aggregator
54+ { operation = Opaleye.AggrCount
55+ , ordering = []
56+ , distinction = Opaleye.AggrAll
57+ }
58+
5759
5860-- | Count the number of distinct occurances of a single column. Corresponds to
5961-- @COUNT(DISTINCT a)@
60−countDistinct :: Sql DBEq a => Expr a -> Aggregate Int64
62+countDistinct :: DBEq a => Expr a -> Aggregate (Expr Int64)
6163countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $
62− Opaleye.distinctAggregator Opaleye.count
64+ Just Aggregator
65+ { operation = Opaleye.AggrCount
66+ , ordering = []
67+ , distinction = Opaleye.AggrDistinct
68+ }
6369
6470
6571-- | Corresponds to @COUNT(*)@.
66−countStar :: Aggregate Int64
72+countStar :: Aggregate (Expr Int64)
6773countStar = count (litExpr True)
6874
6975
7076-- | A count of the number of times a given expression is @true@.
71−countWhere :: Expr Bool -> Aggregate Int64
77+countWhere :: Expr Bool -> Aggregate (Expr Int64)
7278countWhere condition = count (caseExpr [(condition, litExpr (Just True))] null)
7379
7480
7581-- | Corresponds to @bool_and@.
76−and :: Expr Bool -> Aggregate Bool
77−and = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolAnd
82+and :: Expr Bool -> Aggregate (Expr Bool)
83+and = unsafeMakeAggregate toPrimExpr fromPrimExpr $
84+ Just Aggregator
85+ { operation = Opaleye.AggrBoolAnd
86+ , ordering = []
87+ , distinction = Opaleye.AggrAll
88+ }
7889
7990
8091-- | Corresponds to @bool_or@.
81−or :: Expr Bool -> Aggregate Bool
82−or = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolOr
92+or :: Expr Bool -> Aggregate (Expr Bool)
93+or = unsafeMakeAggregate toPrimExpr fromPrimExpr $
94+ Just Aggregator
95+ { operation = Opaleye.AggrBoolOr
96+ , ordering = []
97+ , distinction = Opaleye.AggrAll
98+ }
8399
84100
85101-- | Produce an aggregation for @Expr a@ using the @max@ function.
86−max :: Sql DBMax a => Expr a -> Aggregate a
87−max = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMax
102+max :: Sql DBMax a => Expr a -> Aggregate (Expr a)
103+max = unsafeMakeAggregate toPrimExpr fromPrimExpr $
104+ Just Aggregator
105+ { operation = Opaleye.AggrSum
106+ , ordering = []
107+ , distinction = Opaleye.AggrAll
108+ }
88109
89110
90111-- | Produce an aggregation for @Expr a@ using the @max@ function.
91−min :: Sql DBMin a => Expr a -> Aggregate a
92−min = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMin
112+min :: Sql DBMin a => Expr a -> Aggregate (Expr a)
113+min = unsafeMakeAggregate toPrimExpr fromPrimExpr $
114+ Just Aggregator
115+ { operation = Opaleye.AggrSum
116+ , ordering = []
117+ , distinction = Opaleye.AggrAll
118+ }
93119
94120-- | Corresponds to @sum@. Note that in SQL, @sum@ is type changing - for
95121-- example the @sum@ of @integer@ returns a @bigint@. Rel8 doesn't support
96−-- this, and will add explicit casts back to the original input type. This can
122+-- this, and will add explicit cast back to the original input type. This can
97123-- lead to overflows, and if you anticipate very large sums, you should upcast
98124-- your input.
99−sum :: Sql DBSum a => Expr a -> Aggregate a
100−sum = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) Opaleye.unsafeSum
101−
125+sum :: Sql DBSum a => Expr a -> Aggregate (Expr a)
126+sum = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $
127+ Just Aggregator
128+ { operation = Opaleye.AggrSum
129+ , ordering = []
130+ , distinction = Opaleye.AggrAll
131+ }
102132
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
110133
111−-- | Take the sum of all expressions that satisfy a predicate.
112134sumWhere :: (Sql DBNum a, Sql DBSum a)
113− => Expr Bool -> Expr a -> Aggregate a
135+ => Expr Bool -> Expr a -> Aggregate (Expr a)
114136sumWhere condition a = sum (caseExpr [(condition, a)] 0)
115137
116138
117139-- | Corresponds to @string_agg()@.
118140stringAgg :: Sql DBString a
119− => Expr db -> Expr a -> Aggregate a
141+ => Expr db -> Expr a -> Aggregate (Expr a)
120142stringAgg delimiter =
121− unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) (Opaleye.stringAgg (Column (toPrimExpr delimiter)))
143+ unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $
144+ Just Aggregator
145+ { operation = Opaleye.AggrStringAggr (toPrimExpr delimiter)
146+ , ordering = []
147+ , distinction = Opaleye.AggrAll
148+ }
122149
123150
124151-- | Aggregate a value by grouping by it.
125−groupByExpr :: Sql DBEq a => Expr a -> Aggregate a
126−groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.groupBy
127−
152+groupByExpr :: Sql DBEq a => Expr a -> Aggregate (Expr a)
153+groupByExpr = sgroupByExpr nullabilization
128154
129−-- | Collect expressions values as a list.
130−listAggExpr :: Sql DBType a => Expr a -> Aggregate [a]
131−listAggExpr = slistAggExpr typeInformation
132155
133−
134−-- | Collect expressions values as a non-empty list.
135−nonEmptyAggExpr :: Sql DBType a => Expr a -> Aggregate (NonEmpty a)
136−nonEmptyAggExpr = snonEmptyAggExpr typeInformation
156+listAggExpr :: Expr a -> Aggregate (Expr [a])
157+listAggExpr = unsafeMakeAggregate toPrimExpr from $ Just
158+ Aggregator
159+ { operation = Opaleye.AggrArr
160+ , ordering = []
161+ , distinction = Opaleye.AggrAll
162+ }
163+ where
164+ from = fromPrimExpr . fromPrimArray
137165
138166
139−slistAggExpr :: ()
140− => TypeInformation (Unnullify a) -> Expr a -> Aggregate [a]
141−slistAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg
167+nonEmptyAggExpr :: Expr a -> Aggregate (Expr (NonEmpty a))
168+nonEmptyAggExpr = unsafeMakeAggregate toPrimExpr from $ Just
169+ Aggregator
170+ { operation = Opaleye.AggrArr
171+ , ordering = []
172+ , distinction = Opaleye.AggrAll
173+ }
142174 where
143− to = encodeArrayElement info . toPrimExpr
175+ from = fromPrimExpr . fromPrimArray
144176
145177
146−snonEmptyAggExpr :: ()
147− => TypeInformation (Unnullify a) -> Expr a -> Aggregate (NonEmpty a)
148−snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg
149− where
150− to = encodeArrayElement info . toPrimExpr
178+sgroupByExpr :: DBEq db => Nullability db a -> Expr a -> Aggregate (Expr a)
179+sgroupByExpr _ = unsafeMakeAggregate toPrimExpr fromPrimExpr Nothing
src/Rel8/Expr/Array.hs+14−19
@@ -1,12 +1,13 @@
11{-# language DataKinds #-}
22{-# language FlexibleContexts #-}
3+{-# language ScopedTypeVariables #-}
4+{-# language TypeApplications #-}
35{-# language TypeFamilies #-}
46
57{-# options_ghc -fno-warn-redundant-constraints #-}
68
79module Rel8.Expr.Array
810 ( listOf, nonEmptyOf
9− , slistOf, snonEmptyOf
1011 , sappend, sappend1, sempty
1112 )
1213where
@@ -25,34 +26,28 @@ import Rel8.Expr.Opaleye
2526 , zipPrimExprsWith
2627 )
2728import Rel8.Type ( DBType, typeInformation )
28−import Rel8.Type.Array ( array )
29+import Rel8.Type.Array ( array, zipPrimArraysWith )
2930import Rel8.Type.Information ( TypeInformation(..) )
30−import Rel8.Schema.Null ( Unnullify, Sql )
31+import Rel8.Schema.Nullability ( Unnullify, Nullability, Sql )
3132
3233
3334sappend :: Expr [a] -> Expr [a] -> Expr [a]
34−sappend = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
35+sappend = zipPrimExprsWith (zipPrimArraysWith (Opaleye.BinExpr (Opaleye.:||)))
3536
3637
3738sappend1 :: Expr (NonEmpty a) -> Expr (NonEmpty a) -> Expr (NonEmpty a)
38−sappend1 = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
39+sappend1 = zipPrimExprsWith (zipPrimArraysWith (Opaleye.BinExpr (Opaleye.:||)))
3940
4041
41−sempty :: TypeInformation (Unnullify a) -> Expr [a]
42−sempty info = fromPrimExpr $ array info []
42+sempty :: Nullability t a -> TypeInformation t -> Expr [a]
43+sempty _ info = fromPrimExpr $ array info []
4344
4445
45−slistOf :: TypeInformation (Unnullify a) -> [Expr a] -> Expr [a]
46−slistOf info = fromPrimExpr . array info . fmap toPrimExpr
46+listOf :: forall a. Sql DBType a => [Expr a] -> Expr [a]
47+listOf =
48+ fromPrimExpr . array (typeInformation @(Unnullify a)) . fmap toPrimExpr
4749
4850
49−snonEmptyOf :: TypeInformation (Unnullify a) -> NonEmpty (Expr a) -> Expr (NonEmpty a)
50−snonEmptyOf info = fromPrimExpr . array info . fmap toPrimExpr
51−
52−
53−listOf :: Sql DBType a => [Expr a] -> Expr [a]
54−listOf = slistOf typeInformation
55−
56−
57−nonEmptyOf :: Sql DBType a => NonEmpty (Expr a) -> Expr (NonEmpty a)
58−nonEmptyOf = snonEmptyOf typeInformation
51+nonEmptyOf :: forall a. Sql DBType a => NonEmpty (Expr a) -> Expr (NonEmpty a)
52+nonEmptyOf =
53+ fromPrimExpr . array (typeInformation @(Unnullify a)) . fmap toPrimExpr
src/Rel8/Expr/Bool.hs+42−8
@@ -1,5 +1,3 @@
1−{-# language GADTs #-}
2−
31module Rel8.Expr.Bool
42 ( false, true
53 , (&&.), (||.), not_
@@ -19,7 +17,7 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
1917
2018-- rel8
2119import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
22−import Rel8.Expr.Opaleye ( mapPrimExpr, toPrimExpr, zipPrimExprsWith )
20+import Rel8.Expr.Opaleye ( mapPrimExpr, zipPrimExprsWith )
2321import Rel8.Expr.Serialize ( litExpr )
2422
2523
@@ -34,28 +32,68 @@ true = litExpr True
3432
3533
3634-- | The SQL @AND@ operator.
35+--
36+-- >>> :{
37+-- mapM_ print =<< select c do
38+-- x <- values [lit True, lit False]
39+-- y <- values [lit True, lit False]
40+-- return (x, y, x &&. y)
41+-- :}
42+-- (True,True,True)
43+-- (True,False,False)
44+-- (False,True,False)
45+-- (False,False,False)
3746(&&.) :: Expr Bool -> Expr Bool -> Expr Bool
3847(&&.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpAnd)
3948infixr 3 &&.
4049
4150
4251-- | The SQL @OR@ operator.
52+--
53+-- >>> :{
54+-- mapM_ print =<< select c do
55+-- x <- values [lit True, lit False]
56+-- y <- values [lit True, lit False]
57+-- return (x, y, x ||. y)
58+-- :}
59+-- (True,True,True)
60+-- (True,False,True)
61+-- (False,True,True)
62+-- (False,False,False)
4363(||.) :: Expr Bool -> Expr Bool -> Expr Bool
4464(||.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpOr)
4565infixr 2 ||.
4666
4767
4868-- | The SQL @NOT@ operator.
69+--
70+-- >>> select c $ pure $ not_ $ lit True
71+-- [False]
72+--
73+-- >>> select c $ pure $ not_ $ lit False
74+-- [True]
4975not_ :: Expr Bool -> Expr Bool
5076not_ = mapPrimExpr (Opaleye.UnExpr Opaleye.OpNot)
5177
5278
5379-- | Fold @AND@ over a collection of expressions.
80+--
81+-- >>> select c $ pure $ and_ [ lit True ==. lit False, lit False, lit True ]
82+-- [False]
83+--
84+-- >>> select c $ pure $ and_ []
85+-- [True]
5486and_ :: Foldable f => f (Expr Bool) -> Expr Bool
5587and_ = foldl' (&&.) true
5688
5789
5890-- | Fold @OR@ over a collection of expressions.
91+--
92+-- >>> select c $ pure $ or_ [ lit True ==. lit False, lit False, lit True ]
93+-- [True]
94+--
95+-- >>> select c $ pure $ or_ []
96+-- [False]
5997or_ :: Foldable f => f (Expr Bool) -> Expr Bool
6098or_ = foldl' (||.) false
6199
@@ -77,13 +115,9 @@ caseExpr :: [(Expr Bool, Expr a)] -> Expr a -> Expr a
77115caseExpr branches (Expr fallback) =
78116 Expr $ Opaleye.CaseExpr (map go branches) fallback
79117 where
80− go (condition, value) = (toPrimExpr condition, toPrimExpr value)
118+ go (Expr condition, Expr value) = (condition, value)
81119
82120
83−-- | Convert a @Expr (Maybe Bool)@ to a @Expr Bool@ by treating @Nothing@ as
84−-- @False@. This can be useful when combined with 'Rel8.where_', which expects
85−-- a @Bool@, and produces expressions that optimize better than general case
86−-- analysis.
87121coalesce :: Expr (Maybe Bool) -> Expr Bool
88122coalesce (Expr a) = Expr a &&. Expr (Opaleye.FunExpr "COALESCE" [a, untrue])
89123 where
src/Rel8/Expr/Default.hsdeleted−35
@@ -1,35 +0,0 @@
1−module Rel8.Expr.Default
2− ( unsafeDefault
3− )
4−where
5−
6−-- base
7−import Prelude ()
8−
9−-- opaleye
10−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
11−
12−-- rel8
13−import Rel8.Expr ( Expr )
14−import Rel8.Expr.Opaleye ( fromPrimExpr )
15−
16−
17−-- | Corresponds to the SQL @DEFAULT@ expression.
18−--
19−-- This 'Expr' is unsafe for numerous reasons, and should be used with care:
20−--
21−-- 1. This 'Expr' only makes sense in an @INSERT@ or @UPDATE@ statement.
22−--
23−-- 2. Rel8 is not able to verify that a particular column actually has a
24−-- @DEFAULT@ value. Trying to use @unsafeDefault@ where there is no default
25−-- will cause a runtime crash
26−--
27−-- 3. @DEFAULT@ values can not be transformed. For example, the innocuous Rel8
28−-- code @unsafeDefault + 1@ will crash, despite type checking.
29−--
30−-- Given all these caveats, we suggest avoiding the use of default values where
31−-- possible, instead being explicit. A common scenario where default values are
32−-- used is with auto-incrementing identifier columns. In this case, we suggest
33−-- using 'Rel8.nextval' instead.
34−unsafeDefault :: Expr a
35−unsafeDefault = fromPrimExpr Opaleye.DefaultInsertExpr
src/Rel8/Expr/Eq.hs+60−29
@@ -1,13 +1,13 @@
11{-# language FlexibleContexts #-}
22{-# language GADTs #-}
3−{-# language ScopedTypeVariables #-}
4−{-# language TypeApplications #-}
3+{-# language LambdaCase #-}
54{-# language ViewPatterns #-}
65
76{-# options_ghc -fno-warn-redundant-constraints #-}
87
98module Rel8.Expr.Eq
10− ( (==.), (/=.)
9+ ( seq, sne
10+ , (==.), (/=.)
1111 , (==?), (/=?)
1212 , in_
1313 )
@@ -16,7 +16,7 @@ where
1616-- base
1717import Data.Foldable ( toList )
1818import Data.List.NonEmpty ( nonEmpty )
19−import Prelude
19+import Prelude hiding ( seq, sin )
2020
2121-- opaleye
2222import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
@@ -24,9 +24,12 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
2424-- rel8
2525import Rel8.Expr ( Expr )
2626import Rel8.Expr.Bool ( (&&.), (||.), false, or_, coalesce )
27−import Rel8.Expr.Null ( isNull, unsafeLiftOpNull )
27+import Rel8.Expr.Null ( isNull, unsafeLiftOpNullable )
2828import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr, zipPrimExprsWith )
29−import Rel8.Schema.Null ( Nullity( NotNull, Null ), Sql, nullable )
29+import Rel8.Schema.Nullability
30+ ( Nullability( NonNullable, Nullable )
31+ , Sql, nullabilization
32+ )
3033import Rel8.Type.Eq ( DBEq )
3134
3235
@@ -38,18 +41,40 @@ ne :: DBEq a => Expr a -> Expr a -> Expr Bool
3841ne = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:<>))
3942
4043
44+seq :: DBEq db => Nullability db a -> Expr a -> Expr a -> Expr Bool
45+seq = \case
46+ Nullable -> \ma mb -> isNull ma &&. isNull mb ||. ma ==? mb
47+ NonNullable -> eq
48+
49+
50+sne :: DBEq db => Nullability db a -> Expr a -> Expr a -> Expr Bool
51+sne = \case
52+ Nullable -> \ma mb -> isNull ma `ne` isNull mb ||. ma /=? mb
53+ NonNullable -> ne
54+
55+
56+sin :: (DBEq db, Foldable f)
57+ => Nullability db a -> f (Expr a) -> Expr a -> Expr Bool
58+sin nullability (toList -> as) a = case nullability of
59+ Nullable -> or_ $ map (seq Nullable a) as
60+ NonNullable -> case nonEmpty as of
61+ Nothing -> false
62+ Just xs ->
63+ fromPrimExpr $
64+ Opaleye.BinExpr Opaleye.OpIn
65+ (toPrimExpr a)
66+ (Opaleye.ListExpr (toPrimExpr <$> xs))
67+
68+
4169-- | Compare two expressions for equality.
4270--
4371-- This corresponds to the SQL @IS NOT DISTINCT FROM@ operator, and will equate
4472-- @null@ values as @true@. This differs from @=@ which would return @null@.
4573-- This operator matches Haskell's '==' operator. For an operator identical to
4674-- SQL @=@, see '==?'.
47−(==.) :: forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool
48−(==.) = case nullable @a of
49− Null -> \ma mb -> isNull ma &&. isNull mb ||. ma ==? mb
50− NotNull -> eq
75+(==.) :: Sql DBEq a => Expr a -> Expr a -> Expr Bool
76+(==.) = seq nullabilization
5177infix 4 ==.
52−{-# INLINABLE (==.) #-}
5378
5479
5580-- | Test if two expressions are different (not equal).
@@ -58,12 +83,9 @@ infix 4 ==.
5883-- @false@ when comparing two @null@ values. This differs from ordinary @=@
5984-- which would return @null@. This operator is closer to Haskell's '=='
6085-- operator. For an operator identical to SQL @=@, see '/=?'.
61−(/=.) :: forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool
62−(/=.) = case nullable @a of
63− Null -> \ma mb -> isNull ma `ne` isNull mb ||. ma /=? mb
64− NotNull -> ne
86+(/=.) :: Sql DBEq a => Expr a -> Expr a -> Expr Bool
87+(/=.) = sne nullabilization
6588infix 4 /=.
66−{-# INLINABLE (/=.) #-}
6789
6890
6991-- | Test if two expressions are equal. This operator is usually the best
@@ -72,8 +94,14 @@ infix 4 /=.
7294--
7395-- This corresponds to the SQL @=@ operator, though it will always return a
7496-- 'Bool'.
97+--
98+-- >>> select c $ pure $ lit Nothing ==? lit True
99+-- False
100+--
101+-- >>> select c $ pure $ lit Nothing ==? lit Nothing
102+-- False
75103(==?) :: DBEq a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
76−a ==? b = coalesce $ unsafeLiftOpNull eq a b
104+a ==? b = coalesce $ unsafeLiftOpNullable eq a b
77105infix 4 ==?
78106
79107
@@ -81,21 +109,24 @@ infix 4 ==?
81109--
82110-- This corresponds to the SQL @<>@ operator, though it will always return a
83111-- 'Bool'.
112+--
113+-- >>> select c $ pure $ lit Nothing /=? lit True
114+-- True
115+--
116+-- >>> select c $ pure $ lit Nothing /=? lit Nothing
117+-- False
84118(/=?) :: DBEq a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
85−a /=? b = coalesce $ unsafeLiftOpNull ne a b
119+a /=? b = coalesce $ unsafeLiftOpNullable ne a b
86120infix 4 /=?
87121
88122
89123-- | Like the SQL @IN@ operator, but implemented by folding over a list with
90124-- '==.' and '||.'.
91−in_ :: forall a f. (Sql DBEq a, Foldable f)
92− => Expr a -> f (Expr a) -> Expr Bool
93−in_ a (toList -> as) = case nullable @a of
94− Null -> or_ $ map (a ==.) as
95− NotNull -> case nonEmpty as of
96− Nothing -> false
97− Just xs ->
98− fromPrimExpr $
99− Opaleye.BinExpr Opaleye.OpIn
100− (toPrimExpr a)
101− (Opaleye.ListExpr (toPrimExpr <$> xs))
125+--
126+-- >>> select c $ return $ lit (5 :: Int32) `in_` [ lit x | x <- [1..5] ]
127+-- [True]
128+--
129+-- >>> select c $ return $ lit (42 :: Int32) `in_` [ lit x | x <- [1..5] ]
130+-- [False]
131+in_ :: (Sql DBEq a, Foldable f) => f (Expr a) -> Expr a -> Expr Bool
132+in_ = sin nullabilization
src/Rel8/Expr/Function.hs+33−2
@@ -20,12 +20,12 @@ import Prelude
2020import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
2121
2222-- rel8
23−import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
23+import Rel8.Expr ( Expr( Expr ) )
2424import Rel8.Expr.Opaleye
2525 ( castExpr
2626 , fromPrimExpr, toPrimExpr, zipPrimExprsWith
2727 )
28−import Rel8.Schema.Null ( Sql )
28+import Rel8.Schema.Nullability ( Sql )
2929import Rel8.Type ( DBType )
3030
3131
@@ -47,11 +47,42 @@ instance (arg ~ Expr a, Function args res) => Function arg (args -> res) where
4747
4848-- | Construct an n-ary function that produces an 'Expr' that when called runs
4949-- a SQL function.
50+--
51+-- For example, here's how we can wrap PostgreSQL's @factorial@ function:
52+--
53+-- >>> :{
54+-- factorial :: Expr Int64 -> Expr Data.Scientific.Scientific
55+-- factorial = function "factorial"
56+-- :}
57+--
58+-- >>> select c $ pure $ factorial 5
59+-- [120.0]
60+--
61+-- The same approach works for any number of arguments:
62+--
63+-- >>> :{
64+-- power :: Expr Float -> Expr Float -> Expr Double
65+-- power = function "power"
66+-- :}
67+--
68+-- >>> select c $ pure $ power 9 3
69+-- [729.0]
5070function :: Function args result => String -> args -> result
5171function = applyArgument . Opaleye.FunExpr
5272
5373
5474-- | Construct a function call for functions with no arguments.
75+--
76+-- For example, we can call the database function @pi()@ by using
77+-- @nullaryFunction@:
78+--
79+-- >>> :{
80+-- sqlPi :: Expr Double
81+-- sqlPi = nullaryFunction "pi"
82+-- :}
83+--
84+-- >>> select c $ pure $ sqlPi
85+-- [3.141592653589793]
5586nullaryFunction :: Sql DBType a => String -> Expr a
5687nullaryFunction name = castExpr $ Expr (Opaleye.FunExpr name [])
5788
src/Rel8/Expr/Null.hs+39−26
@@ -5,11 +5,11 @@
55{-# options -fno-warn-redundant-constraints #-}
66
77module Rel8.Expr.Null
8− ( null, snull, nullableExpr, nullableOf
8+ ( null, snull, nullable, nullableOf
99 , isNull, isNonNull
1010 , nullify, unsafeUnnullify
11− , mapNull, liftOpNull
12− , unsafeMapNull, unsafeLiftOpNull
11+ , mapNullable, liftOpNullable
12+ , unsafeMapNullable, unsafeLiftOpNullable
1313 )
1414where
1515
@@ -23,7 +23,7 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
2323import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
2424import Rel8.Expr.Bool ( (||.), boolExpr )
2525import Rel8.Expr.Opaleye ( scastExpr, mapPrimExpr )
26−import Rel8.Schema.Null ( NotNull )
26+import Rel8.Schema.Nullability ( Nullability( Nullable ), IsMaybe )
2727import Rel8.Type ( DBType, typeInformation )
2828import Rel8.Type.Information ( TypeInformation )
2929
@@ -31,7 +31,7 @@ import Rel8.Type.Information ( TypeInformation )
3131-- | Lift an expression that can't be @null@ to a type that might be @null@.
3232-- This is an identity operation in terms of any generated query, and just
3333-- modifies the query's type.
34−nullify :: NotNull a => Expr a -> Expr (Maybe a)
34+nullify :: IsMaybe a ~ 'False => Expr a -> Expr (Maybe a)
3535nullify (Expr a) = Expr a
3636
3737
@@ -40,63 +40,76 @@ unsafeUnnullify (Expr a) = Expr a
4040
4141
4242-- | Like 'maybe', but to eliminate @null@.
43−nullableExpr :: Expr b -> (Expr a -> Expr b) -> Expr (Maybe a) -> Expr b
44−nullableExpr b f ma = boolExpr (f (unsafeUnnullify ma)) b (isNull ma)
43+--
44+-- >>> select c $ pure $ null 0 id (nullExpr :: Expr (Maybe Int32))
45+-- [0]
46+--
47+-- >>> select c $ pure $ null 0 id (lit (Just 42) :: Expr (Maybe Int32))
48+-- [42]
49+nullable :: Expr b -> (Expr a -> Expr b) -> Expr (Maybe a) -> Expr b
50+nullable b f ma = boolExpr (f (unsafeUnnullify ma)) b (isNull ma)
4551
4652
47−nullableOf :: DBType a => Maybe (Expr a) -> Expr (Maybe a)
53+nullableOf :: (IsMaybe a ~ 'False, DBType a)
54+ => Maybe (Expr a) -> Expr (Maybe a)
4855nullableOf = maybe null nullify
4956
5057
51−-- | Like 'Data.Maybe.isNothing', but for @null@.
58+-- | Like 'isNothing', but for @null@.
59+--
60+-- >>> select c $ pure $ isNull (nullExpr :: Expr (Maybe Int32))
61+-- [True]
62+--
63+-- >>> select c $ pure $ isNull (lit (Just 42) :: Expr (Maybe Int32))
64+-- [False]
5265isNull :: Expr (Maybe a) -> Expr Bool
5366isNull = mapPrimExpr (Opaleye.UnExpr Opaleye.OpIsNull)
5467
5568
56−-- | Like 'Data.Maybe.isJust', but for @null@.
69+-- | Like 'isJust', but for @null@.
5770isNonNull :: Expr (Maybe a) -> Expr Bool
5871isNonNull = mapPrimExpr (Opaleye.UnExpr Opaleye.OpIsNotNull)
5972
6073
6174-- | Lift an operation on non-@null@ values to an operation on possibly @null@
62−-- values. When given @null@, @mapNull f@ returns @null@.
75+-- values. When given @null@, @mapNullable f@ returns @null@.
6376--
6477-- This is like 'fmap' for 'Maybe'.
65−mapNull :: DBType b
78+mapNullable :: (IsMaybe b ~ 'False, DBType b)
6679 => (Expr a -> Expr b) -> Expr (Maybe a) -> Expr (Maybe b)
67−mapNull f ma = boolExpr (unsafeMapNull f ma) null (isNull ma)
80+mapNullable f ma = boolExpr (unsafeMapNullable f ma) null (isNull ma)
6881
6982
7083-- | Lift a binary operation on non-@null@ expressions to an equivalent binary
7184-- operator on possibly @null@ expressions. If either of the final arguments
72−-- are @null@, @liftOpNull@ returns @null@.
85+-- are @null@, @liftOpNullable@ returns @null@.
7386--
7487-- This is like 'liftA2' for 'Maybe'.
75−liftOpNull :: DBType c
88+liftOpNullable :: (IsMaybe c ~ 'False, DBType c)
7689 => (Expr a -> Expr b -> Expr c)
7790 -> Expr (Maybe a) -> Expr (Maybe b) -> Expr (Maybe c)
78−liftOpNull f ma mb =
79− boolExpr (unsafeLiftOpNull f ma mb) null
91+liftOpNullable f ma mb =
92+ boolExpr (unsafeLiftOpNullable f ma mb) null
8093 (isNull ma ||. isNull mb)
81−{-# INLINABLE liftOpNull #-}
8294
8395
84−snull :: TypeInformation a -> Expr (Maybe a)
85−snull info = scastExpr info $ Expr $ Opaleye.ConstExpr Opaleye.NullLit
96+snull :: Nullability a (Maybe a) -> TypeInformation a -> Expr (Maybe a)
97+snull nullability info =
98+ scastExpr nullability info $ Expr $ Opaleye.ConstExpr Opaleye.NullLit
8699
87100
88101-- | Corresponds to SQL @null@.
89−null :: DBType a => Expr (Maybe a)
90−null = snull typeInformation
102+null :: (IsMaybe a ~ 'False, DBType a) => Expr (Maybe a)
103+null = snull Nullable typeInformation
91104
92105
93−unsafeMapNull :: NotNull b
106+unsafeMapNullable :: IsMaybe b ~ 'False
94107 => (Expr a -> Expr b) -> Expr (Maybe a) -> Expr (Maybe b)
95−unsafeMapNull f ma = nullify (f (unsafeUnnullify ma))
108+unsafeMapNullable f ma = nullify (f (unsafeUnnullify ma))
96109
97110
98−unsafeLiftOpNull :: NotNull c
111+unsafeLiftOpNullable :: IsMaybe c ~ 'False
99112 => (Expr a -> Expr b -> Expr c)
100113 -> Expr (Maybe a) -> Expr (Maybe b) -> Expr (Maybe c)
101−unsafeLiftOpNull f ma mb =
114+unsafeLiftOpNullable f ma mb =
102115 nullify (f (unsafeUnnullify ma) (unsafeUnnullify mb))
src/Rel8/Expr/Num.hs+15−68
@@ -4,107 +4,54 @@
44{-# options_ghc -fno-warn-redundant-constraints #-}
55
66module Rel8.Expr.Num
7− ( fromIntegral
8− , realToFrac
9− , div, mod, divMod
10− , quot, rem, quotRem
11− , ceiling, floor, round, truncate
7+ ( fromIntegral, realToFrac, div, mod, ceiling, floor, round, truncate
128 )
139where
1410
1511-- base
16−import Prelude ( (+), (-), fst, negate, signum, snd )
12+import Prelude ()
1713
1814-- rel
1915import Rel8.Expr ( Expr( Expr ) )
20−import Rel8.Expr.Eq ( (==.) )
2116import Rel8.Expr.Function ( function )
2217import Rel8.Expr.Opaleye ( castExpr )
23−import Rel8.Schema.Null ( Homonullable, Sql )
24−import Rel8.Table.Bool ( bool )
18+import Rel8.Schema.Nullability ( IsMaybe, Sql )
2519import Rel8.Type.Num ( DBFractional, DBIntegral, DBNum )
2620
2721
28−-- | Cast 'DBIntegral' types to 'DBNum' types. For example, this can be useful
29−-- if you need to turn an @Expr Int32@ into an @Expr Double@.
30−fromIntegral :: (Sql DBIntegral a, Sql DBNum b, Homonullable a b)
22+fromIntegral :: (Sql DBIntegral a, Sql DBNum b, IsMaybe a ~ IsMaybe b)
3123 => Expr a -> Expr b
3224fromIntegral (Expr a) = castExpr (Expr a)
3325
3426
35−-- | Cast 'DBNum' types to 'DBFractional' types. For example, his can be useful
36−-- to convert @Expr Float@ to @Expr Double@.
37−realToFrac :: (Sql DBNum a, Sql DBFractional b, Homonullable a b)
27+realToFrac :: (Sql DBNum a, Sql DBFractional b, IsMaybe a ~ IsMaybe b)
3828 => Expr a -> Expr b
3929realToFrac (Expr a) = castExpr (Expr a)
4030
4131
42−-- | Round a 'DBFractional' to a 'DBIntegral' by rounding to the nearest larger
43−-- integer.
44−--
45−-- Corresponds to the @ceiling()@ function.
46−ceiling :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)
32+ceiling :: (Sql DBFractional a, Sql DBIntegral b, IsMaybe a ~ IsMaybe b)
4733 => Expr a -> Expr b
48−ceiling = function "ceiling"
34+ceiling = function "CEILING"
4935
5036
51−-- | Emulates the behaviour of the Haskell function 'Prelude.div' in
52−-- PostgreSQL.
5337div :: Sql DBIntegral a => Expr a -> Expr a -> Expr a
54−div n d = fst (divMod n d)
38+div = function "DIV"
5539
5640
57−-- | Emulates the behaviour of the Haskell function 'Prelude.mod' in
58−-- PostgreSQL.
5941mod :: Sql DBIntegral a => Expr a -> Expr a -> Expr a
60−mod n d = snd (divMod n d)
42+mod = function "MOD"
6143
6244
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)
86−
87−
88−-- | Round a 'DFractional' to a 'DBIntegral' by rounding to the nearest smaller
89−-- integer.
90−--
91−-- Corresponds to the @floor()@ function.
92−floor :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)
45+floor :: (Sql DBFractional a, Sql DBIntegral b, IsMaybe a ~ IsMaybe b)
9346 => Expr a -> Expr b
94−floor = function "floor"
47+floor = function "FLOOR"
9548
9649
97−-- | Round a 'DBFractional' to a 'DBIntegral' by rounding to the nearest
98−-- integer.
99−--
100−-- Corresponds to the @round()@ function.
101−round :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)
50+round :: (Sql DBFractional a, Sql DBIntegral b, IsMaybe a ~ IsMaybe b)
10251 => Expr a -> Expr b
103−round = function "round"
52+round = function "ROUND"
10453
10554
106−-- | Round a 'DBFractional' to a 'DBIntegral' by rounding to the nearest
107−-- integer towards zero.
108−truncate :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)
55+truncate :: (Sql DBFractional a, Sql DBIntegral b, IsMaybe a ~ IsMaybe b)
10956 => Expr a -> Expr b
110−truncate = function "trunc"
57+truncate = function "TRUNC"
src/Rel8/Expr/Opaleye.hs+13−27
@@ -1,6 +1,8 @@
11{-# language FlexibleContexts #-}
2+{-# language LambdaCase #-}
23{-# language NamedFieldPuns #-}
34{-# language ScopedTypeVariables #-}
5+{-# language TypeApplications #-}
46{-# language TypeFamilies #-}
57
68{-# options_ghc -fno-warn-redundant-constraints #-}
@@ -10,7 +12,7 @@ module Rel8.Expr.Opaleye
1012 , scastExpr, sunsafeCastExpr
1113 , unsafeLiteral
1214 , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith, traversePrimExpr
13− , toColumn, fromColumn, traverseFieldP
15+ , toColumn, fromColumn
1416 )
1517where
1618
@@ -23,41 +25,31 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
2325
2426-- rel8
2527import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
26−import Rel8.Schema.Null ( Unnullify, Sql )
28+import Rel8.Schema.Nullability ( Nullability, Sql, nullabilization )
2729import Rel8.Type ( DBType, typeInformation )
2830import Rel8.Type.Information ( TypeInformation(..) )
2931
30−-- profunctors
31−import Data.Profunctor ( Profunctor, dimap )
32−
3332
3433castExpr :: Sql DBType a => Expr a -> Expr a
35−castExpr = scastExpr typeInformation
34+castExpr = scastExpr nullabilization typeInformation
3635
3736
38−-- | Cast an expression to a different type. Corresponds to a @CAST()@ function
39−-- call.
4037unsafeCastExpr :: Sql DBType b => Expr a -> Expr b
41−unsafeCastExpr = sunsafeCastExpr typeInformation
38+unsafeCastExpr = sunsafeCastExpr nullabilization typeInformation
4239
4340
44−scastExpr :: TypeInformation (Unnullify a) -> Expr a -> Expr a
41+scastExpr :: Nullability db a -> TypeInformation db -> Expr a -> Expr a
4542scastExpr = sunsafeCastExpr
4643
4744
4845sunsafeCastExpr :: ()
49− => TypeInformation (Unnullify b) -> Expr a -> Expr b
50−sunsafeCastExpr TypeInformation {typeName} =
46+ => Nullability db b -> TypeInformation db -> Expr a -> Expr b
47+sunsafeCastExpr _ TypeInformation {typeName} =
5148 fromPrimExpr . Opaleye.CastExpr typeName . toPrimExpr
5249
5350
54−-- | Unsafely construct an expression from literal SQL.
55−--
56−-- This is an escape hatch, and can be used if Rel8 can not adequately express
57−-- the query you need. If you find yourself using this function, please let us
58−-- know, as it may indicate that something is missing from Rel8!
59−unsafeLiteral :: String -> Expr a
60−unsafeLiteral = Expr . Opaleye.ConstExpr . Opaleye.OtherLit
51+unsafeLiteral :: Sql DBType a => String -> Expr a
52+unsafeLiteral = castExpr . Expr . Opaleye.ConstExpr . Opaleye.OtherLit
6153
6254
6355fromPrimExpr :: Opaleye.PrimExpr -> Expr a
@@ -83,15 +75,9 @@ traversePrimExpr :: Functor f
8375traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr
8476
8577
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
78+toColumn :: Opaleye.PrimExpr -> Opaleye.Column b
9379toColumn = Opaleye.Column
9480
9581
96−fromColumn :: Opaleye.Field_ n b -> Opaleye.PrimExpr
82+fromColumn :: Opaleye.Column b -> Opaleye.PrimExpr
9783fromColumn (Opaleye.Column a) = a
src/Rel8/Expr/Ord.hs+53−33
@@ -1,5 +1,6 @@
11{-# language DataKinds #-}
22{-# language FlexibleContexts #-}
3+{-# language LambdaCase #-}
34{-# language GADTs #-}
45{-# language ScopedTypeVariables #-}
56{-# language TypeApplications #-}
@@ -7,7 +8,8 @@
78{-# options_ghc -fno-warn-redundant-constraints #-}
89
910module Rel8.Expr.Ord
10− ( (<.), (<=.), (>.), (>=.)
11+ ( slt, sle, sgt, sge
12+ , (<.), (<=.), (>.), (>=.)
1113 , (<?), (<=?), (>?), (>=?)
1214 , leastExpr, greatestExpr
1315 )
@@ -22,9 +24,12 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
2224-- rel8
2325import Rel8.Expr ( Expr( Expr ) )
2426import Rel8.Expr.Bool ( (&&.), (||.), coalesce )
25−import Rel8.Expr.Null ( isNull, isNonNull, nullableExpr, unsafeLiftOpNull )
26−import Rel8.Expr.Opaleye ( toPrimExpr, zipPrimExprsWith )
27−import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
27+import Rel8.Expr.Null ( isNull, isNonNull, nullable, unsafeLiftOpNullable )
28+import Rel8.Expr.Opaleye ( zipPrimExprsWith )
29+import Rel8.Schema.Nullability
30+ ( Nullability( NonNullable, Nullable )
31+ , Sql, nullabilization
32+ )
2833import Rel8.Type.Ord ( DBOrd )
2934
3035
@@ -44,71 +49,87 @@ ge :: DBOrd a => Expr a -> Expr a -> Expr Bool
4449ge = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:>=))
4550
4651
52+slt :: DBOrd db => Nullability db a -> Expr a -> Expr a -> Expr Bool
53+slt = \case
54+ Nullable -> \ma mb -> isNull ma &&. isNonNull mb ||. ma <? mb
55+ NonNullable -> lt
56+
57+
58+sle :: DBOrd db => Nullability db a -> Expr a -> Expr a -> Expr Bool
59+sle = \case
60+ Nullable -> \ma mb -> isNull ma ||. ma <=? mb
61+ NonNullable -> le
62+
63+
64+sgt :: DBOrd db => Nullability db a -> Expr a -> Expr a -> Expr Bool
65+sgt = \case
66+ Nullable -> \ma mb -> isNonNull ma &&. isNull mb ||. ma >? mb
67+ NonNullable -> gt
68+
69+
70+sge :: DBOrd db => Nullability db a -> Expr a -> Expr a -> Expr Bool
71+sge = \case
72+ Nullable -> \ma mb -> isNull mb ||. ma >=? mb
73+ NonNullable -> ge
74+
75+
4776-- | Corresponds to the SQL @<@ operator. Note that this differs from SQL @<@
4877-- as @null@ will sort below any other value. For a version of @<@ that exactly
4978-- matches SQL, see '(<?)'.
50−(<.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool
51−(<.) = case nullable @a of
52− Null -> \ma mb -> isNull ma &&. isNonNull mb ||. ma <? mb
53− NotNull -> lt
79+(<.) :: Sql DBOrd a => Expr a -> Expr a -> Expr Bool
80+(<.) = slt nullabilization
5481infix 4 <.
5582
5683
5784-- | Corresponds to the SQL @<=@ operator. Note that this differs from SQL @<=@
5885-- as @null@ will sort below any other value. For a version of @<=@ that exactly
5986-- matches SQL, see '(<=?)'.
60−(<=.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool
61−(<=.) = case nullable @a of
62− Null -> \ma mb -> isNull ma ||. ma <=? mb
63− NotNull -> le
87+(<=.) :: Sql DBOrd a => Expr a -> Expr a -> Expr Bool
88+(<=.) = sle nullabilization
6489infix 4 <=.
6590
6691
6792-- | Corresponds to the SQL @>@ operator. Note that this differs from SQL @>@
6893-- as @null@ will sort below any other value. For a version of @>@ that exactly
6994-- matches SQL, see '(>?)'.
70−(>.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool
71−(>.) = case nullable @a of
72− Null -> \ma mb -> isNonNull ma &&. isNull mb ||. ma >? mb
73− NotNull -> gt
95+(>.) :: Sql DBOrd a => Expr a -> Expr a -> Expr Bool
96+(>.) = sgt nullabilization
7497infix 4 >.
7598
7699
77100-- | Corresponds to the SQL @>=@ operator. Note that this differs from SQL @>@
78101-- as @null@ will sort below any other value. For a version of @>=@ that
79102-- exactly matches SQL, see '(>=?)'.
80−(>=.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool
81−(>=.) = case nullable @a of
82− Null -> \ma mb -> isNull mb ||. ma >=? mb
83− NotNull -> ge
103+(>=.) :: Sql DBOrd a => Expr a -> Expr a -> Expr Bool
104+(>=.) = sge nullabilization
84105infix 4 >=.
85106
86107
87108-- | Corresponds to the SQL @<@ operator. Returns @null@ if either arguments
88109-- are @null@.
89110(<?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
90−a <? b = coalesce $ unsafeLiftOpNull lt a b
111+a <? b = coalesce $ unsafeLiftOpNullable lt a b
91112infix 4 <?
92113
93114
94115-- | Corresponds to the SQL @<=@ operator. Returns @null@ if either arguments
95116-- are @null@.
96117(<=?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
97−a <=? b = coalesce $ unsafeLiftOpNull le a b
118+a <=? b = coalesce $ unsafeLiftOpNullable le a b
98119infix 4 <=?
99120
100121
101122-- | Corresponds to the SQL @>@ operator. Returns @null@ if either arguments
102123-- are @null@.
103124(>?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
104−a >? b = coalesce $ unsafeLiftOpNull gt a b
125+a >? b = coalesce $ unsafeLiftOpNullable gt a b
105126infix 4 >?
106127
107128
108129-- | Corresponds to the SQL @>=@ operator. Returns @null@ if either arguments
109130-- are @null@.
110131(>=?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
111−a >=? b = coalesce $ unsafeLiftOpNull ge a b
132+a >=? b = coalesce $ unsafeLiftOpNullable ge a b
112133infix 4 >=?
113134
114135
@@ -117,11 +138,11 @@ infix 4 >=?
117138--
118139-- Corresponds to the SQL @least()@ function.
119140leastExpr :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr a
120−leastExpr ma mb = case nullable @a of
121− Null -> nullableExpr ma (\a -> nullableExpr mb (least_ a) mb) ma
122− NotNull -> least_ ma mb
141+leastExpr ma mb = case nullabilization @a of
142+ Nullable -> nullable ma (\a -> nullable mb (least_ a) mb) ma
143+ NonNullable -> least_ ma mb
123144 where
124− least_ a b = Expr (Opaleye.FunExpr "LEAST" [toPrimExpr a, toPrimExpr b])
145+ least_ (Expr a) (Expr b) = Expr (Opaleye.FunExpr "LEAST" [a, b])
125146
126147
127148-- | Given two expressions, return the expression that sorts greater than the
@@ -129,9 +150,8 @@ leastExpr ma mb = case nullable @a of
129150--
130151-- Corresponds to the SQL @greatest()@ function.
131152greatestExpr :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr a
132−greatestExpr ma mb = case nullable @a of
133− Null -> nullableExpr mb (\a -> nullableExpr ma (greatest_ a) mb) ma
134− NotNull -> greatest_ ma mb
153+greatestExpr ma mb = case nullabilization @a of
154+ Nullable -> nullable mb (\a -> nullable ma (greatest_ a) mb) ma
155+ NonNullable -> greatest_ ma mb
135156 where
136− greatest_ a b =
137− Expr (Opaleye.FunExpr "GREATEST" [toPrimExpr a, toPrimExpr b])
157+ greatest_ (Expr a) (Expr b) = Expr (Opaleye.FunExpr "GREATEST" [a, b])
src/Rel8/Expr/Order.hs+12
@@ -28,6 +28,9 @@ import Rel8.Type.Ord ( DBOrd )
2828
2929
3030-- | Sort a column in ascending order.
31+--
32+-- >>> select c $ orderBy asc $ values [ lit x | x <- [1..5 :: Int32] ]
33+-- [1,2,3,4,5]
3134asc :: DBOrd a => Order (Expr a)
3235asc = Order $ Opaleye.Order (\expr -> [(orderOp, toPrimExpr expr)])
3336 where
@@ -39,6 +42,9 @@ asc = Order $ Opaleye.Order (\expr -> [(orderOp, toPrimExpr expr)])
3942
4043
4144-- | Sort a column in descending order.
45+--
46+-- >>> select c $ orderBy desc $ values [ lit x | x <- [1..5 :: Int32] ]
47+-- [5,4,3,2,1]
4248desc :: DBOrd a => Order (Expr a)
4349desc = Order $ Opaleye.Order (\expr -> [(orderOp, toPrimExpr expr)])
4450 where
@@ -51,6 +57,9 @@ desc = Order $ Opaleye.Order (\expr -> [(orderOp, toPrimExpr expr)])
5157
5258-- | Transform an ordering so that @null@ values appear first. This corresponds
5359-- to @NULLS FIRST@ in SQL.
60+--
61+-- >>> select c $ orderBy (nullsFirst desc) $ values $ [ nullExpr, nullExpr ] <> [ lit (Just x) | x <- [1..5 :: Int32] ]
62+-- [Nothing,Nothing,Just 5,Just 4,Just 3,Just 2,Just 1]
5463nullsFirst :: Order (Expr a) -> Order (Expr (Maybe a))
5564nullsFirst (Order (Opaleye.Order f)) =
5665 Order $ Opaleye.Order $ fmap (first g) . f . unsafeUnnullify
@@ -61,6 +70,9 @@ nullsFirst (Order (Opaleye.Order f)) =
6170
6271-- | Transform an ordering so that @null@ values appear first. This corresponds
6372-- to @NULLS LAST@ in SQL.
73+--
74+-- >>> select c $ orderBy (nullsLast desc) $ values $ [ nullExpr, nullExpr ] <> [ lit (Just x) | x <- [1..5 :: Int32] ]
75+-- [Just 5,Just 4,Just 3,Just 2,Just 1,Nothing,Nothing]
6476nullsLast :: Order (Expr a) -> Order (Expr (Maybe a))
6577nullsLast (Order (Opaleye.Order f)) =
6678 Order $ Opaleye.Order $ fmap (first g) . f . unsafeUnnullify
src/Rel8/Expr/Sequence.hsdeleted−22
@@ -1,22 +0,0 @@
1−module Rel8.Expr.Sequence
2− ( nextval
3− )
4−where
5−
6−-- base
7−import Data.Int ( Int64 )
8−import Prelude
9−
10−-- rel8
11−import Rel8.Expr ( Expr )
12−import Rel8.Expr.Function ( function )
13−import Rel8.Expr.Serialize ( litExpr )
14−import Rel8.Expr.Text ( quoteIdent )
15−
16−-- text
17−import Data.Text ( pack )
18−
19−
20−-- | See https://www.postgresql.org/docs/current/functions-sequence.html
21−nextval :: String -> Expr Int64
22−nextval = function "nextval" . quoteIdent . litExpr . pack
src/Rel8/Expr/Serialize.hs+15−16
@@ -21,29 +21,28 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
2121-- rel8
2222import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
2323import Rel8.Expr.Opaleye ( scastExpr )
24−import Rel8.Schema.Null ( Unnullify, Nullity( Null, NotNull ), Sql, nullable )
24+import Rel8.Schema.Nullability
25+ ( Nullability( Nullable, NonNullable )
26+ , Sql, nullabilization
27+ )
2528import Rel8.Type ( DBType, typeInformation )
2629import Rel8.Type.Information ( TypeInformation(..) )
2730
2831
29−-- | Produce an expression from a literal.
30−--
31−-- Note that you can usually use 'Rel8.lit', but @litExpr@ can solve problems
32−-- of inference in polymorphic code.
3332litExpr :: Sql DBType a => a -> Expr a
34−litExpr = slitExpr nullable typeInformation
33+litExpr = slitExpr nullabilization typeInformation
3534
3635
37−slitExpr :: Nullity a -> TypeInformation (Unnullify a) -> a -> Expr a
38−slitExpr nullity info@TypeInformation {encode} =
39− scastExpr info . Expr . encoder
36+slitExpr :: Nullability db a -> TypeInformation db -> a -> Expr a
37+slitExpr nullable info@TypeInformation {encode} =
38+ scastExpr nullable info . Expr . encoder
4039 where
41− encoder = case nullity of
42− Null -> maybe (Opaleye.ConstExpr Opaleye.NullLit) encode
43− NotNull -> encode
40+ encoder = case nullable of
41+ Nullable -> maybe (Opaleye.ConstExpr Opaleye.NullLit) encode
42+ NonNullable -> encode
4443
4544
46−sparseValue :: Nullity a -> TypeInformation (Unnullify a) -> Hasql.Row a
47−sparseValue nullity TypeInformation {decode} = case nullity of
48− Null -> Hasql.column $ Hasql.nullable decode
49− NotNull -> Hasql.column $ Hasql.nonNullable decode
45+sparseValue :: Nullability db a -> TypeInformation db -> Hasql.Row a
46+sparseValue nullability TypeInformation {decode, out} = case nullability of
47+ Nullable -> Hasql.column $ Hasql.nullable $ out <$> decode
48+ NonNullable -> Hasql.column $ Hasql.nonNullable $ out <$> decode
src/Rel8/Expr/Text.hs+11−66
@@ -16,10 +16,7 @@ module Rel8.Expr.Text
1616 , initcap, left, length, lengthEncoding, lpad, ltrim, md5
1717 , pgClientEncoding, quoteIdent, quoteLiteral, quoteNullable, regexpReplace
1818 , regexpSplitToArray, repeat, replace, reverse, right, rpad, rtrim
19− , splitPart, strpos, substr, translate
20−
21− -- * @LIKE@ and @ILIKE@
22− , like, ilike
19+ , splitPart, strpos, substr, toAscii, toHex, translate
2320 )
2421where
2522
@@ -27,7 +24,7 @@ where
2724import Data.Bool ( Bool )
2825import Data.Int ( Int32 )
2926import Data.Maybe ( Maybe( Nothing, Just ) )
30−import Prelude ( flip )
27+import Prelude ()
3128
3229-- bytestring
3330import Data.ByteString ( ByteString )
@@ -35,6 +32,7 @@ import Data.ByteString ( ByteString )
3532-- rel8
3633import Rel8.Expr ( Expr )
3734import Rel8.Expr.Function ( binaryOperator, function, nullaryFunction )
35+import Rel8.Type.Array1D ( Array1D )
3836
3937-- text
4038import Data.Text (Text)
@@ -52,32 +50,24 @@ infixr 6 ++.
5250
5351
5452-- | Matches regular expression, case sensitive
55−--
56−-- Corresponds to the @~.@ operator.
5753(~.) :: Expr Text -> Expr Text -> Expr Bool
5854(~.) = binaryOperator "~."
5955infix 2 ~.
6056
6157
6258-- | Matches regular expression, case insensitive
63−--
64−-- Corresponds to the @~*@ operator.
6559(~*) :: Expr Text -> Expr Text -> Expr Bool
6660(~*) = binaryOperator "~*"
6761infix 2 ~*
6862
6963
7064-- | Does not match regular expression, case sensitive
71−--
72−-- Corresponds to the @!~@ operator.
7365(!~) :: Expr Text -> Expr Text -> Expr Bool
7466(!~) = binaryOperator "!~"
7567infix 2 !~
7668
7769
7870-- | Does not match regular expression, case insensitive
79−--
80−-- Corresponds to the @!~*@ operator.
8171(!~*) :: Expr Text -> Expr Text -> Expr Bool
8272(!~*) = binaryOperator "!~*"
8373infix 2 !~*
@@ -88,209 +78,164 @@ infix 2 !~*
8878-- * Standard SQL functions
8979
9080
91−-- | Corresponds to the @bit_length@ function.
9281bitLength :: Expr Text -> Expr Int32
9382bitLength = function "bit_length"
9483
9584
96−-- | Corresponds to the @char_length@ function.
9785charLength :: Expr Text -> Expr Int32
9886charLength = function "char_length"
9987
10088
101−-- | Corresponds to the @lower@ function.
10289lower :: Expr Text -> Expr Text
10390lower = function "lower"
10491
10592
106−-- | Corresponds to the @octet_length@ function.
10793octetLength :: Expr Text -> Expr Int32
10894octetLength = function "octet_length"
10995
11096
111−-- | Corresponds to the @upper@ function.
11297upper :: Expr Text -> Expr Text
11398upper = function "upper"
11499
115100
116−-- | Corresponds to the @ascii@ function.
101+-- * PostgreSQL functions
117102ascii :: Expr Text -> Expr Int32
118103ascii = function "ascii"
119104
120105
121−-- | Corresponds to the @btrim@ function.
122106btrim :: Expr Text -> Maybe (Expr Text) -> Expr Text
123107btrim a (Just b) = function "btrim" a b
124108btrim a Nothing = function "btrim" a
125109
126110
127−-- | Corresponds to the @chr@ function.
128111chr :: Expr Int32 -> Expr Text
129112chr = function "chr"
130113
131114
132−-- | Corresponds to the @convert@ function.
133115convert :: Expr ByteString -> Expr Text -> Expr Text -> Expr ByteString
134116convert = function "convert"
135117
136118
137−-- | Corresponds to the @convert_from@ function.
138119convertFrom :: Expr ByteString -> Expr Text -> Expr Text
139120convertFrom = function "convert_from"
140121
141122
142−-- | Corresponds to the @convert_to@ function.
143123convertTo :: Expr Text -> Expr Text -> Expr ByteString
144124convertTo = function "convert_to"
145125
146126
147−-- | Corresponds to the @decode@ function.
148127decode :: Expr Text -> Expr Text -> Expr ByteString
149128decode = function "decode"
150129
151130
152−-- | Corresponds to the @encode@ function.
153131encode :: Expr ByteString -> Expr Text -> Expr Text
154132encode = function "encode"
155133
156134
157−-- | Corresponds to the @initcap@ function.
158135initcap :: Expr Text -> Expr Text
159136initcap = function "initcap"
160137
161138
162−-- | Corresponds to the @left@ function.
163139left :: Expr Text -> Expr Int32 -> Expr Text
164140left = function "left"
165141
166142
167−-- | Corresponds to the @length@ function.
168143length :: Expr Text -> Expr Int32
169144length = function "length"
170145
171146
172−-- | Corresponds to the @length@ function.
173147lengthEncoding :: Expr ByteString -> Expr Text -> Expr Int32
174148lengthEncoding = function "length"
175149
176150
177−-- | Corresponds to the @lpad@ function.
178151lpad :: Expr Text -> Expr Int32 -> Maybe (Expr Text) -> Expr Text
179152lpad a b (Just c) = function "lpad" a b c
180153lpad a b Nothing = function "lpad" a b
181154
182155
183−-- | Corresponds to the @ltrim@ function.
184156ltrim :: Expr Text -> Maybe (Expr Text) -> Expr Text
185157ltrim a (Just b) = function "ltrim" a b
186158ltrim a Nothing = function "ltrim" a
187159
188160
189−-- | Corresponds to the @md5@ function.
190161md5 :: Expr Text -> Expr Text
191162md5 = function "md5"
192163
193164
194−-- | Corresponds to the @pg_client_encoding()@ expression.
195165pgClientEncoding :: Expr Text
196166pgClientEncoding = nullaryFunction "pg_client_encoding"
197167
198168
199−-- | Corresponds to the @quote_ident@ function.
200169quoteIdent :: Expr Text -> Expr Text
201170quoteIdent = function "quote_ident"
202171
203172
204−-- | Corresponds to the @quote_literal@ function.
205173quoteLiteral :: Expr Text -> Expr Text
206174quoteLiteral = function "quote_literal"
207175
208176
209−-- | Corresponds to the @quote_nullable@ function.
210177quoteNullable :: Expr Text -> Expr Text
211178quoteNullable = function "quote_nullable"
212179
213180
214−-- | Corresponds to the @regexp_replace@ function.
215181regexpReplace :: ()
216182 => Expr Text -> Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr Text
217183regexpReplace a b c (Just d) = function "regexp_replace" a b c d
218184regexpReplace a b c Nothing = function "regexp_replace" a b c
219185
220186
221−-- | Corresponds to the @regexp_split_to_array@ function.
222187regexpSplitToArray :: ()
223− => Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr [Text]
188+ => Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr (Array1D Text)
224189regexpSplitToArray a b (Just c) = function "regexp_split_to_array" a b c
225190regexpSplitToArray a b Nothing = function "regexp_split_to_array" a b
226191
227192
228−-- | Corresponds to the @repeat@ function.
229193repeat :: Expr Text -> Expr Int32 -> Expr Text
230194repeat = function "repeat"
231195
232196
233−-- | Corresponds to the @replace@ function.
234197replace :: Expr Text -> Expr Text -> Expr Text -> Expr Text
235198replace = function "replace"
236199
237200
238−-- | Corresponds to the @reverse@ function.
239201reverse :: Expr Text -> Expr Text
240202reverse = function "reverse"
241203
242204
243−-- | Corresponds to the @right@ function.
244205right :: Expr Text -> Expr Int32 -> Expr Text
245206right = function "right"
246207
247208
248−-- | Corresponds to the @rpad@ function.
249209rpad :: Expr Text -> Expr Int32 -> Maybe (Expr Text) -> Expr Text
250210rpad a b (Just c) = function "rpad" a b c
251211rpad a b Nothing = function "rpad" a b
252212
253213
254−-- | Corresponds to the @rtrim@ function.
255214rtrim :: Expr Text -> Maybe (Expr Text) -> Expr Text
256215rtrim a (Just b) = function "rtrim" a b
257216rtrim a Nothing = function "rtrim" a
258217
259218
260−-- | Corresponds to the @split_part@ function.
261219splitPart :: Expr Text -> Expr Text -> Expr Int32 -> Expr Text
262220splitPart = function "split_part"
263221
264222
265−-- | Corresponds to the @strpos@ function.
266223strpos :: Expr Text -> Expr Text -> Expr Int32
267224strpos = function "strpos"
268225
269226
270−-- | Corresponds to the @substr@ function.
271227substr :: Expr Text -> Expr Int32 -> Maybe (Expr Int32) -> Expr Text
272228substr a b (Just c) = function "substr" a b c
273229substr a b Nothing = function "substr" a b
274230
275231
276−-- | Corresponds to the @translate@ function.
277−translate :: Expr Text -> Expr Text -> Expr Text -> Expr Text
278−translate = function "translate"
232+toAscii :: Expr Text -> Expr Text -> Expr Text
233+toAscii = function "toAscii"
279234
280235
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")
236+toHex :: Expr Int32 -> Expr Text
237+toHex = function "toHex"
288238
289239
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")
240+translate :: Expr Text -> Expr Text -> Expr Text -> Expr Text
241+translate = function "translate"
src/Rel8/Expr/Time.hs+24−36
@@ -13,13 +13,12 @@ module Rel8.Expr.Time
1313 , diffTime
1414 , subtractTime
1515
16− -- * Working with @CalendarDiffTime@
16+ -- Working with @DiffTime@
1717 , scaleInterval
1818 , second, seconds
1919 , minute, minutes
2020 , hour, hours
2121 , day, days
22− , week, weeks
2322 , month, months
2423 , year, years
2524 ) where
@@ -31,12 +30,11 @@ import Prelude
3130-- rel8
3231import Rel8.Expr ( Expr )
3332import Rel8.Expr.Function ( binaryOperator, nullaryFunction )
34−import Rel8.Expr.Opaleye ( castExpr, unsafeCastExpr, unsafeLiteral )
33+import Rel8.Expr.Opaleye ( unsafeCastExpr, unsafeLiteral )
3534
3635-- time
3736import Data.Time.Calendar ( Day )
38−import Data.Time.Clock ( UTCTime )
39−import Data.Time.LocalTime ( CalendarDiffTime )
37+import Data.Time.Clock ( DiffTime, UTCTime )
4038
4139
4240-- | Corresponds to @date(now())@.
@@ -75,93 +73,83 @@ now = nullaryFunction "now"
7573
7674
7775-- | Add a time interval to a point in time, yielding a new point in time.
78−addTime :: Expr CalendarDiffTime -> Expr UTCTime -> Expr UTCTime
76+addTime :: Expr DiffTime -> Expr UTCTime -> Expr UTCTime
7977addTime = flip (binaryOperator "+")
8078
8179
8280-- | Find the duration between two times.
83−diffTime :: Expr UTCTime -> Expr UTCTime -> Expr CalendarDiffTime
81+diffTime :: Expr UTCTime -> Expr UTCTime -> Expr DiffTime
8482diffTime = binaryOperator "-"
8583
8684
8785-- | Subtract a time interval from a point in time, yielding a new point in time.
88−subtractTime :: Expr CalendarDiffTime -> Expr UTCTime -> Expr UTCTime
86+subtractTime :: Expr DiffTime -> Expr UTCTime -> Expr UTCTime
8987subtractTime = flip (binaryOperator "-")
9088
9189
92−scaleInterval :: Expr Double -> Expr CalendarDiffTime -> Expr CalendarDiffTime
90+scaleInterval :: Expr Double -> Expr DiffTime -> Expr DiffTime
9391scaleInterval = binaryOperator "*"
9492
9593
9694-- | An interval of one second.
97−second :: Expr CalendarDiffTime
95+second :: Expr DiffTime
9896second = singleton "second"
9997
10098
101−-- | Create a literal interval from a number of seconds.
102−seconds :: Expr Double -> Expr CalendarDiffTime
99+-- | Create a literal interval from an integral number of seconds.
100+seconds :: Expr Double -> Expr DiffTime
103101seconds = (`scaleInterval` second)
104102
105103
106104-- | An interval of one minute.
107−minute :: Expr CalendarDiffTime
105+minute :: Expr DiffTime
108106minute = singleton "minute"
109107
110108
111−-- | Create a literal interval from a number of minutes.
112−minutes :: Expr Double -> Expr CalendarDiffTime
109+-- | Create a literal interval from an integral number of minutes.
110+minutes :: Expr Double -> Expr DiffTime
113111minutes = (`scaleInterval` minute)
114112
115113
116114-- | An interval of one hour.
117−hour :: Expr CalendarDiffTime
115+hour :: Expr DiffTime
118116hour = singleton "hour"
119117
120118
121−-- | Create a literal interval from a number of hours.
122−hours :: Expr Double -> Expr CalendarDiffTime
119+-- | Create a literal interval from an integral number of hours.
120+hours :: Expr Double -> Expr DiffTime
123121hours = (`scaleInterval` hour)
124122
125123
126124-- | An interval of one day.
127−day :: Expr CalendarDiffTime
125+day :: Expr DiffTime
128126day = singleton "day"
129127
130128
131129-- | Create a literal interval from a number of days.
132−days :: Expr Double -> Expr CalendarDiffTime
130+days :: Expr Double -> Expr DiffTime
133131days = (`scaleInterval` day)
134132
135133
136−-- | An interval of one week.
137−week :: Expr CalendarDiffTime
138−week = singleton "week"
139−
140−
141−-- | Create a literal interval from a number of weeks.
142−weeks :: Expr Double -> Expr CalendarDiffTime
143−weeks = (`scaleInterval` week)
144−
145−
146134-- | An interval of one month.
147−month :: Expr CalendarDiffTime
135+month :: Expr DiffTime
148136month = singleton "month"
149137
150138
151139-- | Create a literal interval from a number of months.
152−months :: Expr Double -> Expr CalendarDiffTime
140+months :: Expr Double -> Expr DiffTime
153141months = (`scaleInterval` month)
154142
155143
156144-- | An interval of one year.
157−year :: Expr CalendarDiffTime
145+year :: Expr DiffTime
158146year = singleton "year"
159147
160148
161149-- | Create a literal interval from a number of years.
162−years :: Expr Double -> Expr CalendarDiffTime
150+years :: Expr Double -> Expr DiffTime
163151years = (`scaleInterval` year)
164152
165153
166−singleton :: String -> Expr CalendarDiffTime
167−singleton unit = castExpr $ unsafeLiteral $ "'1 " ++ unit ++ "'"
154+singleton :: String -> Expr DiffTime
155+singleton unit = unsafeLiteral $ "'1 " ++ unit ++ "'"
src/Rel8/Expr/Window.hsdeleted−121
@@ -1,121 +0,0 @@
1−module Rel8.Expr.Window
2− ( cumulative
3− , rowNumber
4− , rank
5− , denseRank
6− , percentRank
7− , cumeDist
8− , ntile
9− , lag
10− , lead
11− , firstValue
12− , lastValue
13− , nthValue
14− )
15−where
16−
17−-- base
18−import Data.Int ( Int32, Int64 )
19−import Prelude
20−
21−-- opaleye
22−import qualified Opaleye.Internal.Aggregate as Opaleye
23−import qualified Opaleye.Internal.PackMap as Opaleye
24−import qualified Opaleye.Internal.Window as Opaleye
25−import qualified Opaleye.Window as Opaleye
26−
27−-- profunctors
28−import Data.Profunctor (dimap)
29−
30−-- rel8
31−import Rel8.Aggregate ( Aggregate( Aggregate ) )
32−import Rel8.Expr ( Expr )
33−import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr, toColumn, toPrimExpr )
34−import Rel8.Schema.Null ( Nullify )
35−import Rel8.Window ( Window( Window ) )
36−
37−
38−cumulative :: (a -> Aggregate b) -> Window a (Expr b)
39−cumulative f =
40− fromWindowFunction $ Opaleye.aggregatorWindowFunction (fromAggregate f) id
41−
42−
43−-- | [@row_number()@](https://www.postgresql.org/docs/current/functions-window.html)
44−rowNumber :: Window a (Expr Int64)
45−rowNumber = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.rowNumber
46−
47−
48−-- | [@rank()@](https://www.postgresql.org/docs/current/functions-window.html)
49−rank :: Window a (Expr Int64)
50−rank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.rank
51−
52−
53−-- | [@dense_rank()@](https://www.postgresql.org/docs/current/functions-window.html)
54−denseRank :: Window a (Expr Int64)
55−denseRank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.denseRank
56−
57−
58−-- | [@percent_rank()@](https://www.postgresql.org/docs/current/functions-window.html)
59−percentRank :: Window a (Expr Double)
60−percentRank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.percentRank
61−
62−
63−-- | [@cume_dist()@](https://www.postgresql.org/docs/current/functions-window.html)
64−cumeDist :: Window a (Expr Double)
65−cumeDist = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.cumeDist
66−
67−
68−-- | [@ntile(num_buckets)@](https://www.postgresql.org/docs/current/functions-window.html)
69−ntile :: Expr Int32 -> Window a (Expr Int32)
70−ntile buckets = fromWindowFunction $ fromPrimExpr . fromColumn <$>
71− Opaleye.ntile (toColumn (toPrimExpr buckets))
72−
73−
74−-- | [@lag(value, offset, default)@](https://www.postgresql.org/docs/current/functions-window.html)
75−lag :: Expr Int32 -> Expr a -> Window (Expr a) (Expr a)
76−lag offset def =
77− fromWindowFunction $
78− dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $
79− Opaleye.lag (toColumn (toPrimExpr offset)) (toColumn (toPrimExpr def))
80−
81−
82−-- | [@lead(value, offset, default)@](https://www.postgresql.org/docs/current/functions-window.html)
83−lead :: Expr Int32 -> Expr a -> Window (Expr a) (Expr a)
84−lead offset def =
85− fromWindowFunction $
86− dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $
87− Opaleye.lead (toColumn (toPrimExpr offset)) (toColumn (toPrimExpr def))
88−
89−
90−-- | [@first_value(value)@](https://www.postgresql.org/docs/current/functions-window.html)
91−firstValue :: Window (Expr a) (Expr a)
92−firstValue =
93− fromWindowFunction $
94− dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn)
95− Opaleye.firstValue
96−
97−
98−-- | [@last_value(value)@](https://www.postgresql.org/docs/current/functions-window.html)
99−lastValue :: Window (Expr a) (Expr a)
100−lastValue =
101− fromWindowFunction $
102− dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn)
103− Opaleye.lastValue
104−
105−
106−-- | [@nth_value(value, n)@](https://www.postgresql.org/docs/current/functions-window.html)
107−nthValue :: Expr Int32 -> Window (Expr a) (Expr (Nullify a))
108−nthValue n =
109− fromWindowFunction $
110− dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $
111− Opaleye.nthValue (toColumn (toPrimExpr n))
112−
113−
114−fromAggregate :: (a -> Aggregate b) -> Opaleye.Aggregator a (Expr b)
115−fromAggregate f = Opaleye.Aggregator $ Opaleye.PackMap $ \w a -> case f a of
116− Aggregate (Opaleye.Aggregator (Opaleye.PackMap x)) -> x w ()
117−
118−
119−fromWindowFunction :: Opaleye.WindowFunction a b -> Window a b
120−fromWindowFunction (Opaleye.WindowFunction (Opaleye.PackMap w)) =
121− Window $ Opaleye.Windows $ Opaleye.PackMap $ \f -> w $ \o -> f (o, mempty)
src/Rel8/FCF.hs+1−9
@@ -3,11 +3,7 @@
33{-# language StandaloneKindSignatures #-}
44{-# language TypeFamilies #-}
55
6−module Rel8.FCF
7− ( Exp, Eval
8− , Id
9− )
10−where
6+module Rel8.FCF ( Exp, Eval ) where
117
128-- base
139import Data.Kind ( Type )
@@ -20,7 +16,3 @@ type Exp e = e -> Type
2016
2117type Eval :: Exp e -> e
2218type family Eval a
23−
24−
25−data Id :: a -> Exp a
26−type instance Eval (Id a) = a
src/Rel8/Generic/Construction.hsdeleted−352
@@ -1,352 +0,0 @@
1−{-# language AllowAmbiguousTypes #-}
2−{-# language ConstraintKinds #-}
3−{-# language DataKinds #-}
4−{-# language FlexibleContexts #-}
5−{-# language NamedFieldPuns #-}
6−{-# language ScopedTypeVariables #-}
7−{-# language StandaloneKindSignatures #-}
8−{-# language TypeApplications #-}
9−{-# language TypeFamilies #-}
10−{-# language UndecidableInstances #-}
11−{-# language ViewPatterns #-}
12−
13−module Rel8.Generic.Construction
14− ( GGBuildable
15− , GGBuild, ggbuild
16− , GGConstructable
17− , GGConstruct, ggconstruct
18− , GGDeconstruct, ggdeconstruct
19− , GGName, ggname
20− , GGAggregate, ggaggregate
21− )
22−where
23−
24−-- base
25−import Data.Bifunctor ( first )
26−import Data.Kind ( Constraint, Type )
27−import Data.List.NonEmpty ( NonEmpty( (:|) ) )
28−import GHC.TypeLits ( Symbol )
29−import Prelude
30−
31−-- rel8
32−import Rel8.Aggregate ( Aggregate( Aggregate ) )
33−import Rel8.Expr ( Expr )
34−import Rel8.Expr.Aggregate ( groupByExpr )
35−import Rel8.Expr.Eq ( (==.) )
36−import Rel8.Expr.Null ( nullify, snull, unsafeUnnullify )
37−import Rel8.Expr.Serialize ( litExpr )
38−import Rel8.FCF ( Eval, Exp, Id )
39−import Rel8.Generic.Construction.ADT
40− ( GConstructorADT, GMakeableADT, gmakeADT
41− , GConstructableADT
42− , GBuildADT, gbuildADT, gunbuildADT
43− , GConstructADT, gconstructADT, gdeconstructADT
44− , RepresentableConstructors, GConstructors, gcindex, gctabulate
45− , RepresentableFields, gfindex, gftabulate
46− )
47−import Rel8.Generic.Construction.Record
48− ( GConstructor
49− , GConstructable, GConstruct, gconstruct, gdeconstruct
50− , Representable, gindex, gtabulate
51− )
52−import Rel8.Generic.Table ( GGColumns )
53−import Rel8.Kind.Algebra
54− ( SAlgebra( SProduct, SSum )
55− , KnownAlgebra, algebraSing
56− )
57−import qualified Rel8.Kind.Algebra as K
58−import Rel8.Schema.Context.Nullify ( sguard, snullify )
59−import Rel8.Schema.HTable ( HTable )
60−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
61−import qualified Rel8.Schema.Kind as K
62−import Rel8.Schema.Name ( Name( Name ) )
63−import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
64−import Rel8.Schema.Spec ( Spec( Spec, nullity, info ) )
65−import Rel8.Table
66− ( TTable, TColumns
67− , Table, fromColumns, toColumns
68− )
69−import Rel8.Table.Bool ( case_ )
70−import Rel8.Type.Tag ( Tag )
71−
72−
73−type GGBuildable :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Constraint
74−type GGBuildable algebra name rep =
75− ( KnownAlgebra algebra
76− , Eval (GGColumns algebra TColumns (Eval (rep Aggregate))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))
77− , Eval (GGColumns algebra TColumns (Eval (rep Expr))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))
78− , Eval (GGColumns algebra TColumns (Eval (rep Name))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))
79− , HTable (Eval (GGColumns algebra TColumns (Eval (rep Expr))))
80− , GGBuildable' algebra name rep
81− )
82−
83−
84−type GGBuildable' :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Constraint
85−type family GGBuildable' algebra name rep where
86− GGBuildable' 'K.Product name rep =
87− ( name ~ GConstructor (Eval (rep Expr))
88− , Representable Id (Eval (rep Expr))
89− , GConstructable (TTable Expr) TColumns Id Expr (Eval (rep Expr))
90− )
91− GGBuildable' 'K.Sum name rep =
92− ( Representable Id (GConstructorADT name (Eval (rep Expr)))
93− , GMakeableADT (TTable Expr) TColumns Id Expr name (Eval (rep Expr))
94− )
95−
96−
97−type GGBuild :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Type -> Type
98−type family GGBuild algebra name rep r where
99− GGBuild 'K.Product _name rep r =
100− GConstruct Id (Eval (rep Expr)) r
101− GGBuild 'K.Sum name rep r =
102− GConstruct Id (GConstructorADT name (Eval (rep Expr))) r
103−
104−
105−ggbuild :: forall algebra name rep a. GGBuildable algebra name rep
106− => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a)
107− -> GGBuild algebra name rep a
108−ggbuild gfromColumns = case algebraSing @algebra of
109− SProduct ->
110− gtabulate @Id @(Eval (rep Expr)) @a $
111− gfromColumns .
112− gconstruct
113− @(TTable Expr)
114− @TColumns
115− @Id
116− @Expr
117− @(Eval (rep Expr))
118− (const toColumns)
119− SSum ->
120− gtabulate @Id @(GConstructorADT name (Eval (rep Expr))) @a $
121− gfromColumns .
122− gmakeADT
123− @(TTable Expr)
124− @TColumns
125− @Id
126− @Expr
127− @name
128− @(Eval (rep Expr))
129− (const toColumns)
130− (\Spec {info} -> snull info)
131− (\Spec {nullity} -> case nullity of
132− Null -> id
133− NotNull -> nullify)
134− (HIdentity . litExpr)
135−
136−
137−type GGConstructable :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint
138−type GGConstructable algebra rep =
139− ( KnownAlgebra algebra
140− , Eval (GGColumns algebra TColumns (Eval (rep Aggregate))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))
141− , Eval (GGColumns algebra TColumns (Eval (rep Expr))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))
142− , Eval (GGColumns algebra TColumns (Eval (rep Name))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))
143− , HTable (Eval (GGColumns algebra TColumns (Eval (rep Expr))))
144− , GGConstructable' algebra rep
145− )
146−
147−
148−type GGConstructable' :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint
149−type family GGConstructable' algebra rep where
150− GGConstructable' 'K.Product rep =
151− ( Representable Id (Eval (rep Aggregate))
152− , Representable Id (Eval (rep Expr))
153− , Representable Id (Eval (rep Name))
154− , GConstructable (TTable Aggregate) TColumns Id Aggregate (Eval (rep Aggregate))
155− , GConstructable (TTable Expr) TColumns Id Expr (Eval (rep Expr))
156− , GConstructable (TTable Name) TColumns Id Name (Eval (rep Name))
157− )
158− GGConstructable' 'K.Sum rep =
159− ( RepresentableConstructors Id (Eval (rep Expr))
160− , RepresentableFields Id (Eval (rep Aggregate))
161− , RepresentableFields Id (Eval (rep Expr))
162− , RepresentableFields Id (Eval (rep Name))
163− , Functor (GConstructors Id (Eval (rep Expr)))
164− , GConstructableADT (TTable Aggregate) TColumns Id Aggregate (Eval (rep Aggregate))
165− , GConstructableADT (TTable Expr) TColumns Id Expr (Eval (rep Expr))
166− , GConstructableADT (TTable Name) TColumns Id Name (Eval (rep Name))
167− )
168−
169−
170−type GGConstruct :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type
171−type family GGConstruct algebra rep r where
172− GGConstruct 'K.Product rep r = GConstruct Id (Eval (rep Expr)) r -> r
173− GGConstruct 'K.Sum rep r = GConstructADT Id (Eval (rep Expr)) r r
174−
175−
176−ggconstruct :: forall algebra rep a. GGConstructable algebra rep
177− => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a)
178− -> GGConstruct algebra rep a -> a
179−ggconstruct gfromColumns f = case algebraSing @algebra of
180− SProduct ->
181− f $
182− gtabulate @Id @(Eval (rep Expr)) @a $
183− gfromColumns .
184− gconstruct
185− @(TTable Expr)
186− @TColumns
187− @Id
188− @Expr
189− @(Eval (rep Expr))
190− (const toColumns)
191− SSum ->
192− gcindex @Id @(Eval (rep Expr)) @a f $
193− fmap gfromColumns $
194− gconstructADT
195− @(TTable Expr)
196− @TColumns
197− @Id
198− @Expr
199− @(Eval (rep Expr))
200− (const toColumns)
201− (\Spec {info} -> snull info)
202− (\Spec {nullity} -> case nullity of
203− Null -> id
204− NotNull -> nullify)
205− (HIdentity . litExpr)
206−
207−
208−type GGDeconstruct :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type -> Type
209−type family GGDeconstruct algebra rep a r where
210− GGDeconstruct 'K.Product rep a r =
211− GConstruct Id (Eval (rep Expr)) r -> a -> r
212− GGDeconstruct 'K.Sum rep a r =
213− GConstructADT Id (Eval (rep Expr)) r (a -> r)
214−
215−
216−ggdeconstruct :: forall algebra rep a r. (GGConstructable algebra rep, Table Expr r)
217− => (a -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)
218− -> GGDeconstruct algebra rep a r
219−ggdeconstruct gtoColumns = case algebraSing @algebra of
220− SProduct -> \build ->
221− gindex @Id @(Eval (rep Expr)) @r build .
222− gdeconstruct
223− @(TTable Expr)
224− @TColumns
225− @Id
226− @Expr
227− @(Eval (rep Expr))
228− (const fromColumns) .
229− gtoColumns
230− SSum ->
231− gctabulate @Id @(Eval (rep Expr)) @r @(a -> r) $ \constructors as ->
232− let
233− (HIdentity tag, cases) =
234− gdeconstructADT
235− @(TTable Expr)
236− @TColumns
237− @Id
238− @Expr
239− @(Eval (rep Expr))
240− (const fromColumns)
241− (\Spec {nullity} -> case nullity of
242− Null -> id
243− NotNull -> unsafeUnnullify)
244− constructors $
245− gtoColumns as
246− in
247− case cases of
248− ((_, r) :| (map (first ((tag ==.) . litExpr)) -> cases')) ->
249− case_ cases' r
250−
251−
252−type GGName :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type
253−type family GGName algebra rep a where
254− GGName 'K.Product rep a = GConstruct Id (Eval (rep Name)) a
255− GGName 'K.Sum rep a = Name Tag -> GBuildADT Id (Eval (rep Name)) a
256−
257−
258−ggname :: forall algebra rep a. GGConstructable algebra rep
259− => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Name -> a)
260− -> GGName algebra rep a
261−ggname gfromColumns = case algebraSing @algebra of
262− SProduct ->
263− gtabulate @Id @(Eval (rep Name)) @a $
264− gfromColumns .
265− gconstruct
266− @(TTable Name)
267− @TColumns
268− @Id
269− @Name
270− @(Eval (rep Name))
271− (const toColumns)
272− SSum -> \tag ->
273− gftabulate @Id @(Eval (rep Name)) @a $
274− gfromColumns .
275− gbuildADT
276− @(TTable Name)
277− @TColumns
278− @Id
279− @Name
280− @(Eval (rep Name))
281− (const toColumns)
282− (\_ _ (Name a) -> Name a)
283− (HIdentity tag)
284−
285−
286−type GGAggregate :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type
287−type family GGAggregate algebra rep r where
288− GGAggregate 'K.Product rep r =
289− GConstruct Id (Eval (rep Aggregate)) r ->
290− GConstruct Id (Eval (rep Expr)) r
291− GGAggregate 'K.Sum rep r =
292− GBuildADT Id (Eval (rep Aggregate)) r ->
293− GBuildADT Id (Eval (rep Expr)) r
294−
295−
296−ggaggregate :: forall algebra rep exprs agg. GGConstructable algebra rep
297− => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Aggregate -> agg)
298− -> (exprs -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)
299− -> GGAggregate algebra rep agg -> exprs -> agg
300−ggaggregate gfromColumns gtoColumns agg es = case algebraSing @algebra of
301− SProduct -> flip f exprs $
302− gfromColumns .
303− gconstruct
304− @(TTable Aggregate)
305− @TColumns
306− @Id
307− @Aggregate
308− @(Eval (rep Aggregate))
309− (const toColumns)
310− where
311− f =
312− gindex @Id @(Eval (rep Expr)) @agg .
313− agg .
314− gtabulate @Id @(Eval (rep Aggregate)) @agg
315− exprs =
316− gdeconstruct
317− @(TTable Expr)
318− @TColumns
319− @Id
320− @Expr
321− @(Eval (rep Expr))
322− (const fromColumns) $
323− gtoColumns es
324− SSum -> flip f exprs $
325− gfromColumns .
326− gbuildADT
327− @(TTable Aggregate)
328− @TColumns
329− @Id
330− @Aggregate
331− @(Eval (rep Aggregate))
332− (const toColumns)
333− (\tag' Spec {nullity} (Aggregate a) ->
334− Aggregate $ sguard (tag ==. litExpr tag') . snullify nullity <$> a)
335− (HIdentity (groupByExpr tag))
336− where
337− f =
338− gfindex @Id @(Eval (rep Expr)) @agg .
339− agg .
340− gftabulate @Id @(Eval (rep Aggregate)) @agg
341− (HIdentity tag, exprs) =
342− gunbuildADT
343− @(TTable Expr)
344− @TColumns
345− @Id
346− @Expr
347− @(Eval (rep Expr))
348− (const fromColumns)
349− (\Spec {nullity} -> case nullity of
350− Null -> id
351− NotNull -> unsafeUnnullify) $
352− gtoColumns es
src/Rel8/Generic/Construction/ADT.hsdeleted−478
@@ -1,478 +0,0 @@
1−{-# language AllowAmbiguousTypes #-}
2−{-# language BlockArguments #-}
3−{-# language DataKinds #-}
4−{-# language FlexibleContexts #-}
5−{-# language FlexibleInstances #-}
6−{-# language MultiParamTypeClasses #-}
7−{-# language RankNTypes #-}
8−{-# language ScopedTypeVariables #-}
9−{-# language StandaloneKindSignatures #-}
10−{-# language TupleSections #-}
11−{-# language TypeApplications #-}
12−{-# language TypeFamilies #-}
13−{-# language TypeOperators #-}
14−{-# language UndecidableInstances #-}
15−
16−module Rel8.Generic.Construction.ADT
17− ( GConstructableADT
18− , GBuildADT, gbuildADT, gunbuildADT
19− , GConstructADT, gconstructADT, gdeconstructADT
20− , GFields, RepresentableFields, gftabulate, gfindex
21− , GConstructors, RepresentableConstructors, gctabulate, gcindex
22− , GConstructorADT, GMakeableADT, gmakeADT
23− )
24−where
25−
26−-- base
27−import Data.Bifunctor ( first )
28−import Data.Functor.Identity ( runIdentity )
29−import Data.Kind ( Constraint, Type )
30−import Data.List.NonEmpty ( NonEmpty )
31−import Data.Proxy ( Proxy( Proxy ) )
32−import GHC.Generics
33− ( (:+:), (:*:)( (:*:) ), M1, U1
34− , C, D
35− , Meta( MetaData, MetaCons )
36− )
37−import GHC.TypeLits
38− ( ErrorMessage( (:<>:), Text ), TypeError
39− , Symbol, KnownSymbol, symbolVal
40− )
41−import Prelude hiding ( null )
42−
43−-- rel8
44−import Rel8.FCF ( Exp )
45−import Rel8.Generic.Construction.Record
46− ( GConstruct, GConstructable, gconstruct, gdeconstruct
47− , GFields, Representable, gtabulate, gindex
48− , FromColumns, ToColumns
49− )
50−import Rel8.Generic.Table.ADT ( GColumnsADT, GColumnsADT' )
51−import Rel8.Generic.Table.Record ( GColumns )
52−import Rel8.Schema.HTable ( HTable )
53−import Rel8.Schema.HTable.Identity ( HIdentity )
54−import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
55−import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify )
56−import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
57−import Rel8.Schema.Null ( Nullify )
58−import Rel8.Schema.Spec ( Spec )
59−import qualified Rel8.Schema.Kind as K
60−import Rel8.Type.Tag ( Tag( Tag ) )
61−
62−-- text
63−import Data.Text ( pack )
64−
65−
66−type Null :: K.Context -> Type
67−type Null context = forall a. Spec a -> context (Nullify a)
68−
69−
70−type Nullifier :: K.Context -> Type
71−type Nullifier context = forall a. Spec a -> context a -> context (Nullify a)
72−
73−
74−type Unnullifier :: K.Context -> Type
75−type Unnullifier context = forall a. Spec a -> context (Nullify a) -> context a
76−
77−
78−type NoConstructor :: Symbol -> Symbol -> ErrorMessage
79−type NoConstructor datatype constructor =
80− ( 'Text "The type `" ':<>:
81− 'Text datatype ':<>:
82− 'Text "` has no constructor `" ':<>:
83− 'Text constructor ':<>:
84− 'Text "`."
85− )
86−
87−
88−type GConstructorADT :: Symbol -> (Type -> Type) -> Type -> Type
89−type family GConstructorADT name rep where
90− GConstructorADT name (M1 D ('MetaData datatype _ _ _) rep) =
91− GConstructorADT' name rep (TypeError (NoConstructor datatype name))
92−
93−
94−type GConstructorADT' :: Symbol -> (Type -> Type) -> (Type -> Type) -> Type -> Type
95−type family GConstructorADT' name rep fallback where
96− GConstructorADT' name (M1 D _ rep) fallback =
97− GConstructorADT' name rep fallback
98− GConstructorADT' name (a :+: b) fallback =
99− GConstructorADT' name a (GConstructorADT' name b fallback)
100− GConstructorADT' name (M1 C ('MetaCons name _ _) rep) _ = rep
101− GConstructorADT' _ _ fallback = fallback
102−
103−
104−type GConstructADT
105− :: (Type -> Exp Type)
106− -> (Type -> Type) -> Type -> Type -> Type
107−type family GConstructADT f rep r x where
108− GConstructADT f (M1 D _ rep) r x = GConstructADT f rep r x
109− GConstructADT f (a :+: b) r x = GConstructADT f a r (GConstructADT f b r x)
110− GConstructADT f (M1 C _ rep) r x = GConstruct f rep r -> x
111−
112−
113−type GConstructors :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type
114−type family GConstructors f rep where
115− GConstructors f (M1 D _ rep) = GConstructors f rep
116− GConstructors f (a :+: b) = GConstructors f a :*: GConstructors f b
117− GConstructors f (M1 C _ rep) = (->) (GFields f rep)
118−
119−
120−type RepresentableConstructors :: (Type -> Exp Type) -> (Type -> Type) -> Constraint
121−class RepresentableConstructors f rep where
122− gctabulate :: (GConstructors f rep r -> a) -> GConstructADT f rep r a
123− gcindex :: GConstructADT f rep r a -> GConstructors f rep r -> a
124−
125−
126−instance RepresentableConstructors f rep => RepresentableConstructors f (M1 D meta rep) where
127− gctabulate = gctabulate @f @rep
128− gcindex = gcindex @f @rep
129−
130−
131−instance (RepresentableConstructors f a, RepresentableConstructors f b) =>
132− RepresentableConstructors f (a :+: b)
133− where
134− gctabulate f =
135− gctabulate @f @a \a -> gctabulate @f @b \b -> f (a :*: b)
136− gcindex f (a :*: b) = gcindex @f @b (gcindex @f @a f a) b
137−
138−
139−instance Representable f rep => RepresentableConstructors f (M1 C meta rep) where
140− gctabulate f = f . gindex @f @rep
141− gcindex f = f . gtabulate @f @rep
142−
143−
144−type GBuildADT :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type
145−type family GBuildADT f rep r where
146− GBuildADT f (M1 D _ rep) r = GBuildADT f rep r
147− GBuildADT f (a :+: b) r = GBuildADT f a (GBuildADT f b r)
148− GBuildADT f (M1 C _ rep) r = GConstruct f rep r
149−
150−
151−type GFieldsADT :: (Type -> Exp Type) -> (Type -> Type) -> Type
152−type family GFieldsADT f rep where
153− GFieldsADT f (M1 D _ rep) = GFieldsADT f rep
154− GFieldsADT f (a :+: b) = (GFieldsADT f a, GFieldsADT f b)
155− GFieldsADT f (M1 C _ rep) = GFields f rep
156−
157−
158−type RepresentableFields :: (Type -> Exp Type) -> (Type -> Type) -> Constraint
159−class RepresentableFields f rep where
160− gftabulate :: (GFieldsADT f rep -> a) -> GBuildADT f rep a
161− gfindex :: GBuildADT f rep a -> GFieldsADT f rep -> a
162−
163−
164−instance RepresentableFields f rep => RepresentableFields f (M1 D meta rep) where
165− gftabulate = gftabulate @f @rep
166− gfindex = gfindex @f @rep
167−
168−
169−instance (RepresentableFields f a, RepresentableFields f b) => RepresentableFields f (a :+: b) where
170− gftabulate f =
171− gftabulate @f @a \a -> gftabulate @f @b \b -> f (a, b)
172− gfindex f (a, b) = gfindex @f @b (gfindex @f @a f a) b
173−
174−
175−instance Representable f rep => RepresentableFields f (M1 C meta rep) where
176− gftabulate = gtabulate @f @rep
177− gfindex = gindex @f @rep
178−
179−
180−type GConstructableADT
181− :: (Type -> Exp Constraint)
182− -> (Type -> Exp K.HTable)
183− -> (Type -> Exp Type)
184− -> K.Context -> (Type -> Type) -> Constraint
185−class GConstructableADT _Table _Columns f context rep where
186− gbuildADT :: ()
187− => ToColumns _Table _Columns f context
188− -> (Tag -> Nullifier context)
189− -> HIdentity Tag context
190− -> GFieldsADT f rep
191− -> GColumnsADT _Columns rep context
192−
193− gunbuildADT :: ()
194− => FromColumns _Table _Columns f context
195− -> Unnullifier context
196− -> GColumnsADT _Columns rep context
197− -> (HIdentity Tag context, GFieldsADT f rep)
198−
199− gconstructADT :: ()
200− => ToColumns _Table _Columns f context
201− -> Null context
202− -> Nullifier context
203− -> (Tag -> HIdentity Tag context)
204− -> GConstructors f rep (GColumnsADT _Columns rep context)
205−
206− gdeconstructADT :: ()
207− => FromColumns _Table _Columns f context
208− -> Unnullifier context
209− -> GConstructors f rep r
210− -> GColumnsADT _Columns rep context
211− -> (HIdentity Tag context, NonEmpty (Tag, r))
212−
213−
214−instance
215− ( htable ~ HLabel "tag" (HIdentity Tag)
216− , GConstructableADT' _Table _Columns f context htable rep
217− )
218− => GConstructableADT _Table _Columns f context (M1 D meta rep)
219− where
220− gbuildADT toColumns nullifier =
221− gbuildADT' @_Table @_Columns @f @context @htable @rep toColumns nullifier .
222− hlabel
223−
224− gunbuildADT fromColumns unnullifier =
225− first hunlabel .
226− gunbuildADT' @_Table @_Columns @f @context @htable @rep fromColumns unnullifier
227−
228− gconstructADT toColumns null nullifier mk =
229− gconstructADT' @_Table @_Columns @f @context @htable @rep toColumns null nullifier
230− (hlabel . mk)
231−
232− gdeconstructADT fromColumns unnullifier cases =
233− first hunlabel .
234− gdeconstructADT' @_Table @_Columns @f @context @htable @rep fromColumns unnullifier cases
235−
236−
237−type GConstructableADT'
238− :: (Type -> Exp Constraint)
239− -> (Type -> Exp K.HTable)
240− -> (Type -> Exp Type)
241− -> K.Context -> K.HTable -> (Type -> Type) -> Constraint
242−class GConstructableADT' _Table _Columns f context htable rep where
243− gbuildADT' :: ()
244− => ToColumns _Table _Columns f context
245− -> (Tag -> Nullifier context)
246− -> htable context
247− -> GFieldsADT f rep
248− -> GColumnsADT' _Columns htable rep context
249−
250− gunbuildADT' :: ()
251− => FromColumns _Table _Columns f context
252− -> Unnullifier context
253− -> GColumnsADT' _Columns htable rep context
254− -> (htable context, GFieldsADT f rep)
255−
256− gconstructADT' :: ()
257− => ToColumns _Table _Columns f context
258− -> Null context
259− -> Nullifier context
260− -> (Tag -> htable context)
261− -> GConstructors f rep (GColumnsADT' _Columns htable rep context)
262−
263− gdeconstructADT' :: ()
264− => FromColumns _Table _Columns f context
265− -> Unnullifier context
266− -> GConstructors f rep r
267− -> GColumnsADT' _Columns htable rep context
268− -> (htable context, NonEmpty (Tag, r))
269−
270− gfill :: ()
271− => Null context
272− -> htable context
273− -> GColumnsADT' _Columns htable rep context
274−
275−
276−instance
277− ( htable' ~ GColumnsADT' _Columns htable a
278− , Functor (GConstructors f a)
279− , GConstructableADT' _Table _Columns f context htable a
280− , GConstructableADT' _Table _Columns f context htable' b
281− )
282− => GConstructableADT' _Table _Columns f context htable (a :+: b)
283− where
284− gbuildADT' toColumns nullifier htable (a, b) =
285− gbuildADT' @_Table @_Columns @f @context @htable' @b toColumns nullifier
286− (gbuildADT' @_Table @_Columns @f @context @htable @a toColumns nullifier htable a)
287− b
288−
289− gunbuildADT' fromColumns unnullifier columns =
290− case gunbuildADT' @_Table @_Columns @f @context @htable' @b fromColumns unnullifier columns of
291− (htable', b) ->
292− case gunbuildADT' @_Table @_Columns @f @context @htable @a fromColumns unnullifier htable' of
293− (htable, a) -> (htable, (a, b))
294−
295− gconstructADT' toColumns null nullifier mk =
296− fmap (gfill @_Table @_Columns @f @context @htable' @b null) (gconstructADT' @_Table @_Columns @f @context @htable @a toColumns null nullifier mk) :*:
297− gconstructADT' @_Table @_Columns @f @context @htable' @b toColumns null nullifier (gfill @_Table @_Columns @f @context @htable @a null . mk)
298−
299− gdeconstructADT' fromColumns unnullifier (a :*: b) columns =
300− case gdeconstructADT' @_Table @_Columns @f @context @htable' @b fromColumns unnullifier b columns of
301− (htable', cases) ->
302− case gdeconstructADT' @_Table @_Columns @f @context @htable @a fromColumns unnullifier a htable' of
303− (htable, cases') -> (htable, cases' <> cases)
304−
305− gfill null =
306− gfill @_Table @_Columns @f @context @htable' @b null .
307− gfill @_Table @_Columns @f @context @htable @a null
308−
309−
310−instance (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) =>
311− GConstructableADT' _Table _Columns f context htable (M1 C meta U1)
312− where
313− gbuildADT' _ _ = const
314− gunbuildADT' _ _ = (, ())
315− gconstructADT' _ _ _ f _ = f tag
316− where
317− tag = Tag $ pack $ symbolVal (Proxy @label)
318− gdeconstructADT' _ _ r htable = (htable, pure (tag, r ()))
319− where
320− tag = Tag $ pack $ symbolVal (Proxy @label)
321− gfill _ = id
322−
323−
324−instance {-# OVERLAPPABLE #-}
325− ( HTable (GColumns _Columns rep)
326− , KnownSymbol label
327− , meta ~ 'MetaCons label _fixity _isRecord
328− , GConstructable _Table _Columns f context rep
329− , GColumnsADT' _Columns htable (M1 C meta rep) ~
330− HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))
331− )
332− => GConstructableADT' _Table _Columns f context htable (M1 C meta rep)
333− where
334− gbuildADT' toColumns nullifier htable =
335− HProduct htable .
336− hlabel .
337− hnullify (nullifier tag) .
338− gconstruct @_Table @_Columns @f @context @rep toColumns
339− where
340− tag = Tag $ pack $ symbolVal (Proxy @label)
341−
342− gunbuildADT' fromColumns unnullifier (HProduct htable a) =
343− ( htable
344− , gdeconstruct @_Table @_Columns @f @context @rep fromColumns $
345− runIdentity $
346− hunnullify (\spec -> pure . unnullifier spec) $
347− hunlabel
348− a
349− )
350−
351− gconstructADT' toColumns _ nullifier mk =
352− HProduct htable .
353− hlabel .
354− hnullify nullifier .
355− gconstruct @_Table @_Columns @f @context @rep toColumns
356− where
357− tag = Tag $ pack $ symbolVal (Proxy @label)
358− htable = mk tag
359−
360− gdeconstructADT' fromColumns unnullifier r (HProduct htable columns) =
361− ( htable
362− , pure (tag, r a)
363− )
364− where
365− a = gdeconstruct @_Table @_Columns @f @context @rep fromColumns $
366− runIdentity $
367− hunnullify (\spec -> pure . unnullifier spec) $
368− hunlabel
369− columns
370− tag = Tag $ pack $ symbolVal (Proxy @label)
371−
372− gfill null htable = HProduct htable (hlabel (hnulls null))
373−
374−
375−type GMakeableADT
376− :: (Type -> Exp Constraint)
377− -> (Type -> Exp K.HTable)
378− -> (Type -> Exp Type)
379− -> K.Context -> Symbol -> (Type -> Type) -> Constraint
380−class GMakeableADT _Table _Columns f context name rep where
381− gmakeADT :: ()
382− => ToColumns _Table _Columns f context
383− -> Null context
384− -> Nullifier context
385− -> (Tag -> HIdentity Tag context)
386− -> GFields f (GConstructorADT name rep)
387− -> GColumnsADT _Columns rep context
388−
389−
390−instance
391− ( htable ~ HLabel "tag" (HIdentity Tag)
392− , meta ~ 'MetaData datatype _module _package _newtype
393− , fallback ~ TypeError (NoConstructor datatype name)
394− , fields ~ GFields f (GConstructorADT' name rep fallback)
395− , GMakeableADT' _Table _Columns f context htable name rep fields
396− , KnownSymbol name
397− )
398− => GMakeableADT _Table _Columns f context name (M1 D meta rep)
399− where
400− gmakeADT toColumns null nullifier wrap =
401− gmakeADT'
402− @_Table @_Columns @f @context @htable @name @rep @fields
403− toColumns null nullifier htable
404− where
405− tag = Tag $ pack $ symbolVal (Proxy @name)
406− htable = hlabel (wrap tag)
407−
408−
409−type GMakeableADT'
410− :: (Type -> Exp Constraint)
411− -> (Type -> Exp K.HTable)
412− -> (Type -> Exp Type)
413− -> K.Context -> K.HTable -> Symbol -> (Type -> Type) -> Type -> Constraint
414−class GMakeableADT' _Table _Columns f context htable name rep fields where
415− gmakeADT' :: ()
416− => ToColumns _Table _Columns f context
417− -> Null context
418− -> Nullifier context
419− -> htable context
420− -> fields
421− -> GColumnsADT' _Columns htable rep context
422−
423−
424−instance
425− ( htable' ~ GColumnsADT' _Columns htable a
426− , GMakeableADT' _Table _Columns f context htable name a fields
427− , GMakeableADT' _Table _Columns f context htable' name b fields
428− )
429− => GMakeableADT' _Table _Columns f context htable name (a :+: b) fields
430− where
431− gmakeADT' toColumns null nullifier htable x =
432− gmakeADT' @_Table @_Columns @f @context @htable' @name @b @fields
433− toColumns null nullifier
434− (gmakeADT'
435− @_Table @_Columns @f @context @htable @name @a @fields toColumns
436− null nullifier htable x)
437− x
438−
439−
440−instance {-# OVERLAPPING #-}
441− GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons name _fixity _isRecord) U1) fields
442− where
443− gmakeADT' _ _ _ = const
444−
445−
446−instance {-# OVERLAPS #-}
447− GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons label _fixity _isRecord) U1) fields
448− where
449− gmakeADT' _ _ _ = const
450−
451−
452−instance {-# OVERLAPS #-}
453− ( HTable (GColumns _Columns rep)
454− , GConstructable _Table _Columns f context rep
455− , fields ~ GFields f rep
456− , GColumnsADT' _Columns htable (M1 C ('MetaCons name _fixity _isRecord) rep) ~
457− HProduct htable (HLabel name (HNullify (GColumns _Columns rep)))
458− )
459− => GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons name _fixity _isRecord) rep) fields
460− where
461− gmakeADT' toColumns _ nullifier htable =
462− HProduct htable .
463− hlabel .
464− hnullify nullifier .
465− gconstruct @_Table @_Columns @f @context @rep toColumns
466−
467−
468−instance {-# OVERLAPPABLE #-}
469− ( HTable (GColumns _Columns rep)
470− , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) rep) ~
471− HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))
472− )
473− => GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons label _fixity _isRecord) rep) fields
474− where
475− gmakeADT' _ null _ htable _ =
476− HProduct htable $
477− hlabel $
478− hnulls null
src/Rel8/Generic/Construction/Record.hsdeleted−168
@@ -1,168 +0,0 @@
1−{-# language AllowAmbiguousTypes #-}
2−{-# language BlockArguments #-}
3−{-# language DataKinds #-}
4−{-# language FlexibleInstances #-}
5−{-# language MultiParamTypeClasses #-}
6−{-# language RankNTypes #-}
7−{-# language ScopedTypeVariables #-}
8−{-# language StandaloneKindSignatures #-}
9−{-# language TypeApplications #-}
10−{-# language TypeFamilies #-}
11−{-# language TypeOperators #-}
12−{-# language UndecidableInstances #-}
13−
14−module Rel8.Generic.Construction.Record
15− ( GConstructor, GConstruct, GConstructable, gconstruct, gdeconstruct
16− , GFields, Representable, gtabulate, gindex
17− , FromColumns, ToColumns
18− )
19−where
20−
21−-- base
22−import Data.Kind ( Constraint, Type )
23−import Data.Proxy ( Proxy( Proxy ) )
24−import GHC.Generics
25− ( (:*:), K1, M1, U1
26− , D, C, S, Meta( MetaData, MetaCons, MetaSel )
27− )
28−import GHC.TypeLits
29− ( ErrorMessage( (:<>:), Text ), TypeError
30− , Symbol
31− )
32−import Prelude
33−
34−-- rel8
35−import Rel8.FCF ( Eval, Exp )
36−import Rel8.Generic.Table.Record ( GColumns )
37−import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
38−import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
39−import qualified Rel8.Schema.Kind as K
40−
41−
42−type FromColumns
43− :: (Type -> Exp Constraint)
44− -> (Type -> Exp K.HTable)
45− -> (Type -> Exp Type)
46− -> K.Context
47− -> Type
48−type FromColumns _Table _Columns f context = forall proxy x.
49− Eval (_Table x) => proxy x -> Eval (_Columns x) context -> Eval (f x)
50−
51−
52−type ToColumns
53− :: (Type -> Exp Constraint)
54− -> (Type -> Exp K.HTable)
55− -> (Type -> Exp Type)
56− -> K.Context
57− -> Type
58−type ToColumns _Table _Columns f context = forall proxy x.
59− Eval (_Table x) => proxy x -> Eval (f x) -> Eval (_Columns x) context
60−
61−
62−type GConstructor :: (Type -> Type) -> Symbol
63−type family GConstructor rep where
64− GConstructor (M1 D _ (M1 C ('MetaCons name _ _) _)) = name
65− GConstructor (M1 D ('MetaData name _ _ _) _) = TypeError (
66− 'Text "`" ':<>:
67− 'Text name ':<>:
68− 'Text "` does not appear to have exactly 1 constructor"
69− )
70−
71−
72−type GConstruct :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type
73−type family GConstruct f rep r where
74− GConstruct f (M1 _ _ rep) r = GConstruct f rep r
75− GConstruct f (a :*: b) r = GConstruct f a (GConstruct f b r)
76− GConstruct _ U1 r = r
77− GConstruct f (K1 _ a) r = Eval (f a) -> r
78−
79−
80−type GFields :: (Type -> Exp Type) -> (Type -> Type) -> Type
81−type family GFields f rep where
82− GFields f (M1 _ _ rep) = GFields f rep
83− GFields f (a :*: b) = (GFields f a, GFields f b)
84− GFields _ U1 = ()
85− GFields f (K1 _ a) = Eval (f a)
86−
87−
88−type Representable :: (Type -> Exp Type) -> (Type -> Type) -> Constraint
89−class Representable f rep where
90− gtabulate :: (GFields f rep -> a) -> GConstruct f rep a
91− gindex :: GConstruct f rep a -> GFields f rep -> a
92−
93−
94−instance Representable f rep => Representable f (M1 i meta rep) where
95− gtabulate = gtabulate @f @rep
96− gindex = gindex @f @rep
97−
98−
99−instance (Representable f a, Representable f b) =>
100− Representable f (a :*: b)
101− where
102− gtabulate f = gtabulate @f @a \a -> gtabulate @f @b \b -> f (a, b)
103− gindex f (a, b) = gindex @f @b (gindex @f @a f a) b
104−
105−
106−instance Representable f U1 where
107− gtabulate = ($ ())
108− gindex = const
109−
110−
111−instance Representable f (K1 i a) where
112− gtabulate = id
113− gindex = id
114−
115−
116−type GConstructable
117− :: (Type -> Exp Constraint)
118− -> (Type -> Exp K.HTable)
119− -> (Type -> Exp Type)
120− -> K.Context -> (Type -> Type) -> Constraint
121−class GConstructable _Table _Columns f context rep where
122− gconstruct :: ()
123− => ToColumns _Table _Columns f context
124− -> GFields f rep
125− -> GColumns _Columns rep context
126− gdeconstruct :: ()
127− => FromColumns _Table _Columns f context
128− -> GColumns _Columns rep context
129− -> GFields f rep
130−
131−
132−instance (GConstructable _Table _Columns f context rep) =>
133− GConstructable _Table _Columns f context (M1 D meta rep)
134− where
135− gconstruct = gconstruct @_Table @_Columns @f @context @rep
136− gdeconstruct = gdeconstruct @_Table @_Columns @f @context @rep
137−
138−
139−instance (GConstructable _Table _Columns f context rep) =>
140− GConstructable _Table _Columns f context (M1 C meta rep)
141− where
142− gconstruct = gconstruct @_Table @_Columns @f @context @rep
143− gdeconstruct = gdeconstruct @_Table @_Columns @f @context @rep
144−
145−
146−instance
147− ( GConstructable _Table _Columns f context a
148− , GConstructable _Table _Columns f context b
149− )
150− => GConstructable _Table _Columns f context (a :*: b)
151− where
152− gconstruct toColumns (a, b) = HProduct
153− (gconstruct @_Table @_Columns @f @context @a toColumns a)
154− (gconstruct @_Table @_Columns @f @context @b toColumns b)
155− gdeconstruct fromColumns (HProduct a b) =
156− ( gdeconstruct @_Table @_Columns @f @context @a fromColumns a
157− , gdeconstruct @_Table @_Columns @f @context @b fromColumns b
158− )
159−
160−
161−instance
162− ( Eval (_Table a)
163− , meta ~ 'MetaSel ('Just label) _su _ss _ds
164− )
165− => GConstructable _Table _Columns f context (M1 S meta (K1 i a))
166− where
167− gconstruct toColumns = hlabel . toColumns (Proxy @a)
168− gdeconstruct fromColumns = fromColumns (Proxy @a) . hunlabel
src/Rel8/Generic/Map.hsdeleted−49
@@ -1,49 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language StandaloneKindSignatures #-}
3−{-# language TypeFamilies #-}
4−{-# language TypeOperators #-}
5−{-# language UndecidableInstances #-}
6−
7−module Rel8.Generic.Map
8− ( GMap
9− , Map
10− )
11−where
12−
13−-- base
14−import Data.Kind ( Type )
15−import GHC.Generics
16− ( (:+:), (:*:), K1, M1, U1, V1
17− )
18−import Prelude ()
19−
20−-- rel8
21−import Rel8.FCF ( Eval, Exp )
22−
23−
24−type GMap :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type
25−type family GMap f rep where
26− GMap f (M1 i c rep) = M1 i c (GMap f rep)
27− GMap _ V1 = V1
28− GMap f (rep1 :+: rep2) = GMap f rep1 :+: GMap f rep2
29− GMap _ U1 = U1
30− GMap f (rep1 :*: rep2) = GMap f rep1 :*: GMap f rep2
31− GMap f (K1 i a) = K1 i (Eval (f a))
32−
33−
34−-- | Map a @Type -> Type@ function over the @Type@-kinded type variables in
35−-- of a type constructor.
36−type Map :: (Type -> Exp Type) -> Type -> Type
37−type family Map f a where
38− Map p (t a b c d e f g) =
39− t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e))
40− (Eval (p f)) (Eval (p g))
41− Map p (t a b c d e f) =
42− t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e))
43− (Eval (p f))
44− Map p (t a b c d e) =
45− t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e))
46− Map p (t a b c d) = t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d))
47− Map p (t a b c) = t (Eval (p a)) (Eval (p b)) (Eval (p c))
48− Map p (t a b) = t (Eval (p a)) (Eval (p b))
49− Map p (t a) = t (Eval (p a))
src/Rel8/Generic/Record.hsdeleted−155
@@ -1,155 +0,0 @@
1−{-# language AllowAmbiguousTypes #-}
2−{-# language DataKinds #-}
3−{-# language FlexibleContexts #-}
4−{-# language FlexibleInstances #-}
5−{-# language MultiParamTypeClasses #-}
6−{-# language PolyKinds #-}
7−{-# language ScopedTypeVariables #-}
8−{-# language StandaloneKindSignatures #-}
9−{-# language TypeApplications #-}
10−{-# language TypeFamilies #-}
11−{-# language TypeOperators #-}
12−{-# language UndecidableInstances #-}
13−
14−module Rel8.Generic.Record
15− ( Record(..)
16− , GRecordable, GRecord, grecord, gunrecord
17− )
18−where
19−
20−-- base
21−import Data.Kind ( Constraint, Type )
22−import GHC.Generics
23− ( Generic, Rep, from, to
24− , (:+:)( L1, R1 ), (:*:)( (:*:) ), M1( M1 )
25− , Meta( MetaCons, MetaSel ), D, C, S
26− )
27−import GHC.TypeLits ( type (+), AppendSymbol, Div, Mod, Nat, Symbol )
28−import Prelude hiding ( Show )
29−
30−
31−type GRecord :: (Type -> Type) -> Type -> Type
32−type family GRecord rep where
33− GRecord (M1 D meta rep) = M1 D meta (GRecord rep)
34− GRecord (l :+: r) = GRecord l :+: GRecord r
35− GRecord (M1 C ('MetaCons name fixity 'False) rep) =
36− M1 C ('MetaCons name fixity 'True) (Snd (Count 0 rep))
37− GRecord rep = rep
38−
39−
40−type Count :: Nat -> (Type -> Type) -> (Nat, Type -> Type)
41−type family Count n rep where
42− Count n (M1 S ('MetaSel _selector su ss ds) rep) =
43− '(n + 1, M1 S ('MetaSel ('Just (Show (n + 1))) su ss ds) rep)
44− Count n (a :*: b) = CountHelper1 (Count n a) b
45− Count n rep = '(n, rep)
46−
47−
48−type CountHelper1 :: (Nat, Type -> Type) -> (Type -> Type) -> (Nat, Type -> Type)
49−type family CountHelper1 tuple b where
50− CountHelper1 '(n, a) b = CountHelper2 a (Count n b)
51−
52−
53−type CountHelper2 :: (Type -> Type) -> (Nat, Type -> Type) -> (Nat, Type -> Type)
54−type family CountHelper2 a tuple where
55− CountHelper2 a '(n, b) = '(n, a :*: b)
56−
57−
58−type Show :: Nat -> Symbol
59−type Show n =
60− AppendSymbol "_" (AppendSymbol (Show' (Div n 10)) (ShowDigit (Mod n 10)))
61−
62−
63−type Show' :: Nat -> Symbol
64−type family Show' n where
65− Show' 0 = ""
66− Show' n = AppendSymbol (Show' (Div n 10)) (ShowDigit (Mod n 10))
67−
68−
69−type ShowDigit :: Nat -> Symbol
70−type family ShowDigit n where
71− ShowDigit 0 = "0"
72− ShowDigit 1 = "1"
73− ShowDigit 2 = "2"
74− ShowDigit 3 = "3"
75− ShowDigit 4 = "4"
76− ShowDigit 5 = "5"
77− ShowDigit 6 = "6"
78− ShowDigit 7 = "7"
79− ShowDigit 8 = "8"
80− ShowDigit 9 = "9"
81−
82−
83−type Snd :: (a, b) -> b
84−type family Snd tuple where
85− Snd '(_a, b) = b
86−
87−
88−type GRecordable :: (Type -> Type) -> Constraint
89−class GRecordable rep where
90− grecord :: rep x -> GRecord rep x
91− gunrecord :: GRecord rep x -> rep x
92−
93−
94−instance GRecordable rep => GRecordable (M1 D meta rep) where
95− grecord (M1 a) = M1 (grecord a)
96− gunrecord (M1 a) = M1 (gunrecord a)
97−
98−
99−instance (GRecordable l, GRecordable r) => GRecordable (l :+: r) where
100− grecord (L1 a) = L1 (grecord a)
101− grecord (R1 a) = R1 (grecord a)
102− gunrecord (L1 a) = L1 (gunrecord a)
103− gunrecord (R1 a) = R1 (gunrecord a)
104−
105−
106−instance Countable 0 rep =>
107− GRecordable (M1 C ('MetaCons name fixity 'False) rep)
108− where
109− grecord (M1 a) = M1 (count @0 a)
110− gunrecord (M1 a) = M1 (uncount @0 a)
111−
112−
113−instance {-# OVERLAPPABLE #-} GRecord rep ~ rep => GRecordable rep where
114− grecord = id
115− gunrecord = id
116−
117−
118−type Countable :: Nat -> (Type -> Type) -> Constraint
119−class Countable n rep where
120− count :: rep x -> Snd (Count n rep) x
121− uncount :: Snd (Count n rep) x -> rep x
122−
123−
124−instance Countable n (M1 S ('MetaSel selector su ss ds) rep) where
125− count (M1 a) = M1 a
126− uncount (M1 a) = M1 a
127−
128−
129−instance
130− ( Countable n a, Countable n' b
131− , '(n', a') ~ Count n a
132− , Snd (CountHelper2 a' (Count n' b)) ~ (a' :*: Snd (Count n' b))
133− )
134− => Countable n (a :*: b)
135− where
136− count (a :*: b) = count @n a :*: count @n' b
137− uncount (a :*: b) = uncount @n a :*: uncount @n' b
138−
139−
140−instance {-# OVERLAPPABLE #-} Snd (Count n rep) ~ rep => Countable n rep where
141− count = id
142− uncount = id
143−
144−
145−type Record :: Type -> Type
146−newtype Record a = Record
147− { unrecord :: a
148− }
149−
150−
151−instance (Generic a, GRecordable (Rep a)) => Generic (Record a) where
152− type Rep (Record a) = GRecord (Rep a)
153−
154− from (Record a) = grecord (from a)
155− to = Record . to . gunrecord
src/Rel8/Generic/Rel8able.hsdeleted−281
@@ -1,281 +0,0 @@
1−{-# language AllowAmbiguousTypes #-}
2−{-# language ConstraintKinds #-}
3−{-# language DataKinds #-}
4−{-# language DefaultSignatures #-}
5−{-# language FlexibleContexts #-}
6−{-# language FlexibleInstances #-}
7−{-# language LambdaCase #-}
8−{-# language MultiParamTypeClasses #-}
9−{-# language PolyKinds #-}
10−{-# language QuantifiedConstraints #-}
11−{-# language ScopedTypeVariables #-}
12−{-# language StandaloneKindSignatures #-}
13−{-# language TypeApplications #-}
14−{-# language TypeFamilyDependencies #-}
15−{-# language TypeOperators #-}
16−{-# language UndecidableInstances #-}
17−
18−module Rel8.Generic.Rel8able
19− ( KRel8able, Rel8able
20− , Algebra
21− , GRep
22− , GColumns, gfromColumns, gtoColumns
23− , GFromExprs, gfromResult, gtoResult
24− , TSerialize, serialize, deserialize
25− )
26−where
27−
28−-- base
29−import Data.Functor.Identity ( Identity )
30−import Data.Kind ( Constraint, Type )
31−import Data.Type.Bool ( type (&&) )
32−import GHC.Generics ( Generic, Rep, from, to )
33−import Prelude
34−
35−-- rel8
36−import Rel8.Aggregate ( Aggregate )
37−import Rel8.Expr ( Expr )
38−import Rel8.FCF ( Exp, Eval )
39−import Rel8.Generic.Record ( Record(..) )
40−import Rel8.Generic.Table ( GAlgebra )
41−import qualified Rel8.Generic.Table.Record as G
42−import qualified Rel8.Kind.Algebra as K ( Algebra(..) )
43−import Rel8.Kind.Context ( SContext(..) )
44−import Rel8.Schema.Field ( Field )
45−import Rel8.Schema.HTable ( HTable )
46−import qualified Rel8.Schema.Kind as K
47−import Rel8.Schema.Name ( Name )
48−import Rel8.Schema.Result ( Result )
49−import Rel8.Table
50− ( Table, Columns, Context, fromColumns, toColumns
51− , FromExprs, fromResult, toResult
52− , Transpose
53− , TTable, TColumns
54− )
55−import Rel8.Table.Transpose ( Transposes )
56−
57−
58−-- | The kind of 'Rel8able' types
59−type KRel8able :: Type
60−type KRel8able = K.Rel8able
61−
62−
63−-- This is almost 'Data.Type.Equality.==', but we add an extra case.
64−type (==) :: k -> k -> Bool
65−type family a == b where
66− -- This extra case is needed to solve the equation "a == a" (where a is a
67− -- KRel8able), which occurs when we have polymorphic Rel8ables
68− -- (e.g., newtype T t f = T { x :: t a })
69− (a :: KRel8able) == (a :: KRel8able) = 'True
70−
71− -- This extra case is needed to solve the equation "a == Identity a",
72− -- which occurs when we have polymorphic Rel8ables
73− -- (e.g., newtype T a f = T { x :: Column f a })
74− a == Identity a = 'False
75−
76− -- These cases are exactly the same as those in 'Data.Type.Equality.==.
77− f a == g b = f == g && a == b
78− a == a = 'True
79− _ == _ = 'False
80−
81−
82−type Serialize :: Bool -> Type -> Type -> Constraint
83−class transposition ~ (a == Transpose Result expr) =>
84− Serialize transposition expr a
85− where
86− serialize :: a -> Columns expr Result
87− deserialize :: Columns expr Result -> a
88−
89−
90−instance
91− ( (a == Transpose Result expr) ~ 'True
92− , Transposes Expr Result expr a
93− )
94− => Serialize 'True expr a
95− where
96− serialize = toColumns
97− deserialize = fromColumns
98−
99−
100−instance
101− ( (a == Transpose Result expr) ~ 'False
102− , Table (Context expr) expr
103− , FromExprs expr ~ a
104− )
105− => Serialize 'False expr a
106− where
107− serialize = toResult @_ @expr
108− deserialize = fromResult @_ @expr
109−
110−
111−data TSerialize :: Type -> Type -> Exp Constraint
112−type instance Eval (TSerialize expr a) =
113− Serialize (a == Transpose Result expr) expr a
114−
115−
116−-- | This type class allows you to define custom 'Table's using higher-kinded
117−-- data types. Higher-kinded data types are data types of the pattern:
118−--
119−-- @
120−-- data MyType f =
121−-- MyType { field1 :: Column f T1 OR HK1 f
122−-- , field2 :: Column f T2 OR HK2 f
123−-- , ...
124−-- , fieldN :: Column f Tn OR HKn f
125−-- }
126−-- @
127−--
128−-- where @Tn@ is any Haskell type, and @HKn@ is any higher-kinded type.
129−--
130−-- That is, higher-kinded data are records where all fields in the record are
131−-- all either of the type @Column f T@ (for any @T@), or are themselves
132−-- higher-kinded data:
133−--
134−-- [Nested]
135−--
136−-- @
137−-- data Nested f =
138−-- Nested { nested1 :: MyType f
139−-- , nested2 :: MyType f
140−-- }
141−-- @
142−--
143−-- The @Rel8able@ type class is used to give us a special mapping operation
144−-- that lets us change the type parameter @f@.
145−--
146−-- [Supplying @Rel8able@ instances]
147−--
148−-- This type class should be derived generically for all table types in your
149−-- project. To do this, enable the @DeriveAnyClass@ and @DeriveGeneric@ language
150−-- extensions:
151−--
152−-- @
153−-- \{\-\# LANGUAGE DeriveAnyClass, DeriveGeneric #-\}
154−--
155−-- data MyType f = MyType { fieldA :: Column f T }
156−-- deriving ( GHC.Generics.Generic, Rel8able )
157−-- @
158−type Rel8able :: K.Rel8able -> Constraint
159−class HTable (GColumns t) => Rel8able t where
160− type GColumns t :: K.HTable
161− type GFromExprs t :: Type
162−
163− gfromColumns :: SContext context -> GColumns t context -> t context
164− gtoColumns :: SContext context -> t context -> GColumns t context
165−
166− gfromResult :: GColumns t Result -> GFromExprs t
167− gtoResult :: GFromExprs t -> GColumns t Result
168−
169− type GColumns t = G.GColumns TColumns (GRep t Expr)
170− type GFromExprs t = t Result
171−
172− default gfromColumns :: forall context.
173− ( SRel8able t Aggregate
174− , SRel8able t Expr
175− , forall table. SRel8able t (Field table)
176− , SRel8able t Name
177− , SSerialize t
178− )
179− => SContext context -> GColumns t context -> t context
180− gfromColumns = \case
181− SAggregate -> sfromColumns
182− SExpr -> sfromColumns
183− SField -> sfromColumns
184− SName -> sfromColumns
185− SResult -> sfromResult
186−
187− default gtoColumns :: forall context.
188− ( SRel8able t Aggregate
189− , SRel8able t Expr
190− , forall table. SRel8able t (Field table)
191− , SRel8able t Name
192− , SSerialize t
193− )
194− => SContext context -> t context -> GColumns t context
195− gtoColumns = \case
196− SAggregate -> stoColumns
197− SExpr -> stoColumns
198− SField -> stoColumns
199− SName -> stoColumns
200− SResult -> stoResult
201−
202− default gfromResult :: (SSerialize t, GFromExprs t ~ t Result)
203− => GColumns t Result -> GFromExprs t
204− gfromResult = sfromResult
205−
206− default gtoResult :: (SSerialize t, GFromExprs t ~ t Result)
207− => GFromExprs t -> GColumns t Result
208− gtoResult = stoResult
209−
210−
211−type Algebra :: K.Rel8able -> K.Algebra
212−type Algebra t = GAlgebra (GRep t Expr)
213−
214−
215−type GRep :: K.Rel8able -> K.Context -> Type -> Type
216−type GRep t context = Rep (Record (t context))
217−
218−
219−type SRel8able :: K.Rel8able -> K.Context -> Constraint
220−class
221− ( Generic (Record (t context))
222− , G.GTable (TTable context) TColumns (GRep t context)
223− , G.GColumns TColumns (GRep t context) ~ GColumns t
224− )
225− => SRel8able t context
226−instance
227− ( Generic (Record (t context))
228− , G.GTable (TTable context) TColumns (GRep t context)
229− , G.GColumns TColumns (GRep t context) ~ GColumns t
230− )
231− => SRel8able t context
232−
233−
234−type SSerialize :: K.Rel8able -> Constraint
235−type SSerialize t =
236− ( Generic (Record (t Result))
237− , G.GSerialize TSerialize TColumns (GRep t Expr) (GRep t Result)
238− , G.GColumns TColumns (GRep t Expr) ~ GColumns t
239− )
240−
241−
242−sfromColumns :: forall t context. SRel8able t context
243− => GColumns t context -> t context
244−sfromColumns =
245− unrecord .
246− to .
247− G.gfromColumns @(TTable context) @TColumns fromColumns
248−
249−
250−stoColumns :: forall t context. SRel8able t context
251− => t context -> GColumns t context
252−stoColumns =
253− G.gtoColumns @(TTable context) @TColumns toColumns .
254− from .
255− Record
256−
257−
258−sfromResult :: forall t. SSerialize t
259− => GColumns t Result -> t Result
260−sfromResult =
261− unrecord .
262− to .
263− G.gfromResult
264− @TSerialize
265− @TColumns
266− @(GRep t Expr)
267− @(GRep t Result)
268− (\(_ :: proxy x) -> deserialize @_ @x)
269−
270−
271−stoResult :: forall t. SSerialize t
272− => t Result -> GColumns t Result
273−stoResult =
274− G.gtoResult
275− @TSerialize
276− @TColumns
277− @(GRep t Expr)
278− @(GRep t Result)
279− (\(_ :: proxy x) -> serialize @_ @x) .
280− from .
281− Record
src/Rel8/Generic/Table.hsdeleted−103
@@ -1,103 +0,0 @@
1−{-# language AllowAmbiguousTypes #-}
2−{-# language DataKinds #-}
3−{-# language FlexibleContexts #-}
4−{-# language FlexibleInstances #-}
5−{-# language MultiParamTypeClasses #-}
6−{-# language RankNTypes #-}
7−{-# language ScopedTypeVariables #-}
8−{-# language StandaloneKindSignatures #-}
9−{-# language TypeApplications #-}
10−{-# language TypeFamilies #-}
11−{-# language TypeOperators #-}
12−{-# language UndecidableInstances #-}
13−
14−module Rel8.Generic.Table
15− ( GGSerialize, GGColumns, ggfromResult, ggtoResult
16− , GAlgebra
17− )
18−where
19−
20−-- base
21−import Data.Kind ( Constraint, Type )
22−import GHC.Generics ( (:+:), (:*:), K1, M1, U1, V1 )
23−import Prelude ()
24−
25−-- rel8
26−import Rel8.FCF ( Eval, Exp )
27−import Rel8.Generic.Table.ADT
28− ( GSerializeADT, GColumnsADT, gtoResultADT, gfromResultADT
29− )
30−import Rel8.Generic.Table.Record ( GSerialize, GColumns, gtoResult, gfromResult )
31−import Rel8.Kind.Algebra
32− ( Algebra( Product, Sum )
33− , SAlgebra( SProduct, SSum )
34− , KnownAlgebra, algebraSing
35− )
36−import qualified Rel8.Schema.Kind as K
37−import Rel8.Schema.Result ( Result )
38−
39−
40−data GGSerialize
41− :: Algebra
42− -> (Type -> Type -> Exp Constraint)
43− -> (Type -> Exp K.HTable)
44− -> (Type -> Type)
45− -> (Type -> Type)
46− -> Exp Constraint
47−
48−
49−type instance Eval (GGSerialize 'Product _Serialize _Columns exprs rep) =
50− GSerialize _Serialize _Columns exprs rep
51−
52−
53−type instance Eval (GGSerialize 'Sum _Serialize _Columns exprs rep) =
54− GSerializeADT _Serialize _Columns exprs rep
55−
56−
57−data GGColumns
58− :: Algebra
59− -> (Type -> Exp K.HTable)
60− -> (Type -> Type)
61− -> Exp K.HTable
62−
63−
64−type instance Eval (GGColumns 'Product _Columns rep) = GColumns _Columns rep
65−
66−
67−type instance Eval (GGColumns 'Sum _Columns rep) = GColumnsADT _Columns rep
68−
69−
70−type GAlgebra :: (Type -> Type) -> Algebra
71−type family GAlgebra rep where
72− GAlgebra (M1 _ _ rep) = GAlgebra rep
73− GAlgebra V1 = 'Sum
74− GAlgebra (_ :+: _) = 'Sum
75− GAlgebra U1 = 'Sum
76− GAlgebra (_ :*: _) = 'Product
77− GAlgebra (K1 _ _) = 'Product
78−
79−
80−ggfromResult :: forall algebra _Serialize _Columns exprs rep x.
81− ( KnownAlgebra algebra
82− , Eval (GGSerialize algebra _Serialize _Columns exprs rep)
83− )
84− => (forall expr a proxy. Eval (_Serialize expr a)
85− => proxy expr -> Eval (_Columns expr) Result -> a)
86− -> Eval (GGColumns algebra _Columns exprs) Result
87− -> rep x
88−ggfromResult f x = case algebraSing @algebra of
89− SProduct -> gfromResult @_Serialize @_Columns @exprs @rep f x
90− SSum -> gfromResultADT @_Serialize @_Columns @exprs @rep f x
91−
92−
93−ggtoResult :: forall algebra _Serialize _Columns exprs rep x.
94− ( KnownAlgebra algebra
95− , Eval (GGSerialize algebra _Serialize _Columns exprs rep)
96− )
97− => (forall expr a proxy. Eval (_Serialize expr a)
98− => proxy expr -> a -> Eval (_Columns expr) Result)
99− -> rep x
100− -> Eval (GGColumns algebra _Columns exprs) Result
101−ggtoResult f x = case algebraSing @algebra of
102− SProduct -> gtoResult @_Serialize @_Columns @exprs @rep f x
103− SSum -> gtoResultADT @_Serialize @_Columns @exprs @rep f x
src/Rel8/Generic/Table/ADT.hsdeleted−221
@@ -1,221 +0,0 @@
1−{-# language AllowAmbiguousTypes #-}
2−{-# language DataKinds #-}
3−{-# language FlexibleContexts #-}
4−{-# language FlexibleInstances #-}
5−{-# language LambdaCase #-}
6−{-# language MultiParamTypeClasses #-}
7−{-# language RankNTypes #-}
8−{-# language ScopedTypeVariables #-}
9−{-# language StandaloneKindSignatures #-}
10−{-# language TypeApplications #-}
11−{-# language TypeFamilies #-}
12−{-# language TypeOperators #-}
13−{-# language UndecidableInstances #-}
14−
15−module Rel8.Generic.Table.ADT
16− ( GSerializeADT, GColumnsADT, gfromResultADT, gtoResultADT
17− , GSerializeADT', GColumnsADT'
18− )
19−where
20−
21−-- base
22−import Data.Functor.Identity ( Identity( Identity ) )
23−import Data.Kind ( Constraint, Type )
24−import Data.Proxy ( Proxy( Proxy ) )
25−import GHC.Generics
26− ( (:+:)( L1, R1 ), M1( M1 ), U1( U1 )
27− , C, D
28− , Meta( MetaCons )
29− )
30−import GHC.TypeLits ( KnownSymbol, symbolVal )
31−import Prelude hiding ( null )
32−
33−-- rel8
34−import Rel8.FCF ( Eval, Exp )
35−import Rel8.Generic.Table.Record ( GSerialize, GColumns, gfromResult, gtoResult )
36−import Rel8.Schema.HTable ( HTable )
37−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
38−import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
39−import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify )
40−import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
41−import qualified Rel8.Schema.Kind as K
42−import Rel8.Schema.Result ( Result, null, nullifier, unnullifier )
43−import Rel8.Type.Tag ( Tag( Tag ) )
44−
45−-- text
46−import Data.Text ( pack )
47−
48−
49−type GColumnsADT
50− :: (Type -> Exp K.HTable)
51− -> (Type -> Type) -> K.HTable
52−type family GColumnsADT _Columns rep where
53− GColumnsADT _Columns (M1 D _ rep) =
54− GColumnsADT' _Columns (HLabel "tag" (HIdentity Tag)) rep
55−
56−
57−type GColumnsADT'
58− :: (Type -> Exp K.HTable)
59− -> K.HTable -> (Type -> Type) -> K.HTable
60−type family GColumnsADT' _Columns htable rep where
61− GColumnsADT' _Columns htable (a :+: b) =
62− GColumnsADT' _Columns (GColumnsADT' _Columns htable a) b
63− GColumnsADT' _Columns htable (M1 C ('MetaCons _ _ _) U1) = htable
64− GColumnsADT' _Columns htable (M1 C ('MetaCons label _ _) rep) =
65− HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))
66−
67−
68−type GSerializeADT
69− :: (Type -> Type -> Exp Constraint)
70− -> (Type -> Exp K.HTable)
71− -> (Type -> Type) -> (Type -> Type) -> Constraint
72−class GSerializeADT _Serialize _Columns exprs rep where
73− gfromResultADT :: ()
74− => (forall expr a proxy. Eval (_Serialize expr a)
75− => proxy expr -> Eval (_Columns expr) Result -> a)
76− -> GColumnsADT _Columns exprs Result
77− -> rep x
78−
79− gtoResultADT :: ()
80− => (forall expr a proxy. Eval (_Serialize expr a)
81− => proxy expr -> a -> Eval (_Columns expr) Result)
82− -> rep x
83− -> GColumnsADT _Columns exprs Result
84−
85−
86−instance
87− ( htable ~ HLabel "tag" (HIdentity Tag)
88− , GSerializeADT' _Serialize _Columns htable exprs rep
89− )
90− => GSerializeADT _Serialize _Columns (M1 D meta exprs) (M1 D meta rep)
91− where
92− gfromResultADT fromResult columns =
93− case gfromResultADT' @_Serialize @_Columns @htable @exprs @rep fromResult tag columns of
94− Just rep -> M1 rep
95− _ -> error "ADT.fromColumns: mismatch between tag and data"
96− where
97− tag = (\(HIdentity (Identity a)) -> a) . hunlabel @"tag"
98−
99− gtoResultADT toResult (M1 rep) =
100− gtoResultADT' @_Serialize @_Columns @htable @exprs @rep toResult tag (Just rep)
101− where
102− tag = hlabel @"tag" . HIdentity . Identity
103−
104−
105−type GSerializeADT'
106− :: (Type -> Type -> Exp Constraint)
107− -> (Type -> Exp K.HTable)
108− -> K.HTable -> (Type -> Type) -> (Type -> Type) -> Constraint
109−class GSerializeADT' _Serialize _Columns htable exprs rep where
110− gfromResultADT' :: context ~ Result
111− => (forall expr a proxy. Eval (_Serialize expr a)
112− => proxy expr -> Eval (_Columns expr) context -> a)
113− -> (htable Result -> Tag)
114− -> GColumnsADT' _Columns htable exprs context
115− -> Maybe (rep x)
116−
117− gtoResultADT' :: context ~ Result
118− => (forall expr a proxy. Eval (_Serialize expr a)
119− => proxy expr -> a -> Eval (_Columns expr) context)
120− -> (Tag -> htable Result)
121− -> Maybe (rep x)
122− -> GColumnsADT' _Columns htable exprs context
123−
124− extract :: GColumnsADT' _Columns htable exprs context -> htable context
125−
126−
127−instance
128− ( htable' ~ GColumnsADT' _Columns htable exprs1
129− , GSerializeADT' _Serialize _Columns htable exprs1 a
130− , GSerializeADT' _Serialize _Columns htable' exprs2 b
131− )
132− => GSerializeADT' _Serialize _Columns htable (exprs1 :+: exprs2) (a :+: b)
133− where
134− gfromResultADT' fromResult f columns =
135− case ma of
136− Just a -> Just (L1 a)
137− Nothing -> R1 <$>
138− gfromResultADT' @_Serialize @_Columns @_ @exprs2 @b
139− fromResult
140− (f . extract @_Serialize @_Columns @_ @exprs1 @a)
141− columns
142− where
143− ma =
144− gfromResultADT' @_Serialize @_Columns @_ @exprs1 @a
145− fromResult
146− f
147− (extract @_Serialize @_Columns @_ @exprs2 @b columns)
148−
149− gtoResultADT' toResult tag = \case
150− Just (L1 a) ->
151− gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b
152− toResult
153− (\_ -> gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a
154− toResult
155− tag
156− (Just a))
157− Nothing
158− Just (R1 b) ->
159− gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b
160− toResult
161− (\tag' ->
162− gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a
163− toResult
164− (\_ -> tag tag')
165− Nothing)
166− (Just b)
167− Nothing ->
168− gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b
169− toResult
170− (\_ -> gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a toResult tag Nothing)
171− Nothing
172−
173− extract =
174− extract @_Serialize @_Columns @_ @exprs1 @a .
175− extract @_Serialize @_Columns @_ @exprs2 @b
176−
177−
178−instance (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) =>
179− GSerializeADT' _Serialize _Columns _htable (M1 C meta U1) (M1 C meta U1)
180− where
181− gfromResultADT' _ tag columns
182− | tag columns == tag' = Just (M1 U1)
183− | otherwise = Nothing
184− where
185− tag' = Tag $ pack $ symbolVal (Proxy @label)
186−
187− gtoResultADT' _ tag _ = tag tag'
188− where
189− tag' = Tag $ pack $ symbolVal (Proxy @label)
190−
191− extract = id
192−
193−
194−instance {-# OVERLAPPABLE #-}
195− ( HTable (GColumns _Columns exprs)
196− , GSerialize _Serialize _Columns exprs rep
197− , meta ~ 'MetaCons label _fixity _isRecord
198− , KnownSymbol label
199− , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) exprs) ~
200− HProduct htable (HLabel label (HNullify (GColumns _Columns exprs)))
201− )
202− => GSerializeADT' _Serialize _Columns htable (M1 C meta exprs) (M1 C meta rep)
203− where
204− gfromResultADT' fromResult tag (HProduct a b)
205− | tag a == tag' =
206− M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult <$>
207− hunnullify unnullifier (hunlabel b)
208− | otherwise = Nothing
209− where
210− tag' = Tag $ pack $ symbolVal (Proxy @label)
211−
212− gtoResultADT' toResult tag = \case
213− Nothing -> HProduct (tag tag') (hlabel (hnulls (const null)))
214− Just (M1 rep) -> HProduct (tag tag') $
215− hlabel $
216− hnullify nullifier $
217− gtoResult @_Serialize @_Columns @exprs @rep toResult rep
218− where
219− tag' = Tag $ pack $ symbolVal (Proxy @label)
220−
221− extract (HProduct a _) = a
src/Rel8/Generic/Table/Record.hsdeleted−181
@@ -1,181 +0,0 @@
1−{-# language AllowAmbiguousTypes #-}
2−{-# language DataKinds #-}
3−{-# language FlexibleContexts #-}
4−{-# language FlexibleInstances #-}
5−{-# language MultiParamTypeClasses #-}
6−{-# language PolyKinds #-}
7−{-# language RankNTypes #-}
8−{-# language ScopedTypeVariables #-}
9−{-# language StandaloneKindSignatures #-}
10−{-# language TypeApplications #-}
11−{-# language TypeFamilies #-}
12−{-# language TypeOperators #-}
13−{-# language UndecidableInstances #-}
14−
15−module Rel8.Generic.Table.Record
16− ( GTable, GColumns, GContext, gfromColumns, gtoColumns, gtable
17− , GSerialize, gfromResult, gtoResult
18− )
19−where
20−
21−-- base
22−import Data.Kind ( Constraint, Type )
23−import Data.Proxy ( Proxy( Proxy ) )
24−import GHC.Generics
25− ( (:*:)( (:*:) ), K1( K1 ), M1( M1 )
26− , C, D, S
27− , Meta( MetaSel )
28− )
29−import Prelude hiding ( null )
30−
31−-- rel8
32−import Rel8.FCF ( Eval, Exp )
33−import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
34−import Rel8.Schema.HTable.Product ( HProduct(..) )
35−import qualified Rel8.Schema.Kind as K
36−
37−
38−type GColumns :: (Type -> Exp K.HTable) -> (Type -> Type) -> K.HTable
39−type family GColumns _Columns rep where
40− GColumns _Columns (M1 D _ rep) = GColumns _Columns rep
41− GColumns _Columns (M1 C _ rep) = GColumns _Columns rep
42− GColumns _Columns (rep1 :*: rep2) =
43− HProduct (GColumns _Columns rep1) (GColumns _Columns rep2)
44− GColumns _Columns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ a)) =
45− HLabel label (Eval (_Columns a))
46−
47−
48−type GContext :: (Type -> Exp K.Context) -> (Type -> Type) -> K.Context
49−type family GContext _Context rep where
50− GContext _Context (M1 _ _ rep) = GContext _Context rep
51− GContext _Context (rep1 :*: _rep2) = GContext _Context rep1
52− GContext _Context (K1 _ a) = Eval (_Context a)
53−
54−
55−type GTable
56− :: (Type -> Exp Constraint)
57− -> (Type -> Exp K.HTable)
58− -> (Type -> Type) -> Constraint
59−class GTable _Table _Columns rep
60− where
61− gfromColumns :: ()
62− => (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)
63− -> GColumns _Columns rep context
64− -> rep x
65−
66− gtoColumns :: ()
67− => (forall a. Eval (_Table a) => a -> Eval (_Columns a) context)
68− -> rep x
69− -> GColumns _Columns rep context
70−
71− gtable :: ()
72− => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)
73− -> GColumns _Columns rep context
74−
75−
76−type GSerialize
77− :: (Type -> Type -> Exp Constraint)
78− -> (Type -> Exp K.HTable)
79− -> (Type -> Type) -> (Type -> Type) -> Constraint
80−class GSerialize _Serialize _Columns exprs rep
81− where
82− gfromResult :: ()
83− => (forall expr a proxy. Eval (_Serialize expr a)
84− => proxy expr -> Eval (_Columns expr) context -> a)
85− -> GColumns _Columns exprs context
86− -> rep x
87−
88− gtoResult :: ()
89− => (forall expr a proxy. Eval (_Serialize expr a)
90− => proxy expr -> a -> Eval (_Columns expr) context)
91− -> rep x
92− -> GColumns _Columns exprs context
93−
94−
95−instance GTable _Table _Columns rep => GTable _Table _Columns (M1 D c rep)
96− where
97− gfromColumns fromColumns =
98− M1 . gfromColumns @_Table @_Columns @rep fromColumns
99− gtoColumns toColumns (M1 a) =
100− gtoColumns @_Table @_Columns @rep toColumns a
101− gtable = gtable @_Table @_Columns @rep
102−
103−
104−instance GSerialize _Serialize _Columns exprs rep =>
105− GSerialize _Serialize _Columns (M1 D c exprs) (M1 D c rep)
106− where
107− gfromResult fromResult =
108− M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult
109− gtoResult toResult (M1 a) =
110− gtoResult @_Serialize @_Columns @exprs @rep toResult a
111−
112−
113−instance GTable _Table _Columns rep => GTable _Table _Columns (M1 C c rep)
114− where
115− gfromColumns fromColumns =
116− M1 . gfromColumns @_Table @_Columns @rep fromColumns
117− gtoColumns toColumns (M1 a) =
118− gtoColumns @_Table @_Columns @rep toColumns a
119− gtable = gtable @_Table @_Columns @rep
120−
121−
122−instance GSerialize _Serialize _Columns exprs rep =>
123− GSerialize _Serialize _Columns (M1 C c exprs) (M1 C c rep)
124− where
125− gfromResult fromResult =
126− M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult
127− gtoResult toResult (M1 a) =
128− gtoResult @_Serialize @_Columns @exprs @rep toResult a
129−
130−
131−instance (GTable _Table _Columns rep1, GTable _Table _Columns rep2) =>
132− GTable _Table _Columns (rep1 :*: rep2)
133− where
134− gfromColumns fromColumns (HProduct a b) =
135− gfromColumns @_Table @_Columns @rep1 fromColumns a :*:
136− gfromColumns @_Table @_Columns @rep2 fromColumns b
137− gtoColumns toColumns (a :*: b) = HProduct
138− (gtoColumns @_Table @_Columns @rep1 toColumns a)
139− (gtoColumns @_Table @_Columns @rep2 toColumns b)
140− gtable table = HProduct
141− (gtable @_Table @_Columns @rep1 table)
142− (gtable @_Table @_Columns @rep2 table)
143−
144−
145−instance
146− ( GSerialize _Serialize _Columns expr1 rep1
147− , GSerialize _Serialize _Columns expr2 rep2
148− )
149− => GSerialize _Serialize _Columns (expr1 :*: expr2) (rep1 :*: rep2)
150− where
151− gfromResult fromResult (HProduct a b) =
152− gfromResult @_Serialize @_Columns @expr1 @rep1 fromResult a :*:
153− gfromResult @_Serialize @_Columns @expr2 @rep2 fromResult b
154− gtoResult toResult (a :*: b) =
155− HProduct
156− (gtoResult @_Serialize @_Columns @expr1 @rep1 toResult a)
157− (gtoResult @_Serialize @_Columns @expr2 @rep2 toResult b)
158−
159−
160−instance
161− ( Eval (_Table a)
162− , meta ~ 'MetaSel ('Just label) _su _ss _ds
163− , k1 ~ K1 i a
164− )
165− => GTable _Table _Columns (M1 S meta k1)
166− where
167− gfromColumns fromColumns = M1 . K1 . fromColumns . hunlabel
168− gtoColumns toColumns (M1 (K1 a)) = hlabel (toColumns a)
169− gtable table = hlabel (table (Proxy @a))
170−
171−
172−instance
173− ( Eval (_Serialize expr a)
174− , meta ~ 'MetaSel ('Just label) _su _ss _ds
175− , k1 ~ K1 i expr
176− , k1' ~ K1 i a
177− )
178− => GSerialize _Serialize _Columns (M1 S meta k1) (M1 S meta k1')
179− where
180− gfromResult fromResult = M1 . K1 . fromResult (Proxy @expr) . hunlabel
181− gtoResult toResult (M1 (K1 a)) = hlabel (toResult (Proxy @expr) a)
src/Rel8/Kind/Algebra.hsdeleted−38
@@ -1,38 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
3−{-# language GADTs #-}
4−{-# language StandaloneKindSignatures #-}
5−
6−module Rel8.Kind.Algebra
7− ( Algebra( Product, Sum )
8− , SAlgebra( SProduct, SSum )
9− , KnownAlgebra( algebraSing )
10− )
11−where
12−
13−-- base
14−import Data.Kind ( Constraint, Type )
15−import Prelude ()
16−
17−
18−type Algebra :: Type
19−data Algebra = Product | Sum
20−
21−
22−type SAlgebra :: Algebra -> Type
23−data SAlgebra algebra where
24− SProduct :: SAlgebra 'Product
25− SSum :: SAlgebra 'Sum
26−
27−
28−type KnownAlgebra :: Algebra -> Constraint
29−class KnownAlgebra algebra where
30− algebraSing :: SAlgebra algebra
31−
32−
33−instance KnownAlgebra 'Product where
34− algebraSing = SProduct
35−
36−
37−instance KnownAlgebra 'Sum where
38− algebraSing = SSum
src/Rel8/Kind/Context.hsdeleted−56
@@ -1,56 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language GADTs #-}
3−{-# language StandaloneKindSignatures #-}
4−{-# language TypeSynonymInstances #-}
5−
6−module Rel8.Kind.Context
7− ( Reifiable( contextSing )
8− , SContext(..)
9− )
10−where
11−
12−-- base
13−import Data.Kind ( Constraint, Type )
14−import Prelude ()
15−
16−-- rel8
17−import Rel8.Aggregate ( Aggregate )
18−import Rel8.Expr ( Expr )
19−import Rel8.Schema.Field ( Field )
20−import Rel8.Schema.Kind ( Context )
21−import Rel8.Schema.Name ( Name )
22−import Rel8.Schema.Result ( Result )
23−
24−
25−type SContext :: Context -> Type
26−data SContext context where
27− SAggregate :: SContext Aggregate
28− SExpr :: SContext Expr
29− SField :: SContext (Field table)
30− SName :: SContext Name
31− SResult :: SContext Result
32−
33−
34−type Reifiable :: Context -> Constraint
35−class Reifiable context where
36− contextSing :: SContext context
37−
38−
39−instance Reifiable Aggregate where
40− contextSing = SAggregate
41−
42−
43−instance Reifiable Expr where
44− contextSing = SExpr
45−
46−
47−instance Reifiable (Field table) where
48− contextSing = SField
49−
50−
51−instance Reifiable Result where
52− contextSing = SResult
53−
54−
55−instance Reifiable Name where
56− contextSing = SName
src/Rel8/Kind/Labels.hsnew file+61
@@ -0,0 +1,61 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language FlexibleInstances #-}
4+{-# language GADTs #-}
5+{-# language LambdaCase #-}
6+{-# language StandaloneKindSignatures #-}
7+{-# language TypeOperators #-}
8+
9+module Rel8.Kind.Labels
10+ ( Labels
11+ , SLabels( SLabel, SLabels )
12+ , KnownLabels( labelsSing )
13+ , renderLabels
14+ )
15+where
16+
17+-- base
18+import Data.Kind ( Constraint, Type )
19+import Data.List.NonEmpty ( NonEmpty( (:|) ), (<|) )
20+import Data.Proxy ( Proxy( Proxy ) )
21+import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
22+import Prelude
23+
24+
25+type Labels :: Type
26+type Labels = [Symbol]
27+
28+
29+type SLabels :: Labels -> Type
30+data SLabels labels where
31+ SLabel :: KnownSymbol label => Proxy label -> SLabels '[label]
32+ SLabels :: KnownSymbol label => Proxy label -> SLabels labels -> SLabels (label ': labels)
33+
34+
35+type KnownLabels :: Labels -> Constraint
36+class KnownLabels labels where
37+ labelsSing :: SLabels labels
38+
39+
40+instance KnownSymbol label => KnownLabels (label ': '[]) where
41+ labelsSing = SLabel Proxy
42+
43+
44+instance (KnownSymbol label, KnownLabels (label_ ': labels)) =>
45+ KnownLabels (label ': (label_ ': labels))
46+ where
47+ labelsSing = SLabels Proxy labelsSing
48+
49+
50+renderLabels :: SLabels labels -> NonEmpty String
51+renderLabels = cleanup . go
52+ where
53+ go :: SLabels labels -> NonEmpty String
54+ go = \case
55+ SLabel label -> pure (symbolVal label)
56+ SLabels label labels -> symbolVal label <| go labels
57+
58+ cleanup ("" :| []) = "anon" :| []
59+ cleanup (a :| []) = a :| []
60+ cleanup (a :| [""]) = a :| []
61+ cleanup (a :| (b : c)) = a <| cleanup (b :| c)
src/Rel8/Kind/Necessity.hsnew file+38
@@ -0,0 +1,38 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language GADTs #-}
4+{-# language StandaloneKindSignatures #-}
5+
6+module Rel8.Kind.Necessity
7+ ( Necessity( Optional, Required )
8+ , SNecessity( SOptional, SRequired )
9+ , KnownNecessity( necessitySing )
10+ )
11+where
12+
13+-- base
14+import Data.Kind ( Constraint, Type )
15+import Prelude ()
16+
17+
18+type Necessity :: Type
19+data Necessity = Optional | Required
20+
21+
22+type SNecessity :: Necessity -> Type
23+data SNecessity necessity where
24+ SOptional :: SNecessity 'Optional
25+ SRequired :: SNecessity 'Required
26+
27+
28+type KnownNecessity :: Necessity -> Constraint
29+class KnownNecessity necessity where
30+ necessitySing :: SNecessity necessity
31+
32+
33+instance KnownNecessity 'Optional where
34+ necessitySing = SOptional
35+
36+
37+instance KnownNecessity 'Required where
38+ necessitySing = SRequired
src/Rel8/Opaque.hsnew file+20
@@ -0,0 +1,20 @@
1+{-# language PolyKinds #-}
2+{-# language StandaloneKindSignatures #-}
3+
4+module Rel8.Opaque
5+ ( Opaque
6+ , Opaque1
7+ )
8+where
9+
10+-- base
11+import Data.Kind ( Type )
12+import Prelude ()
13+
14+
15+type Opaque :: Type
16+data Opaque
17+
18+
19+type Opaque1 :: k -> Type -> Type
20+data Opaque1 a x
src/Rel8/Order.hs+14−5
@@ -16,15 +16,24 @@ import Prelude
1616import Data.Functor.Contravariant.Divisible ( Decidable, Divisible )
1717
1818-- opaleye
19−import qualified Opaleye.Order as Opaleye
19+import qualified Opaleye.Internal.Order as Opaleye
2020
2121
22−-- | An ordering expression for @a@. Primitive orderings are defined with
23−-- 'Rel8.asc' and 'Rel8.desc', and you can combine @Order@ via its various
24−-- instances.
22+-- | An ordering expression for @a@. Primitive orderings are defined with 'asc'
23+-- and 'desc', and you can combine @Order@ via its various instances.
2524--
2625-- A common pattern is to use '<>' to combine multiple orderings in sequence,
27−-- and 'Data.Functor.Contravariant.>$<' to select individual columns.
26+-- and '>$<' (from 'Contravariant') to select individual columns. For example,
27+-- to sort a @Query@ on two columns, we could do:
28+--
29+-- >>> import Data.Functor.Contravariant ((>$<))
30+-- >>> :{
31+-- select c $ orderBy (mconcat [fst >$< asc, snd >$< desc]) $ do
32+-- x <- values [ lit x | x <- [1..3 :: Int32 ] ]
33+-- y <- values [ lit x | x <- [1..3 :: Int32 ] ]
34+-- return (x, y)
35+-- :}
36+-- [(1,3),(1,2),(1,1),(2,3),(2,2),(2,1),(3,3),(3,2),(3,1)]
2837type Order :: Type -> Type
2938newtype Order a = Order (Opaleye.Order a)
3039 deriving newtype (Contravariant, Divisible, Decidable, Semigroup, Monoid)
src/Rel8/Query.hs+5−188
@@ -1,6 +1,6 @@
1−{-# language FlexibleContexts #-}
1+{-# language DerivingStrategies #-}
2+{-# language GeneralizedNewtypeDeriving #-}
23{-# language StandaloneKindSignatures #-}
3−{-# language UndecidableInstances #-}
44
55module Rel8.Query
66 ( Query( Query )
@@ -8,199 +8,26 @@ module Rel8.Query
88where
99
1010-- base
11−import Control.Applicative ( liftA2 )
12−import Control.Monad ( liftM2 )
1311import Data.Kind ( Type )
14−import Data.Monoid ( Any( Any ) )
1512import Prelude
1613
1714-- opaleye
18−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
19−import qualified Opaleye.Internal.PackMap as Opaleye
20−import qualified Opaleye.Internal.PrimQuery as Opaleye hiding (lateral)
21−import qualified Opaleye.Internal.QueryArr as Opaleye
22−import qualified Opaleye.Internal.Tag as Opaleye
15+import qualified Opaleye.Select as Opaleye
2316
2417-- rel8
25−import Rel8.Expr ( Expr )
2618import Rel8.Query.Set ( unionAll )
27−import Rel8.Query.Opaleye ( fromOpaleye )
2819import Rel8.Query.Values ( values )
29−import Rel8.Table ( Table, fromColumns, toColumns )
3020import Rel8.Table.Alternative
3121 ( AltTable, (<|>:)
3222 , AlternativeTable, emptyTable
3323 )
34−import Rel8.Table.Projection ( Projectable, apply, project )
35−
36−-- semigroupoids
37−import Data.Functor.Apply ( Apply, (<.>) )
38−import Data.Functor.Bind ( Bind, (>>-) )
3924
4025
4126-- | The @Query@ monad allows you to compose a @SELECT@ query. This monad has
4227-- semantics similar to the list (@[]@) monad.
4328type Query :: Type -> Type
44−newtype Query a =
45− Query (
46− -- This is based on Opaleye's Select monad, but with two addtions. We
47− -- maintain a stack of PrimExprs from parent previous subselects. In
48− -- practice, these are always the results of dummy calls to random().
49− --
50− -- We also return a Bool that indicates to the parent subselect whether
51− -- or not that stack of PrimExprs were used at any point. If they weren't,
52− -- then the call to random() is never added to the query.
53− --
54− -- This is all needed to implement evaluate. Consider the following code:
55− --
56− -- do
57− -- x <- values [lit 'a', lit 'b', lit 'c']
58− -- y <- evaluate $ nextval "user_id_seq"
59− -- pure (x, y)
60− --
61− -- If we just used Opaleye's Select monad directly, the SQL would come out
62− -- like this:
63− --
64− -- SELECT
65− -- a, b
66− -- FROM
67− -- (VALUES ('a'), ('b'), ('c')) Q1(a),
68− -- LATERAL (SELECT nextval('user_id_seq')) Q2(b);
69− --
70− -- From the Haskell code, you would intuitively expect to get back the
71− -- results of three different calls to nextval(), but from Postgres' point
72− -- of view, because the Q2 subquery doesn't reference anything from the Q1
73− -- query, it thinks it only needs to call nextval() once. This is actually
74− -- exactly the same problem you get with the deprecated ListT IO monad from
75− -- the transformers package — *> behaves differently to >>=, so
76− -- using ApplicativeDo can change the results of a program. ApplicativeDo
77− -- is exactly the optimisation Postgres does on a "LATERAL" query that
78− -- doesn't make any references to previous subselects.
79− --
80− -- Rel8's solution is generate the following SQL instead:
81− --
82− -- SELECT
83− -- a, b
84− -- FROM
85− -- (SELECT
86− -- random() AS dummy,
87− -- *
88− -- FROM
89− -- (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1,
90− -- LATERAL (SELECT
91− -- CASE
92− -- WHEN dummy IS NOT NULL
93− -- THEN nextval('user_id_seq')
94− -- END) Q2(b);
95− --
96− -- We use random() here as the dummy value (and not some constant) because
97− -- Postgres will again optimize if it sees that a value is constant
98− -- (and thus only call nextval() once), but because random() is marked as
99− -- VOLATILE, this inhibits Postgres from doing that optimisation.
100− --
101− -- Why not just reference the a column from the previous query directly
102− -- instead of adding a dummy value? Basically, even if we extract out all
103− -- the bindings introduced in a PrimQuery, we can't always be sure which
104− -- ones refer to constant values, so if we end up laterally referencing a
105− -- constant value, then all of this would be for nothing.
106− --
107− -- Why not just add the call to the previous subselect directly, like so:
108− --
109− -- SELECT
110− -- a, b
111− -- FROM
112− -- (SELECT
113− -- nextval('user_id_seq') AS eval,
114− -- *
115− -- FROM
116− -- (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1,
117− -- LATERAL (SELECT eval) Q2(b);
118− --
119− -- That would work in this case. But consider the following Rel8 code:
120− --
121− -- do
122− -- x <- values [lit 'a', lit 'b', lit 'c']
123− -- y <- values [lit 'd', lit 'e', lit 'f']
124− -- z <- evaluate $ nextval "user_id_seq"
125− -- pure (x, y, z)
126− --
127− -- How many calls to nextval should there be? Our Haskell intuition says
128− -- nine. But that's not what you would get if you used the above
129− -- technique. The problem is, which VALUES query should the nextval be
130− -- added to? You can choose one or the other to get three calls to
131− -- nextval, but you still need to make a superfluous LATERAL references to
132− -- the other if you want nine calls. So for the above Rel8 code we generate
133− -- the following SQL:
134− --
135− -- SELECT
136− -- a, b, c
137− -- FROM
138− -- (SELECT
139− -- random() AS dummy,
140− -- *
141− -- FROM
142− -- (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1,
143− -- (SELECT
144− -- random() AS dummy,
145− -- *
146− -- FROM
147− -- (VALUES ('d'), ('e'), ('f')) Q2(b)) Q2,
148− -- LATERAL (SELECT
149− -- CASE
150− -- WHEN Q1.dummy IS NOT NULL AND Q2.dummy IS NOT NULL
151− -- THEN nextval('user_id_seq')
152− -- END) Q3(c);
153− --
154− -- This gives nine calls to nextval() as we would expect.
155− [Opaleye.PrimExpr] -> Opaleye.Select (Any, a)
156− )
157−
158−
159−instance Projectable Query where
160− project f = fmap (fromColumns . apply f . toColumns)
161−
162−
163−instance Functor Query where
164− fmap f (Query a) = Query (fmap (fmap (fmap f)) a)
165−
166−
167−instance Apply Query where
168− (<.>) = (<*>)
169−
170−
171−instance Applicative Query where
172− pure = fromOpaleye . pure
173− liftA2 = liftM2
174−
175−
176−instance Bind Query where
177− (>>-) = (>>=)
178−
179−
180−instance Monad Query where
181− Query q >>= f = Query $ \dummies -> Opaleye.stateQueryArr $ \_ tag ->
182− let
183− qa = q dummies
184− ((m, a), query, tag') = Opaleye.runStateQueryArr qa () tag
185− Query q' = f a
186− (dummies', query', tag'') =
187− ( dummy : dummies
188− , query <> Opaleye.aRebind bindings
189− , Opaleye.next tag'
190− )
191− where
192− (dummy, bindings) = Opaleye.run $ name random
193− where
194− random = Opaleye.FunExpr "random" []
195− name = Opaleye.extractAttr "dummy" tag'
196− qa' = Opaleye.lateral $ \_ -> q' dummies'
197− ((m'@(Any needsDummies), b), query'', tag''') = Opaleye.runStateQueryArr qa' () tag''
198− query'''
199− | needsDummies = query' <> query''
200− | otherwise = query <> query''
201− m'' = m <> m'
202− in
203− ((m'', b), query''', tag''')
29+newtype Query a = Query (Opaleye.Select a)
30+ deriving newtype (Functor, Applicative, Monad)
20431
20532
20633-- | '<|>:' = 'unionAll'.
@@ -211,13 +38,3 @@ instance AltTable Query where
21138-- | 'emptyTable' = 'values' @[]@.
21239instance AlternativeTable Query where
21340 emptyTable = values []
214−
215−
216−-- | '<>' = 'unionAll'.
217−instance Table Expr a => Semigroup (Query a) where
218− (<>) = (<|>:)
219−
220−
221−-- | 'mempty' = @'values' []@.
222−instance Table Expr a => Monoid (Query a) where
223− mempty = emptyTable
src/Rel8/Query.hs-boot+1−3
@@ -7,13 +7,11 @@ where
77
88-- base
99import Data.Kind ( Type )
10−import Data.Monoid ( Any )
1110import Prelude ()
1211
1312-- opaleye
14−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
1513import qualified Opaleye.Select as Opaleye
1614
1715
1816type Query :: Type -> Type
19−newtype Query a = Query ([Opaleye.PrimExpr] -> Opaleye.Select (Any, a))
17+newtype Query a = Query (Opaleye.Select a)
src/Rel8/Query/Aggregate.hs+3−36
@@ -1,56 +1,23 @@
11{-# language FlexibleContexts #-}
2−{-# language MonoLocalBinds #-}
3−{-# language ScopedTypeVariables #-}
4−{-# language TypeApplications #-}
52
63module Rel8.Query.Aggregate
74 ( aggregate
8− , countRows
9− , mode
105 )
116where
127
138-- base
14−import Data.Functor.Contravariant ( (>$<) )
15−import Data.Int ( Int64 )
16−import Prelude
9+import Prelude ()
1710
1811-- opaleye
1912import qualified Opaleye.Aggregate as Opaleye
2013
2114-- rel8
22−import Rel8.Aggregate ( Aggregates )
23−import Rel8.Expr ( Expr )
24−import Rel8.Expr.Aggregate ( countStar )
25−import Rel8.Expr.Order ( desc )
15+import Rel8.Aggregate ( Aggregate )
2616import Rel8.Query ( Query )
27−import Rel8.Query.Limit ( limit )
28−import Rel8.Query.Maybe ( optional )
2917import 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 )
3518import Rel8.Table.Opaleye ( aggregator )
36−import Rel8.Table.Maybe ( maybeTable )
3719
3820
3921-- | Apply an aggregation to all rows returned by a 'Query'.
40−aggregate :: Aggregates aggregates exprs => Query aggregates -> Query exprs
22+aggregate :: Query (Aggregate exprs) -> Query exprs
4123aggregate = mapOpaleye (Opaleye.aggregate aggregator)
42−
43−
44−-- | Count the number of rows returned by a query. Note that this is different
45−-- from @countStar@, as even if the given query yields no rows, @countRows@
46−-- will return @0@.
47−countRows :: Query a -> Query (Expr Int64)
48−countRows = 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+12−4
@@ -1,3 +1,5 @@
1+{-# options_ghc -fno-warn-redundant-constraints #-}
2+
13module Rel8.Query.Distinct
24 ( distinct
35 , distinctOn
@@ -6,11 +8,12 @@ module Rel8.Query.Distinct
68where
79
810-- base
9−import Prelude ()
11+import Prelude
1012
1113-- opaleye
1214import qualified Opaleye.Distinct as Opaleye
13−import qualified Opaleye.Order as Opaleye
15+import qualified Opaleye.Internal.Order as Opaleye
16+import qualified Opaleye.Internal.QueryArr as Opaleye
1417
1518-- rel8
1619import Rel8.Order ( Order( Order ) )
@@ -22,6 +25,9 @@ import Rel8.Table.Opaleye ( distinctspec, unpackspec )
2225
2326-- | Select all distinct rows from a query, removing duplicates. @distinct q@
2427-- is equivalent to the SQL statement @SELECT DISTINCT q@.
28+--
29+-- >>> select c $ distinct $ values [ lit True, lit True, lit False ]
30+-- [False,True]
2531distinct :: EqTable a => Query a -> Query a
2632distinct = mapOpaleye (Opaleye.distinctExplicit distinctspec)
2733
@@ -30,11 +36,13 @@ distinct = mapOpaleye (Opaleye.distinctExplicit distinctspec)
3036-- to a projection. If multiple rows have the same projection, it is
3137-- unspecified which row will be returned. If this matters, use 'distinctOnBy'.
3238distinctOn :: EqTable b => (a -> b) -> Query a -> Query a
33−distinctOn proj = mapOpaleye (Opaleye.distinctOnExplicit unpackspec proj)
39+distinctOn proj =
40+ mapOpaleye (\q -> Opaleye.productQueryArr (Opaleye.distinctOn unpackspec proj . Opaleye.runSimpleQueryArr q))
3441
3542
3643-- | Select all distinct rows from a query, where rows are equivalent according
3744-- to a projection. If there are multiple rows with the same projection, the
3845-- first row according to the specified 'Order' will be returned.
3946distinctOnBy :: EqTable b => (a -> b) -> Order a -> Query a -> Query a
40−distinctOnBy proj (Order order) = mapOpaleye (Opaleye.distinctOnByExplicit unpackspec proj order)
47+distinctOnBy proj (Order order) =
48+ mapOpaleye (\q -> Opaleye.productQueryArr (Opaleye.distinctOnBy unpackspec proj order . Opaleye.runSimpleQueryArr q))
src/Rel8/Query/Each.hs+9−5
@@ -1,5 +1,4 @@
11{-# language FlexibleContexts #-}
2−{-# language MonoLocalBinds #-}
32
43module Rel8.Query.Each
54 ( each
@@ -15,18 +14,23 @@ import qualified Opaleye.Table as Opaleye
1514-- rel8
1615import Rel8.Query ( Query )
1716import Rel8.Query.Opaleye ( fromOpaleye )
18−import Rel8.Schema.Name ( Selects )
1917import Rel8.Schema.Table ( TableSchema )
20−import Rel8.Table.Cols ( fromCols, toCols )
18+import Rel8.Table ( fromColumns, toColumns )
2119import Rel8.Table.Opaleye ( table, unpackspec )
20+import Rel8.Table.Recontextualize ( Selects )
2221
2322
2423-- | Select each row from a table definition. This is equivalent to @FROM
2524-- table@.
25+--
26+-- >>> mapM_ print =<< select c (each projectSchema)
27+-- Project {projectAuthorId = 1, projectName = "rel8"}
28+-- Project {projectAuthorId = 2, projectName = "aeson"}
29+-- Project {projectAuthorId = 2, projectName = "text"}
2630each :: Selects names exprs => TableSchema names -> Query exprs
2731each =
28− fmap fromCols .
32+ fmap fromColumns .
2933 fromOpaleye .
3034 Opaleye.selectTableExplicit unpackspec .
3135 table .
32− fmap toCols
36+ fmap toColumns
src/Rel8/Query/Either.hs+30−34
@@ -3,67 +3,63 @@
33module Rel8.Query.Either
44 ( keepLeftTable
55 , keepRightTable
6+ , bindEitherTable
67 , bitraverseEitherTable
78 )
89where
910
1011-- base
12+import Data.Functor ( (<&>) )
1113import Prelude
1214
13−-- comonad
14−import Control.Comonad ( extract )
15−
1615-- rel8
1716import Rel8.Expr ( Expr )
1817import Rel8.Expr.Eq ( (==.) )
1918import Rel8.Query ( Query )
2019import Rel8.Query.Filter ( where_ )
2120import Rel8.Query.Maybe ( optional )
21+import Rel8.Query.Set ( unionAll )
22+import Rel8.Table ( Table )
23+import Rel8.Table.Bool ( bool )
2224import Rel8.Table.Either
2325 ( EitherTable( EitherTable )
26+ , leftTable, rightTable
2427 , isLeftTable, isRightTable
2528 )
2629import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
2730
2831
29−-- | Filter 'EitherTable's, keeping only 'leftTable's.
30−keepLeftTable :: EitherTable Expr a b -> Query a
32+keepLeftTable :: EitherTable a b -> Query a
3133keepLeftTable e@(EitherTable _ a _) = do
3234 where_ $ isLeftTable e
33− pure (extract a)
35+ pure a
3436
3537
36−-- | Filter 'EitherTable's, keeping only 'rightTable's.
37−keepRightTable :: EitherTable Expr a b -> Query b
38+keepRightTable :: EitherTable a b -> Query b
3839keepRightTable e@(EitherTable _ _ b) = do
3940 where_ $ isRightTable e
40− pure (extract b)
41+ pure b
42+
43+
44+bindEitherTable :: (Table Expr a, Functor m)
45+ => (i -> m (EitherTable a b)) -> EitherTable a i -> m (EitherTable a b)
46+bindEitherTable query e@(EitherTable input a i) = do
47+ query i <&> \(EitherTable output a' b) ->
48+ EitherTable (input <> output) (bool a a' (isRightTable e)) b
4149
4250
43−-- | @bitraverseEitherTable f g x@ will pass all @leftTable@s through @f@ and
44−-- all @rightTable@s through @g@. The results are then lifted back into
45−-- @leftTable@ and @rightTable@, respectively. This is similar to 'bitraverse'
46−-- for 'Either'.
47−--
48−-- For example,
49−--
50−-- >>> :{
51−-- select do
52−-- x <- values (map lit [ Left True, Right (42 :: Int32) ])
53−-- bitraverseEitherTable (\y -> values [y, not_ y]) (\y -> pure (y * 100)) x
54−-- :}
55−-- [ Left True
56−-- , Left False
57−-- , Right 4200
58−-- ]
59−bitraverseEitherTable :: ()
51+bitraverseEitherTable :: (Table Expr c, Table Expr d)
6052 => (a -> Query c)
6153 -> (b -> Query d)
62− -> EitherTable Expr a b
63− -> Query (EitherTable Expr c d)
64−bitraverseEitherTable f g e@(EitherTable tag _ _) = do
65− mc@(MaybeTable _ c) <- optional (f =<< keepLeftTable e)
66− md@(MaybeTable _ d) <- optional (g =<< keepRightTable e)
67− where_ $ isJustTable mc ==. isLeftTable e
68− where_ $ isJustTable md ==. isRightTable e
69− pure $ EitherTable tag c d
54+ -> EitherTable a b
55+ -> Query (EitherTable c d)
56+bitraverseEitherTable f g e = traverseLeftTable `unionAll` traverseRightTable
57+ where
58+ traverseLeftTable = do
59+ mc@(MaybeTable _ c) <- optional (f =<< keepLeftTable e)
60+ where_ $ isJustTable mc ==. isLeftTable e
61+ pure $ leftTable c
62+ traverseRightTable = do
63+ md@(MaybeTable _ d) <- optional (g =<< keepRightTable e)
64+ where_ $ isJustTable md ==. isRightTable e
65+ pure $ rightTable d
src/Rel8/Query/Evaluate.hsdeleted−49
@@ -1,49 +0,0 @@
1−{-# language FlexibleContexts #-}
2−{-# language TupleSections #-}
3−
4−module Rel8.Query.Evaluate
5− ( evaluate
6− )
7−where
8−
9−-- base
10−import Control.Monad ( (>=>) )
11−import Data.Foldable ( foldl' )
12−import Data.List.NonEmpty ( NonEmpty( (:|) ), nonEmpty )
13−import Data.Monoid ( Any( Any ) )
14−import Prelude hiding ( undefined )
15−
16−-- opaleye
17−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
18−
19−-- rel8
20−import Rel8.Expr ( Expr )
21−import Rel8.Expr.Bool ( (&&.) )
22−import Rel8.Expr.Opaleye ( fromPrimExpr )
23−import Rel8.Query ( Query( Query ) )
24−import Rel8.Query.Rebind ( rebind )
25−import Rel8.Table ( Table )
26−import Rel8.Table.Bool ( case_ )
27−import Rel8.Table.Undefined ( undefined )
28−
29−
30−-- | 'evaluate' takes expressions that could potentially have side effects and
31−-- \"runs\" them in the 'Query' monad. The returned expressions have no side
32−-- effects and can safely be reused.
33−evaluate :: Table Expr a => a -> Query a
34−evaluate = laterally >=> rebind "eval"
35−
36−
37−laterally :: Table Expr a => a -> Query a
38−laterally a = Query $ \bindings -> pure $ (Any True,) $
39− case nonEmpty bindings of
40− Nothing -> a
41− Just bindings' -> case_ [(condition, a)] undefined
42− where
43− condition = foldl1' (&&.) (fmap go bindings')
44− where
45− go = fromPrimExpr . Opaleye.UnExpr Opaleye.OpIsNotNull
46−
47−
48−foldl1' :: (a -> a -> a) -> NonEmpty a -> a
49−foldl1' f (a :| as) = foldl' f a as
src/Rel8/Query/Exists.hs+49−21
@@ -2,8 +2,8 @@
22
33module Rel8.Query.Exists
44 ( exists, inQuery
5− , present, with, withBy
6− , absent, without, withoutBy
5+ , whereExists, with, withBy
6+ , whereNotExists, without, withoutBy
77 )
88where
99
@@ -11,56 +11,84 @@ where
1111import Prelude hiding ( filter )
1212
1313-- opaleye
14−import qualified Opaleye.Exists as Opaleye
1514import qualified Opaleye.Operators as Opaleye
1615
1716-- rel8
1817import Rel8.Expr ( Expr )
19−import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )
2018import Rel8.Query ( Query )
2119import Rel8.Query.Filter ( filter )
20+import Rel8.Query.Maybe ( optional )
2221import Rel8.Query.Opaleye ( mapOpaleye )
2322import Rel8.Table.Eq ( EqTable, (==:) )
23+import Rel8.Table.Maybe ( isJustTable )
2424
2525
2626-- | Checks if a query returns at least one row.
27+--
28+-- >>> :{
29+-- mapM_ print =<< select c do
30+-- author <- each authorSchema
31+-- hasProjects <- exists do
32+-- project <- each projectSchema
33+-- where_ $ authorId author ==. projectAuthorId project
34+-- return (authorName author, hasProjects)
35+-- :}
36+-- ("Ollie",True)
37+-- ("Bryan O'Sullivan",True)
38+-- ("Emily Pillmore",False)
2739exists :: Query a -> Query (Expr Bool)
28−exists = fmap (fromPrimExpr . fromColumn) . mapOpaleye Opaleye.exists
40+exists = fmap isJustTable . optional . whereExists
41+-- FIXME: change this when b7aacc07c6392654cae439fc3b997620c3aa7a87 makes it
42+-- into a release of Opaleye
2943
3044
3145inQuery :: EqTable a => a -> Query a -> Query (Expr Bool)
3246inQuery a = exists . (>>= filter (a ==:))
3347
3448
35−-- | Produce the empty query if the given query returns no rows. @present@
49+-- | Produce the empty query if the given query returns no rows. @whereExists@
3650-- is equivalent to @WHERE EXISTS@ in SQL.
37−present :: Query a -> Query ()
38−present = mapOpaleye Opaleye.restrictExists
39−
40−
41−-- | Produce the empty query if the given query returns rows. @absent@
51+--
52+-- >>> :{
53+-- select c do
54+-- author <- each authorSchema
55+-- whereExists do
56+-- project <- each projectSchema
57+-- where_ $ projectAuthorId project ==. authorId author
58+-- return $ authorName author
59+-- :}
60+-- ["Ollie","Bryan O'Sullivan"]
61+whereExists :: Query a -> Query ()
62+whereExists = mapOpaleye Opaleye.restrictExists
63+
64+
65+-- | Produce the empty query if the given query returns rows. @whereNotExists@
4266-- is equivalent to @WHERE NOT EXISTS@ in SQL.
43−absent :: Query a -> Query ()
44−absent = mapOpaleye Opaleye.restrictNotExists
67+--
68+-- >>> :{
69+-- select c do
70+-- author <- each authorSchema
71+-- whereNotExists do
72+-- project <- each projectSchema
73+-- where_ $ projectAuthorId project ==. authorId author
74+-- return $ authorName author
75+-- :}
76+-- ["Emily Pillmore"]
77+whereNotExists :: Query a -> Query ()
78+whereNotExists = mapOpaleye Opaleye.restrictNotExists
4579
4680
47−-- | @with@ is similar to 'filter', but allows the predicate to be a full query.
48−--
49−-- @with f a = a <$ present (f a)@, but this form matches 'filter'.
5081with :: (a -> Query b) -> a -> Query a
51−with f a = a <$ present (f a)
82+with f a = a <$ whereExists (f a)
5283
5384
54−-- | Like @with@, but with a custom membership test.
5585withBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a
5686withBy predicate bs = with $ \a -> bs >>= filter (predicate a)
5787
5888
59−-- | Filter rows where @a -> Query b@ yields no rows.
6089without :: (a -> Query b) -> a -> Query a
61−without f a = a <$ absent (f a)
90+without f a = a <$ whereNotExists (f a)
6291
6392
64−-- | Like @without@, but with a custom membership test.
6593withoutBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a
6694withoutBy predicate bs = without $ \a -> bs >>= filter (predicate a)
src/Rel8/Query/Filter.hs+11
@@ -24,12 +24,23 @@ import Rel8.Query.Opaleye ( fromOpaleye )
2424-- return @x@ unchanged when @f x@ is @True@. This is similar to
2525-- 'Control.Monad.guard', but as the predicate is separate from the argument,
2626-- it is easy to use in a pipeline of 'Query' transformations.
27+--
28+-- >>> select c $ values [ lit x | x <- [ 1..5 :: Int32 ] ] >>= filter (>. 3)
29+-- [4,5]
2730filter :: (a -> Expr Bool) -> a -> Query a
2831filter f a = a <$ where_ (f a)
2932
3033
3134-- | Drop any rows that don't match a predicate. @where_ expr@ is equivalent
3235-- to the SQL @WHERE expr@.
36+--
37+-- >>> :{
38+-- select c $ do
39+-- x <- values [ lit x | x <- [ 1..5 :: Int32 ] ]
40+-- where_ $ x >. lit 2
41+-- return x
42+-- :}
43+-- [3,4,5]
3344where_ :: Expr Bool -> Query ()
3445where_ condition =
3546 fromOpaleye $ lmap (\_ -> toColumn $ toPrimExpr condition) Opaleye.restrict
src/Rel8/Query/Indexed.hsdeleted−21
@@ -1,21 +0,0 @@
1−module Rel8.Query.Indexed
2− ( indexed
3− )
4−where
5−
6−-- base
7−import Control.Applicative ( liftA2 )
8−import Data.Int ( Int64 )
9−import Prelude
10−
11−-- rel8
12−import Rel8.Expr ( Expr )
13−import Rel8.Expr.Window ( rowNumber )
14−import Rel8.Query ( Query )
15−import Rel8.Query.Window ( window )
16−import Rel8.Table.Window ( currentRow )
17−
18−
19−-- | Pair each row of a query with its index within the query.
20−indexed :: Query a -> Query (Expr Int64, a)
21−indexed = window (liftA2 (,) (subtract 1 <$> rowNumber) currentRow)
src/Rel8/Query/Limit.hs+6
@@ -17,11 +17,17 @@ import Rel8.Query.Opaleye ( mapOpaleye )
1717
1818-- | @limit n@ select at most @n@ rows from a query. @limit n@ is equivalent
1919-- to the SQL @LIMIT n@.
20+--
21+-- >>> select c $ limit 3 $ values [ lit x | x <- [ 1..5 :: Int32 ] ]
22+-- [1,2,3]
2023limit :: Word -> Query a -> Query a
2124limit = mapOpaleye . Opaleye.limit . fromIntegral
2225
2326
2427-- | @offset n@ drops the first @n@ rows from a query. @offset n@ is equivalent
2528-- to the SQL @OFFSET n@.
29+--
30+-- >>> select c $ offset 3 $ values [ lit x | x <- [ 1..5 :: Int32 ] ]
31+-- [4,5]
2632offset :: Word -> Query a -> Query a
2733offset = mapOpaleye . Opaleye.offset . fromIntegral
src/Rel8/Query/List.hs+14−93
@@ -1,58 +1,23 @@
11{-# language FlexibleContexts #-}
2−{-# language GADTs #-}
3−{-# language NamedFieldPuns #-}
42
53module Rel8.Query.List
64 ( many, some
7− , manyExpr, someExpr
8− , catListTable, catNonEmptyTable
9− , catList, catNonEmpty
105 )
116where
127
138-- base
14−import Data.Functor.Identity ( runIdentity )
15−import Data.List.NonEmpty ( NonEmpty )
169import Prelude
1710
18−-- opaleye
19−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
20−
2111-- rel8
2212import Rel8.Expr ( Expr )
23−import Rel8.Expr.Aggregate ( listAggExpr, nonEmptyAggExpr )
24−import Rel8.Expr.Opaleye ( mapPrimExpr )
2513import Rel8.Query ( Query )
2614import Rel8.Query.Aggregate ( aggregate )
2715import Rel8.Query.Maybe ( optional )
28−import Rel8.Query.Rebind ( rebind )
29−import Rel8.Schema.HTable.Vectorize ( hunvectorize )
30−import Rel8.Schema.Null ( Sql, Unnullify )
31−import Rel8.Schema.Spec ( Spec( Spec, info ) )
32−import Rel8.Table ( Table, fromColumns )
33−import Rel8.Table.Cols ( toCols )
16+import Rel8.Table ( Table )
3417import Rel8.Table.Aggregate ( listAgg, nonEmptyAgg )
35−import Rel8.Table.List ( ListTable( ListTable ) )
18+import Rel8.Table.List ( ListTable )
3619import Rel8.Table.Maybe ( maybeTable )
37−import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )
38−import Rel8.Type ( DBType, typeInformation )
39−import Rel8.Type.Array ( extractArrayElement )
40−import Rel8.Type.Information ( TypeInformation )
41−
42−
43−-- | Aggregate a 'Query' into a 'ListTable'. If the supplied query returns 0
44−-- rows, this function will produce a 'Query' that returns one row containing
45−-- the empty @ListTable@. If the supplied @Query@ does return rows, @many@ will
46−-- return exactly one row, with a @ListTable@ collecting all returned rows.
47−--
48−-- @many@ is analogous to 'Control.Applicative.many' from
49−-- @Control.Applicative@.
50−many :: Table Expr a => Query a -> Query (ListTable Expr a)
51−many =
52− fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .
53− optional .
54− aggregate .
55− fmap (listAgg . toCols)
20+import Rel8.Table.NonEmpty ( NonEmptyTable )
5621
5722
5823-- | Aggregate a 'Query' into a 'NonEmptyTable'. If the supplied query returns
@@ -63,60 +28,16 @@ many =
6328--
6429-- @some@ is analogous to 'Control.Applicative.some' from
6530-- @Control.Applicative@.
66−some :: Table Expr a => Query a -> Query (NonEmptyTable Expr a)
67−some =
68− fmap (\(NonEmptyTable a) -> NonEmptyTable a) .
69− aggregate .
70− fmap (nonEmptyAgg . toCols)
71−
72−
73−-- | A version of 'many' specialised to single expressions.
74−manyExpr :: Sql DBType a => Query (Expr a) -> Query (Expr [a])
75−manyExpr = fmap (maybeTable mempty id) . optional . aggregate . fmap listAggExpr
76−
77−
78−-- | A version of 'many' specialised to single expressions.
79−someExpr :: Sql DBType a => Query (Expr a) -> Query (Expr (NonEmpty a))
80−someExpr = aggregate . fmap nonEmptyAggExpr
81−
82−
83−-- | Expand a 'ListTable' into a 'Query', where each row in the query is an
84−-- element of the given @ListTable@.
85−--
86−-- @catListTable@ is an inverse to 'many'.
87−catListTable :: Table Expr a => ListTable Expr a -> Query a
88−catListTable (ListTable as) =
89− rebind "unnest" $ fromColumns $ runIdentity $
90− hunvectorize (\Spec {info} -> pure . sunnest info) as
91−
92−
93−-- | Expand a 'NonEmptyTable' into a 'Query', where each row in the query is an
94−-- element of the given @NonEmptyTable@.
95−--
96−-- @catNonEmptyTable@ is an inverse to 'some'.
97−catNonEmptyTable :: Table Expr a => NonEmptyTable Expr a -> Query a
98−catNonEmptyTable (NonEmptyTable as) =
99− rebind "unnest" $ fromColumns $ runIdentity $
100− hunvectorize (\Spec {info} -> pure . sunnest info) as
101−
102−
103−-- | Expand an expression that contains a list into a 'Query', where each row
104−-- in the query is an element of the given list.
105−--
106−-- @catList@ is an inverse to 'manyExpr'.
107−catList :: Sql DBType a => Expr [a] -> Query (Expr a)
108−catList = rebind "unnest" . sunnest typeInformation
109−
110−
111−-- | Expand an expression that contains a non-empty list into a 'Query', where
112−-- each row in the query is an element of the given list.
113−--
114−-- @catNonEmpty@ is an inverse to 'someExpr'.
115−catNonEmpty :: Sql DBType a => Expr (NonEmpty a) -> Query (Expr a)
116−catNonEmpty = rebind "unnest" . sunnest typeInformation
31+some :: Table Expr a => Query a -> Query (NonEmptyTable a)
32+some = aggregate . fmap nonEmptyAgg
11733
11834
119−sunnest :: TypeInformation (Unnullify a) -> Expr (list a) -> Expr a
120−sunnest info = mapPrimExpr $
121− extractArrayElement info .
122− Opaleye.UnExpr (Opaleye.UnOpOther "UNNEST")
35+-- | Aggregate a 'Query' into a 'ListTable'. If the supplied query returns 0
36+-- rows, this function will produce a 'Query' that returns one row containing
37+-- the empty @ListTable@. If the supplied @Query@ does return rows, @many@ will
38+-- return exactly one row, with a @ListTable@ collecting all returned rows.
39+--
40+-- @many@ is analogous to 'Control.Applicative.many' from
41+-- @Control.Applicative@.
42+many :: Table Expr a => Query a -> Query (ListTable a)
43+many = fmap (maybeTable mempty id) . optional . aggregate . fmap listAgg
src/Rel8/Query/Maybe.hs+101−33
@@ -1,10 +1,7 @@
1−{-# language GADTs #-}
2−{-# language LambdaCase #-}
3−{-# language NamedFieldPuns #-}
4−
51module Rel8.Query.Maybe
62 ( optional
73 , catMaybeTable
4+ , bindMaybeTable
85 , traverseMaybeTable
96 )
107where
@@ -12,32 +9,35 @@ where
129-- base
1310import Prelude
1411
15−-- comonad
16−import Control.Comonad ( extract )
17−
1812-- opaleye
19−import qualified Opaleye.Internal.MaybeFields as Opaleye
13+import qualified Opaleye.Internal.PackMap as Opaleye
14+import qualified Opaleye.Internal.PrimQuery as Opaleye
15+import qualified Opaleye.Internal.QueryArr as Opaleye
16+import qualified Opaleye.Internal.Tag as Opaleye
17+import qualified Opaleye.Internal.Unpackspec as Opaleye
2018
2119-- rel8
22−import Rel8.Expr ( Expr )
20+import Rel8.Expr.Bool ( true )
2321import Rel8.Expr.Eq ( (==.) )
24−import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )
22+import Rel8.Expr.Opaleye ( toPrimExpr )
2523import Rel8.Query ( Query )
2624import Rel8.Query.Filter ( where_ )
2725import Rel8.Query.Opaleye ( mapOpaleye )
28−import Rel8.Table.Maybe ( MaybeTable(..), isJustTable )
26+import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
27+import Rel8.Table.Opaleye ( unpackspec )
2928
3029
31−-- | Convert a query that might return zero rows to a query that always returns
32−-- at least one row.
33−--
34−-- To speak in more concrete terms, 'optional' is most useful to write @LEFT
35−-- JOIN@s.
36−optional :: Query a -> Query (MaybeTable Expr a)
37−optional = mapOpaleye $ Opaleye.optionalInternal $ \tag a -> MaybeTable
38− { tag = fromPrimExpr $ fromColumn tag
39− , just = pure a
40− }
30+optional :: Query a -> Query (MaybeTable a)
31+optional = mapOpaleye $ Opaleye.QueryArr . go
32+ where
33+ go query (i, left, tag) = (MaybeTable t' a, join, Opaleye.next tag')
34+ where
35+ (MaybeTable t a, right, tag') =
36+ Opaleye.runSimpleQueryArr (pure <$> query) (i, tag)
37+ (t', bindings) = Opaleye.run $
38+ Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr "maybe" tag') t
39+ join = Opaleye.Join Opaleye.LeftJoin condition [] bindings left right
40+ condition = toPrimExpr true
4141
4242
4343-- | Filter out 'MaybeTable's, returning only the tables that are not-null.
@@ -45,24 +45,92 @@ optional = mapOpaleye $ Opaleye.optionalInternal $ \tag a -> MaybeTable
4545-- This operation can be used to "undo" the effect of 'optional', which
4646-- operationally is like turning a @LEFT JOIN@ back into a full @JOIN@. You
4747-- can think of this as analogous to 'Data.Maybe.catMaybes'.
48−catMaybeTable :: MaybeTable Expr a -> Query a
48+--
49+-- To see this in action, first consider the following 'optional' query:
50+--
51+-- >>> :{
52+-- select c $ do
53+-- author <- each authorSchema
54+-- maybeRel8 <- optional $
55+-- each projectSchema
56+-- >>= filter (\p -> projectAuthorId p ==. authorId author)
57+-- >>= filter (\p -> projectName p ==. "rel8")
58+-- return (authorName author, projectName <$> maybeRel8)
59+-- :}
60+-- [("Ollie",Just "rel8"),("Bryan O'Sullivan",Nothing),("Emily Pillmore",Nothing)]
61+--
62+-- Here @optional@ is acting as a @LEFT JOIN@. We can turn this into a proper
63+-- join by using @catMaybeTable@ to filter out rows where the join failed:
64+--
65+-- >>> :{
66+-- select c $ do
67+-- author <- each authorSchema
68+-- maybeRel8 <- optional $
69+-- each projectSchema
70+-- >>= filter (\p -> projectAuthorId p ==. authorId author)
71+-- >>= filter (\p -> projectName p ==. "rel8")
72+-- rel8 <- catMaybeTable maybeRel8
73+-- return (authorName author, projectName rel8)
74+-- :}
75+-- [("Ollie","rel8")]
76+catMaybeTable :: MaybeTable a -> Query a
4977catMaybeTable ma@(MaybeTable _ a) = do
5078 where_ $ isJustTable ma
51− pure (extract a)
79+ pure a
80+
81+
82+-- | @bindMaybeTable f x@ is similar to the monadic bind (@>>=@) operation. It
83+-- allows you to "extend" an optional query with another query. If either the
84+-- input or output are 'noTable', then the result is 'noTable'.
85+--
86+-- This is similar to 'traverseMaybeTable', followed by a @join@ on the
87+-- resulting @MaybeTable@s.
88+--
89+-- >>> select c $ bindMaybeTable (optional . values . pure . not_) =<< optional (values [lit True])
90+-- [Just False]
91+--
92+-- >>> select c $ bindMaybeTable (\_ -> return (noTable :: MaybeTable (Expr Bool))) =<< optional (values [lit True])
93+-- [Nothing]
94+--
95+-- >>> select c $ bindMaybeTable (optional . values . pure . not_) =<< return (noTable :: MaybeTable (Expr Bool))
96+-- [Nothing]
97+bindMaybeTable :: Monad m
98+ => (a -> m (MaybeTable b)) -> MaybeTable a -> m (MaybeTable b)
99+bindMaybeTable query (MaybeTable input a) = do
100+ MaybeTable output b <- query a
101+ pure $ MaybeTable (input <> output) b
52102
53103
54104-- | Extend an optional query with another query. This is useful if you want
55105-- to step through multiple @LEFT JOINs@.
56106--
57107-- Note that @traverseMaybeTable@ takes a @a -> Query b@ function, which means
58−-- you also have the ability to "expand" one row into multiple rows. If the
59−-- @a -> Query b@ function returns no rows, then the resulting query will also
60−-- have no rows. However, regardless of the given @a -> Query b@ function, if
61−-- the input is @nothingTable@, you will always get exactly one @nothingTable@
62−-- back.
63−traverseMaybeTable :: (a -> Query b) -> MaybeTable Expr a -> Query (MaybeTable Expr b)
108+-- you also have the ability to "expand" one row into multiple rows.
109+--
110+-- >>> :{
111+-- duplicate :: Expr Bool -> Query (Expr Bool)
112+-- duplicate x = unionAll (return x) (return x)
113+-- :}
114+--
115+-- >>> select c $ traverseMaybeTable duplicate =<< optional (values [lit True])
116+-- [Just True,Just True]
117+--
118+-- Note that if the @a -> Query b@ function returns no rows, then the resulting
119+-- query will also have no rows:
120+--
121+-- >>> select c $ traverseMaybeTable (limit 0 . pure) =<< optional (values [lit True])
122+-- []
123+--
124+-- However, regardless of the given @a -> Query b@ function, if the input is
125+-- @noTable@, you will always get exactly one @noTable@ back:
126+--
127+-- >>> select c $ traverseMaybeTable duplicate (noTable :: MaybeTable (Expr Bool))
128+-- [Nothing]
129+--
130+-- >>> select c $ traverseMaybeTable (limit 0 . pure) (noTable :: MaybeTable (Expr Bool))
131+-- [Nothing]
132+traverseMaybeTable :: (a -> Query b) -> MaybeTable a -> Query (MaybeTable b)
64133traverseMaybeTable 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
134+ MaybeTable output b <- optional (query =<< catMaybeTable ma)
135+ where_ $ output ==. input
136+ pure $ MaybeTable input b
src/Rel8/Query/Null.hs+18−18
@@ -1,8 +1,5 @@
1−{-# language FlexibleContexts #-}
2−
31module Rel8.Query.Null
4− ( catNull
5− , catNullTable
2+ ( catNullable
63 )
74where
85
@@ -12,8 +9,6 @@ import Prelude
129-- rel8
1310import Rel8.Expr ( Expr )
1411import Rel8.Expr.Null ( isNonNull, unsafeUnnullify )
15−import Rel8.Table ( Table )
16−import Rel8.Table.Null ( NullTable, isNonNullTable, unsafeUnnullifyTable )
1712import Rel8.Query ( Query )
1813import Rel8.Query.Filter ( where_ )
1914
@@ -22,17 +17,22 @@ import Rel8.Query.Filter ( where_ )
2217-- @null@s.
2318--
2419-- Corresponds to 'Data.Maybe.catMaybes'.
25−catNull :: Expr (Maybe a) -> Query (Expr a)
26−catNull a = do
20+--
21+-- >>> select c $ pure (nullExpr :: Expr (Maybe Bool))
22+-- [Nothing]
23+--
24+-- >>> select c $ catNullable (nullExpr :: Expr (Maybe Bool))
25+-- []
26+--
27+-- >>> select c $ catNullable (lit (Just True))
28+-- [True]
29+--
30+-- Notice how in the last example a @Bool@ is returned (rather than @Maybe
31+-- Bool@):
32+--
33+-- >>> :t catNullable (lit (Just True))
34+-- catMaybe (lit (Just True)) :: Query (Expr Bool)
35+catNullable :: Expr (Maybe a) -> Query (Expr a)
36+catNullable a = do
2737 where_ $ isNonNull a
2838 pure $ unsafeUnnullify a
29−
30−
31−-- | Filter a 'Query' that might return @nullTable@ to a 'Query' without any
32−-- @nullTable@s.
33−--
34−-- Corresponds to 'Data.Maybe.catMaybes'.
35−catNullTable :: Table Expr a => NullTable Expr a -> Query a
36−catNullTable a = do
37− where_ $ isNonNullTable a
38− pure $ unsafeUnnullifyTable a
src/Rel8/Query/Opaleye.hs+5−41
@@ -1,70 +1,34 @@
1−{-# language TupleSections #-}
2−
31module Rel8.Query.Opaleye
42 ( fromOpaleye
53 , toOpaleye
64 , mapOpaleye
75 , zipOpaleyeWith
8− , unsafePeekQuery
96 )
107where
118
129-- base
13−import Control.Applicative ( liftA2 )
1410import Prelude
1511
1612-- opaleye
17−import qualified Opaleye.Internal.QueryArr as Opaleye
18−import qualified Opaleye.Internal.Tag as Opaleye
13+import qualified Opaleye.Select as Opaleye
1914
2015-- rel8
2116import {-# SOURCE #-} Rel8.Query ( Query( Query ) )
2217
2318
2419fromOpaleye :: Opaleye.Select a -> Query a
25−fromOpaleye = Query . pure . fmap pure
20+fromOpaleye = Query
2621
2722
2823toOpaleye :: Query a -> Opaleye.Select a
29−toOpaleye (Query a) = snd <$> a mempty
24+toOpaleye (Query a) = a
3025
3126
3227mapOpaleye :: (Opaleye.Select a -> Opaleye.Select b) -> Query a -> Query b
33−mapOpaleye f (Query a) = Query (fmap (mapping f) a)
28+mapOpaleye f = fromOpaleye . f . toOpaleye
3429
3530
3631zipOpaleyeWith :: ()
3732 => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)
3833 -> Query a -> Query b -> Query c
39−zipOpaleyeWith f (Query a) (Query b) = Query $ liftA2 (zipping f) a b
40−
41−
42−unsafePeekQuery :: Query a -> a
43−unsafePeekQuery (Query q) = case q mempty of
44− f -> case Opaleye.runStateQueryArr f () Opaleye.start of
45− ((_, a), _, _) -> a
46−
47−
48−mapping :: ()
49− => (Opaleye.Select a -> Opaleye.Select b)
50− -> Opaleye.Select (m, a) -> Opaleye.Select (m, b)
51−mapping f q = Opaleye.stateQueryArr $ \_ tag ->
52− let
53− ((m, _), _, _) = Opaleye.runStateQueryArr q () tag
54− q' = (m,) <$> f (snd <$> q)
55− in
56− Opaleye.runStateQueryArr q' () tag
57−
58−
59−zipping :: Semigroup m
60− => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)
61− -> Opaleye.Select (m, a) -> Opaleye.Select (m, b) -> Opaleye.Select (m, c)
62−zipping f q q' =
63− Opaleye.stateQueryArr $ \_ tag ->
64− let
65− ((m, _), _, _) = Opaleye.runStateQueryArr q () tag
66− ((m', _), _, _) = Opaleye.runStateQueryArr q' () tag
67− m'' = m <> m'
68− q'' = (m'',) <$> f (snd <$> q) (snd <$> q')
69− in
70− Opaleye.runStateQueryArr q'' () tag
34+zipOpaleyeWith f a b = fromOpaleye $ f (toOpaleye a) (toOpaleye b)
src/Rel8/Query/Optimize.hsnew file+200
@@ -0,0 +1,200 @@
1+{-# language ApplicativeDo #-}
2+{-# language LambdaCase #-}
3+
4+{-# options -fno-warn-name-shadowing #-}
5+
6+module Rel8.Query.Optimize
7+ ( optimize
8+ )
9+where
10+
11+-- base
12+import Control.Applicative
13+import Data.Functor.Identity
14+import Prelude
15+
16+-- opaleye
17+import Opaleye.Internal.HaskellDB.PrimQuery
18+import Opaleye.Internal.PrimQuery
19+
20+
21+optimize :: PrimQuery' a -> PrimQuery' a
22+optimize =
23+ transformOf primQuery optimisePredicates
24+
25+
26+primQuery
27+ :: Applicative f
28+ => ( PrimQuery' a -> f ( PrimQuery' a ) ) -> PrimQuery' a -> f ( PrimQuery' a )
29+primQuery f = \case
30+ Aggregate bindingsAndPrimExpr primQuery -> do
31+ primQuery <- f primQuery
32+
33+ return ( Aggregate bindingsAndPrimExpr primQuery )
34+
35+ DistinctOnOrderBy maybePrimExprs orderExprs primQuery -> do
36+ primQuery <- f primQuery
37+
38+ return ( DistinctOnOrderBy maybePrimExprs orderExprs primQuery )
39+
40+ Limit limitOp primQuery -> do
41+ primQuery <- f primQuery
42+
43+ return ( Limit limitOp primQuery )
44+
45+ Join joinType primExpr bindingsA bindingsB primQueryA primQueryB -> do
46+ primQueryA <- f primQueryA
47+ primQueryB <- f primQueryB
48+
49+ return ( Join joinType primExpr bindingsA bindingsB primQueryA primQueryB )
50+
51+ Exists bool primQueryA primQueryB -> do
52+ primQueryA <- f primQueryA
53+ primQueryB <- f primQueryB
54+
55+ return ( Exists bool primQueryA primQueryB )
56+
57+ Binary binOp primQueries -> do
58+ primQueries <- both f primQueries
59+
60+ return ( Binary binOp primQueries )
61+
62+ Label label primQuery -> do
63+ primQuery <- f primQuery
64+
65+ return ( Label label primQuery )
66+
67+ other ->
68+ pure other
69+
70+
71+optimisePredicates :: PrimQuery' a -> PrimQuery' a
72+optimisePredicates = \case
73+ Join joinType predicate bindingsA bindingsB primQueryA primQueryB ->
74+ Join joinType ( nullIsFalse predicate ) bindingsA bindingsB primQueryA primQueryB
75+
76+ other ->
77+ other
78+
79+
80+nullIsFalse :: PrimExpr -> PrimExpr
81+nullIsFalse =
82+ rewriteOf primExprs simplifyCaseAnalysis
83+
84+ where
85+
86+ simplifyCaseAnalysis = \case
87+ CaseExpr [ ( UnExpr OpIsNull _, ConstExpr ( BoolLit False ) ) ] notNullBranch ->
88+ Just notNullBranch
89+
90+ CaseExpr [ ( UnExpr OpIsNull x, UnExpr OpIsNull y ) ] notNullBranch ->
91+ Just
92+ ( BinExpr
93+ (:||)
94+ ( BinExpr (:&&) ( UnExpr OpIsNull x ) ( UnExpr OpIsNull y ) )
95+ notNullBranch
96+ )
97+
98+ _ ->
99+ Nothing
100+
101+
102+
103+-- | Traverse all immediate 'PrimExpr's
104+primExprs :: Applicative f => ( PrimExpr -> f PrimExpr ) -> PrimExpr -> f PrimExpr
105+primExprs f = \case
106+ AttrExpr ( Symbol string tag ) ->
107+ pure ( AttrExpr ( Symbol string tag ) )
108+
109+ BaseTableAttrExpr attribute ->
110+ pure ( BaseTableAttrExpr attribute )
111+
112+ CompositeExpr primExpr attribute -> do
113+ primExpr <- f primExpr
114+
115+ return ( CompositeExpr primExpr attribute )
116+
117+ BinExpr binOp a b -> do
118+ a <- f a
119+ b <- f b
120+
121+ return ( BinExpr binOp a b )
122+
123+ UnExpr unOp primExpr -> do
124+ primExpr <- f primExpr
125+
126+ return ( UnExpr unOp primExpr )
127+
128+ AggrExpr aggrDistinct aggrOp primExpr orderExprs -> do
129+ aggrOp <- aggrOpPrimExprs f aggrOp
130+ primExpr <- f primExpr
131+ orderExprs <- traverse ( orderExprPrimExprs f ) orderExprs
132+
133+ return ( AggrExpr aggrDistinct aggrOp primExpr orderExprs )
134+
135+ ConstExpr l ->
136+ pure ( ConstExpr l )
137+
138+ CaseExpr cases def -> do
139+ cases <- traverse ( both f ) cases
140+ def <- f def
141+
142+ return ( CaseExpr cases def )
143+
144+ other ->
145+ pure other
146+
147+
148+
149+aggrOpPrimExprs :: Applicative f => ( PrimExpr -> f PrimExpr ) -> AggrOp -> f AggrOp
150+aggrOpPrimExprs f = \case
151+ AggrStringAggr primExpr -> do
152+ primExpr <- f primExpr
153+
154+ return ( AggrStringAggr primExpr )
155+
156+ other ->
157+ pure other
158+
159+
160+orderExprPrimExprs :: Applicative f => ( PrimExpr -> f PrimExpr ) -> OrderExpr -> f OrderExpr
161+orderExprPrimExprs f ( OrderExpr orderOp primExpr ) = do
162+ primExpr <- f primExpr
163+
164+ return ( OrderExpr orderOp primExpr )
165+
166+
167+-- | Traverse both sides of a homogeneous tuple.
168+both :: Applicative f => ( t -> f b ) -> ( t, t ) -> f ( b, b )
169+both f ( a,b ) =
170+ liftA2 (,) ( f a ) ( f b )
171+
172+
173+rewriteOf
174+ :: ( ( a -> Identity a ) -> a -> Identity a )
175+ -> ( a -> Maybe a ) -> a -> a
176+rewriteOf l f =
177+ go where
178+
179+ go = transformOf l ( \x -> maybe x go ( f x ) )
180+
181+
182+transformOf
183+ :: ( ( a -> Identity a ) -> a -> Identity a )
184+ -> ( a -> a )
185+ -> a
186+ -> a
187+{-# inline transformOf #-}
188+transformOf l f = go where
189+
190+ go =
191+ f . over l go
192+
193+
194+over
195+ :: ( ( s -> Identity t ) -> a -> Identity b )
196+ -> ( s -> t )
197+ -> a
198+ -> b
199+over l f =
200+ runIdentity . l (Identity . f)
src/Rel8/Query/Rebind.hsdeleted−27
@@ -1,27 +0,0 @@
1−{-# language FlexibleContexts #-}
2−
3−module Rel8.Query.Rebind
4− ( rebind
5− )
6−where
7−
8−-- base
9−import Prelude
10−import Control.Arrow ((<<<))
11−
12−-- opaleye
13−import qualified Opaleye.Internal.Rebind as Opaleye
14−
15−-- rel8
16−import Rel8.Expr ( Expr )
17−import Rel8.Query ( Query )
18−import Rel8.Table ( Table )
19−import Rel8.Table.Opaleye ( unpackspec )
20−import Rel8.Query.Opaleye (fromOpaleye)
21−
22−
23−-- | 'rebind' takes a variable name, some expressions, and binds each of them
24−-- to a new variable in the SQL. The @a@ returned consists only of these
25−-- variables. It's essentially a @let@ binding for Postgres expressions.
26−rebind :: Table Expr a => String -> a -> Query a
27−rebind prefix a = fromOpaleye (Opaleye.rebindExplicitPrefix prefix unpackspec <<< pure a)
src/Rel8/Query/SQL.hs+59−5
@@ -1,21 +1,75 @@
11{-# language FlexibleContexts #-}
2−{-# language MonoLocalBinds #-}
2+{-# language TypeFamilies #-}
3+{-# language ViewPatterns #-}
34
45module Rel8.Query.SQL
56 ( showQuery
7+ , sqlForQuery, sqlForQueryWithNames
68 )
79where
810
911-- base
12+import Data.Foldable ( fold )
13+import Data.Functor.Const ( Const( Const ), getConst )
14+import Data.Void ( Void )
1015import Prelude
1116
17+-- opaleye
18+import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye
19+import qualified Opaleye.Internal.PrimQuery as Opaleye
20+import qualified Opaleye.Internal.Print as Opaleye
21+import qualified Opaleye.Internal.Optimize as Opaleye
22+import qualified Opaleye.Internal.QueryArr as Opaleye hiding ( Select )
23+import qualified Opaleye.Internal.Sql as Opaleye
24+
1225-- rel8
1326import Rel8.Expr ( Expr )
27+import Rel8.Expr.Opaleye ( toPrimExpr )
1428import Rel8.Query ( Query )
15−import Rel8.Statement.Select ( ppSelect )
16−import Rel8.Table ( Table )
29+import Rel8.Query.Opaleye ( toOpaleye )
30+import qualified Rel8.Query.Optimize as Rel8 ( optimize )
31+import Rel8.Schema.Context ( Col(..) )
32+import Rel8.Schema.HTable ( htabulateA, hfield )
33+import Rel8.Table ( Table, toColumns )
34+import Rel8.Table.Name ( namesFromLabels )
35+import Rel8.Table.Recontextualize ( Selects )
1736
1837
19−-- | Convert a 'Query' to a 'String' containing a @SELECT@ statement.
38+-- | Convert a query to a 'String' containing the query as a @SELECT@
39+-- statement.
2040showQuery :: Table Expr a => Query a -> String
21−showQuery = show . ppSelect
41+showQuery = fold . sqlForQuery
42+
43+
44+sqlForQuery :: Table Expr a
45+ => Query a -> Maybe String
46+sqlForQuery = sqlForQueryWithNames namesFromLabels . fmap toColumns
47+
48+
49+sqlForQueryWithNames :: Selects names exprs
50+ => names -> Query exprs -> Maybe String
51+sqlForQueryWithNames names query =
52+ show . Opaleye.ppSql . selectFrom names exprs <$> optimize primQuery
53+ where
54+ (exprs, primQuery, _) =
55+ Opaleye.runSimpleQueryArrStart (toOpaleye query) ()
56+
57+
58+optimize :: Opaleye.PrimQuery' a -> Maybe (Opaleye.PrimQuery' Void)
59+optimize = Opaleye.removeEmpty . Rel8.optimize . Opaleye.optimize
60+
61+
62+selectFrom :: Selects names exprs
63+ => names -> exprs -> Opaleye.PrimQuery' Void -> Opaleye.Select
64+selectFrom (toColumns -> names) (toColumns -> exprs) query =
65+ Opaleye.SelectFrom $ Opaleye.newSelect
66+ { Opaleye.attrs = Opaleye.SelectAttrs attributes
67+ , Opaleye.tables = Opaleye.oneTable select
68+ }
69+ where
70+ select = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator query
71+ attributes = getConst $ htabulateA $ \field -> case hfield names field of
72+ NameCol name -> case hfield exprs field of
73+ DB (toPrimExpr -> expr) -> Const (pure (makeAttr name expr))
74+ makeAttr label expr =
75+ (Opaleye.sqlExpr expr, Just (Opaleye.SqlColumn label))
src/Rel8/Query/Set.hs+26−8
@@ -23,36 +23,54 @@ import Rel8.Table.Opaleye ( binaryspec )
2323
2424
2525-- | Combine the results of two queries of the same type, collapsing
26−-- duplicates. @union a b@ is the same as the SQL statement @a UNION b@.
26+-- duplicates. @union a b@ is the same as the SQL statement @x UNION b@.
27+--
28+-- >>> select c $ values [lit True, lit True, lit False] `union` values [lit True]
29+-- [False,True]
2730union :: EqTable a => Query a -> Query a -> Query a
2831union = zipOpaleyeWith (Opaleye.unionExplicit binaryspec)
2932
3033
3134-- | Combine the results of two queries of the same type, retaining duplicates.
32−-- @unionAll a b@ is the same as the SQL statement @a UNION ALL b@.
35+-- @unionAll a b@ is the same as the SQL statement @x UNION ALL b@.
36+--
37+-- >>> select c $ values [lit True, lit True, lit False] `unionAll` values [lit True]
38+-- [True,True,False,True]
3339unionAll :: Table Expr a => Query a -> Query a -> Query a
3440unionAll = zipOpaleyeWith (Opaleye.unionAllExplicit binaryspec)
3541
3642
3743-- | Find the intersection of two queries, collapsing duplicates. @intersect a
38−-- b@ is the same as the SQL statement @a INTERSECT b@.
44+-- b@ is the same as the SQL statement @x INTERSECT b@.
45+--
46+-- >>> select c $ values [lit True, lit True, lit False] `intersect` values [lit True]
47+-- [True]
3948intersect :: EqTable a => Query a -> Query a -> Query a
4049intersect = zipOpaleyeWith (Opaleye.intersectExplicit binaryspec)
4150
4251
4352-- | Find the intersection of two queries, retaining duplicates. @intersectAll
44−-- a b@ is the same as the SQL statement @a INTERSECT ALL b@.
45−intersectAll :: EqTable a => Query a -> Query a -> Query a
53+-- a b@ is the same as the SQL statement @x INTERSECT ALL b@.
54+--
55+-- >>> select c $ values [lit True, lit True, lit False] `intersectAll` values [lit True, lit True]
56+-- [True,True]
57+intersectAll :: Table Expr a => Query a -> Query a -> Query a
4658intersectAll = zipOpaleyeWith (Opaleye.intersectAllExplicit binaryspec)
4759
4860
4961-- | Find the difference of two queries, collapsing duplicates @except a b@ is
50−-- the same as the SQL statement @a EXCEPT b@.
62+-- the same as the SQL statement @x INTERSECT b@.
63+--
64+-- >>> select c $ values [lit True, lit False, lit False] `except` values [lit True]
65+-- [False]
5166except :: EqTable a => Query a -> Query a -> Query a
5267except = zipOpaleyeWith (Opaleye.exceptExplicit binaryspec)
5368
5469
5570-- | Find the difference of two queries, retaining duplicates. @exceptAll a b@
56−-- is the same as the SQL statement @a EXCEPT ALL b@.
57−exceptAll :: EqTable a => Query a -> Query a -> Query a
71+-- is the same as the SQL statement @x EXCEPT ALL b@.
72+--
73+-- >>> select c $ values [lit True, lit False, lit False] `exceptAll` values [lit True]
74+-- [False,False]
75+exceptAll :: Table Expr a => Query a -> Query a -> Query a
5876exceptAll = zipOpaleyeWith (Opaleye.exceptAllExplicit binaryspec)
src/Rel8/Query/These.hs+53−62
@@ -1,5 +1,4 @@
11{-# language FlexibleContexts #-}
2−{-# language GADTs #-}
32
43module Rel8.Query.These
54 ( alignBy
@@ -8,116 +7,100 @@ module Rel8.Query.These
87 , keepThisTable, loseThisTable
98 , keepThatTable, loseThatTable
109 , keepThoseTable, loseThoseTable
10+ , bindTheseTable
1111 , bitraverseTheseTable
1212 )
1313where
1414
1515-- base
16+import Data.Bifunctor ( bimap )
1617import Prelude
1718
18−-- comonad
19−import Control.Comonad ( extract )
20−
2119-- opaleye
22−import qualified Opaleye.Internal.PackMap as Opaleye
20+import qualified Opaleye.Internal.Join as Opaleye
2321import qualified Opaleye.Internal.PrimQuery as Opaleye
24−import qualified Opaleye.Internal.QueryArr as Opaleye
25−import qualified Opaleye.Internal.Tag as Opaleye
2622
2723-- rel8
2824import Rel8.Expr ( Expr )
29−import Rel8.Expr.Bool ( boolExpr, not_ )
30−import Rel8.Expr.Eq ( (==.) )
31−import Rel8.Expr.Opaleye ( toPrimExpr, traversePrimExpr )
25+import Rel8.Expr.Bool ( (&&.), boolExpr, not_ )
26+import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
3227import Rel8.Expr.Serialize ( litExpr )
3328import Rel8.Query ( Query )
3429import Rel8.Query.Filter ( where_ )
35−import Rel8.Query.Maybe ( optional )
30+import Rel8.Query.Maybe ( traverseMaybeTable )
3631import Rel8.Query.Opaleye ( zipOpaleyeWith )
32+import Rel8.Table ( Table )
3733import Rel8.Table.Either ( EitherTable( EitherTable ) )
3834import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
35+import Rel8.Table.Opaleye ( unpackspec )
3936import Rel8.Table.These
40− ( TheseTable( TheseTable, here, there )
41− , hasHereTable, hasThereTable
37+ ( TheseTable( TheseTable )
4238 , isThisTable, isThatTable, isThoseTable
4339 )
4440import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) )
4541
4642
4743-- | Corresponds to a @FULL OUTER JOIN@ between two queries.
48−alignBy :: ()
44+alignBy :: (Table Expr a, Table Expr b)
4945 => (a -> b -> Expr Bool)
50− -> Query a -> Query b -> Query (TheseTable Expr a b)
51−alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.stateQueryArr $ \_ t -> case t of
52− tag -> (tab, join', tag''')
53− where
54− (ma, left', tag') = Opaleye.runStateQueryArr (pure <$> left) () tag
55− (mb, right', tag'') = Opaleye.runStateQueryArr (pure <$> right) () tag'
56− MaybeTable hasHere a = ma
57− MaybeTable hasThere b = mb
58− (hasHere', lbindings) = Opaleye.run $ do
59− traversePrimExpr (Opaleye.extractAttr "hasHere" tag'') hasHere
60− (hasThere', rbindings) = Opaleye.run $ do
61− traversePrimExpr (Opaleye.extractAttr "hasThere" tag'') hasThere
62− tag''' = Opaleye.next tag''
63− join = Opaleye.Join Opaleye.FullJoin on left'' right''
64− where
65− on = toPrimExpr $ condition (extract a) (extract b)
66− left'' = (Opaleye.NonLateral, Opaleye.toPrimQuery (left' <> Opaleye.aRebind lbindings))
67− right'' = (Opaleye.NonLateral, Opaleye.toPrimQuery (right' <> Opaleye.aRebind rbindings))
68− ma' = MaybeTable hasHere' a
69− mb' = MaybeTable hasThere' b
70− tab = TheseTable {here = ma', there = mb'}
71− join' = Opaleye.aProduct join
72−
73−
74−keepHereTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)
46+ -> Query a -> Query b -> Query (TheseTable a b)
47+alignBy condition as bs =
48+ uncurry TheseTable <$> zipOpaleyeWith fullOuterJoin as bs
49+ where
50+ fullOuterJoin a b =
51+ Opaleye.joinExplicit unpackspec unpackspec pure pure full a b on
52+ where
53+ full = Opaleye.FullJoin
54+ on = toColumn . toPrimExpr . uncurry condition
55+
56+
57+keepHereTable :: TheseTable a b -> Query (a, MaybeTable b)
7558keepHereTable = loseThatTable
7659
7760
78−loseHereTable :: TheseTable Expr a b -> Query b
61+loseHereTable :: TheseTable a b -> Query b
7962loseHereTable = keepThatTable
8063
8164
82−keepThereTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)
65+keepThereTable :: TheseTable a b -> Query (MaybeTable a, b)
8366keepThereTable = loseThisTable
8467
8568
86−loseThereTable :: TheseTable Expr a b -> Query a
69+loseThereTable :: TheseTable a b -> Query a
8770loseThereTable = keepThisTable
8871
8972
90−keepThisTable :: TheseTable Expr a b -> Query a
73+keepThisTable :: TheseTable a b -> Query a
9174keepThisTable t@(TheseTable (MaybeTable _ a) _) = do
9275 where_ $ isThisTable t
93− pure (extract a)
76+ pure a
9477
9578
96−loseThisTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)
79+loseThisTable :: TheseTable a b -> Query (MaybeTable a, b)
9780loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do
9881 where_ $ not_ $ isThisTable t
99− pure (ma, extract b)
82+ pure (ma, b)
10083
10184
102−keepThatTable :: TheseTable Expr a b -> Query b
85+keepThatTable :: TheseTable a b -> Query b
10386keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do
10487 where_ $ isThatTable t
105− pure (extract b)
88+ pure b
10689
10790
108−loseThatTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)
91+loseThatTable :: TheseTable a b -> Query (a, MaybeTable b)
10992loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do
11093 where_ $ not_ $ isThatTable t
111− pure (extract a, mb)
94+ pure (a, mb)
11295
11396
114−keepThoseTable :: TheseTable Expr a b -> Query (a, b)
97+keepThoseTable :: TheseTable a b -> Query (a, b)
11598keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
11699 where_ $ isThoseTable t
117− pure (extract a, extract b)
100+ pure (a, b)
118101
119102
120−loseThoseTable :: TheseTable Expr a b -> Query (EitherTable Expr a b)
103+loseThoseTable :: TheseTable a b -> Query (EitherTable a b)
121104loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
122105 where_ $ not_ $ isThoseTable t
123106 pure $ EitherTable tag a b
@@ -125,14 +108,22 @@ loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
125108 tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)
126109
127110
128−bitraverseTheseTable :: ()
111+bindTheseTable :: (Table Expr a, Semigroup a, Monad m)
112+ => (i -> m (TheseTable a b)) -> TheseTable a i -> m (TheseTable a b)
113+bindTheseTable query (TheseTable here (MaybeTable input i)) = do
114+ TheseTable here' (MaybeTable output b) <- query i
115+ pure $ TheseTable (here <> here') (MaybeTable (input <> output) b)
116+
117+
118+bitraverseTheseTable :: (Table Expr c, Table Expr d)
129119 => (a -> Query c)
130120 -> (b -> Query d)
131− -> TheseTable Expr a b
132− -> Query (TheseTable Expr c d)
133−bitraverseTheseTable f g t = do
134− mc <- optional (f . fst =<< keepHereTable t)
135− md <- optional (g . snd =<< keepThereTable t)
136− where_ $ isJustTable mc ==. hasHereTable t
137− where_ $ isJustTable md ==. hasThereTable t
138− pure $ TheseTable mc md
121+ -> TheseTable a b
122+ -> Query (TheseTable c d)
123+bitraverseTheseTable f g (TheseTable here there) =
124+ bimap fromJustTable fromJustTable <$>
125+ alignBy (\l r -> isJustTable l &&. isJustTable r)
126+ (traverseMaybeTable f here)
127+ (traverseMaybeTable g there)
128+ where
129+ fromJustTable (MaybeTable _ a) = a
src/Rel8/Query/Values.hs+7−1
@@ -21,7 +21,13 @@ import Rel8.Table.Opaleye ( valuesspec )
2121
2222
2323-- | Construct a query that returns the given input list of rows. This is like
24−-- folding a list of 'return' statements under 'Rel8.union', but uses the SQL
24+-- folding a list of 'return' statements under 'union', but uses the SQL
2525-- @VALUES@ expression for efficiency.
26+--
27+-- Typically @values@ will be used with 'lit':
28+--
29+-- >>> mapM_ Data.Text.IO.putStrLn =<< select c (values [ lit "Hello", lit "World!" ])
30+-- Hello
31+-- World!
2632values :: (Table Expr a, Foldable f) => f a -> Query a
2733values = fromOpaleye . Opaleye.valuesExplicit valuesspec . toList
src/Rel8/Query/Window.hsdeleted−26
@@ -1,26 +0,0 @@
1−module Rel8.Query.Window
2− ( window
3− )
4−where
5−
6−-- base
7−import Prelude ()
8−
9−-- opaleye
10−import qualified Opaleye.Window as Opaleye
11−
12−-- rel8
13−import Rel8.Query ( Query )
14−import Rel8.Query.Opaleye ( mapOpaleye )
15−import Rel8.Window ( Window( Window ) )
16−
17−
18−-- | 'window' runs a query composed of expressions containing
19−-- [window functions](https://www.postgresql.org/docs/current/tutorial-window.html).
20−-- 'window' is similar to 'Rel8.aggregate', with the main difference being
21−-- that in a window query, each input row corresponds to one output row,
22−-- whereas aggregation queries fold the entire input query down into a single
23−-- row. To put this into a Haskell context, 'Rel8.aggregate' is to 'foldl' as
24−-- 'window' is to 'scanl'.
25−window :: Window a b -> Query a -> Query b
26−window (Window a) = mapOpaleye (Opaleye.runWindows a)
src/Rel8/Schema/Column.hsnew file+169
@@ -0,0 +1,169 @@
1+{-# language DataKinds #-}
2+{-# language TypeFamilies #-}
3+{-# language StandaloneKindSignatures #-}
4+
5+module Rel8.Schema.Column
6+ ( Column, Default, Label
7+ , HEither
8+ , HList
9+ , HMaybe
10+ , HNonEmpty
11+ , HThese
12+ )
13+where
14+
15+-- base
16+import Data.Functor.Identity ( Identity )
17+import Data.Kind ( Type )
18+import Data.List.NonEmpty ( NonEmpty )
19+import GHC.TypeLits ( Symbol )
20+import Prelude
21+
22+-- rel8
23+import Rel8.Aggregate ( Aggregate )
24+import Rel8.Expr ( Expr )
25+import Rel8.Kind.Labels ( Labels )
26+import Rel8.Kind.Necessity ( Necessity( Required, Optional ) )
27+import Rel8.Schema.Context ( Name, Insertion )
28+import Rel8.Schema.Field ( Field )
29+import qualified Rel8.Schema.Kind as K
30+import Rel8.Schema.Nullability ( Unnullify )
31+import Rel8.Schema.Structure
32+ ( Structure
33+ , Shape( Either, List, Maybe, NonEmpty, These )
34+ , Shape1
35+ , Shape2
36+ )
37+import Rel8.Table.Either ( EitherTable )
38+import Rel8.Table.List ( ListTable )
39+import Rel8.Table.Maybe ( MaybeTable )
40+import Rel8.Table.NonEmpty ( NonEmptyTable )
41+import Rel8.Table.These ( TheseTable )
42+
43+-- these
44+import Data.These ( These )
45+
46+
47+type Label :: Symbol -> Type -> Type
48+data Label label a
49+
50+
51+type Default :: Type -> Type
52+data Default a
53+
54+
55+type GetLabel :: Type -> Labels
56+type family GetLabel a where
57+ GetLabel (Label label _) = '[label]
58+ GetLabel _ = '[]
59+
60+
61+type UnwrapLabel :: Type -> Type
62+type family UnwrapLabel a where
63+ UnwrapLabel (Label _ a) = a
64+ UnwrapLabel a = a
65+
66+
67+type GetNecessity :: Type -> Necessity
68+type family GetNecessity a where
69+ GetNecessity (Default _) = 'Optional
70+ GetNecessity _ = 'Required
71+
72+
73+type UnwrapDefault :: Type -> Type
74+type family UnwrapDefault a where
75+ UnwrapDefault (Default a) = a
76+ UnwrapDefault a = a
77+
78+
79+-- | The @Column@ type family should be used to indicate which fields of your
80+-- data types are single columns in queries. This type family has special
81+-- support when a query is executed, allowing you to use a single data type for
82+-- both query data and rows decoded to Haskell.
83+--
84+-- To understand why this type family is special, let's consider a simple
85+-- higher-kinded data type of Haskell packages:
86+--
87+-- >>> :{
88+-- data Package f = Package
89+-- { packageName :: Column f Text
90+-- , packageAuthor :: Column f Text
91+-- }
92+-- :}
93+--
94+-- In queries, @f@ will be some type of 'Expr', and @Column Expr a@ reduces to
95+-- just @Expr a@:
96+--
97+-- >>> :t packageName (undefined :: Package Expr)
98+-- packageName (undefined :: Package Expr) :: Expr Text
99+--
100+-- When we 'select' queries of this type, @f@ will be instantiated as
101+-- @Identity@, at which point all wrapping entire disappears:
102+--
103+-- >>> :t packageName (undefined :: Package Identity)
104+-- packageName (undefined :: Package Identity) :: Text
105+--
106+-- In @rel8@ we try hard to always know what @f@ is, which means holes should
107+-- mention precise types, rather than the @Column@ type family. You should only
108+-- need to be aware of the type family when defining your table types.
109+type Column :: K.Context -> Type -> Type
110+type Column context a =
111+ Field context (GetLabel a)
112+ (GetNecessity (UnwrapLabel a))
113+ (Unnullify (UnwrapDefault (UnwrapLabel a)))
114+ (UnwrapDefault (UnwrapLabel a))
115+
116+
117+type HEither :: K.Context -> Type -> Type -> Type
118+type family HEither context where
119+ HEither Structure = Shape2 'Either
120+ HEither Aggregate = EitherTable
121+ HEither Expr = EitherTable
122+ HEither Identity = Either
123+ HEither Insertion = EitherTable
124+ HEither Name = EitherTable
125+ HEither _ = Either
126+
127+
128+type HList :: K.Context -> Type -> Type
129+type family HList context where
130+ HList Structure = Shape1 'List
131+ HList Aggregate = ListTable
132+ HList Expr = ListTable
133+ HList Identity = []
134+ HList Insertion = ListTable
135+ HList Name = ListTable
136+ HList _ = []
137+
138+
139+type HMaybe :: K.Context -> Type -> Type
140+type family HMaybe context where
141+ HMaybe Structure = Shape1 'Maybe
142+ HMaybe Aggregate = MaybeTable
143+ HMaybe Expr = MaybeTable
144+ HMaybe Identity = Maybe
145+ HMaybe Insertion = MaybeTable
146+ HMaybe Name = MaybeTable
147+ HMaybe _ = Maybe
148+
149+
150+type HNonEmpty :: K.Context -> Type -> Type
151+type family HNonEmpty context where
152+ HNonEmpty Structure = Shape1 'NonEmpty
153+ HNonEmpty Aggregate = NonEmptyTable
154+ HNonEmpty Expr = NonEmptyTable
155+ HNonEmpty Identity = NonEmpty
156+ HNonEmpty Insertion = NonEmptyTable
157+ HNonEmpty Name = NonEmptyTable
158+ HNonEmpty _ = NonEmpty
159+
160+
161+type HThese :: K.Context -> Type -> Type -> Type
162+type family HThese context where
163+ HThese Structure = Shape2 'These
164+ HThese Aggregate = TheseTable
165+ HThese Expr = TheseTable
166+ HThese Identity = These
167+ HThese Insertion = TheseTable
168+ HThese Name = TheseTable
169+ HThese _ = These
src/Rel8/Schema/Context.hsnew file+75
@@ -0,0 +1,75 @@
1+{-# language DataKinds #-}
2+{-# language DerivingStrategies #-}
3+{-# language GADTs #-}
4+{-# language GeneralizedNewtypeDeriving #-}
5+{-# language StandaloneKindSignatures #-}
6+{-# language TypeFamilies #-}
7+
8+module Rel8.Schema.Context
9+ ( Interpretation, Col(..)
10+ , Insertion(..)
11+ , Name(..)
12+ )
13+where
14+
15+-- base
16+import Data.Functor.Identity ( Identity )
17+import Data.Kind ( Constraint )
18+import Data.String ( IsString )
19+import Prelude
20+
21+-- rel8
22+import Rel8.Aggregate ( Aggregate )
23+import Rel8.Expr ( Expr )
24+import Rel8.Kind.Necessity ( Necessity( Optional, Required ) )
25+import qualified Rel8.Schema.Kind as K
26+import Rel8.Schema.Spec ( Spec( Spec ) )
27+
28+
29+type Interpretation :: K.Context -> Constraint
30+class Interpretation context where
31+ data Col context :: K.HContext
32+
33+
34+instance Interpretation Aggregate where
35+ data Col Aggregate _spec where
36+ Aggregation :: ()
37+ => Aggregate (Expr a)
38+ -> Col Aggregate ('Spec labels necessity db a)
39+
40+
41+instance Interpretation Expr where
42+ data Col Expr _spec where
43+ DB :: ()
44+ => { unDB :: Expr a }
45+ -> Col Expr ('Spec labels necessity db a)
46+
47+
48+instance Interpretation Identity where
49+ data Col Identity _spec where
50+ Result :: a -> Col Identity ('Spec labels necessity db a)
51+
52+
53+instance Interpretation Insertion where
54+ data Col Insertion _spec where
55+ RequiredInsert :: Expr a -> Col Insertion ('Spec labels 'Required db a)
56+ OptionalInsert :: Maybe (Expr a) -> Col Insertion ('Spec labels 'Optional db a)
57+
58+
59+instance Interpretation Name where
60+ data Col Name _spec where
61+ NameCol :: String -> Col Name ('Spec labels necessity db a)
62+
63+
64+type Insertion :: K.Context
65+newtype Insertion a = Insertion (Expr a)
66+
67+
68+-- | A @Name@ is the name of a column, as it would be defined in a table's
69+-- schema definition. You can construct names by using the @OverloadedStrings@
70+-- extension and writing string literals. This is typically done when providing
71+-- a 'TableSchema' value.
72+type Name :: K.Context
73+newtype Name a = Name String
74+ deriving stock Show
75+ deriving newtype (IsString, Monoid, Semigroup)
src/Rel8/Schema/Context/Identity.hsnew file+198
@@ -0,0 +1,198 @@
1+{-# language DataKinds #-}
2+{-# language DisambiguateRecordFields #-}
3+{-# language NamedFieldPuns #-}
4+{-# language TypeFamilies #-}
5+
6+module Rel8.Schema.Context.Identity
7+ ( fromHEitherTable, toHEitherTable
8+ , fromHListTable, toHListTable
9+ , fromHMaybeTable, toHMaybeTable
10+ , fromHNonEmptyTable, toHNonEmptyTable
11+ , fromHTheseTable, toHTheseTable
12+ )
13+where
14+
15+-- base
16+import Data.Functor ( ($>) )
17+import Data.Functor.Identity ( Identity )
18+import Data.List.NonEmpty ( NonEmpty )
19+import Prelude hiding ( null )
20+
21+-- rel8
22+import Rel8.Schema.Context ( Col( Result ) )
23+import Rel8.Schema.HTable ( HTable )
24+import Rel8.Schema.HTable.Either ( HEitherTable(..) )
25+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
26+import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
27+import Rel8.Schema.HTable.List ( HListTable )
28+import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
29+import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify )
30+import Rel8.Schema.HTable.These ( HTheseTable(..) )
31+import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )
32+import Rel8.Schema.Nullability
33+ ( Nullability( Nullable, NonNullable )
34+ )
35+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
36+import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )
37+
38+-- these
39+import Data.These ( These( This, That, These ) )
40+import Data.These.Combinators ( justHere, justThere )
41+
42+
43+toHEitherTable :: (HTable t, HTable u)
44+ => Either (t (Col Identity)) (u (Col Identity))
45+ -> HEitherTable t u (Col Identity)
46+toHEitherTable = either hleft hright
47+ where
48+ hleft table = HEitherTable
49+ { htag = HIdentity (Result IsLeft)
50+ , hleft = hnullify nullifier table
51+ , hright = hnulls null
52+ }
53+ hright table = HEitherTable
54+ { htag = HIdentity (Result IsRight)
55+ , hleft = hnulls null
56+ , hright = hnullify nullifier table
57+ }
58+{-# INLINABLE toHEitherTable #-}
59+
60+
61+fromHEitherTable :: (HTable t, HTable u)
62+ => HEitherTable t u (Col Identity)
63+ -> Either (t (Col Identity)) (u (Col Identity))
64+fromHEitherTable HEitherTable {htag, hleft, hright} = case htag of
65+ HIdentity (Result tag) -> case tag of
66+ IsLeft -> maybe err Left $ hunnullify unnullifier hleft
67+ IsRight -> maybe err Right $ hunnullify unnullifier hright
68+ where
69+ err = error "fromHEitherTable: mismatch between tag and data"
70+{-# INLINABLE fromHEitherTable #-}
71+
72+
73+toHListTable :: HTable t => [t (Col Identity)] -> HListTable t (Col Identity)
74+toHListTable = hvectorize vectorizer
75+{-# INLINABLE toHListTable #-}
76+
77+
78+fromHListTable :: HTable t => HListTable t (Col Identity) -> [t (Col Identity)]
79+fromHListTable = hunvectorize unvectorizer
80+{-# INLINABLE fromHListTable #-}
81+
82+
83+toHMaybeTable :: HTable t => Maybe (t (Col Identity)) -> HMaybeTable t (Col Identity)
84+toHMaybeTable = maybe hnothing hjust
85+ where
86+ hnothing = HMaybeTable
87+ { htag = HIdentity (Result Nothing)
88+ , hjust = hnulls null
89+ }
90+ hjust table = HMaybeTable
91+ { htag = HIdentity (Result (Just IsJust))
92+ , hjust = hnullify nullifier table
93+ }
94+{-# INLINABLE toHMaybeTable #-}
95+
96+
97+fromHMaybeTable :: HTable t => HMaybeTable t (Col Identity) -> Maybe (t (Col Identity))
98+fromHMaybeTable HMaybeTable {htag, hjust} = case htag of
99+ HIdentity (Result tag) -> tag $>
100+ case hunnullify unnullifier hjust of
101+ Nothing -> error "fromHMaybeTable: mismatch between tag and data"
102+ Just just -> just
103+{-# INLINABLE fromHMaybeTable #-}
104+
105+
106+toHNonEmptyTable :: HTable t => NonEmpty (t (Col Identity)) -> HNonEmptyTable t (Col Identity)
107+toHNonEmptyTable = hvectorize vectorizer
108+{-# INLINABLE toHNonEmptyTable #-}
109+
110+
111+fromHNonEmptyTable :: HTable t => HNonEmptyTable t (Col Identity) -> NonEmpty (t (Col Identity))
112+fromHNonEmptyTable = hunvectorize unvectorizer
113+{-# INLINABLE fromHNonEmptyTable #-}
114+
115+
116+toHTheseTable :: (HTable t, HTable u)
117+ => These (t (Col Identity)) (u (Col Identity))
118+ -> HTheseTable t u (Col Identity)
119+toHTheseTable tables = HTheseTable
120+ { hhereTag = relabel hhereTag
121+ , hhere
122+ , hthereTag = relabel hthereTag
123+ , hthere
124+ }
125+ where
126+ HMaybeTable
127+ { htag = hhereTag
128+ , hjust = hhere
129+ } = toHMaybeTable (justHere tables)
130+ HMaybeTable
131+ { htag = hthereTag
132+ , hjust = hthere
133+ } = toHMaybeTable (justThere tables)
134+{-# INLINABLE toHTheseTable #-}
135+
136+
137+fromHTheseTable :: (HTable t, HTable u)
138+ => HTheseTable t u (Col Identity)
139+ -> These (t (Col Identity)) (u (Col Identity))
140+fromHTheseTable HTheseTable {hhereTag, hhere, hthereTag, hthere} =
141+ case (fromHMaybeTable mhere, fromHMaybeTable mthere) of
142+ (Just a, Nothing) -> This a
143+ (Nothing, Just b) -> That b
144+ (Just a, Just b) -> These a b
145+ _ -> error "fromHTheseTable: mismatch between tags and data"
146+ where
147+ mhere = HMaybeTable
148+ { htag = relabel hhereTag
149+ , hjust = hhere
150+ }
151+ mthere = HMaybeTable
152+ { htag = relabel hthereTag
153+ , hjust = hthere
154+ }
155+{-# INLINABLE fromHTheseTable #-}
156+
157+
158+null :: Col Identity ('Spec labels necessity db (Maybe db))
159+null = Result Nothing
160+
161+
162+nullifier :: ()
163+ => SSpec ('Spec labels necessity db a)
164+ -> Col Identity ('Spec labels necessity db a)
165+ -> Col Identity ('Spec labels necessity db (Maybe db))
166+nullifier SSpec {nullability} (Result a) = Result $ case nullability of
167+ Nullable -> a
168+ NonNullable -> Just a
169+
170+
171+unnullifier :: ()
172+ => SSpec ('Spec labels necessity db a)
173+ -> Col Identity ('Spec labels necessity db (Maybe db))
174+ -> Maybe (Col Identity ('Spec labels necessity db a))
175+unnullifier SSpec {nullability} (Result a) =
176+ case nullability of
177+ Nullable -> pure $ Result a
178+ NonNullable -> Result <$> a
179+
180+
181+vectorizer :: Functor f
182+ => SSpec ('Spec labels necessity db a)
183+ -> f (Col Identity ('Spec labels necessity db a))
184+ -> Col Identity ('Spec labels necessity (f a) (f a))
185+vectorizer _ = Result . fmap (\(Result a) -> a)
186+
187+
188+unvectorizer :: Functor f
189+ => SSpec ('Spec labels necessity db a)
190+ -> Col Identity ('Spec labels necessity (f a) (f a))
191+ -> f (Col Identity ('Spec labels necessity db a))
192+unvectorizer _ (Result results) = Result <$> results
193+
194+
195+relabel :: ()
196+ => HIdentity ('Spec labels necessity db a) (Col Identity)
197+ -> HIdentity ('Spec relabels necessity db a) (Col Identity)
198+relabel (HIdentity (Result a)) = HIdentity (Result a)
src/Rel8/Schema/Context/Label.hsnew file+82
@@ -0,0 +1,82 @@
1+{-# language DataKinds #-}
2+{-# language LambdaCase #-}
3+{-# language FlexibleInstances #-}
4+{-# language MultiParamTypeClasses #-}
5+{-# language StandaloneKindSignatures #-}
6+{-# language TypeFamilies #-}
7+{-# language TypeOperators #-}
8+
9+module Rel8.Schema.Context.Label
10+ ( Labelable( labeler, unlabeler )
11+ , HLabelable( hlabeler, hunlabeler )
12+ )
13+where
14+
15+-- base
16+import Data.Functor.Identity ( Identity )
17+import Data.Kind ( Constraint )
18+import Prelude hiding ( null )
19+
20+-- rel8
21+import Rel8.Aggregate ( Aggregate )
22+import Rel8.Expr ( Expr )
23+import Rel8.Schema.Context ( Interpretation, Col(..), Insertion, Name )
24+import qualified Rel8.Schema.Kind as K
25+import Rel8.Schema.Spec ( Spec( Spec ) )
26+
27+
28+type Labelable :: K.Context -> Constraint
29+class Interpretation context => Labelable context where
30+ labeler :: ()
31+ => Col context ('Spec labels necessity db a)
32+ -> Col context ('Spec (label ': labels) necessity db a)
33+
34+ unlabeler :: ()
35+ => Col context ('Spec (label ': labels) necessity db a)
36+ -> Col context ('Spec labels necessity db a)
37+
38+
39+instance Labelable Aggregate where
40+ labeler (Aggregation aggregate) = Aggregation aggregate
41+ unlabeler (Aggregation aggregate) = Aggregation aggregate
42+
43+
44+instance Labelable Expr where
45+ labeler (DB a) = DB a
46+ unlabeler (DB a) = DB a
47+
48+
49+instance Labelable Insertion where
50+ labeler = \case
51+ RequiredInsert a -> RequiredInsert a
52+ OptionalInsert ma -> OptionalInsert ma
53+
54+ unlabeler = \case
55+ RequiredInsert a -> RequiredInsert a
56+ OptionalInsert ma -> OptionalInsert ma
57+
58+
59+instance Labelable Identity where
60+ labeler (Result a) = Result a
61+ unlabeler (Result a) = Result a
62+
63+
64+instance Labelable Name where
65+ labeler (NameCol a) = NameCol a
66+ unlabeler (NameCol a) = NameCol a
67+
68+
69+type HLabelable :: K.HContext -> Constraint
70+class HLabelable context where
71+ hlabeler :: ()
72+ => context ('Spec labels necessity db a)
73+ -> context ('Spec (label ': labels) necessity db a)
74+
75+ hunlabeler :: ()
76+ => context ('Spec (label ': labels) necessity db a)
77+ -> context ('Spec labels necessity db a)
78+
79+
80+instance Labelable context => HLabelable (Col context) where
81+ hlabeler = labeler
82+ hunlabeler = unlabeler
src/Rel8/Schema/Context/Nullify.hs+121−107
@@ -1,144 +1,158 @@
11{-# language DataKinds #-}
2−{-# language EmptyCase #-}
3−{-# language FlexibleContexts #-}
4−{-# language GADTs #-}
52{-# language LambdaCase #-}
3+{-# language FlexibleContexts #-}
4+{-# language FlexibleInstances #-}
5+{-# language MultiParamTypeClasses #-}
66{-# language NamedFieldPuns #-}
7+{-# language ScopedTypeVariables #-}
78{-# language StandaloneKindSignatures #-}
9+{-# language TypeApplications #-}
10+{-# language TypeFamilies #-}
811
912module Rel8.Schema.Context.Nullify
10− ( Nullifiability(..), NonNullifiability(..), nullifiableOrNot, absurd
11− , Nullifiable, nullifiability
12− , guarder, nullifier, unnullifier
13− , sguard, snullify
13+ ( Nullifiable( encodeTag, decodeTag, nullifier, unnullifier )
14+ , NullifiableEq
1415 )
1516where
1617
1718-- base
18−import Data.Bool ( bool )
19−import Data.Functor.Identity ( Identity( Identity ) )
20−import Data.Kind ( Constraint, Type )
19+import Control.Applicative ( empty )
20+import Data.Foldable ( fold )
21+import Data.Kind ( Constraint )
22+import qualified Data.List.NonEmpty as NonEmpty
23+import Data.Monoid ( First( First ), getFirst )
2124import Prelude hiding ( null )
2225
2326-- opaleye
2427import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
2528
2629-- rel8
27−import Rel8.Aggregate ( Aggregate(..), zipOutputs )
28−import Rel8.Expr ( Expr )
30+import Rel8.Aggregate ( Aggregate, foldInputs, mapInputs )
31+import Rel8.Expr ( Expr( Expr ) )
32+import Rel8.Expr.Aggregate ( groupByExpr )
2933import Rel8.Expr.Bool ( boolExpr )
3034import Rel8.Expr.Null ( nullify, unsafeUnnullify )
31−import Rel8.Expr.Opaleye ( fromPrimExpr )
32−import Rel8.Kind.Context ( SContext(..) )
33−import Rel8.Schema.Field ( Field )
35+import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
36+import Rel8.Kind.Labels ( KnownLabels, labelsSing, renderLabels )
37+import Rel8.Kind.Necessity ( Necessity( Required ) )
38+import Rel8.Schema.Context ( Interpretation, Col(..), Insertion, Name )
3439import qualified Rel8.Schema.Kind as K
35−import Rel8.Schema.Name ( Name( Name ) )
36−import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )
37−import Rel8.Schema.Result ( Result )
38−import Rel8.Schema.Spec ( Spec(..) )
40+import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ), Sql )
41+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
42+import Rel8.Type.Eq ( DBEq )
43+import Rel8.Type.Monoid ( DBMonoid )
44+
3945
46+type Nullifiable :: K.Context -> Constraint
47+class Interpretation context => Nullifiable context where
48+ encodeTag :: (Sql DBEq a, KnownLabels labels)
49+ => Expr a
50+ -> Col context ('Spec labels 'Required db a)
4051
41−type Nullifiability :: K.Context -> Type
42−data Nullifiability context where
43− NAggregate :: Nullifiability Aggregate
44− NExpr :: Nullifiability Expr
45− NName :: Nullifiability Name
52+ decodeTag :: Sql DBMonoid a
53+ => Col context ('Spec labels 'Required db a)
54+ -> Expr a
4655
56+ nullifier :: ()
57+ => Expr Bool
58+ -> SSpec ('Spec labels necessity db a)
59+ -> Col context ('Spec labels necessity db a)
60+ -> Col context ('Spec labels necessity db (Maybe db))
4761
48−type Nullifiable :: K.Context -> Constraint
49−class Nullifiable context where
50− nullifiability :: Nullifiability context
62+ unnullifier :: ()
63+ => Expr Bool
64+ -> SSpec ('Spec labels necessity db a)
65+ -> Col context ('Spec labels necessity db (Maybe db))
66+ -> Col context ('Spec labels necessity db a)
5167
5268
5369instance Nullifiable Aggregate where
54− nullifiability = NAggregate
70+ encodeTag = Aggregation . groupByExpr
71+ decodeTag (Aggregation aggregate) = fold $ undoGroupBy aggregate
72+
73+ nullifier tag SSpec {nullability} (Aggregation aggregate) = Aggregation $
74+ mapInputs (toPrimExpr . runTag nullability tag . fromPrimExpr) $
75+ runTag nullability tag <$> aggregate
76+
77+ unnullifier _ SSpec {nullability} (Aggregation aggregate) =
78+ Aggregation $ unnull nullability <$> aggregate
79+
80+ {-# INLINABLE encodeTag #-}
81+ {-# INLINABLE decodeTag #-}
82+ {-# INLINABLE nullifier #-}
83+ {-# INLINABLE unnullifier #-}
5584
5685
5786instance Nullifiable Expr where
58− nullifiability = NExpr
87+ encodeTag = DB
88+ decodeTag (DB a) = a
89+ nullifier tag SSpec {nullability} (DB a) = DB $ runTag nullability tag a
90+ unnullifier _ SSpec {nullability} (DB a) = DB $ unnull nullability a
91+
92+ {-# INLINABLE encodeTag #-}
93+ {-# INLINABLE decodeTag #-}
94+ {-# INLINABLE nullifier #-}
95+ {-# INLINABLE unnullifier #-}
96+
97+
98+instance Nullifiable Insertion where
99+ encodeTag = RequiredInsert
100+ decodeTag (RequiredInsert a) = a
101+
102+ nullifier tag SSpec {nullability} = \case
103+ RequiredInsert a -> RequiredInsert $ runTag nullability tag a
104+ OptionalInsert ma -> OptionalInsert $ runTag nullability tag <$> ma
105+
106+ unnullifier _ SSpec {nullability} = \case
107+ RequiredInsert a -> RequiredInsert $ unnull nullability a
108+ OptionalInsert ma -> OptionalInsert $ unnull nullability <$> ma
109+
110+ {-# INLINABLE encodeTag #-}
111+ {-# INLINABLE decodeTag #-}
112+ {-# INLINABLE nullifier #-}
113+ {-# INLINABLE unnullifier #-}
59114
60115
61116instance Nullifiable Name where
62− nullifiability = NName
63−
64−
65−type NonNullifiability :: K.Context -> Type
66−data NonNullifiability context where
67− NField :: NonNullifiability (Field table)
68− NResult :: NonNullifiability Result
69−
70−
71−nullifiableOrNot :: ()
72− => SContext context
73− -> Either (NonNullifiability context) (Nullifiability context)
74−nullifiableOrNot = \case
75− SAggregate -> Right NAggregate
76− SExpr -> Right NExpr
77− SField -> Left NField
78− SName -> Right NName
79− SResult -> Left NResult
80−
81−
82−absurd :: Nullifiability context -> NonNullifiability context -> a
83−absurd = \case
84− NAggregate -> \case
85− NExpr -> \case
86− NName -> \case
87−
88−
89−guarder :: ()
90− => SContext context
91− -> context tag
92− -> (tag -> Bool)
93− -> (Expr tag -> Expr Bool)
94− -> context (Maybe a)
95− -> context (Maybe a)
96−guarder = \case
97− SAggregate -> \tag _ isNonNull -> zipOutputs (sguard . isNonNull) tag
98− SExpr -> \tag _ isNonNull -> sguard (isNonNull tag)
99− SField -> \_ _ _ -> id
100− SName -> \_ _ _ -> id
101− SResult -> \(Identity tag) isNonNull _ (Identity a) ->
102− Identity (bool Nothing a (isNonNull tag))
103−
104−
105−nullifier :: ()
106− => Nullifiability context
107− -> Spec a
108− -> context a
109− -> context (Nullify a)
110−nullifier = \case
111− NAggregate -> \Spec {nullity} (Aggregate a) ->
112− Aggregate $ snullify nullity <$> a
113− NExpr -> \Spec {nullity} a -> snullify nullity a
114− NName -> \_ (Name a) -> Name a
115−
116−
117−unnullifier :: ()
118− => Nullifiability context
119− -> Spec a
120− -> context (Nullify a)
121− -> context a
122−unnullifier = \case
123− NAggregate -> \Spec {nullity} (Aggregate a) ->
124− Aggregate $ sunnullify nullity <$> a
125− NExpr -> \Spec {nullity} a -> sunnullify nullity a
126− NName -> \_ (Name a) -> Name a
127−
128−
129−sguard :: Expr Bool -> Expr (Maybe a) -> Expr (Maybe a)
130−sguard condition a = boolExpr null a condition
117+ encodeTag _ = nameFromLabel
118+ decodeTag _ = mempty
119+ nullifier _ _ (NameCol name) = NameCol name
120+ unnullifier _ _ (NameCol name) = NameCol name
121+
122+ {-# INLINABLE encodeTag #-}
123+ {-# INLINABLE decodeTag #-}
124+ {-# INLINABLE nullifier #-}
125+ {-# INLINABLE unnullifier #-}
126+
127+
128+type NullifiableEq :: K.Context -> K.Context -> Constraint
129+class (a ~ b, Nullifiable b) => NullifiableEq a b
130+instance (a ~ b, Nullifiable b) => NullifiableEq a b
131+
132+
133+runTag :: Nullability db a -> Expr Bool -> Expr a -> Expr (Maybe db)
134+runTag nullability tag a = case nullability of
135+ Nullable -> boolExpr null a tag
136+ NonNullable -> boolExpr null (nullify a) tag
131137 where
132− null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit
138+ null = Expr (Opaleye.ConstExpr Opaleye.NullLit)
139+
133140
141+unnull :: Nullability db a -> Expr (Maybe db) -> Expr a
142+unnull nullability a = case nullability of
143+ Nullable -> a
144+ NonNullable -> unsafeUnnullify a
134145
135−snullify :: Nullity a -> Expr a -> Expr (Nullify a)
136−snullify nullity a = case nullity of
137− Null -> a
138− NotNull -> nullify a
146+
147+-- HACK
148+undoGroupBy :: Aggregate (Expr _a) -> Maybe (Expr a)
149+undoGroupBy = getFirst . foldInputs go
150+ where
151+ go Nothing a = pure (Expr a)
152+ go _ _ = First empty
139153
140154
141−sunnullify :: Nullity a -> Expr (Nullify a) -> Expr a
142−sunnullify nullity a = case nullity of
143− Null -> a
144− NotNull -> unsafeUnnullify a
155+nameFromLabel :: forall labels necessity db a.
156+ KnownLabels labels => Col Name ('Spec labels necessity db a)
157+nameFromLabel = case labelsSing @labels of
158+ labels -> NameCol (NonEmpty.last (renderLabels labels))
src/Rel8/Schema/Field.hs+21−37
@@ -1,50 +1,34 @@
11{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
3−{-# language MultiParamTypeClasses #-}
42{-# language StandaloneKindSignatures #-}
53{-# language TypeFamilies #-}
64
75module Rel8.Schema.Field
8− ( Field(..)
9− , fields
6+ ( Field
107 )
118where
129
1310-- base
14−import Data.Functor.Identity ( Identity( Identity ) )
11+import Data.Functor.Identity ( Identity )
1512import Data.Kind ( Type )
1613import Prelude
1714
1815-- rel8
19−import Rel8.Schema.HTable ( HField, htabulate )
20−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
21−import Rel8.Schema.Kind as K
22−import Rel8.Schema.Null ( Sql )
23−import Rel8.Table
24− ( Table, Columns, Context, fromColumns, toColumns
25− , FromExprs, fromResult, toResult
26− , Transpose
27− )
28−import Rel8.Table.Transpose ( Transposes )
29−import Rel8.Type ( DBType )
30−
31−
32−-- | A special context used in the construction of 'Rel8.Projection's.
33−type Field :: Type -> K.Context
34−newtype Field table a = Field (HField (Columns table) a)
35−
36−
37−instance Sql DBType a => Table (Field table) (Field table a) where
38− type Columns (Field table a) = HIdentity a
39− type Context (Field table a) = Field table
40− type FromExprs (Field table a) = a
41− type Transpose to (Field table a) = to a
42−
43− toColumns = HIdentity
44− fromColumns (HIdentity a) = a
45− toResult a = HIdentity (Identity a)
46− fromResult (HIdentity (Identity a)) = a
47−
48−
49−fields :: Transposes context (Field table) table fields => fields
50−fields = fromColumns $ htabulate Field
16+import Rel8.Aggregate ( Aggregate )
17+import Rel8.Expr ( Expr )
18+import Rel8.Kind.Labels ( Labels )
19+import Rel8.Kind.Necessity ( Necessity( Required, Optional ) )
20+import Rel8.Schema.Context ( Insertion )
21+import qualified Rel8.Schema.Kind as K
22+import Rel8.Schema.Spec ( Spec( Spec ) )
23+import Rel8.Schema.Structure ( Structure, Shape( Column ), Shape1 )
24+
25+
26+type Field :: K.Context -> Labels -> Necessity -> Type -> Type -> Type
27+type family Field labels context necessity db a where
28+ Field Identity _labels _necessity _db a = a
29+ Field Expr _labels _necessity _db a = Expr a
30+ Field Insertion _labels 'Required _db a = Expr a
31+ Field Insertion _labels 'Optional _db a = Maybe (Expr a)
32+ Field Aggregate _labels _necessity _db a = Aggregate (Expr a)
33+ Field Structure labels necessity db a = Shape1 'Column ('Spec labels necessity db a)
34+ Field context _labels _necessity _db a = context a
src/Rel8/Schema/Generic.hsnew file+1047
@@ -0,0 +1,1047 @@
1+{-# language AllowAmbiguousTypes #-}
2+{-# language DataKinds #-}
3+{-# language DisambiguateRecordFields #-}
4+{-# language DefaultSignatures #-}
5+{-# language FlexibleContexts #-}
6+{-# language FlexibleInstances #-}
7+{-# language GADTs #-}
8+{-# language MultiParamTypeClasses #-}
9+{-# language ScopedTypeVariables #-}
10+{-# language StandaloneKindSignatures #-}
11+{-# language TypeApplications #-}
12+{-# language TypeFamilies #-}
13+{-# language TypeOperators #-}
14+{-# language UndecidableInstances #-}
15+{-# language ViewPatterns #-}
16+
17+{-# options_ghc -fno-warn-orphans #-}
18+
19+module Rel8.Schema.Generic
20+ ( Rel8able
21+ )
22+where
23+
24+-- base
25+import Data.Bifunctor ( bimap )
26+import Data.Functor.Identity ( Identity )
27+import Data.Kind ( Constraint, Type )
28+import Data.List.NonEmpty ( NonEmpty )
29+import GHC.Generics
30+ ( Generic, Rep, from, to
31+ , (:*:)( (:*:) ), K1( K1 ), M1( M1 )
32+ , D, C, S
33+ , Meta( MetaSel )
34+ )
35+import GHC.TypeLits ( Symbol, KnownSymbol )
36+import Prelude
37+
38+-- rel8
39+import Rel8.Aggregate ( Aggregate )
40+import Rel8.Expr ( Expr )
41+import Rel8.Kind.Necessity
42+ ( SNecessity( SRequired, SOptional )
43+ , KnownNecessity, necessitySing
44+ )
45+import Rel8.Schema.Context
46+import Rel8.Schema.Context.Identity
47+ ( fromHEitherTable, toHEitherTable
48+ , fromHListTable, toHListTable
49+ , fromHMaybeTable, toHMaybeTable
50+ , fromHNonEmptyTable, toHNonEmptyTable
51+ , fromHTheseTable, toHTheseTable
52+ )
53+import Rel8.Schema.Context.Label
54+ ( Labelable, labeler, unlabeler
55+ , hlabeler, hunlabeler
56+ )
57+import Rel8.Schema.Field ( Field )
58+import Rel8.Schema.HTable ( HTable )
59+import Rel8.Schema.HTable.Either ( HEitherTable )
60+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
61+import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
62+import Rel8.Schema.HTable.List ( HListTable )
63+import Rel8.Schema.HTable.Maybe ( HMaybeTable )
64+import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
65+import Rel8.Schema.HTable.Pair ( HPair(..) )
66+import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
67+import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
68+import Rel8.Schema.HTable.These ( HTheseTable )
69+import Rel8.Schema.HTable.Trio ( HTrio(..) )
70+import Rel8.Schema.HTable.Vectorize ( hrelabel )
71+import qualified Rel8.Schema.Kind as K
72+import Rel8.Schema.Spec ( Spec( Spec ), KTable )
73+import Rel8.Schema.Structure
74+ ( IsStructure, Shape(..), Shape1, Shape2
75+ , Structure
76+ )
77+import Rel8.Table
78+ ( Table, Columns, Context, fromColumns, toColumns
79+ )
80+import Rel8.Table.Either ( EitherTable )
81+import Rel8.Table.Lifted
82+ ( fromColumns1, toColumns1
83+ , fromColumns2, toColumns2
84+ )
85+import Rel8.Table.List ( ListTable )
86+import Rel8.Table.Maybe ( MaybeTable(..) )
87+import Rel8.Table.NonEmpty ( NonEmptyTable )
88+import Rel8.Table.These ( TheseTable )
89+
90+-- these
91+import Data.These ( These )
92+
93+
94+instance (Rel8able t, TableHelper context) => Table context (t context) where
95+ type Columns (t context) = GRep t
96+ type Context (t context) = context
97+ fromColumns = gfromColumns
98+ toColumns = gtoColumns
99+
100+
101+type TableHelper :: K.Context -> Constraint
102+class TableHelper context where
103+ gfromColumns :: Rel8able t => GRep t (Col context) -> t context
104+ gtoColumns :: Rel8able t => t context -> GRep t (Col context)
105+
106+
107+instance TableHelper Aggregate where
108+ gfromColumns = fromAggregateColumns
109+ gtoColumns = toAggregateColumns
110+
111+
112+instance TableHelper Expr where
113+ gfromColumns = fromExprColumns
114+ gtoColumns = toExprColumns
115+
116+
117+instance TableHelper Insertion where
118+ gfromColumns = fromInsertionColumns
119+ gtoColumns = toInsertionColumns
120+
121+
122+instance TableHelper Identity where
123+ gfromColumns = fromIdentityColumns
124+ gtoColumns = toIdentityColumns
125+
126+
127+instance TableHelper Name where
128+ gfromColumns = fromNameColumns
129+ gtoColumns = toNameColumns
130+
131+
132+-- | This type class allows you to define custom 'Table's using higher-kinded
133+-- data types. Higher-kinded data types are data types of the pattern:
134+--
135+-- @
136+-- data MyType f =
137+-- MyType { field1 :: Column f T1 OR HK1 f
138+-- , field2 :: Column f T2 OR HK2 f
139+-- , ...
140+-- , fieldN :: Column f Tn OR HKn f
141+-- }
142+-- @
143+--
144+-- where @Tn@ is any Haskell type, and @HKn@ is any higher-kinded type.
145+--
146+-- That is, higher-kinded data are records where all fields in the record are
147+-- all either of the type @Column f T@ (for any @T@), or are themselves
148+-- higher-kinded data:
149+--
150+-- [Nested]
151+--
152+-- @
153+-- data Nested f =
154+-- Nested { nested1 :: MyType f
155+-- , nested2 :: MyType f
156+-- }
157+-- @
158+--
159+-- The @Rel8able@ type class is used to give us a special mapping operation
160+-- that lets us change the type parameter @f@.
161+--
162+-- [Supplying @Rel8able@ instances]
163+--
164+-- This type class should be derived generically for all table types in your
165+-- project. To do this, enable the @DeriveAnyType@ and @DeriveGeneric@ language
166+-- extensions:
167+--
168+-- @
169+-- \{\-\# LANGUAGE DeriveAnyClass, DeriveGeneric #-\}
170+--
171+-- data MyType f = MyType { fieldA :: Column f T }
172+-- deriving ( GHC.Generics.Generic, Rel8able )
173+-- @
174+type Rel8able :: KTable -> Constraint
175+class HTable (GRep t) => Rel8able t where
176+ type GRep t :: K.HTable
177+
178+ fromAggregateColumns :: GRep t (Col Aggregate) -> t Aggregate
179+ toAggregateColumns :: t Aggregate -> GRep t (Col Aggregate)
180+
181+ fromExprColumns :: GRep t (Col Expr) -> t Expr
182+ toExprColumns :: t Expr -> GRep t (Col Expr)
183+
184+ fromInsertionColumns :: GRep t (Col Insertion) -> t Insertion
185+ toInsertionColumns :: t Insertion -> GRep t (Col Insertion)
186+
187+ fromIdentityColumns :: GRep t (Col Identity) -> t Identity
188+ toIdentityColumns :: t Identity -> GRep t (Col Identity)
189+
190+ fromNameColumns :: GRep t (Col Name) -> t Name
191+ toNameColumns :: t Name -> GRep t (Col Name)
192+
193+ type GRep t = GColumns (Rep (t Structure))
194+
195+ default fromAggregateColumns ::
196+ ( Generic (t Aggregate)
197+ , GColumns (Rep (t Structure)) ~ GRep t
198+ , GRel8able Aggregate (Rep (t Structure)) (Rep (t Aggregate))
199+ ) => GRep t (Col Aggregate) -> t Aggregate
200+ fromAggregateColumns = to . fromGColumns @_ @(Rep (t Structure))
201+
202+ default toAggregateColumns ::
203+ ( Generic (t Aggregate)
204+ , GColumns (Rep (t Structure)) ~ GRep t
205+ , GRel8able Aggregate (Rep (t Structure)) (Rep (t Aggregate))
206+ ) => t Aggregate -> GRep t (Col Aggregate)
207+ toAggregateColumns = toGColumns @_ @(Rep (t Structure)) . from
208+
209+ default fromExprColumns ::
210+ ( Generic (t Expr)
211+ , GColumns (Rep (t Structure)) ~ GRep t
212+ , GRel8able Expr (Rep (t Structure)) (Rep (t Expr))
213+ ) => GRep t (Col Expr) -> t Expr
214+ fromExprColumns = to . fromGColumns @_ @(Rep (t Structure))
215+
216+ default toExprColumns ::
217+ ( Generic (t Expr)
218+ , GColumns (Rep (t Structure)) ~ GRep t
219+ , GRel8able Expr (Rep (t Structure)) (Rep (t Expr))
220+ ) => t Expr -> GRep t (Col Expr)
221+ toExprColumns = toGColumns @_ @(Rep (t Structure)) . from
222+
223+ default fromInsertionColumns ::
224+ ( Generic (t Insertion)
225+ , GColumns (Rep (t Structure)) ~ GRep t
226+ , GRel8able Insertion (Rep (t Structure)) (Rep (t Insertion))
227+ ) => GRep t (Col Insertion) -> t Insertion
228+ fromInsertionColumns = to . fromGColumns @_ @(Rep (t Structure))
229+
230+ default toInsertionColumns ::
231+ ( Generic (t Insertion)
232+ , GColumns (Rep (t Structure)) ~ GRep t
233+ , GRel8able Insertion (Rep (t Structure)) (Rep (t Insertion))
234+ ) => t Insertion -> GRep t (Col Insertion)
235+ toInsertionColumns = toGColumns @_ @(Rep (t Structure)) . from
236+
237+ default fromIdentityColumns ::
238+ ( Generic (t Identity)
239+ , GColumns (Rep (t Structure)) ~ GRep t
240+ , GRel8able Identity (Rep (t Structure)) (Rep (t Identity))
241+ ) => GRep t (Col Identity) -> t Identity
242+ fromIdentityColumns = to . fromGColumns @_ @(Rep (t Structure))
243+
244+ default toIdentityColumns ::
245+ ( Generic (t Identity)
246+ , GColumns (Rep (t Structure)) ~ GRep t
247+ , GRel8able Identity (Rep (t Structure)) (Rep (t Identity))
248+ ) => t Identity -> GRep t (Col Identity)
249+ toIdentityColumns = toGColumns @_ @(Rep (t Structure)) . from
250+
251+ default fromNameColumns ::
252+ ( Generic (t Name)
253+ , GColumns (Rep (t Structure)) ~ GRep t
254+ , GRel8able Name (Rep (t Structure)) (Rep (t Name))
255+ ) => GRep t (Col Name) -> t Name
256+ fromNameColumns = to . fromGColumns @_ @(Rep (t Structure))
257+
258+ default toNameColumns ::
259+ ( Generic (t Name)
260+ , GColumns (Rep (t Structure)) ~ GRep t
261+ , GRel8able Name (Rep (t Structure)) (Rep (t Name))
262+ ) => t Name -> GRep t (Col Name)
263+ toNameColumns = toGColumns @_ @(Rep (t Structure)) . from
264+
265+
266+type GColumns :: (Type -> Type) -> K.HTable
267+type family GColumns structure where
268+ GColumns (M1 D _ structure) = GColumns structure
269+ GColumns (M1 C _ structure) = GColumns structure
270+ GColumns (a :*: b) = HPair (GColumns a) (GColumns b)
271+ GColumns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ structure)) =
272+ K1Columns label structure
273+
274+
275+type GRel8able :: K.Context -> (Type -> Type) -> (Type -> Type) -> Constraint
276+class GRel8able context structure rep where
277+ fromGColumns :: GColumns structure (Col context) -> rep x
278+ toGColumns :: rep x -> GColumns structure (Col context)
279+
280+
281+instance GRel8able context structure rep => GRel8able context (M1 D c structure) (M1 D c rep) where
282+ fromGColumns = M1 . fromGColumns @context @structure @rep
283+ toGColumns (M1 a) = toGColumns @context @structure @rep a
284+
285+
286+instance GRel8able context structure rep => GRel8able context (M1 C c structure) (M1 C c rep) where
287+ fromGColumns = M1 . fromGColumns @context @structure @rep
288+ toGColumns (M1 a) = toGColumns @context @structure @rep a
289+
290+
291+instance (GRel8able context structure1 rep1, GRel8able context structure2 rep2) =>
292+ GRel8able context (structure1 :*: structure2) (rep1 :*: rep2)
293+ where
294+ fromGColumns (HPair a b) =
295+ fromGColumns @context @structure1 @rep1 a :*:
296+ fromGColumns @context @structure2 @rep2 b
297+ toGColumns (a :*: b) =
298+ HPair
299+ (toGColumns @context @structure1 @rep1 a)
300+ (toGColumns @context @structure2 @rep2 b)
301+
302+
303+instance
304+ ( K1Table label context isStructure structure a
305+ , meta ~ 'MetaSel ('Just label) _su _ss _ds
306+ , structureK1 ~ K1 i structure
307+ , k1 ~ K1 i a
308+ ) => GRel8able context (M1 S meta structureK1) (M1 S meta k1)
309+ where
310+ fromGColumns = M1 . K1 . fromK1Columns @label @_ @_ @structure
311+ toGColumns (M1 (K1 a)) = toK1Columns @label @_ @_ @structure a
312+
313+
314+type K1Columns :: Symbol -> Type -> K.HTable
315+type family K1Columns label structure where
316+ K1Columns label (Shape1 'Column ('Spec '[] necessity nullability blueprint)) =
317+ HIdentity ('Spec '[label] necessity nullability blueprint)
318+ K1Columns _label (Shape1 'Column ('Spec (label ': labels) necessity nullability blueprint)) =
319+ HIdentity ('Spec (label ': labels) necessity nullability blueprint)
320+ K1Columns label (Shape2 'Either a b) =
321+ HLabel label (HEitherTable (K1Columns "Left" a) (K1Columns "Right" b))
322+ K1Columns label (Shape1 'List a) = HListTable (K1Columns label a)
323+ K1Columns label (Shape1 'Maybe a) = HLabel label (HMaybeTable (K1Columns "Just" a))
324+ K1Columns label (Shape1 'NonEmpty a) = HNonEmptyTable (K1Columns label a)
325+ K1Columns label (Shape2 'These a b) =
326+ HLabel label (HTheseTable (K1Columns "Here" a) (K1Columns "There" b))
327+ K1Columns label (a, b) =
328+ HLabel label
329+ (HPair
330+ (K1Columns "fst" a)
331+ (K1Columns "snd" b))
332+ K1Columns label (a, b, c) =
333+ HLabel label
334+ (HTrio
335+ (K1Columns "fst" a)
336+ (K1Columns "snd" b)
337+ (K1Columns "trd" c))
338+ K1Columns label (a, b, c, d) =
339+ HLabel label
340+ (HQuartet
341+ (K1Columns "fst" a)
342+ (K1Columns "snd" b)
343+ (K1Columns "trd" c)
344+ (K1Columns "frt" d))
345+ K1Columns label (a, b, c, d, e) =
346+ HLabel label
347+ (HQuintet
348+ (K1Columns "fst" a)
349+ (K1Columns "snd" b)
350+ (K1Columns "trd" c)
351+ (K1Columns "frt" d)
352+ (K1Columns "fft" e))
353+ K1Columns label a = HLabel label (Columns a)
354+
355+
356+type K1Table :: Symbol -> K.Context -> Bool -> Type -> Type -> Constraint
357+class isStructure ~ IsStructure structure =>
358+ K1Table label context isStructure structure a
359+ where
360+ fromK1Columns :: K1Columns label structure (Col context) -> a
361+ toK1Columns :: a -> K1Columns label structure (Col context)
362+
363+
364+instance
365+ ( x ~ Field Aggregate '[] necessity db a
366+ ) => K1Table label Aggregate 'True (Shape1 'Column ('Spec '[] necessity db a)) x
367+ where
368+ fromK1Columns (HIdentity (Aggregation a)) = a
369+ toK1Columns = HIdentity . Aggregation
370+ {-# INLINABLE fromK1Columns #-}
371+ {-# INLINABLE toK1Columns #-}
372+
373+
374+instance
375+ ( x ~ Field Aggregate (label ': labels) necessity db a
376+ ) => K1Table _label Aggregate 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
377+ where
378+ fromK1Columns (HIdentity (Aggregation a)) = a
379+ toK1Columns = HIdentity . Aggregation
380+ {-# INLINABLE fromK1Columns #-}
381+ {-# INLINABLE toK1Columns #-}
382+
383+
384+instance
385+ ( x ~ Field Expr '[] necessity db a
386+ ) => K1Table label Expr 'True (Shape1 'Column ('Spec '[] necessity db a)) x
387+ where
388+ fromK1Columns (HIdentity (DB a)) = a
389+ toK1Columns = HIdentity . DB
390+ {-# INLINABLE fromK1Columns #-}
391+ {-# INLINABLE toK1Columns #-}
392+
393+
394+instance
395+ ( x ~ Field Expr (label ': labels) necessity db a
396+ ) => K1Table _label Expr 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
397+ where
398+ fromK1Columns (HIdentity (DB a)) = a
399+ toK1Columns = HIdentity . DB
400+ {-# INLINABLE fromK1Columns #-}
401+ {-# INLINABLE toK1Columns #-}
402+
403+
404+instance
405+ ( x ~ Field Insertion '[] necessity db a
406+ , KnownNecessity necessity
407+ ) => K1Table label Insertion 'True (Shape1 'Column ('Spec '[] necessity db a)) x
408+ where
409+ fromK1Columns (HIdentity insert) = case insert of
410+ RequiredInsert a -> a
411+ OptionalInsert ma -> ma
412+ toK1Columns a = HIdentity $ case necessitySing @necessity of
413+ SRequired -> RequiredInsert a
414+ SOptional -> OptionalInsert a
415+ {-# INLINABLE fromK1Columns #-}
416+ {-# INLINABLE toK1Columns #-}
417+
418+
419+instance
420+ ( x ~ Field Insertion (label ': labels) necessity db a
421+ , KnownNecessity necessity
422+ ) => K1Table _label Insertion 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
423+ where
424+ fromK1Columns (HIdentity insert) = case insert of
425+ RequiredInsert a -> a
426+ OptionalInsert ma -> ma
427+ toK1Columns a = HIdentity $ case necessitySing @necessity of
428+ SRequired -> RequiredInsert a
429+ SOptional -> OptionalInsert a
430+ {-# INLINABLE fromK1Columns #-}
431+ {-# INLINABLE toK1Columns #-}
432+
433+
434+instance
435+ ( x ~ Field Identity '[] necessity db a
436+ ) => K1Table label Identity 'True (Shape1 'Column ('Spec '[] necessity db a)) x
437+ where
438+ fromK1Columns (HIdentity (Result a)) = a
439+ toK1Columns = HIdentity . Result
440+ {-# INLINABLE fromK1Columns #-}
441+ {-# INLINABLE toK1Columns #-}
442+
443+
444+instance
445+ ( x ~ Field Identity (label ': labels) necessity db a
446+ ) => K1Table _label Identity 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
447+ where
448+ fromK1Columns (HIdentity (Result a)) = a
449+ toK1Columns = HIdentity . Result
450+ {-# INLINABLE fromK1Columns #-}
451+ {-# INLINABLE toK1Columns #-}
452+
453+
454+instance
455+ ( x ~ Field Name '[] necessity db a
456+ ) => K1Table _label Name 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
457+ where
458+ fromK1Columns (HIdentity (NameCol a)) = Name a
459+ toK1Columns (Name a) = HIdentity (NameCol a)
460+ {-# INLINABLE fromK1Columns #-}
461+ {-# INLINABLE toK1Columns #-}
462+
463+
464+instance
465+ ( x ~ Field Name (label ': labels) necessity db a
466+ ) => K1Table label Name 'True (Shape1 'Column ('Spec '[] necessity db a)) x
467+ where
468+ fromK1Columns = Name . (\(NameCol a) -> a) . unlabeler . unHIdentity
469+ toK1Columns = HIdentity . labeler . NameCol . (\(Name a) -> a)
470+ {-# INLINABLE fromK1Columns #-}
471+ {-# INLINABLE toK1Columns #-}
472+
473+
474+instance
475+ ( HTable (K1Columns "Left" structure1)
476+ , HTable (K1Columns "Right" structure2)
477+ , K1Table "Left" Aggregate (IsStructure structure1) structure1 a
478+ , K1Table "Right" Aggregate (IsStructure structure2) structure2 b
479+ , e ~ EitherTable a b
480+ , KnownSymbol label
481+ ) => K1Table label Aggregate 'True (Shape2 'Either structure1 structure2) e
482+ where
483+ fromK1Columns =
484+ fromColumns2
485+ (fromK1Columns @"Left" @_ @_ @structure1)
486+ (fromK1Columns @"Right" @_ @_ @structure2) .
487+ hunlabel unlabeler
488+ toK1Columns =
489+ hlabel labeler .
490+ toColumns2
491+ (toK1Columns @"Left" @_ @_ @structure1)
492+ (toK1Columns @"Right" @_ @_ @structure2)
493+ {-# INLINABLE fromK1Columns #-}
494+ {-# INLINABLE toK1Columns #-}
495+
496+
497+instance
498+ ( HTable (K1Columns "Left" structure1)
499+ , HTable (K1Columns "Right" structure2)
500+ , K1Table "Left" Expr (IsStructure structure1) structure1 a
501+ , K1Table "Right" Expr (IsStructure structure2) structure2 b
502+ , e ~ EitherTable a b
503+ , KnownSymbol label
504+ ) => K1Table label Expr 'True (Shape2 'Either structure1 structure2) e
505+ where
506+ fromK1Columns =
507+ fromColumns2
508+ (fromK1Columns @"Left" @_ @_ @structure1)
509+ (fromK1Columns @"Right" @_ @_ @structure2) .
510+ hunlabel unlabeler
511+ toK1Columns =
512+ hlabel labeler .
513+ toColumns2
514+ (toK1Columns @"Left" @_ @_ @structure1)
515+ (toK1Columns @"Right" @_ @_ @structure2)
516+ {-# INLINABLE fromK1Columns #-}
517+ {-# INLINABLE toK1Columns #-}
518+
519+
520+instance
521+ ( HTable (K1Columns "Left" structure1)
522+ , HTable (K1Columns "Right" structure2)
523+ , K1Table "Left" Insertion (IsStructure structure1) structure1 a
524+ , K1Table "Right" Insertion (IsStructure structure2) structure2 b
525+ , e ~ EitherTable a b
526+ , KnownSymbol label
527+ ) => K1Table label Insertion 'True (Shape2 'Either structure1 structure2) e
528+ where
529+ fromK1Columns =
530+ fromColumns2
531+ (fromK1Columns @"Left" @_ @_ @structure1)
532+ (fromK1Columns @"Right" @_ @_ @structure2) .
533+ hunlabel unlabeler
534+ toK1Columns =
535+ hlabel labeler .
536+ toColumns2
537+ (toK1Columns @"Left" @_ @_ @structure1)
538+ (toK1Columns @"Right" @_ @_ @structure2)
539+ {-# INLINABLE fromK1Columns #-}
540+ {-# INLINABLE toK1Columns #-}
541+
542+
543+instance
544+ ( HTable (K1Columns "Left" structure1)
545+ , HTable (K1Columns "Right" structure2)
546+ , K1Table "Left" Identity (IsStructure structure1) structure1 a
547+ , K1Table "Right" Identity (IsStructure structure2) structure2 b
548+ , e ~ Either a b
549+ , KnownSymbol label
550+ ) => K1Table label Identity 'True (Shape2 'Either structure1 structure2) e
551+ where
552+ fromK1Columns
553+ = bimap
554+ (fromK1Columns @"Left" @_ @_ @structure1)
555+ (fromK1Columns @"Right" @_ @_ @structure2)
556+ . fromHEitherTable
557+ . hunlabel unlabeler
558+ toK1Columns
559+ = hlabel labeler
560+ . toHEitherTable
561+ . bimap
562+ (toK1Columns @"Left" @_ @_ @structure1)
563+ (toK1Columns @"Right" @_ @_ @structure2)
564+ {-# INLINABLE fromK1Columns #-}
565+ {-# INLINABLE toK1Columns #-}
566+
567+
568+instance
569+ ( HTable (K1Columns "Left" structure1)
570+ , HTable (K1Columns "Right" structure2)
571+ , K1Table "Left" Name (IsStructure structure1) structure1 a
572+ , K1Table "Right" Name (IsStructure structure2) structure2 b
573+ , e ~ EitherTable a b
574+ , KnownSymbol label
575+ ) => K1Table label Name 'True (Shape2 'Either structure1 structure2) e
576+ where
577+ fromK1Columns =
578+ fromColumns2
579+ (fromK1Columns @"Left" @_ @_ @structure1)
580+ (fromK1Columns @"Right" @_ @_ @structure2) .
581+ hunlabel unlabeler
582+ toK1Columns =
583+ hlabel labeler .
584+ toColumns2
585+ (toK1Columns @"Left" @_ @_ @structure1)
586+ (toK1Columns @"Right" @_ @_ @structure2)
587+ {-# INLINABLE fromK1Columns #-}
588+ {-# INLINABLE toK1Columns #-}
589+
590+
591+instance
592+ ( Table Aggregate a
593+ , K1Columns label structure ~ HLabel label (Columns a)
594+ , as ~ ListTable a
595+ , KnownSymbol label
596+ ) => K1Table label Aggregate 'True (Shape1 'List structure) as
597+ where
598+ fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
599+ toK1Columns = hrelabel (hlabel hlabeler) . toColumns
600+ {-# INLINABLE fromK1Columns #-}
601+ {-# INLINABLE toK1Columns #-}
602+
603+
604+instance
605+ ( Table Expr a
606+ , K1Columns label structure ~ HLabel label (Columns a)
607+ , as ~ ListTable a
608+ , KnownSymbol label
609+ ) => K1Table label Expr 'True (Shape1 'List structure) as
610+ where
611+ fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
612+ toK1Columns = hrelabel (hlabel hlabeler) . toColumns
613+ {-# INLINABLE fromK1Columns #-}
614+ {-# INLINABLE toK1Columns #-}
615+
616+
617+instance
618+ ( Table Insertion a
619+ , K1Columns label structure ~ HLabel label (Columns a)
620+ , as ~ ListTable a
621+ , KnownSymbol label
622+ ) => K1Table label Insertion 'True (Shape1 'List structure) as
623+ where
624+ fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
625+ toK1Columns = hrelabel (hlabel hlabeler) . toColumns
626+ {-# INLINABLE fromK1Columns #-}
627+ {-# INLINABLE toK1Columns #-}
628+
629+
630+instance
631+ ( K1Table label Identity (IsStructure structure) structure a
632+ , HTable (K1Columns label structure)
633+ , as ~ [a]
634+ ) => K1Table label Identity 'True (Shape1 'List structure) as
635+ where
636+ fromK1Columns = fmap (fromK1Columns @label @_ @_ @structure) . fromHListTable
637+ toK1Columns = toHListTable . fmap (toK1Columns @label @_ @_ @structure)
638+ {-# INLINABLE fromK1Columns #-}
639+ {-# INLINABLE toK1Columns #-}
640+
641+
642+instance
643+ ( Table Name a
644+ , K1Columns label structure ~ HLabel label (Columns a)
645+ , as ~ ListTable a
646+ , KnownSymbol label
647+ ) => K1Table label Name 'True (Shape1 'List structure) as
648+ where
649+ fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
650+ toK1Columns = hrelabel (hlabel hlabeler) . toColumns
651+ {-# INLINABLE fromK1Columns #-}
652+ {-# INLINABLE toK1Columns #-}
653+
654+
655+instance
656+ ( HTable (K1Columns "Just" structure)
657+ , K1Table "Just" Aggregate (IsStructure structure) structure a
658+ , ma ~ MaybeTable a
659+ , KnownSymbol label
660+ ) => K1Table label Aggregate 'True (Shape1 'Maybe structure) ma
661+ where
662+ fromK1Columns =
663+ fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .
664+ hunlabel unlabeler
665+ toK1Columns =
666+ hlabel labeler .
667+ toColumns1 (toK1Columns @"Just" @_ @_ @structure)
668+ {-# INLINABLE fromK1Columns #-}
669+ {-# INLINABLE toK1Columns #-}
670+
671+
672+instance
673+ ( HTable (K1Columns "Just" structure)
674+ , K1Table "Just" Expr (IsStructure structure) structure a
675+ , ma ~ MaybeTable a
676+ , KnownSymbol label
677+ ) => K1Table label Expr 'True (Shape1 'Maybe structure) ma
678+ where
679+ fromK1Columns =
680+ fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .
681+ hunlabel unlabeler
682+ toK1Columns =
683+ hlabel labeler .
684+ toColumns1 (toK1Columns @"Just" @_ @_ @structure)
685+ {-# INLINABLE fromK1Columns #-}
686+ {-# INLINABLE toK1Columns #-}
687+
688+
689+instance
690+ ( HTable (K1Columns "Just" structure)
691+ , K1Table "Just" Insertion (IsStructure structure) structure a
692+ , ma ~ MaybeTable a
693+ , KnownSymbol label
694+ ) => K1Table label Insertion 'True (Shape1 'Maybe structure) ma
695+ where
696+ fromK1Columns =
697+ fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .
698+ hunlabel unlabeler
699+ toK1Columns =
700+ hlabel labeler .
701+ toColumns1 (toK1Columns @"Just" @_ @_ @structure)
702+ {-# INLINABLE fromK1Columns #-}
703+ {-# INLINABLE toK1Columns #-}
704+
705+
706+instance
707+ ( HTable (K1Columns "Just" structure)
708+ , K1Table "Just" Identity (IsStructure structure) structure a
709+ , ma ~ Maybe a
710+ , KnownSymbol label
711+ ) => K1Table label Identity 'True (Shape1 'Maybe structure) ma
712+ where
713+ fromK1Columns
714+ = fmap (fromK1Columns @"Just" @_ @_ @structure)
715+ . fromHMaybeTable
716+ . hunlabel unlabeler
717+ toK1Columns
718+ = hlabel labeler
719+ . toHMaybeTable
720+ . fmap (toK1Columns @"Just" @_ @_ @structure)
721+ {-# INLINABLE fromK1Columns #-}
722+ {-# INLINABLE toK1Columns #-}
723+
724+
725+instance
726+ ( HTable (K1Columns "Just" structure)
727+ , K1Table "Just" Name (IsStructure structure) structure a
728+ , ma ~ MaybeTable a
729+ , KnownSymbol label
730+ ) => K1Table label Name 'True (Shape1 'Maybe structure) ma
731+ where
732+ fromK1Columns =
733+ fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .
734+ hunlabel unlabeler
735+ toK1Columns =
736+ hlabel labeler .
737+ toColumns1 (toK1Columns @"Just" @_ @_ @structure)
738+ {-# INLINABLE fromK1Columns #-}
739+ {-# INLINABLE toK1Columns #-}
740+
741+
742+instance
743+ ( Table Aggregate a
744+ , K1Columns label structure ~ HLabel label (Columns a)
745+ , as ~ NonEmptyTable a
746+ , KnownSymbol label
747+ ) => K1Table label Aggregate 'True (Shape1 'NonEmpty structure) as
748+ where
749+ fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
750+ toK1Columns = hrelabel (hlabel hlabeler) . toColumns
751+ {-# INLINABLE fromK1Columns #-}
752+ {-# INLINABLE toK1Columns #-}
753+
754+
755+instance
756+ ( Table Expr a
757+ , K1Columns label structure ~ HLabel label (Columns a)
758+ , as ~ NonEmptyTable a
759+ , KnownSymbol label
760+ ) => K1Table label Expr 'True (Shape1 'NonEmpty structure) as
761+ where
762+ fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
763+ toK1Columns = hrelabel (hlabel hlabeler) . toColumns
764+ {-# INLINABLE fromK1Columns #-}
765+ {-# INLINABLE toK1Columns #-}
766+
767+
768+instance
769+ ( Table Insertion a
770+ , K1Columns label structure ~ HLabel label (Columns a)
771+ , as ~ NonEmptyTable a
772+ , KnownSymbol label
773+ ) => K1Table label Insertion 'True (Shape1 'NonEmpty structure) as
774+ where
775+ fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
776+ toK1Columns = hrelabel (hlabel hlabeler) . toColumns
777+ {-# INLINABLE fromK1Columns #-}
778+ {-# INLINABLE toK1Columns #-}
779+
780+
781+instance
782+ ( K1Table label Identity (IsStructure structure) structure a
783+ , HTable (K1Columns label structure)
784+ , as ~ NonEmpty a
785+ ) => K1Table label Identity 'True (Shape1 'NonEmpty structure) as
786+ where
787+ fromK1Columns = fmap (fromK1Columns @label @_ @_ @structure) . fromHNonEmptyTable
788+ toK1Columns = toHNonEmptyTable . fmap (toK1Columns @label @_ @_ @structure)
789+ {-# INLINABLE fromK1Columns #-}
790+ {-# INLINABLE toK1Columns #-}
791+
792+
793+instance
794+ ( Table Name a
795+ , K1Columns label structure ~ HLabel label (Columns a)
796+ , as ~ NonEmptyTable a
797+ , KnownSymbol label
798+ ) => K1Table label Name 'True (Shape1 'NonEmpty structure) as
799+ where
800+ fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
801+ toK1Columns = hrelabel (hlabel hlabeler) . toColumns
802+ {-# INLINABLE fromK1Columns #-}
803+ {-# INLINABLE toK1Columns #-}
804+
805+
806+instance
807+ ( HTable (K1Columns "Here" structure1)
808+ , HTable (K1Columns "There" structure2)
809+ , K1Table "Here" Aggregate (IsStructure structure1) structure1 a
810+ , K1Table "There" Aggregate (IsStructure structure2) structure2 b
811+ , e ~ TheseTable a b
812+ , KnownSymbol label
813+ ) => K1Table label Aggregate 'True (Shape2 'These structure1 structure2) e
814+ where
815+ fromK1Columns =
816+ fromColumns2
817+ (fromK1Columns @"Here" @_ @_ @structure1)
818+ (fromK1Columns @"There" @_ @_ @structure2) .
819+ hunlabel unlabeler
820+ toK1Columns =
821+ hlabel labeler .
822+ toColumns2
823+ (toK1Columns @"Here" @_ @_ @structure1)
824+ (toK1Columns @"There" @_ @_ @structure2)
825+ {-# INLINABLE fromK1Columns #-}
826+ {-# INLINABLE toK1Columns #-}
827+
828+
829+instance
830+ ( HTable (K1Columns "Here" structure1)
831+ , HTable (K1Columns "There" structure2)
832+ , K1Table "Here" Expr (IsStructure structure1) structure1 a
833+ , K1Table "There" Expr (IsStructure structure2) structure2 b
834+ , e ~ TheseTable a b
835+ , KnownSymbol label
836+ ) => K1Table label Expr 'True (Shape2 'These structure1 structure2) e
837+ where
838+ fromK1Columns =
839+ fromColumns2
840+ (fromK1Columns @"Here" @_ @_ @structure1)
841+ (fromK1Columns @"There" @_ @_ @structure2) .
842+ hunlabel unlabeler
843+ toK1Columns =
844+ hlabel labeler .
845+ toColumns2
846+ (toK1Columns @"Here" @_ @_ @structure1)
847+ (toK1Columns @"There" @_ @_ @structure2)
848+ {-# INLINABLE fromK1Columns #-}
849+ {-# INLINABLE toK1Columns #-}
850+
851+
852+instance
853+ ( HTable (K1Columns "Here" structure1)
854+ , HTable (K1Columns "There" structure2)
855+ , K1Table "Here" Insertion (IsStructure structure1) structure1 a
856+ , K1Table "There" Insertion (IsStructure structure2) structure2 b
857+ , e ~ TheseTable a b
858+ , KnownSymbol label
859+ ) => K1Table label Insertion 'True (Shape2 'These structure1 structure2) e
860+ where
861+ fromK1Columns =
862+ fromColumns2
863+ (fromK1Columns @"Here" @_ @_ @structure1)
864+ (fromK1Columns @"There" @_ @_ @structure2) .
865+ hunlabel unlabeler
866+ toK1Columns =
867+ hlabel labeler .
868+ toColumns2
869+ (toK1Columns @"Here" @_ @_ @structure1)
870+ (toK1Columns @"There" @_ @_ @structure2)
871+ {-# INLINABLE fromK1Columns #-}
872+ {-# INLINABLE toK1Columns #-}
873+
874+
875+instance
876+ ( HTable (K1Columns "Here" structure1)
877+ , HTable (K1Columns "There" structure2)
878+ , K1Table "Here" Identity (IsStructure structure1) structure1 a
879+ , K1Table "There" Identity (IsStructure structure2) structure2 b
880+ , e ~ These a b
881+ , KnownSymbol label
882+ ) => K1Table label Identity 'True (Shape2 'These structure1 structure2) e
883+ where
884+ fromK1Columns
885+ = bimap
886+ (fromK1Columns @"Here" @_ @_ @structure1)
887+ (fromK1Columns @"There" @_ @_ @structure2)
888+ . fromHTheseTable
889+ . hunlabel unlabeler
890+ toK1Columns
891+ = hlabel labeler
892+ . toHTheseTable
893+ . bimap
894+ (toK1Columns @"Here" @_ @_ @structure1)
895+ (toK1Columns @"There" @_ @_ @structure2)
896+ {-# INLINABLE fromK1Columns #-}
897+ {-# INLINABLE toK1Columns #-}
898+
899+
900+instance
901+ ( HTable (K1Columns "Here" structure1)
902+ , HTable (K1Columns "There" structure2)
903+ , K1Table "Here" Name (IsStructure structure1) structure1 a
904+ , K1Table "There" Name (IsStructure structure2) structure2 b
905+ , e ~ TheseTable a b
906+ , KnownSymbol label
907+ ) => K1Table label Name 'True (Shape2 'These structure1 structure2) e
908+ where
909+ fromK1Columns =
910+ fromColumns2
911+ (fromK1Columns @"Here" @_ @_ @structure1)
912+ (fromK1Columns @"There" @_ @_ @structure2) .
913+ hunlabel unlabeler
914+ toK1Columns =
915+ hlabel labeler .
916+ toColumns2
917+ (toK1Columns @"Here" @_ @_ @structure1)
918+ (toK1Columns @"There" @_ @_ @structure2)
919+ {-# INLINABLE fromK1Columns #-}
920+ {-# INLINABLE toK1Columns #-}
921+
922+
923+instance
924+ ( K1Table "fst" context (IsStructure structure1) structure1 a1
925+ , K1Table "snd" context (IsStructure structure2) structure2 a2
926+ , HTable (K1Columns "fst" structure1)
927+ , HTable (K1Columns "snd" structure2)
928+ , Labelable context
929+ , a ~ (a1, a2)
930+ , KnownSymbol label
931+ ) => K1Table label context 'True (structure1, structure2) a
932+ where
933+ fromK1Columns (hunlabel unlabeler -> (HPair a b)) =
934+ ( fromK1Columns @"fst" @_ @_ @structure1 a
935+ , fromK1Columns @"snd" @_ @_ @structure2 b
936+ )
937+ toK1Columns (a, b) = hlabel labeler $ HPair
938+ { hfst = toK1Columns @"fst" @_ @_ @structure1 a
939+ , hsnd = toK1Columns @"snd" @_ @_ @structure2 b
940+ }
941+ {-# INLINABLE fromK1Columns #-}
942+ {-# INLINABLE toK1Columns #-}
943+
944+
945+instance
946+ ( K1Table "fst" context (IsStructure structure1) structure1 a1
947+ , K1Table "snd" context (IsStructure structure2) structure2 a2
948+ , K1Table "trd" context (IsStructure structure3) structure3 a3
949+ , HTable (K1Columns "fst" structure1)
950+ , HTable (K1Columns "snd" structure2)
951+ , HTable (K1Columns "trd" structure3)
952+ , Labelable context
953+ , a ~ (a1, a2, a3)
954+ , KnownSymbol label
955+ ) => K1Table label context 'True (structure1, structure2, structure3) a
956+ where
957+ fromK1Columns (hunlabel unlabeler -> (HTrio a b c)) =
958+ ( fromK1Columns @"fst" @_ @_ @structure1 a
959+ , fromK1Columns @"snd" @_ @_ @structure2 b
960+ , fromK1Columns @"trd" @_ @_ @structure3 c
961+ )
962+ toK1Columns (a, b, c) = hlabel labeler $ HTrio
963+ { hfst = toK1Columns @"fst" @_ @_ @structure1 a
964+ , hsnd = toK1Columns @"snd" @_ @_ @structure2 b
965+ , htrd = toK1Columns @"trd" @_ @_ @structure3 c
966+ }
967+ {-# INLINABLE fromK1Columns #-}
968+ {-# INLINABLE toK1Columns #-}
969+
970+
971+instance
972+ ( K1Table "fst" context (IsStructure structure1) structure1 a1
973+ , K1Table "snd" context (IsStructure structure2) structure2 a2
974+ , K1Table "trd" context (IsStructure structure3) structure3 a3
975+ , K1Table "frt" context (IsStructure structure3) structure4 a4
976+ , HTable (K1Columns "fst" structure1)
977+ , HTable (K1Columns "snd" structure2)
978+ , HTable (K1Columns "trd" structure3)
979+ , HTable (K1Columns "frt" structure4)
980+ , Labelable context
981+ , a ~ (a1, a2, a3, a4)
982+ , KnownSymbol label
983+ ) => K1Table label context 'True (structure1, structure2, structure3, structure4) a
984+ where
985+ fromK1Columns (hunlabel unlabeler -> (HQuartet a b c d)) =
986+ ( fromK1Columns @"fst" @_ @_ @structure1 a
987+ , fromK1Columns @"snd" @_ @_ @structure2 b
988+ , fromK1Columns @"trd" @_ @_ @structure3 c
989+ , fromK1Columns @"frt" @_ @_ @structure4 d
990+ )
991+ toK1Columns (a, b, c, d) = hlabel labeler $ HQuartet
992+ { hfst = toK1Columns @"fst" @_ @_ @structure1 a
993+ , hsnd = toK1Columns @"snd" @_ @_ @structure2 b
994+ , htrd = toK1Columns @"trd" @_ @_ @structure3 c
995+ , hfrt = toK1Columns @"frt" @_ @_ @structure4 d
996+ }
997+ {-# INLINABLE fromK1Columns #-}
998+ {-# INLINABLE toK1Columns #-}
999+
1000+
1001+instance
1002+ ( K1Table "fst" context (IsStructure structure1) structure1 a1
1003+ , K1Table "snd" context (IsStructure structure2) structure2 a2
1004+ , K1Table "trd" context (IsStructure structure3) structure3 a3
1005+ , K1Table "frt" context (IsStructure structure3) structure4 a4
1006+ , K1Table "fft" context (IsStructure structure3) structure5 a5
1007+ , HTable (K1Columns "fst" structure1)
1008+ , HTable (K1Columns "snd" structure2)
1009+ , HTable (K1Columns "trd" structure3)
1010+ , HTable (K1Columns "frt" structure4)
1011+ , HTable (K1Columns "fft" structure5)
1012+ , Labelable context
1013+ , a ~ (a1, a2, a3, a4, a5)
1014+ , KnownSymbol label
1015+ ) => K1Table label context 'True (structure1, structure2, structure3, structure4, structure5) a
1016+ where
1017+ fromK1Columns (hunlabel unlabeler -> (HQuintet a b c d e)) =
1018+ ( fromK1Columns @"fst" @_ @_ @structure1 a
1019+ , fromK1Columns @"snd" @_ @_ @structure2 b
1020+ , fromK1Columns @"trd" @_ @_ @structure3 c
1021+ , fromK1Columns @"frt" @_ @_ @structure4 d
1022+ , fromK1Columns @"fft" @_ @_ @structure5 e
1023+ )
1024+ toK1Columns (a, b, c, d, e) = hlabel labeler $ HQuintet
1025+ { hfst = toK1Columns @"fst" @_ @_ @structure1 a
1026+ , hsnd = toK1Columns @"snd" @_ @_ @structure2 b
1027+ , htrd = toK1Columns @"trd" @_ @_ @structure3 c
1028+ , hfrt = toK1Columns @"frt" @_ @_ @structure4 d
1029+ , hfft = toK1Columns @"fft" @_ @_ @structure5 e
1030+ }
1031+ {-# INLINABLE fromK1Columns #-}
1032+ {-# INLINABLE toK1Columns #-}
1033+
1034+
1035+instance
1036+ ( IsStructure structure ~ 'False
1037+ , K1Columns label structure ~ HLabel label (Columns structure)
1038+ , Columns structure ~ Columns a
1039+ , Labelable context
1040+ , Table context a
1041+ , KnownSymbol label
1042+ ) => K1Table label context 'False structure a
1043+ where
1044+ fromK1Columns = fromColumns . hunlabel unlabeler
1045+ toK1Columns = hlabel labeler . toColumns
1046+ {-# INLINABLE fromK1Columns #-}
1047+ {-# INLINABLE toK1Columns #-}
src/Rel8/Schema/Generic/Test.hsnew file+79
@@ -0,0 +1,79 @@
1+{-# language DataKinds #-}
2+{-# language DeriveAnyClass #-}
3+{-# language DeriveGeneric #-}
4+{-# language DerivingStrategies #-}
5+{-# language DuplicateRecordFields #-}
6+
7+{-# options_ghc -O0 #-}
8+
9+module Rel8.Schema.Generic.Test
10+ ( module Rel8.Schema.Generic.Test
11+ )
12+where
13+
14+-- base
15+import GHC.Generics ( Generic )
16+import Prelude
17+
18+-- rel8
19+import Rel8.Schema.Column
20+import Rel8.Schema.Generic
21+
22+-- text
23+import Data.Text ( Text )
24+
25+
26+data Table f = Table
27+ { foo :: Column f (Label "blah" Bool)
28+ , bar :: Column f (Maybe Bool)
29+ }
30+ deriving stock Generic
31+ deriving anyclass Rel8able
32+
33+
34+data TablePair f = TablePair
35+ { foo :: Column f (Default Bool)
36+ , bars :: (Column f Text, Column f Text)
37+ }
38+ deriving stock Generic
39+ deriving anyclass Rel8able
40+
41+
42+data TableMaybe f = TableMaybe
43+ { foo :: Column f (Label "ABC" [Maybe Bool])
44+ , bars :: HMaybe f (TablePair f, TablePair f)
45+ }
46+ deriving stock Generic
47+ deriving anyclass Rel8able
48+
49+
50+data TableEither f = TableEither
51+ { foo :: Column f Bool
52+ , bars :: HEither f (HMaybe f (TablePair f, TablePair f)) (Column f (Label "XYZ" Char))
53+ }
54+ deriving stock Generic
55+ deriving anyclass Rel8able
56+
57+
58+data TableThese f = TableThese
59+ { foo :: Column f Bool
60+ , bars :: HThese f (TableMaybe f) (TableEither f)
61+ }
62+ deriving stock Generic
63+ deriving anyclass Rel8able
64+
65+
66+data TableList f = TableList
67+ { foo :: Column f Bool
68+ , bars :: HList f (TableThese f)
69+ }
70+ deriving stock Generic
71+ deriving anyclass Rel8able
72+
73+
74+data TableNonEmpty f = TableNonEmpty
75+ { foo :: Column f Bool
76+ , bars :: HNonEmpty f (TableList f)
77+ }
78+ deriving stock Generic
79+ deriving anyclass Rel8able
src/Rel8/Schema/HTable.hs+38−68
@@ -16,12 +16,13 @@
1616module Rel8.Schema.HTable
1717 ( HTable (HField, HConstrainTable)
1818 , hfield, htabulate, htraverse, hdicts, hspecs
19− , hfoldMap, hmap, htabulateA, htraverseP, htraversePWithField
19+ , htabulateA
20+
21+ , HPair(..)
2022 )
2123where
2224
2325-- base
24−import Data.Functor.Const ( Const( Const ), getConst )
2526import Data.Kind ( Constraint, Type )
2627import Data.Functor.Compose ( Compose( Compose ), getCompose )
2728import Data.Proxy ( Proxy )
@@ -33,21 +34,16 @@ import GHC.Generics
3334 )
3435import Prelude
3536
36−-- profunctors
37−import Data.Profunctor ( rmap, Profunctor (lmap) )
38−
39−-- product-profunctors
40−import Data.Profunctor.Product ( ProductProfunctor ((****)) )
41−
4237-- rel8
4338import Rel8.Schema.Dict ( Dict )
44−import Rel8.Schema.Spec ( Spec )
45−import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
39+import Rel8.Schema.Spec ( Spec, SSpec )
40+import Rel8.Schema.HTable.Pair ( HPair( HPair ) )
4641import qualified Rel8.Schema.Kind as K
4742
4843-- semigroupoids
4944import Data.Functor.Apply ( Apply, (<.>) )
5045
46+
5147-- | A @HTable@ is a functor-indexed/higher-kinded data type that is
5248-- representable ('htabulate'/'hfield'), constrainable ('hdicts'), and
5349-- specified ('hspecs').
@@ -56,14 +52,14 @@ import Data.Functor.Apply ( Apply, (<.>) )
5652-- instances yourself or specify this constraint.
5753type HTable :: K.HTable -> Constraint
5854class HTable t where
59− type HField t = (field :: Type -> Type) | field -> t
60− type HConstrainTable t (c :: Type -> Constraint) :: Constraint
55+ type HField t = (field :: Spec -> Type) | field -> t
56+ type HConstrainTable t (c :: Spec -> Constraint) :: Constraint
6157
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)
58+ hfield :: t context -> HField t spec -> context spec
59+ htabulate :: (forall spec. HField t spec -> context spec) -> t context
60+ htraverse :: Apply m => (forall spec. f spec -> m (g spec)) -> t f -> m (t g)
6561 hdicts :: HConstrainTable t c => t (Dict c)
66− hspecs :: t Spec
62+ hspecs :: t SSpec
6763
6864 type HField t = GHField t
6965 type HConstrainTable t c = HConstrainTable (GHColumns (Rep (t Proxy))) c
@@ -74,7 +70,7 @@ class HTable t where
7470 , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))
7571 , GHTable context (Rep (t context))
7672 )
77− => t context -> HField t a -> context a
73+ => t context -> HField t spec -> context spec
7874 hfield table (GHField field) = hfield (toGHColumns (from table)) field
7975
8076 default htabulate ::
@@ -83,7 +79,7 @@ class HTable t where
8379 , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))
8480 , GHTable context (Rep (t context))
8581 )
86− => (forall a. HField t a -> context a) -> t context
82+ => (forall spec. HField t spec -> context spec) -> t context
8783 htabulate f = to $ fromGHColumns $ htabulate (f . GHField)
8884
8985 default htraverse
@@ -93,7 +89,7 @@ class HTable t where
9389 , Generic (t g), GHTable g (Rep (t g))
9490 , GHColumns (Rep (t f)) ~ GHColumns (Rep (t g))
9591 )
96− => (forall a. f a -> m (g a)) -> t f -> m (t g)
92+ => (forall spec. f spec -> m (g spec)) -> t f -> m (t g)
9793 htraverse f = fmap (to . fromGHColumns) . htraverse f . toGHColumns . from
9894
9995 default hdicts
@@ -107,10 +103,10 @@ class HTable t where
107103 hdicts = to $ fromGHColumns (hdicts @(GHColumns (Rep (t Proxy))) @c)
108104
109105 default hspecs ::
110− ( Generic (t Spec)
111− , GHTable Spec (Rep (t Spec))
106+ ( Generic (t SSpec)
107+ , GHTable SSpec (Rep (t SSpec))
112108 )
113− => t Spec
109+ => t SSpec
114110 hspecs = to $ fromGHColumns hspecs
115111
116112 {-# INLINABLE hfield #-}
@@ -120,43 +116,17 @@ class HTable t where
120116 {-# INLINABLE hspecs #-}
121117
122118
123−hfoldMap :: (HTable t, Semigroup s)
124− => (forall a. context a -> s) -> t context -> s
125−hfoldMap f a = getConst $ htraverse (Const . f) a
126−
127−
128−hmap :: HTable t
129− => (forall a. context a -> context' a) -> t context -> t context'
130−hmap f a = htabulate $ \field -> f (hfield a field)
131−
132−
133119htabulateA :: (HTable t, Apply m)
134− => (forall a. HField t a -> m (context a)) -> m (t context)
120+ => (forall spec. HField t spec -> m (context spec)) -> m (t context)
135121htabulateA f = htraverse getCompose $ htabulate $ Compose . f
136122{-# INLINABLE htabulateA #-}
137123
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)
154124
155−type GHField :: K.HTable -> Type -> Type
156−newtype GHField t a = GHField (HField (GHColumns (Rep (t Proxy))) a)
125+type GHField :: K.HTable -> Spec -> Type
126+newtype GHField t spec = GHField (HField (GHColumns (Rep (t Proxy))) spec)
157127
158128
159−type GHTable :: K.Context -> (Type -> Type) -> Constraint
129+type GHTable :: K.HContext -> (Type -> Type) -> Constraint
160130class HTable (GHColumns rep) => GHTable context rep | rep -> context where
161131 type GHColumns rep :: K.HTable
162132 toGHColumns :: rep x -> GHColumns rep context
@@ -176,30 +146,30 @@ instance HTable table => GHTable context (K1 i (table context)) where
176146
177147
178148instance (GHTable context a, GHTable context b) => GHTable context (a :*: b) where
179− type GHColumns (a :*: b) = HProduct (GHColumns a) (GHColumns b)
180− toGHColumns (a :*: b) = HProduct (toGHColumns a) (toGHColumns b)
181− fromGHColumns (HProduct a b) = fromGHColumns a :*: fromGHColumns b
149+ type GHColumns (a :*: b) = HPair (GHColumns a) (GHColumns b)
150+ toGHColumns (a :*: b) = HPair (toGHColumns a) (toGHColumns b)
151+ fromGHColumns (HPair a b) = fromGHColumns a :*: fromGHColumns b
182152
183153
184−-- | A HField type for indexing into HProduct.
185−type HProductField :: K.HTable -> K.HTable -> Type -> Type
186−data HProductField x y a
187− = HFst (HField x a)
188− | HSnd (HField y a)
154+-- | A HField type for indexing into HPair.
155+type HPairField :: K.HTable -> K.HTable -> Spec -> Type
156+data HPairField x y spec
157+ = HFst (HField x spec)
158+ | HSnd (HField y spec)
189159
190160
191−instance (HTable x, HTable y) => HTable (HProduct x y) where
192− type HConstrainTable (HProduct x y) c = (HConstrainTable x c, HConstrainTable y c)
193− type HField (HProduct x y) = HProductField x y
161+instance (HTable x, HTable y) => HTable (HPair x y) where
162+ type HConstrainTable (HPair x y) c = (HConstrainTable x c, HConstrainTable y c)
163+ type HField (HPair x y) = HPairField x y
194164
195− hfield (HProduct l r) = \case
165+ hfield (HPair l r) = \case
196166 HFst i -> hfield l i
197167 HSnd i -> hfield r i
198168
199− htabulate f = HProduct (htabulate (f . HFst)) (htabulate (f . HSnd))
200− htraverse f (HProduct x y) = HProduct <$> htraverse f x <.> htraverse f y
201− hdicts = HProduct hdicts hdicts
202− hspecs = HProduct hspecs hspecs
169+ htabulate f = HPair (htabulate (f . HFst)) (htabulate (f . HSnd))
170+ htraverse f (HPair x y) = HPair <$> htraverse f x <.> htraverse f y
171+ hdicts = HPair hdicts hdicts
172+ hspecs = HPair hspecs hspecs
203173
204174 {-# INLINABLE hfield #-}
205175 {-# INLINABLE htabulate #-}
src/Rel8/Schema/HTable/Either.hs+6−5
@@ -14,19 +14,20 @@ import GHC.Generics ( Generic )
1414import Prelude ()
1515
1616-- rel8
17+import Rel8.Kind.Necessity ( Necessity( Required ) )
1718import Rel8.Schema.HTable ( HTable )
18−import Rel8.Schema.HTable.Identity ( HIdentity )
19−import Rel8.Schema.HTable.Label ( HLabel )
19+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
2020import Rel8.Schema.HTable.Nullify ( HNullify )
2121import qualified Rel8.Schema.Kind as K
22+import Rel8.Schema.Spec ( Spec( Spec ) )
2223import Rel8.Type.Tag ( EitherTag )
2324
2425
2526type HEitherTable :: K.HTable -> K.HTable -> K.HTable
2627data HEitherTable left right context = HEitherTable
27− { htag :: HLabel "isRight" (HIdentity EitherTag) context
28− , hleft :: HLabel "Left" (HNullify left) context
29− , hright :: HLabel "Right" (HNullify right) context
28+ { htag :: HIdentity ('Spec '["isRight"] 'Required EitherTag EitherTag) context
29+ , hleft :: HNullify left context
30+ , hright :: HNullify right context
3031 }
3132 deriving stock Generic
3233 deriving anyclass HTable
src/Rel8/Schema/HTable/Identity.hs+17−16
@@ -1,17 +1,15 @@
11{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
2+{-# language GADTs #-}
33{-# language StandaloneKindSignatures #-}
44{-# language TypeFamilies #-}
5−{-# language UndecidableInstances #-}
65
76module Rel8.Schema.HTable.Identity
8− ( HIdentity( HIdentity, unHIdentity )
7+ ( HIdentity(..)
98 )
109where
1110
1211-- base
1312import Data.Kind ( Type )
14−import Data.Type.Equality ( (:~:)( Refl ) )
1513import Prelude
1614
1715-- rel8
@@ -21,23 +19,26 @@ import Rel8.Schema.HTable
2119 , hfield, htabulate, htraverse, hdicts, hspecs
2220 )
2321import qualified Rel8.Schema.Kind as K
24−import Rel8.Schema.Null ( Sql )
25−import Rel8.Schema.Spec ( specification )
26−import Rel8.Type ( DBType )
22+import Rel8.Schema.Spec ( Spec, KnownSpec, specSing )
2723
2824
29−type HIdentity :: Type -> K.HTable
30−newtype HIdentity a context = HIdentity
31− { unHIdentity :: context a
25+type HIdentity :: Spec -> K.HTable
26+newtype HIdentity spec context = HIdentity
27+ { unHIdentity :: context spec
3228 }
3329
3430
35−instance Sql DBType a => HTable (HIdentity a) where
36− type HConstrainTable (HIdentity a) constraint = constraint a
37− type HField (HIdentity a) = (:~:) a
31+type HIdentityField :: Spec -> Spec -> Type
32+data HIdentityField _spec spec where
33+ HIdentityField :: HIdentityField spec spec
3834
39− hfield (HIdentity a) Refl = a
40− htabulate f = HIdentity $ f Refl
35+
36+instance KnownSpec spec => HTable (HIdentity spec) where
37+ type HConstrainTable (HIdentity spec) c = c spec
38+ type HField (HIdentity spec) = HIdentityField spec
39+
40+ hfield (HIdentity a) HIdentityField = a
41+ htabulate f = HIdentity $ f HIdentityField
4142 htraverse f (HIdentity a) = HIdentity <$> f a
4243 hdicts = HIdentity Dict
43− hspecs = HIdentity specification
44+ hspecs = HIdentity specSing
src/Rel8/Schema/HTable/Label.hs+51−36
@@ -1,70 +1,85 @@
1+{-# LANGUAGE DeriveAnyClass #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DerivingStrategies #-}
4+{-# LANGUAGE LambdaCase #-}
5+{-# language ConstraintKinds #-}
16{-# language DataKinds #-}
7+{-# language FlexibleInstances #-}
8+{-# language GADTs #-}
9+{-# language InstanceSigs #-}
10+{-# language MultiParamTypeClasses #-}
11+{-# language QuantifiedConstraints #-}
212{-# language RankNTypes #-}
313{-# language RecordWildCards #-}
414{-# language ScopedTypeVariables #-}
515{-# language StandaloneKindSignatures #-}
616{-# language TypeApplications #-}
717{-# language TypeFamilies #-}
18+{-# language TypeOperators #-}
19+{-# language UndecidableInstances #-}
820
921module Rel8.Schema.HTable.Label
10− ( HLabel, hlabel, hrelabel, hunlabel
11− , hproject
22+ ( HLabel
23+ , hlabel, hunlabel
1224 )
1325where
1426
1527-- base
16−import Data.Kind ( Type )
1728import Data.Proxy ( Proxy( Proxy ) )
18−import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
29+import GHC.TypeLits ( KnownSymbol, Symbol )
1930import Prelude
2031
2132-- rel8
33+import Rel8.Kind.Labels ( SLabels( SLabels ) )
2234import Rel8.Schema.HTable
23− ( HTable, HConstrainTable, HField
24− , htabulate, hfield, htraverse, hdicts, hspecs
35+ ( HTable
36+ , hfield, htabulate, hspecs
2537 )
2638import qualified Rel8.Schema.Kind as K
27−import Rel8.Schema.Spec ( Spec(..) )
39+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
40+import Rel8.FCF
41+import Rel8.Schema.HTable.MapTable
42+import GHC.Generics (Generic)
2843
2944
3045type HLabel :: Symbol -> K.HTable -> K.HTable
31−newtype HLabel label table context = HLabel (table context)
46+newtype HLabel label table context = HLabel (HMapTable (Label label) table context)
47+ deriving stock Generic
48+ deriving anyclass HTable
3249
3350
34−type HLabelField :: Symbol -> K.HTable -> Type -> Type
35−newtype HLabelField label table a = HLabelField (HField table a)
51+data Label :: Symbol -> Spec -> Exp Spec
3652
3753
38−instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where
39− type HField (HLabel label table) = HLabelField label table
40− type HConstrainTable (HLabel label table) constraint =
41− HConstrainTable table constraint
54+type instance Eval (Label label ('Spec labels necessity db a)) = 'Spec (label : labels) necessity db a
4255
43− hfield (HLabel a) (HLabelField field) = hfield a field
44− htabulate f = HLabel (htabulate (f . HLabelField))
45− htraverse f (HLabel a) = HLabel <$> htraverse f a
46− hdicts = HLabel (hdicts @table)
47− hspecs = HLabel $ htabulate $ \field -> case hfield (hspecs @table) field of
48− Spec {..} -> Spec {labels = symbolVal (Proxy @label) : labels, ..}
49− {-# INLINABLE hspecs #-}
5056
51−
52−hlabel :: forall label t context. t context -> HLabel label t context
53−hlabel = HLabel
54−{-# INLINABLE hlabel #-}
57+instance KnownSymbol l => MapSpec (Label l) where
58+ mapInfo = \case
59+ SSpec {..} -> SSpec {labels = SLabels Proxy labels, ..}
5560
5661
57−hrelabel :: forall label' label t context. HLabel label t context -> HLabel label' t context
58−hrelabel = hlabel . hunlabel
59−{-# INLINABLE hrelabel #-}
62+hlabel :: (HTable t, KnownSymbol label)
63+ => (forall labels necessity db a. ()
64+ => context ('Spec labels necessity db a)
65+ -> context ('Spec (label ': labels) necessity db a))
66+ -> t context
67+ -> HLabel label t context
68+hlabel labeler a = HLabel $ htabulate $ \(HMapTableField field) ->
69+ case hfield hspecs field of
70+ SSpec {} -> labeler (hfield a field)
71+{-# INLINABLE hlabel #-}
6072
6173
62−hunlabel :: forall label t context. HLabel label t context -> t context
63−hunlabel (HLabel a) = a
74+hunlabel :: (HTable t, KnownSymbol label)
75+ => (forall labels necessity db a. ()
76+ => context ('Spec (label ': labels) necessity db a)
77+ -> context ('Spec labels necessity db a))
78+ -> HLabel label t context
79+ -> t context
80+hunlabel unlabler (HLabel as) =
81+ htabulate $ \field ->
82+ case hfield hspecs field of
83+ SSpec {} -> case hfield as (HMapTableField field) of
84+ a -> unlabler a
6485{-# INLINABLE hunlabel #-}
65−
66−
67−hproject :: ()
68− => (forall ctx. t ctx -> t' ctx)
69− -> HLabel label t context -> HLabel label t' context
70−hproject f (HLabel a) = HLabel (f a)
src/Rel8/Schema/HTable/MapTable.hs+15−37
@@ -2,11 +2,10 @@
22{-# language BlockArguments #-}
33{-# language ConstraintKinds #-}
44{-# language DataKinds #-}
5−{-# language FlexibleInstances #-}
65{-# language GADTs #-}
76{-# language InstanceSigs #-}
87{-# language MultiParamTypeClasses #-}
9−{-# language RankNTypes #-}
8+{-# language PolyKinds #-}
109{-# language ScopedTypeVariables #-}
1110{-# language StandaloneKindSignatures #-}
1211{-# language TypeApplications #-}
@@ -14,43 +13,31 @@
1413{-# language UndecidableInstances #-}
1514{-# language UndecidableSuperClasses #-}
1615
17−module Rel8.Schema.HTable.MapTable
18− ( HMapTable(..)
19− , MapSpec(..)
20− , Precompose(..)
21− , HMapTableField(..)
22− , hproject
23− )
24−where
16+module Rel8.Schema.HTable.MapTable ( HMapTable(..), MapSpec(..), Precompose(..), HMapTableField(..) ) where
2517
2618-- base
2719import Data.Kind ( Constraint, Type )
28−import Prelude
20+import Prelude ( ($), (.), (<$>), fmap )
2921
3022-- rel8
31−import Rel8.FCF ( Exp, Eval )
23+import Rel8.FCF
3224import Rel8.Schema.HTable
33− ( HTable, HConstrainTable, HField
34− , hfield, htabulate, htraverse, hdicts, hspecs
35− )
36−import Rel8.Schema.Spec ( Spec )
25+import Rel8.Schema.Spec ( Spec, SSpec )
3726import qualified Rel8.Schema.Kind as K
3827import Rel8.Schema.Dict ( Dict( Dict ) )
3928
4029
41−type HMapTable :: (Type -> Exp Type) -> K.HTable -> K.HTable
42−newtype HMapTable f t context = HMapTable
43− { unHMapTable :: t (Precompose f context)
44− }
30+type HMapTable :: (a -> Exp b) -> ((a -> Type) -> Type) -> (b -> Type) -> Type
31+data HMapTable f t g where
32+ HMapTable :: { unHMapTable :: t (Precompose f g) } -> HMapTable f t g
4533
4634
47−type Precompose :: (Type -> Exp Type) -> K.Context -> K.Context
48−newtype Precompose f g x = Precompose
49− { precomposed :: g (Eval (f x))
50− }
35+type Precompose :: (a -> Exp b) -> (b -> Type) -> a -> Type
36+newtype Precompose f g x where
37+ Precompose :: { precomposed :: g (Eval (f x)) } -> Precompose f g x
5138
5239
53−type HMapTableField :: (Type -> Exp Type) -> K.HTable -> K.Context
40+type HMapTableField :: (Spec -> Exp a) -> K.HTable -> a -> Type
5441data HMapTableField f t x where
5542 HMapTableField :: HField t a -> HMapTableField f t (Eval (f a))
5643
@@ -70,7 +57,6 @@ instance (HTable t, MapSpec f) => HTable (HMapTable f t) where
7057
7158 htraverse f (HMapTable x) =
7259 HMapTable <$> htraverse (fmap Precompose . f . precomposed) x
73− {-# INLINABLE htraverse #-}
7460
7561 hdicts :: forall c. HConstrainTable (HMapTable f t) c => HMapTable f t (Dict c)
7662 hdicts =
@@ -80,20 +66,12 @@ instance (HTable t, MapSpec f) => HTable (HMapTable f t) where
8066
8167 hspecs =
8268 HMapTable $ htabulate $ Precompose . mapInfo @f . hfield hspecs
83− {-# INLINABLE hspecs #-}
8469
8570
86−type MapSpec :: (Type -> Exp Type) -> Constraint
71+type MapSpec :: (Spec -> Exp Spec) -> Constraint
8772class MapSpec f where
88− mapInfo :: Spec x -> Spec (Eval (f x))
73+ mapInfo :: SSpec x -> SSpec (Eval (f x))
8974
9075
91−type ComposeConstraint :: (Type -> Exp Type) -> (Type -> Constraint) -> Type -> Constraint
76+type ComposeConstraint :: (a -> Exp b) -> (b -> Constraint) -> a -> Constraint
9277class c (Eval (f a)) => ComposeConstraint f c a
93−instance 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+10−5
@@ -1,3 +1,7 @@
1+{-# LANGUAGE NamedFieldPuns #-}
2+{-# LANGUAGE LambdaCase #-}
3+{-# LANGUAGE TypeFamilies #-}
4+{-# LANGUAGE KindSignatures #-}
15{-# language DataKinds #-}
26{-# language DeriveAnyClass #-}
37{-# language DeriveGeneric #-}
@@ -14,18 +18,19 @@ import GHC.Generics ( Generic )
1418import Prelude
1519
1620-- rel8
21+import Rel8.Kind.Necessity ( Necessity( Required ) )
1722import Rel8.Schema.HTable ( HTable )
18−import Rel8.Schema.HTable.Identity ( HIdentity )
19−import Rel8.Schema.HTable.Label ( HLabel )
20−import Rel8.Schema.HTable.Nullify ( HNullify )
23+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
2124import qualified Rel8.Schema.Kind as K
25+import Rel8.Schema.Spec ( Spec( Spec ) )
2226import Rel8.Type.Tag ( MaybeTag )
27+import Rel8.Schema.HTable.Nullify ( HNullify )
2328
2429
2530type HMaybeTable :: K.HTable -> K.HTable
2631data HMaybeTable table context = HMaybeTable
27− { htag :: HLabel "isJust" (HIdentity (Maybe MaybeTag)) context
28− , hjust :: HLabel "Just" (HNullify table) context
32+ { htag :: HIdentity ('Spec '["isJust"] 'Required MaybeTag (Maybe MaybeTag)) context
33+ , hjust :: HNullify table context
2934 }
3035 deriving stock Generic
3136 deriving anyclass HTable
src/Rel8/Schema/HTable/Nullify.hs+45−55
@@ -1,52 +1,47 @@
1+{-# LANGUAGE DeriveAnyClass #-}
2+{-# LANGUAGE DerivingStrategies #-}
3+{-# LANGUAGE DeriveGeneric #-}
4+{-# LANGUAGE NamedFieldPuns #-}
5+{-# LANGUAGE LambdaCase #-}
16{-# language ConstraintKinds #-}
27{-# language DataKinds #-}
3−{-# language DeriveAnyClass #-}
4−{-# language DerivingStrategies #-}
5−{-# language DeriveGeneric #-}
68{-# language FlexibleInstances #-}
79{-# language GADTs #-}
8−{-# language LambdaCase #-}
10+{-# language InstanceSigs #-}
911{-# language MultiParamTypeClasses #-}
10−{-# language NamedFieldPuns #-}
1112{-# language QuantifiedConstraints #-}
1213{-# language RankNTypes #-}
1314{-# language RecordWildCards #-}
1415{-# language ScopedTypeVariables #-}
1516{-# language StandaloneKindSignatures #-}
17+{-# language TypeApplications #-}
1618{-# language TypeFamilies #-}
1719{-# language UndecidableInstances #-}
1820
1921module Rel8.Schema.HTable.Nullify
2022 ( HNullify( HNullify )
2123 , Nullify
22− , hguard
23− , hnulls
24− , hnullify
25− , hunnullify
26− , hproject
24+ , hnulls, hnullify, hunnullify
2725 )
2826where
2927
3028-- base
31−import Data.Kind ( Type )
32−import GHC.Generics ( Generic )
3329import Prelude hiding ( null )
3430
3531-- rel8
36−import Rel8.FCF ( Eval, Exp )
37−import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )
38−import Rel8.Schema.HTable.MapTable
39− ( HMapTable, HMapTableField( HMapTableField )
40− , MapSpec, mapInfo
32+import Rel8.Schema.HTable
33+ ( HTable
34+ , hfield, htabulate, htabulateA, hspecs
4135 )
42−import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )
4336import qualified Rel8.Schema.Kind as K
44−import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
45−import qualified Rel8.Schema.Null as Type ( Nullify )
46−import Rel8.Schema.Spec ( Spec(..) )
37+import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
38+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
4739
4840-- semigroupoids
4941import Data.Functor.Apply ( Apply )
42+import Rel8.Schema.HTable.MapTable
43+import Rel8.FCF
44+import GHC.Generics (Generic)
5045
5146
5247type HNullify :: K.HTable -> K.HTable
@@ -55,63 +50,58 @@ newtype HNullify table context = HNullify (HMapTable Nullify table context)
5550 deriving anyclass HTable
5651
5752
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
53+
54+-- | Transform a 'Spec' by allowing it to be @null@.
55+data Nullify :: Spec -> Exp Spec
56+
57+
58+type instance Eval (Nullify ('Spec labels necessity dbType _)) =
59+ 'Spec labels necessity dbType (Maybe dbType)
6160
6261
6362instance MapSpec Nullify where
6463 mapInfo = \case
65− Spec {nullity, ..} -> Spec
66− { nullity = case nullity of
67− Null -> Null
68− NotNull -> Null
69− , ..
70− }
71−
72−
73−hguard :: HTable t
74− => (forall a. context (Maybe a) -> context (Maybe a))
75− -> HNullify t context -> HNullify t context
76−hguard guarder (HNullify as) = HNullify $ htabulate $ \(HMapTableField field) ->
77− case hfield hspecs field of
78− Spec {nullity} -> case hfield as (HMapTableField field) of
79− a -> case nullity of
80− Null -> guarder a
81− NotNull -> guarder a
64+ SSpec{labels, necessity, info, nullability} -> SSpec
65+ { labels
66+ , necessity
67+ , info
68+ , nullability = case nullability of
69+ Nullable -> Nullable
70+ NonNullable -> Nullable
71+ }
8272
8373
8474hnulls :: HTable t
85− => (forall a. Spec a -> context (Type.Nullify a))
75+ => (forall labels necessity dbType. ()
76+ => context ('Spec labels necessity dbType (Maybe dbType)))
8677 -> HNullify t context
87−hnulls null = HNullify $ htabulate $ \(HMapTableField field) ->
88− case hfield hspecs field of
89− spec@Spec {} -> null spec
78+hnulls null = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
79+ SSpec {} -> null
9080{-# INLINABLE hnulls #-}
9181
9282
9383hnullify :: HTable t
94− => (forall a. Spec a -> context a -> context (Type.Nullify a))
84+ => (forall labels necessity dbType a. ()
85+ => SSpec ('Spec labels necessity dbType a)
86+ -> context ('Spec labels necessity dbType a)
87+ -> context ('Spec labels necessity dbType (Maybe dbType)))
9588 -> t context
9689 -> HNullify t context
9790hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->
9891 case hfield hspecs field of
99− spec@Spec {} -> nullifier spec (hfield a field)
92+ spec@SSpec {} -> nullifier spec (hfield a field)
10093{-# INLINABLE hnullify #-}
10194
10295
10396hunnullify :: (HTable t, Apply m)
104− => (forall a. Spec a -> context (Type.Nullify a) -> m (context a))
97+ => (forall labels necessity dbType a. ()
98+ => SSpec ('Spec labels necessity dbType a)
99+ -> context ('Spec labels necessity dbType (Maybe dbType))
100+ -> m (context ('Spec labels necessity dbType a)))
105101 -> HNullify t context
106102 -> m (t context)
107103hunnullify unnullifier (HNullify as) =
108104 htabulateA $ \field -> case hfield hspecs field of
109− spec@Spec {} -> case hfield as (HMapTableField field) of
105+ spec@SSpec {} -> case hfield as (HMapTableField field) of
110106 a -> unnullifier spec a
111107{-# INLINABLE hunnullify #-}
112−
113−
114−hproject :: ()
115− => (forall ctx. t ctx -> t' ctx)
116− -> HNullify t context -> HNullify t' context
117−hproject f (HNullify a) = HNullify (HMapTable.hproject f a)
src/Rel8/Schema/HTable/Pair.hsnew file+20
@@ -0,0 +1,20 @@
1+{-# language DataKinds #-}
2+{-# language StandaloneKindSignatures #-}
3+
4+module Rel8.Schema.HTable.Pair
5+ ( HPair(..)
6+ )
7+where
8+
9+-- base
10+import Prelude ()
11+
12+-- rel8
13+import qualified Rel8.Schema.Kind as K
14+
15+
16+type HPair :: K.HTable -> K.HTable -> K.HTable
17+data HPair fst snd context = HPair
18+ { hfst :: fst context
19+ , hsnd :: snd context
20+ }
src/Rel8/Schema/HTable/Product.hsdeleted−17
@@ -1,17 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language StandaloneKindSignatures #-}
3−
4−module Rel8.Schema.HTable.Product
5− ( HProduct(..)
6− )
7−where
8−
9−-- base
10−import Prelude ()
11−
12−-- rel8
13−import qualified Rel8.Schema.Kind as K
14−
15−
16−type HProduct :: K.HTable -> K.HTable -> K.HTable
17−data HProduct a b context = HProduct (a context) (b context)
src/Rel8/Schema/HTable/Quartet.hsnew file+29
@@ -0,0 +1,29 @@
1+{-# language DataKinds #-}
2+{-# language DeriveAnyClass #-}
3+{-# language DeriveGeneric #-}
4+{-# language DerivingStrategies #-}
5+{-# language StandaloneKindSignatures #-}
6+
7+module Rel8.Schema.HTable.Quartet
8+ ( HQuartet(..)
9+ )
10+where
11+
12+-- base
13+import GHC.Generics ( Generic )
14+import Prelude ()
15+
16+-- rel8
17+import Rel8.Schema.HTable ( HTable )
18+import qualified Rel8.Schema.Kind as K
19+
20+
21+type HQuartet :: K.HTable -> K.HTable -> K.HTable -> K.HTable -> K.HTable
22+data HQuartet w x y z context = HQuartet
23+ { hfst :: w context
24+ , hsnd :: x context
25+ , htrd :: y context
26+ , hfrt :: z context
27+ }
28+ deriving stock Generic
29+ deriving anyclass HTable
src/Rel8/Schema/HTable/Quintet.hsnew file+30
@@ -0,0 +1,30 @@
1+{-# language DataKinds #-}
2+{-# language DeriveAnyClass #-}
3+{-# language DeriveGeneric #-}
4+{-# language DerivingStrategies #-}
5+{-# language StandaloneKindSignatures #-}
6+
7+module Rel8.Schema.HTable.Quintet
8+ ( HQuintet(..)
9+ )
10+where
11+
12+-- base
13+import GHC.Generics ( Generic )
14+import Prelude ()
15+
16+-- rel8
17+import Rel8.Schema.HTable ( HTable )
18+import qualified Rel8.Schema.Kind as K
19+
20+
21+type HQuintet :: K.HTable -> K.HTable -> K.HTable -> K.HTable -> K.HTable -> K.HTable
22+data HQuintet v w x y z context = HQuintet
23+ { hfst :: v context
24+ , hsnd :: w context
25+ , htrd :: x context
26+ , hfrt :: y context
27+ , hfft :: z context
28+ }
29+ deriving stock Generic
30+ deriving anyclass HTable
src/Rel8/Schema/HTable/These.hs+6−5
@@ -14,20 +14,21 @@ import GHC.Generics ( Generic )
1414import Prelude
1515
1616-- rel8
17+import Rel8.Kind.Necessity ( Necessity( Required ) )
1718import Rel8.Schema.HTable ( HTable )
1819import Rel8.Schema.HTable.Identity ( HIdentity )
19−import Rel8.Schema.HTable.Label ( HLabel )
2020import Rel8.Schema.HTable.Nullify ( HNullify )
2121import qualified Rel8.Schema.Kind as K
22+import Rel8.Schema.Spec ( Spec( Spec ) )
2223import Rel8.Type.Tag ( MaybeTag )
2324
2425
2526type HTheseTable :: K.HTable -> K.HTable -> K.HTable
2627data HTheseTable here there context = HTheseTable
27− { hhereTag :: HLabel "hereTag" (HIdentity (Maybe MaybeTag)) context
28− , hhere :: HLabel "Here" (HNullify here) context
29− , hthereTag :: HLabel "thereTag" (HIdentity (Maybe MaybeTag)) context
30− , hthere :: HLabel "There" (HNullify there) context
28+ { hhereTag :: HIdentity ('Spec '["hasHere"] 'Required MaybeTag (Maybe MaybeTag)) context
29+ , hhere :: HNullify here context
30+ , hthereTag :: HIdentity ('Spec '["hasThere"] 'Required MaybeTag (Maybe MaybeTag)) context
31+ , hthere :: HNullify there context
3132 }
3233 deriving stock Generic
3334 deriving anyclass HTable
src/Rel8/Schema/HTable/Trio.hsnew file+28
@@ -0,0 +1,28 @@
1+{-# language DataKinds #-}
2+{-# language DeriveAnyClass #-}
3+{-# language DeriveGeneric #-}
4+{-# language DerivingStrategies #-}
5+{-# language StandaloneKindSignatures #-}
6+
7+module Rel8.Schema.HTable.Trio
8+ ( HTrio(..)
9+ )
10+where
11+
12+-- base
13+import GHC.Generics ( Generic )
14+import Prelude ()
15+
16+-- rel8
17+import Rel8.Schema.HTable ( HTable )
18+import qualified Rel8.Schema.Kind as K
19+
20+
21+type HTrio :: K.HTable -> K.HTable -> K.HTable -> K.HTable
22+data HTrio x y z context = HTrio
23+ { hfst :: x context
24+ , hsnd :: y context
25+ , htrd :: z context
26+ }
27+ deriving stock Generic
28+ deriving anyclass HTable
src/Rel8/Schema/HTable/Type.hsnew file+55
@@ -0,0 +1,55 @@
1+{-# language DataKinds #-}
2+{-# language GADTs #-}
3+{-# language StandaloneKindSignatures #-}
4+{-# language TypeFamilies #-}
5+{-# language UndecidableInstances #-}
6+
7+module Rel8.Schema.HTable.Type
8+ ( HType(..)
9+ )
10+where
11+
12+-- base
13+import Data.Kind ( Type )
14+import Data.Proxy ( Proxy( Proxy ) )
15+import Prelude
16+
17+-- rel8
18+import Rel8.Kind.Labels ( SLabels( SLabel ) )
19+import Rel8.Kind.Necessity ( Necessity( Required ), SNecessity( SRequired ) )
20+import Rel8.Schema.Dict ( Dict( Dict ) )
21+import Rel8.Schema.HTable
22+ ( HTable, HConstrainTable, HField
23+ , hfield, htabulate, htraverse, hdicts, hspecs
24+ )
25+import qualified Rel8.Schema.Kind as K
26+import Rel8.Schema.Nullability ( Unnullify, Sql, nullabilization )
27+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
28+import Rel8.Type ( DBType, typeInformation )
29+
30+
31+type HType :: Type -> K.HTable
32+newtype HType a context = HType
33+ { unHType :: context ('Spec '[""] 'Required (Unnullify a) a)
34+ }
35+
36+
37+type HTypeField :: Type -> Spec -> Type
38+data HTypeField a spec where
39+ HTypeField :: HTypeField a ('Spec '[""] 'Required (Unnullify a) a)
40+
41+
42+instance Sql DBType a => HTable (HType a) where
43+ type HConstrainTable (HType a) c = c ('Spec '[""] 'Required (Unnullify a) a)
44+ type HField (HType a) = HTypeField a
45+
46+ hfield (HType a) HTypeField = a
47+ htabulate f = HType $ f HTypeField
48+ htraverse f (HType a) = HType <$> f a
49+ hdicts = HType Dict
50+ hspecs = HType SSpec
51+ { labels = SLabel Proxy
52+ , necessity = SRequired
53+ , info = typeInformation
54+ , nullability = nullabilization
55+ }
src/Rel8/Schema/HTable/Vectorize.hs+69−51
@@ -1,74 +1,74 @@
1+{-# LANGUAGE DeriveAnyClass #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DerivingStrategies #-}
4+{-# LANGUAGE LambdaCase #-}
15{-# language AllowAmbiguousTypes #-}
26{-# language ConstraintKinds #-}
37{-# language DataKinds #-}
4−{-# language DeriveAnyClass #-}
5−{-# language DeriveGeneric #-}
6−{-# language DerivingStrategies #-}
78{-# language FlexibleContexts #-}
89{-# language FlexibleInstances #-}
910{-# language GADTs #-}
10−{-# language LambdaCase #-}
11+{-# language InstanceSigs #-}
1112{-# language MultiParamTypeClasses #-}
13+{-# language NamedFieldPuns #-}
14+{-# language QuantifiedConstraints #-}
1215{-# language RankNTypes #-}
1316{-# language RecordWildCards #-}
1417{-# language ScopedTypeVariables #-}
1518{-# language StandaloneKindSignatures #-}
1619{-# language TypeApplications #-}
1720{-# language TypeFamilies #-}
21+{-# language TypeOperators #-}
1822{-# language UndecidableInstances #-}
1923
2024module Rel8.Schema.HTable.Vectorize
2125 ( HVectorize
2226 , hvectorize, hunvectorize
2327 , happend, hempty
24− , hproject
25− , hcolumn
28+ , hrelabel
2629 )
2730where
2831
2932-- base
30−import Data.Kind ( Constraint, Type )
33+import Data.Kind ( Type )
3134import Data.List.NonEmpty ( NonEmpty )
32−import GHC.Generics (Generic)
35+import Data.Type.Equality ( (:~:)( Refl ) )
3336import Prelude
3437
3538-- rel8
36−import Rel8.FCF ( Eval, Exp )
37−import Rel8.Schema.Dict ( Dict( Dict ) )
39+import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )
3840import qualified Rel8.Schema.Kind as K
39−import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )
40−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
41−import Rel8.Schema.HTable.MapTable
42− ( HMapTable( HMapTable ), HMapTableField( HMapTableField )
43− , MapSpec, mapInfo
44− , Precompose( Precompose )
41+import Rel8.Schema.HTable
42+ ( HTable
43+ , hfield, htabulate, htabulateA, hspecs
4544 )
46−import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )
47−import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )
48−import Rel8.Schema.Spec ( Spec(..) )
45+import Rel8.Schema.Nullability ( IsMaybe, Nullability( NonNullable ) )
46+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
4947import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
5048import Rel8.Type.Information ( TypeInformation )
5149
5250-- semialign
53−import Data.Zip ( Unzip, Zip, Zippy(..) )
51+import Data.Zip ( Unzip, Repeat, Zippy(..) )
52+import Rel8.FCF
53+import Rel8.Schema.HTable.MapTable
54+import GHC.Generics (Generic)
5455
5556
56−type Vector :: (Type -> Type) -> Constraint
5757class Vector list where
58− listNotNull :: proxy a -> Dict NotNull (list a)
58+ listIsn'tMaybe :: proxy a -> IsMaybe (list a) :~: 'False
5959 vectorTypeInformation :: ()
60− => Nullity a
61− -> TypeInformation (Unnullify a)
62− -> TypeInformation (list a)
60+ => Nullability a ma
61+ -> TypeInformation a
62+ -> TypeInformation (list ma)
6363
6464
6565instance Vector [] where
66− listNotNull _ = Dict
66+ listIsn'tMaybe _ = Refl
6767 vectorTypeInformation = listTypeInformation
6868
6969
7070instance Vector NonEmpty where
71− listNotNull _ = Dict
71+ listIsn'tMaybe _ = Refl
7272 vectorTypeInformation = nonEmptyTypeInformation
7373
7474
@@ -78,66 +78,84 @@ newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) t
7878 deriving anyclass HTable
7979
8080
81−data Vectorize :: (Type -> Type) -> Type -> Exp Type
81+data Vectorize :: (Type -> Type) -> Spec -> Exp Spec
8282
8383
84−type instance Eval (Vectorize list a) = list a
84+type instance Eval (Vectorize list ('Spec labels necessity _ a)) = 'Spec labels necessity (list a) (list a)
8585
8686
8787instance Vector list => MapSpec (Vectorize list) where
8888 mapInfo = \case
89− Spec {..} -> case listNotNull @list nullity of
90− Dict -> Spec
91− { nullity = NotNull
92− , info = vectorTypeInformation nullity info
89+ SSpec {..} -> case listIsn'tMaybe @list nullability of
90+ Refl -> SSpec
91+ { nullability = NonNullable
92+ , info = vectorTypeInformation nullability info
9393 , ..
9494 }
9595
9696
9797hvectorize :: (HTable t, Unzip f, Vector list)
98− => (forall a. Spec a -> f (context a) -> context' (list a))
98+ => (forall labels necessity db a. ()
99+ => SSpec ('Spec labels necessity db a)
100+ -> f (context ('Spec labels necessity db a))
101+ -> context' ('Spec labels necessity (list a) (list a)))
99102 -> f (t context)
100103 -> HVectorize list t context'
101104hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->
102105 case hfield hspecs field of
103− spec -> vectorizer spec (fmap (`hfield` field) as)
106+ spec@SSpec {} -> vectorizer spec (fmap (`hfield` field) as)
104107{-# INLINABLE hvectorize #-}
105108
106109
107−hunvectorize :: (HTable t, Zip f, Vector list)
108− => (forall a. Spec a -> context (list a) -> f (context' a))
110+hunvectorize :: (HTable t, Repeat f, Vector list)
111+ => (forall labels necessity db a. ()
112+ => SSpec ('Spec labels necessity db a)
113+ -> context ('Spec labels necessity (list a) (list a))
114+ -> f (context' ('Spec labels necessity db a)))
109115 -> HVectorize list t context
110116 -> f (t context')
111117hunvectorize unvectorizer (HVectorize table) =
112118 getZippy $ htabulateA $ \field -> case hfield hspecs field of
113− spec -> case hfield table (HMapTableField field) of
119+ spec@SSpec{} -> case hfield table (HMapTableField field) of
114120 a -> Zippy (unvectorizer spec a)
115121{-# INLINABLE hunvectorize #-}
116122
117123
118−happend :: (HTable t, Vector list)
119− => (forall a. Spec a -> context (list a) -> context (list a) -> context (list a))
124+happend :: (HTable t, Vector list) =>
125+ ( forall labels necessity db a. ()
126+ => Nullability db a
127+ -> TypeInformation db
128+ -> context ('Spec labels necessity (list a) (list a))
129+ -> context ('Spec labels necessity (list a) (list a))
130+ -> context ('Spec labels necessity (list a) (list a))
131+ )
120132 -> HVectorize list t context
121133 -> HVectorize list t context
122134 -> HVectorize list t context
123135happend append (HVectorize as) (HVectorize bs) = HVectorize $
124136 htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of
125137 (a, b) -> case hfield hspecs j of
126− spec -> append spec a b
138+ SSpec {nullability, info} -> append nullability info a b
127139
128140
129−hempty :: HTable t
130− => (forall a. Spec a -> context [a])
141+hempty :: HTable t =>
142+ ( forall labels necessity db a. ()
143+ => Nullability db a
144+ -> TypeInformation db
145+ -> context ('Spec labels necessity [a] [a])
146+ )
131147 -> HVectorize [] t context
132−hempty empty = HVectorize $ htabulate $ \(HMapTableField field) ->
133− empty (hfield hspecs field)
148+hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
149+ SSpec {nullability, info} -> empty nullability info
134150
135151
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)
152+instance HLabelable g => HLabelable (Precompose (Vectorize list) g) where
153+ hlabeler = Precompose . hlabeler . precomposed
154+ hunlabeler = Precompose . hunlabeler . precomposed
140155
141156
142−hcolumn :: HVectorize list (HIdentity a) context -> context (list a)
143−hcolumn (HVectorize (HMapTable (HIdentity (Precompose a)))) = a
157+hrelabel :: HLabelable context
158+ => (forall ctx. HLabelable ctx => t ctx -> u ctx)
159+ -> HVectorize list t context
160+ -> HVectorize list u context
161+hrelabel f (HVectorize (HMapTable table)) = HVectorize (HMapTable (f table))
src/Rel8/Schema/Kind.hs+14−8
@@ -1,9 +1,8 @@
11{-# language StandaloneKindSignatures #-}
22
33module Rel8.Schema.Kind
4− ( Rel8able
5− , Context
6− , HTable
4+ ( Context, Table
5+ , HContext, HTable
76 )
87where
98
@@ -11,14 +10,21 @@ where
1110import Data.Kind ( Type )
1211import Prelude ()
1312
13+-- rel8
14+import Rel8.Schema.Spec ( Spec )
1415
15−type Context :: Type
16−type Context = Type -> Type
16+
17+type HContext :: Type
18+type HContext = Spec -> Type
1719
1820
1921type HTable :: Type
20−type HTable = Context -> Type
22+type HTable = HContext -> Type
23+
24+
25+type Context :: Type
26+type Context = Type -> Type
2127
2228
23−type Rel8able :: Type
24−type Rel8able = Context -> Type
29+type Table :: Type
30+type Table = Context -> Type
src/Rel8/Schema/Name.hsdeleted−77
@@ -1,77 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language DerivingStrategies #-}
3−{-# language FlexibleContexts #-}
4−{-# language FlexibleInstances #-}
5−{-# language GADTs #-}
6−{-# language GeneralizedNewtypeDeriving #-}
7−{-# language MultiParamTypeClasses #-}
8−{-# language RankNTypes #-}
9−{-# language StandaloneKindSignatures #-}
10−{-# language TypeFamilies #-}
11−{-# language UndecidableInstances #-}
12−
13−module Rel8.Schema.Name
14− ( Name(..)
15− , Selects
16− , ppColumn
17− )
18−where
19−
20−-- base
21−import Data.Functor.Identity ( Identity( Identity ) )
22−import Data.Kind ( Constraint, Type )
23−import Data.String ( IsString )
24−import Prelude
25−
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−
33−-- rel8
34−import Rel8.Expr ( Expr )
35−import qualified Rel8.Schema.Kind as K
36−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
37−import Rel8.Schema.Null ( Sql )
38−import Rel8.Table
39− ( Table, Columns, Context, fromColumns, toColumns
40− , FromExprs, fromResult, toResult
41− , Transpose
42− )
43−import Rel8.Table.Transpose ( Transposes )
44−import Rel8.Type ( DBType )
45−
46−
47−-- | A @Name@ is the name of a column, as it would be defined in a table's
48−-- schema definition. You can construct names by using the @OverloadedStrings@
49−-- extension and writing string literals. This is typically done when providing
50−-- a 'TableSchema' value.
51−type Name :: K.Context
52−newtype Name a = Name String
53− deriving stock Show
54− deriving newtype IsString
55−
56−
57−instance Sql DBType a => Table Name (Name a) where
58− type Columns (Name a) = HIdentity a
59− type Context (Name a) = Name
60− type FromExprs (Name a) = a
61− type Transpose to (Name a) = to a
62−
63− toColumns a = HIdentity a
64− fromColumns (HIdentity a) = a
65− toResult a = HIdentity (Identity a)
66− fromResult (HIdentity (Identity a)) = a
67−
68−
69−-- | @Selects a b@ means that @a@ is a schema (i.e., a 'Table' of 'Name's) for
70−-- the 'Expr' columns in @b@.
71−type Selects :: Type -> Type -> Constraint
72−class Transposes Name Expr names exprs => Selects names exprs
73−instance Transposes Name Expr names exprs => Selects names exprs
74−
75−
76−ppColumn :: String -> Doc
77−ppColumn = Opaleye.ppSqlExpr . Opaleye.ColumnSqlExpr . Opaleye.SqlColumn
src/Rel8/Schema/Null.hsdeleted−110
@@ -1,110 +0,0 @@
1−{-# language ConstraintKinds #-}
2−{-# language DataKinds #-}
3−{-# language FlexibleContexts #-}
4−{-# language FlexibleInstances #-}
5−{-# language GADTs #-}
6−{-# language MultiParamTypeClasses #-}
7−{-# language RankNTypes #-}
8−{-# language StandaloneKindSignatures #-}
9−{-# language TypeFamilies #-}
10−{-# language UndecidableInstances #-}
11−{-# language UndecidableSuperClasses #-}
12−
13−module Rel8.Schema.Null
14− ( Nullify, Unnullify
15− , NotNull
16− , Homonullable
17− , Nullity( Null, NotNull )
18− , Nullable, nullable
19− , Sql
20− )
21−where
22−
23−-- base
24−import Data.Kind ( Constraint, Type )
25−import Prelude
26−
27−
28−type IsMaybe :: Type -> Bool
29−type family IsMaybe a where
30− IsMaybe (Maybe _) = 'True
31− IsMaybe _ = 'False
32−
33−
34−type Unnullify' :: Bool -> Type -> Type
35−type family Unnullify' isMaybe ma where
36− Unnullify' 'False a = a
37− Unnullify' 'True (Maybe a) = a
38−
39−
40−type Unnullify :: Type -> Type
41−type Unnullify a = Unnullify' (IsMaybe a) a
42−
43−
44−type Nullify' :: Bool -> Type -> Type
45−type family Nullify' isMaybe a where
46− Nullify' 'False a = a
47− Nullify' 'True a = Maybe a
48−
49−
50−type Nullify :: Type -> Type
51−type Nullify a = Maybe (Unnullify a)
52−
53−
54−-- | @nullify a@ means @a@ cannot take @null@ as a value.
55−type NotNull :: Type -> Constraint
56−class (Nullable a, IsMaybe a ~ 'False) => NotNull a
57−instance (Nullable a, IsMaybe a ~ 'False) => NotNull a
58−
59−
60−-- | @Homonullable a b@ means that both @a@ and @b@ can be @null@, or neither
61−-- @a@ or @b@ can be @null@.
62−type Homonullable :: Type -> Type -> Constraint
63−class IsMaybe a ~ IsMaybe b => Homonullable a b
64−instance IsMaybe a ~ IsMaybe b => Homonullable a b
65−
66−
67−type Nullity :: Type -> Type
68−data Nullity a where
69− NotNull :: NotNull a => Nullity a
70− Null :: NotNull a => Nullity (Maybe a)
71−
72−
73−type Nullable' :: Bool -> Type -> Constraint
74−class
75− ( IsMaybe a ~ isMaybe
76− , IsMaybe (Unnullify a) ~ 'False
77− , Nullify' isMaybe (Unnullify a) ~ a
78− ) => Nullable' isMaybe a
79− where
80− nullable' :: Nullity a
81−
82−
83−instance IsMaybe a ~ 'False => Nullable' 'False a where
84− nullable' = NotNull
85−
86−
87−instance IsMaybe a ~ 'False => Nullable' 'True (Maybe a) where
88− nullable' = Null
89−
90−
91−-- | @Nullable a@ means that @rel8@ is able to check if the type @a@ is a
92−-- type that can take @null@ values or not.
93−type Nullable :: Type -> Constraint
94−class Nullable' (IsMaybe a) a => Nullable a
95−instance Nullable' (IsMaybe a) a => Nullable a
96−
97−
98−nullable :: Nullable a => Nullity a
99−nullable = nullable'
100−
101−
102−-- | The @Sql@ type class describes both null and not null database values,
103−-- constrained by a specific class.
104−--
105−-- For example, if you see @Sql DBEq a@, this means any database type that
106−-- supports equality, and @a@ can either be exactly an @a@, or it could also be
107−-- @Maybe a@.
108−type Sql :: (Type -> Constraint) -> Type -> Constraint
109−class (constraint (Unnullify a), Nullable a) => Sql constraint a
110−instance (constraint (Unnullify a), Nullable a) => Sql constraint a
src/Rel8/Schema/Nullability.hsnew file+106
@@ -0,0 +1,106 @@
1+{-# language ConstraintKinds #-}
2+{-# language DataKinds #-}
3+{-# language FlexibleContexts #-}
4+{-# language FlexibleInstances #-}
5+{-# language FunctionalDependencies #-}
6+{-# language GADTs #-}
7+{-# language MultiParamTypeClasses #-}
8+{-# language QuantifiedConstraints #-}
9+{-# language StandaloneKindSignatures #-}
10+{-# language TypeFamilies #-}
11+{-# language UndecidableInstances #-}
12+{-# language UndecidableSuperClasses #-}
13+
14+module Rel8.Schema.Nullability
15+ ( IsMaybe, Nullify, Unnullify
16+ , Nullability( Nullable, NonNullable )
17+ , Sql
18+ , Nullabilizes, nullabilization
19+ )
20+where
21+
22+-- base
23+import Data.Kind ( Constraint, Type )
24+import Prelude
25+
26+-- rel8
27+import Rel8.Opaque ( Opaque )
28+
29+
30+type IsMaybe :: Type -> Bool
31+type family IsMaybe a where
32+ IsMaybe (Maybe _) = 'True
33+ IsMaybe _ = 'False
34+
35+
36+type Unnullify' :: Bool -> Type -> Type
37+type family Unnullify' isMaybe ma where
38+ Unnullify' 'False a = a
39+ Unnullify' 'True (Maybe a) = a
40+
41+
42+type Unnullify :: Type -> Type
43+type Unnullify a = Unnullify' (IsMaybe a) a
44+
45+
46+type Nullify' :: Bool -> Type -> Type
47+type family Nullify' isMaybe a where
48+ Nullify' 'False a = a
49+ Nullify' 'True a = Maybe a
50+
51+
52+type Nullify :: Type -> Type
53+type Nullify a = Maybe (Unnullify a)
54+
55+
56+type Nullability :: Type -> Type -> Type
57+data Nullability a ma where
58+ NonNullable :: IsMaybe a ~ 'False => Nullability a a
59+ Nullable :: IsMaybe a ~ 'False => Nullability a (Maybe a)
60+
61+
62+type Nullabilizes' :: Bool -> Type -> Type -> Constraint
63+class
64+ ( IsMaybe ma ~ isMaybe
65+ , IsMaybe a ~ 'False
66+ , Unnullify ma ~ a
67+ , Nullify' isMaybe a ~ ma
68+ ) => Nullabilizes' isMaybe a ma | isMaybe ma -> a, isMaybe a -> ma
69+ where
70+ nullabilization' :: Nullability a ma
71+
72+
73+instance IsMaybe a ~ 'False => Nullabilizes' 'False a a where
74+ nullabilization' = NonNullable
75+
76+
77+instance IsMaybe a ~ 'False => Nullabilizes' 'True a (Maybe a) where
78+ nullabilization' = Nullable
79+
80+
81+type Nullabilizes :: Type -> Type -> Constraint
82+class Nullabilizes' (IsMaybe ma) a ma => Nullabilizes a ma
83+instance Nullabilizes' (IsMaybe ma) a ma => Nullabilizes a ma
84+instance {-# OVERLAPPING #-} Nullabilizes Opaque Opaque
85+
86+
87+-- | The @Sql@ type class describes both null and not null database values,
88+-- constrained by a specific class.
89+--
90+-- For example, if you see @Sql DBEq a@, this means any database type that
91+-- supports equality, and @a@ can either be exactly an @a@, or it could also be
92+-- @Maybe a@.
93+type Sql :: (Type -> Constraint) -> Type -> Constraint
94+class
95+ ( (forall c. (forall x. (constraint x => c x)) => Sql c a)
96+ , Nullabilizes (Unnullify a) a
97+ , constraint (Unnullify a)
98+ )
99+ => Sql constraint a
100+instance (constraint db, Nullabilizes db a) => Sql constraint a
101+instance {-# OVERLAPPING #-} (constraint Opaque, Sql constraint Opaque) => Sql constraint Opaque
102+-- instance {-# OVERLAPPING #-} Sql OpaqueC Opaque => Sql OpaqueC Opaque
103+
104+
105+nullabilization :: forall a db. Nullabilizes db a => Nullability db a
106+nullabilization = nullabilization'
src/Rel8/Schema/Result.hsdeleted−54
@@ -1,54 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language GADTs #-}
3−{-# language NamedFieldPuns #-}
4−{-# language StandaloneKindSignatures #-}
5−{-# language TypeFamilies #-}
6−
7−module Rel8.Schema.Result
8− ( Result
9− , null, nullifier, unnullifier
10− , vectorizer, unvectorizer
11− )
12−where
13−
14−-- base
15−import Data.Functor.Identity ( Identity( Identity), runIdentity )
16−import Prelude hiding ( null )
17−
18−-- rel8
19−import Rel8.Schema.Kind ( Context )
20−import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )
21−import Rel8.Schema.Spec ( Spec(..) )
22−
23−
24−-- | The @Result@ context is the context used for decoded query results.
25−--
26−-- When a query is executed against a PostgreSQL database, Rel8 parses the
27−-- returned rows, decoding each row into the @Result@ context.
28−type Result :: Context
29−type Result = Identity
30−
31−
32−null :: Result (Maybe a)
33−null = Identity Nothing
34−
35−
36−nullifier :: Spec a -> Result a -> Result (Nullify a)
37−nullifier Spec {nullity} (Identity a) = Identity $ case nullity of
38− Null -> a
39− NotNull -> Just a
40−
41−
42−unnullifier :: Spec a -> Result (Nullify a) -> Maybe (Result a)
43−unnullifier Spec {nullity} (Identity a) =
44− case nullity of
45− Null -> pure $ Identity a
46− NotNull -> Identity <$> a
47−
48−
49−vectorizer :: Functor f => Spec a -> f (Result a) -> Result (f a)
50−vectorizer _ = Identity . fmap runIdentity
51−
52−
53−unvectorizer :: Functor f => Spec a -> Result (f a) -> f (Result a)
54−unvectorizer _ (Identity results) = Identity <$> results
src/Rel8/Schema/Spec.hs+61−18
@@ -1,34 +1,77 @@
1+{-# language DataKinds #-}
12{-# language FlexibleContexts #-}
2−{-# language MonoLocalBinds #-}
3+{-# language GADTs #-}
34{-# language StandaloneKindSignatures #-}
5+{-# language UndecidableInstances #-}
46
57module Rel8.Schema.Spec
6− ( Spec( Spec, labels, info, nullity )
7− , specification
8+ ( Spec( Spec )
9+ , SSpec( SSpec, labels, necessity, info, nullability )
10+ , KnownSpec( specSing )
11+ , KContext, HKTable
12+ , KTable
813 )
914where
1015
1116-- base
12−import Data.Kind ( Type )
13−import Prelude
17+import Data.Kind ( Constraint, Type )
18+import Prelude ()
1419
1520-- rel8
16−import Rel8.Schema.Null ( Nullity, Sql, Unnullify, nullable )
21+import Rel8.Kind.Labels ( Labels, SLabels, KnownLabels, labelsSing )
22+import Rel8.Kind.Necessity
23+ ( Necessity
24+ , SNecessity
25+ , KnownNecessity, necessitySing
26+ )
27+import Rel8.Schema.Nullability ( Unnullify, Nullability, Sql, nullabilization )
1728import Rel8.Type ( DBType, typeInformation )
1829import Rel8.Type.Information ( TypeInformation )
1930
2031
21−type Spec :: Type -> Type
22−data Spec a = Spec
23− { labels :: [String]
24− , info :: TypeInformation (Unnullify a)
25− , nullity :: Nullity a
26− }
32+type Spec :: Type
33+data Spec = Spec Labels Necessity Type Type
34+
35+
36+type SSpec :: Spec -> Type
37+data SSpec spec where
38+ SSpec ::
39+ { labels :: SLabels labels
40+ , necessity :: SNecessity necessity
41+ , info :: TypeInformation db
42+ , nullability :: Nullability db a
43+ }
44+ -> SSpec ('Spec labels necessity db a)
45+
46+
47+type KnownSpec :: Spec -> Constraint
48+class KnownSpec spec where
49+ specSing :: SSpec spec
50+
51+
52+instance
53+ ( KnownLabels labels
54+ , KnownNecessity necessity
55+ , Sql DBType a
56+ , db ~ Unnullify a
57+ )
58+ => KnownSpec ('Spec labels necessity db a)
59+ where
60+ specSing = SSpec
61+ { labels = labelsSing
62+ , necessity = necessitySing
63+ , info = typeInformation
64+ , nullability = nullabilization
65+ }
66+
67+
68+type KContext :: Type
69+type KContext = Spec -> Type
70+
71+
72+type HKTable :: Type
73+type HKTable = KContext -> Type
2774
2875
29−specification :: Sql DBType a => Spec a
30−specification = Spec
31− { labels = []
32− , info = typeInformation
33− , nullity = nullable
34− }
76+type KTable :: Type
77+type KTable = (Type -> Type) -> Type
src/Rel8/Schema/Spec/ConstrainDBType.hsnew file+34
@@ -0,0 +1,34 @@
1+{-# language ConstraintKinds #-}
2+{-# language DataKinds #-}
3+{-# language FlexibleInstances #-}
4+{-# language MultiParamTypeClasses #-}
5+{-# language QuantifiedConstraints #-}
6+{-# language StandaloneKindSignatures #-}
7+{-# language TypeFamilies #-}
8+{-# language UndecidableInstances #-}
9+
10+module Rel8.Schema.Spec.ConstrainDBType
11+ ( ConstrainDBType
12+ )
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 ConstrainDBType :: (Type -> Constraint) -> Spec -> Constraint
24+class
25+ ( forall labels necessity db a. ()
26+ => (spec ~ 'Spec labels necessity db a)
27+ => constraint db
28+ )
29+ => ConstrainDBType constraint spec
30+instance
31+ ( spec ~ 'Spec labels necessity db a
32+ , constraint db
33+ )
34+ => ConstrainDBType constraint spec
src/Rel8/Schema/Spec/ConstrainType.hsnew file+31
@@ -0,0 +1,31 @@
1+{-# language ConstraintKinds #-}
2+{-# language DataKinds #-}
3+{-# language FlexibleInstances #-}
4+{-# language MultiParamTypeClasses #-}
5+{-# language QuantifiedConstraints #-}
6+{-# language StandaloneKindSignatures #-}
7+{-# language TypeFamilies #-}
8+{-# language UndecidableInstances #-}
9+
10+module Rel8.Schema.Spec.ConstrainType
11+ ( ConstrainType
12+ )
13+where
14+
15+-- base
16+import Data.Kind ( Constraint, Type )
17+import Prelude ()
18+
19+-- rel8
20+import Rel8.Schema.Spec ( Spec( Spec ) )
21+
22+
23+type ConstrainType :: (Type -> Constraint) -> Spec -> Constraint
24+class
25+ ( forall labels necessity db a. ()
26+ => (spec ~ 'Spec labels necessity db a)
27+ => constraint a
28+ ) =>
29+ ConstrainType constraint spec
30+instance (spec ~ 'Spec labels necessity db a, constraint a) =>
31+ ConstrainType constraint spec
src/Rel8/Schema/Structure.hsnew file+54
@@ -0,0 +1,54 @@
1+{-# language DataKinds #-}
2+{-# language StandaloneKindSignatures #-}
3+{-# language PolyKinds #-}
4+{-# language TypeFamilies #-}
5+
6+module Rel8.Schema.Structure
7+ ( Structure
8+ , Shape( Column, Either, List, Maybe, NonEmpty, These )
9+ , Shape1
10+ , Shape2
11+ , IsStructure
12+ )
13+where
14+
15+-- base
16+import Data.Kind ( Type )
17+import Prelude
18+
19+-- rel8
20+import qualified Rel8.Schema.Kind as K
21+import Rel8.Schema.Spec ( Spec )
22+
23+
24+type Structure :: K.Context
25+data Structure a
26+
27+
28+type Shape :: Type
29+data Shape
30+ = Column Spec
31+ | Either Type Type
32+ | List Type
33+ | Maybe Type
34+ | NonEmpty Type
35+ | These Type Type
36+
37+
38+type Shape1 :: (a -> Shape) -> a -> Type
39+data Shape1 shape a
40+
41+
42+type Shape2 :: (a -> b -> Shape) -> a -> b -> Type
43+data Shape2 shape a b
44+
45+
46+type IsStructure :: Type -> Bool
47+type family IsStructure a where
48+ IsStructure (Shape1 _ _) = 'True
49+ IsStructure (Shape2 _ _ _) = 'True
50+ IsStructure (_, _) = 'True
51+ IsStructure (_, _, _) = 'True
52+ IsStructure (_, _, _, _) = 'True
53+ IsStructure (_, _, _, _, _) = 'True
54+ IsStructure _ = 'False
src/Rel8/Schema/Table.hs+14−21
@@ -1,34 +1,34 @@
11{-# language DeriveFunctor #-}
22{-# language DerivingStrategies #-}
3−{-# language DisambiguateRecordFields #-}
4−{-# language NamedFieldPuns #-}
5−{-# language StandaloneKindSignatures #-}
63
74module Rel8.Schema.Table
85 ( TableSchema(..)
9− , ppTable
106 )
117where
128
139-- base
14−import Data.Kind ( Type )
1510import Prelude
1611
17−-- opaleye
18−import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye
19−import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye
20−
21−-- pretty
22−import Text.PrettyPrint ( Doc )
23−
2412
2513-- | The schema for a table. This is used to specify the name and schema that a
2614-- table belongs to (the @FROM@ part of a SQL query), along with the schema of
2715-- the columns within this table.
2816--
2917-- For each selectable table in your database, you should provide a
30−-- @TableSchema@ in order to interact with the table via Rel8.
31−type TableSchema :: Type -> Type
18+-- @TableSchema@ in order to interact with the table via Rel8. For a table
19+-- storing a list of projects (as defined in the introduction):
20+--
21+-- >>> :{
22+-- projectSchema :: TableSchema (Project ColumnSchema)
23+-- projectSchema = TableSchema
24+-- { tableName = "project"
25+-- , tableSchema = Nothing -- Assumes that the 'project' table is reachable from your connection's search_path
26+-- , tableColumns = Project
27+-- { projectAuthorId = "author_id"
28+-- , projectName = "name"
29+-- }
30+-- }
31+-- :}
3232data TableSchema names = TableSchema
3333 { name :: String
3434 -- ^ The name of the table.
@@ -40,10 +40,3 @@ data TableSchema names = TableSchema
4040 -- data type here, parameterized by the 'Rel8.ColumnSchema.ColumnSchema' functor.
4141 }
4242 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+67−36
@@ -1,37 +1,40 @@
11{-# language DuplicateRecordFields #-}
22{-# language GADTs #-}
33{-# language NamedFieldPuns #-}
4−{-# language RankNTypes #-}
5−{-# language RecordWildCards #-}
4+{-# language ScopedTypeVariables #-}
65{-# language StandaloneKindSignatures #-}
7−{-# language StrictData #-}
6+{-# language TypeApplications #-}
87
98module Rel8.Statement.Delete
109 ( Delete(..)
1110 , delete
12− , ppDelete
1311 )
1412where
1513
1614-- base
15+import Control.Exception ( throwIO )
1716import Data.Kind ( Type )
1817import Prelude
1918
2019-- hasql
20+import Hasql.Connection ( Connection )
21+import qualified Hasql.Decoders as Hasql
2122import qualified Hasql.Encoders as Hasql
23+import qualified Hasql.Session as Hasql
2224import qualified Hasql.Statement as Hasql
2325
24−-- pretty
25−import Text.PrettyPrint ( Doc, (<+>), ($$), text )
26+-- opaleye
27+import qualified Opaleye.Internal.Manipulation as Opaleye
2628
2729-- rel8
2830import Rel8.Expr ( Expr )
29−import Rel8.Query ( Query )
30−import Rel8.Schema.Name ( Selects )
31−import Rel8.Schema.Table ( TableSchema, ppTable )
32−import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )
33−import Rel8.Statement.Using ( ppUsing )
34−import Rel8.Statement.Where ( ppWhere )
31+import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
32+import Rel8.Schema.Table ( TableSchema )
33+import Rel8.Statement.Returning ( Returning( NumberOfRowsAffected, Projection ) )
34+import Rel8.Table ( fromColumns, toColumns )
35+import Rel8.Table.Opaleye ( table, unpackspec )
36+import Rel8.Table.Recontextualize ( Selects )
37+import Rel8.Table.Serialize ( Serializable, parse )
3538
3639-- text
3740import qualified Data.Text as Text
@@ -44,10 +47,7 @@ data Delete a where
4447 Delete :: Selects names exprs =>
4548 { from :: TableSchema names
4649 -- ^ Which table to delete from.
47− , using :: Query using
48− -- ^ @USING@ clause — this can be used to join against other tables,
49− -- and its results can be referenced in the @WHERE@ clause
50− , deleteWhere :: using -> exprs -> Expr Bool
50+ , deleteWhere :: exprs -> Expr Bool
5151 -- ^ Which rows should be selected for deletion.
5252 , returning :: Returning names a
5353 -- ^ What to return from the @DELETE@ statement.
@@ -55,25 +55,56 @@ data Delete a where
5555 -> Delete a
5656
5757
58−ppDelete :: Delete a -> Doc
59−ppDelete Delete {..} = case ppUsing using of
60− Nothing ->
61− text "DELETE FROM" <+> ppTable from $$
62− text "WHERE false"
63− Just (usingDoc, i) ->
64− text "DELETE FROM" <+> ppTable from $$
65− usingDoc $$
66− ppWhere from (deleteWhere i) $$
67− ppReturning from returning
58+-- | Run a @DELETE@ statement.
59+--
60+-- >>> mapM_ print =<< select c (each projectSchema)
61+-- Project {projectAuthorId = 1, projectName = "rel8"}
62+-- Project {projectAuthorId = 2, projectName = "aeson"}
63+-- Project {projectAuthorId = 2, projectName = "text"}
64+--
65+-- >>> :{
66+-- delete c Delete
67+-- { from = projectSchema
68+-- , deleteWhere = \p -> projectName p ==. lit "rel8"
69+-- , returning = Projection projectName
70+-- }
71+-- :}
72+-- ["rel8"]
73+--
74+-- >>> mapM_ print =<< select c (each projectSchema)
75+-- Project {projectAuthorId = 2, projectName = "aeson"}
76+-- Project {projectAuthorId = 2, projectName = "text"}
77+delete :: Connection -> Delete a -> IO a
78+delete c Delete {from, deleteWhere, returning} =
79+ case returning of
80+ NumberOfRowsAffected -> Hasql.run session c >>= either throwIO pure
81+ where
82+ session = Hasql.statement () statement
83+ statement = Hasql.Statement bytes params decode prepare
84+ bytes = encodeUtf8 $ Text.pack sql
85+ params = Hasql.noParams
86+ decode = Hasql.rowsAffected
87+ prepare = False
88+ sql = Opaleye.arrangeDeleteSql from' where'
89+ where
90+ from' = table $ toColumns <$> from
91+ where' = toColumn . toPrimExpr . deleteWhere . fromColumns
6892
69−
70−-- | Run a 'Delete' statement.
71−delete :: Delete a -> Hasql.Statement () a
72−delete d@Delete {returning} = Hasql.Statement bytes params decode prepare
93+ Projection project -> Hasql.run session c >>= either throwIO pure
94+ where
95+ session = Hasql.statement () statement
96+ statement = Hasql.Statement bytes params decode prepare
97+ bytes = encodeUtf8 $ Text.pack sql
98+ params = Hasql.noParams
99+ decode = decoder project
100+ prepare = False
101+ sql =
102+ Opaleye.arrangeDeleteReturningSql unpackspec from' where' project'
103+ where
104+ from' = table $ toColumns <$> from
105+ where' = toColumn . toPrimExpr . deleteWhere . fromColumns
106+ project' = toColumns . project . fromColumns
73107 where
74− bytes = encodeUtf8 $ Text.pack sql
75− params = Hasql.noParams
76− decode = decodeReturning returning
77− prepare = False
78− sql = show doc
79− doc = ppDelete d
108+ decoder :: forall exprs projection a. Serializable projection a
109+ => (exprs -> projection) -> Hasql.Result [a]
110+ decoder _ = Hasql.rowList (parse @projection @a)
src/Rel8/Statement/Insert.hs+81−44
@@ -2,42 +2,39 @@
22{-# language FlexibleContexts #-}
33{-# language GADTs #-}
44{-# language NamedFieldPuns #-}
5−{-# language RecordWildCards #-}
5+{-# language ScopedTypeVariables #-}
66{-# language StandaloneKindSignatures #-}
7−{-# language StrictData #-}
7+{-# language TypeApplications #-}
88
99module Rel8.Statement.Insert
1010 ( Insert(..)
11+ , OnConflict(..)
1112 , insert
12− , ppInsert
13− , ppInto
1413 )
1514where
1615
1716-- base
18−import Data.Foldable ( toList )
17+import Control.Exception ( throwIO )
1918import Data.Kind ( Type )
19+import Data.List.NonEmpty ( NonEmpty( (:|) ) )
2020import Prelude
2121
2222-- hasql
23+import Hasql.Connection ( Connection )
24+import qualified Hasql.Decoders as Hasql
2325import qualified Hasql.Encoders as Hasql
26+import qualified Hasql.Session as Hasql
2427import qualified Hasql.Statement as Hasql
2528
26−-- opaleye
27−import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye
28−
29−-- pretty
30−import Text.PrettyPrint ( Doc, (<+>), ($$), parens, text )
31−
3229-- rel8
33−import Rel8.Query ( Query )
34−import Rel8.Schema.Name ( Name, Selects, ppColumn )
35−import Rel8.Schema.Table ( TableSchema(..), ppTable )
36−import Rel8.Statement.OnConflict ( OnConflict, ppOnConflict )
37−import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )
38−import Rel8.Statement.Select ( ppRows )
39−import Rel8.Table ( Table )
40−import Rel8.Table.Name ( showNames )
30+import qualified Opaleye.Internal.Manipulation as Opaleye
31+import qualified Opaleye.Manipulation as Opaleye
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 ( table, unpackspec )
36+import Rel8.Table.Recontextualize ( Inserts, Selects )
37+import Rel8.Table.Serialize ( Serializable, parse )
4138
4239-- text
4340import qualified Data.Text as Text ( pack )
@@ -47,13 +44,12 @@ import Data.Text.Encoding ( encodeUtf8 )
4744-- | The constituent parts of a SQL @INSERT@ statement.
4845type Insert :: Type -> Type
4946data Insert a where
50− Insert :: Selects names exprs =>
47+ Insert :: (Selects names exprs, Inserts exprs inserts) =>
5148 { into :: TableSchema names
5249 -- ^ Which table to insert into.
53− , rows :: Query exprs
54− -- ^ The rows to insert. This can be an arbitrary query — use
55− -- 'Rel8.values' insert a static list of rows.
56− , onConflict :: OnConflict names
50+ , rows :: [inserts]
51+ -- ^ The rows to insert.
52+ , onConflict :: OnConflict
5753 -- ^ What to do if the inserted rows conflict with data already in the
5854 -- table.
5955 , returning :: Returning names a
@@ -62,28 +58,69 @@ data Insert a where
6258 -> Insert a
6359
6460
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
61+-- | @OnConflict@ allows you to add an @ON CONFLICT@ clause to an @INSERT@
62+-- statement.
63+data OnConflict
64+ = Abort -- ^ @ON CONFLICT ABORT@
65+ | DoNothing -- ^ @ON CONFLICT DO NOTHING@
7266
7367
74−ppInto :: Table Name a => TableSchema a -> Doc
75−ppInto table@TableSchema {columns} =
76− ppTable table <+>
77− parens (Opaleye.commaV ppColumn (toList (showNames columns)))
68+-- | Run an @INSERT@ statement
69+--
70+-- >>> :{
71+-- insert c Insert
72+-- { into = authorSchema
73+-- , rows = [ lit Author{ authorName = "Gabriel Gonzales", authorId = AuthorId 4, authorUrl = Just "https://haskellforall.com" } ]
74+-- , onConflict = Abort
75+-- , returning = NumberOfRowsAffected
76+-- }
77+-- :}
78+-- 1
79+insert :: Connection -> Insert a -> IO a
80+insert c Insert {into, rows, onConflict, returning} =
81+ case (rows, returning) of
82+ ([], NumberOfRowsAffected) -> pure 0
83+ ([], Projection _) -> pure []
7884
85+ (x:xs, NumberOfRowsAffected) -> Hasql.run session c >>= either throwIO pure
86+ where
87+ session = Hasql.statement () statement
88+ statement = Hasql.Statement bytes params decode prepare
89+ bytes = encodeUtf8 $ Text.pack sql
90+ params = Hasql.noParams
91+ decode = Hasql.rowsAffected
92+ prepare = False
93+ sql = Opaleye.arrangeInsertManySql into' rows' onConflict'
94+ where
95+ into' = table $ toColumns <$> into
96+ rows' = toColumns <$> x :| xs
97+
98+ (x:xs, Projection project) -> Hasql.run session c >>= either throwIO pure
99+ where
100+ session = Hasql.statement () statement
101+ statement = Hasql.Statement bytes params decode prepare
102+ bytes = encodeUtf8 $ Text.pack sql
103+ params = Hasql.noParams
104+ decode = decoder project
105+ prepare = False
106+ sql =
107+ Opaleye.arrangeInsertManyReturningSql
108+ unpackspec
109+ into'
110+ rows'
111+ project'
112+ onConflict'
113+ where
114+ into' = table $ toColumns <$> into
115+ rows' = toColumns <$> x :| xs
116+ project' = toColumns . project . fromColumns
79117
80−-- | Run an 'Insert' statement.
81−insert :: Insert a -> Hasql.Statement () a
82−insert i@Insert {returning} = Hasql.Statement bytes params decode prepare
83118 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
119+ onConflict' =
120+ case onConflict of
121+ DoNothing -> Just Opaleye.DoNothing
122+ Abort -> Nothing
123+
124+ decoder :: forall exprs projection a. Serializable projection a
125+ => (exprs -> projection) -> Hasql.Result [a]
126+ decoder _ = Hasql.rowList (parse @projection @a)
src/Rel8/Statement/OnConflict.hsdeleted−106
@@ -1,106 +0,0 @@
1−{-# language DuplicateRecordFields #-}
2−{-# language FlexibleContexts #-}
3−{-# language GADTs #-}
4−{-# language LambdaCase #-}
5−{-# language NamedFieldPuns #-}
6−{-# language RecordWildCards #-}
7−{-# language StandaloneKindSignatures #-}
8−{-# language StrictData #-}
9−
10−module Rel8.Statement.OnConflict
11− ( OnConflict(..)
12− , Upsert(..)
13− , ppOnConflict
14− )
15−where
16−
17−-- base
18−import Data.Foldable ( toList )
19−import Data.Kind ( Type )
20−import Prelude
21−
22−-- opaleye
23−import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye
24−
25−-- pretty
26−import Text.PrettyPrint ( Doc, (<+>), ($$), parens, text )
27−
28−-- rel8
29−import Rel8.Expr ( Expr )
30−import Rel8.Schema.Name ( Name, Selects, ppColumn )
31−import Rel8.Schema.Table ( TableSchema(..) )
32−import Rel8.Statement.Set ( ppSet )
33−import Rel8.Statement.Where ( ppWhere )
34−import Rel8.Table ( Table, toColumns )
35−import Rel8.Table.Cols ( Cols( Cols ) )
36−import Rel8.Table.Name ( showNames )
37−import Rel8.Table.Opaleye ( attributes )
38−import Rel8.Table.Projection ( Projecting, Projection, apply )
39−
40−
41−-- | 'OnConflict' represents the @ON CONFLICT@ clause of an @INSERT@
42−-- statement. This specifies what ought to happen when one or more of the
43−-- rows proposed for insertion conflict with an existing row in the table.
44−type OnConflict :: Type -> Type
45−data OnConflict names
46− = Abort
47− -- ^ Abort the transaction if there are conflicting rows (Postgres' default)
48− | DoNothing
49− -- ^ @ON CONFLICT DO NOTHING@
50− | DoUpdate (Upsert names)
51− -- ^ @ON CONFLICT DO UPDATE@
52−
53−
54−-- | The @ON CONFLICT (...) DO UPDATE@ clause of an @INSERT@ statement, also
55−-- known as \"upsert\".
56−--
57−-- When an existing row conflicts with a row proposed for insertion,
58−-- @ON CONFLICT DO UPDATE@ allows you to instead update this existing row. The
59−-- conflicting row proposed for insertion is then \"excluded\", but its values
60−-- can still be referenced from the @SET@ and @WHERE@ clauses of the @UPDATE@
61−-- statement.
62−--
63−-- Upsert in Postgres requires an explicit set of \"conflict targets\" — the
64−-- set of columns comprising the @UNIQUE@ index from conflicts with which we
65−-- would like to recover.
66−type Upsert :: Type -> Type
67−data Upsert names where
68− Upsert :: (Selects names exprs, Projecting names index, excluded ~ exprs) =>
69− { index :: Projection names index
70− -- ^ The set of conflict targets, projected from the set of columns for
71− -- the whole table
72− , set :: excluded -> exprs -> exprs
73− -- ^ How to update each selected row.
74− , updateWhere :: excluded -> exprs -> Expr Bool
75− -- ^ Which rows to select for update.
76− }
77− -> Upsert names
78−
79−
80−ppOnConflict :: TableSchema names -> OnConflict names -> Doc
81−ppOnConflict schema = \case
82− Abort -> mempty
83− DoNothing -> text "ON CONFLICT DO NOTHING"
84− DoUpdate upsert -> ppUpsert schema upsert
85−
86−
87−ppUpsert :: TableSchema names -> Upsert names -> Doc
88−ppUpsert schema@TableSchema {columns} Upsert {..} =
89− text "ON CONFLICT" <+>
90− ppIndex schema index <+>
91− text "DO UPDATE" $$
92− ppSet schema (set excluded) $$
93− ppWhere schema (updateWhere excluded)
94− where
95− excluded = attributes TableSchema
96− { schema = Nothing
97− , name = "excluded"
98− , columns
99− }
100−
101−
102−ppIndex :: (Table Name names, Projecting names index)
103− => TableSchema names -> Projection names index -> Doc
104−ppIndex TableSchema {columns} index =
105− parens $ Opaleye.commaV ppColumn $ toList $
106− showNames $ Cols $ apply index $ toColumns columns
src/Rel8/Statement/Returning.hs+11−115
@@ -1,133 +1,29 @@
11{-# language GADTs #-}
2−{-# language LambdaCase #-}
3−{-# language NamedFieldPuns #-}
4−{-# language RankNTypes #-}
5−{-# language ScopedTypeVariables #-}
62{-# language StandaloneKindSignatures #-}
7−{-# language StrictData #-}
8−{-# language TypeApplications #-}
93
104module Rel8.Statement.Returning
11− ( Returning( NumberOfRowsAffected, Projection )
12− , decodeReturning
13− , ppReturning
5+ ( Returning(..)
146 )
157where
168
179-- base
18−import Control.Applicative ( liftA2 )
19−import Data.Foldable ( toList )
2010import Data.Int ( Int64 )
2111import Data.Kind ( Type )
22−import Data.List.NonEmpty ( NonEmpty )
23−import Prelude
24−
25−-- hasql
26−import qualified Hasql.Decoders as Hasql
27−
28−-- opaleye
29−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
30−import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye
31−import qualified Opaleye.Internal.Sql as Opaleye
32−
33−-- pretty
34−import Text.PrettyPrint ( Doc, (<+>), text )
12+import Prelude ()
3513
3614-- rel8
37−import Rel8.Schema.Name ( Selects )
38−import Rel8.Schema.Table ( TableSchema(..) )
39−import Rel8.Table.Opaleye ( castTable, exprs, view )
40−import Rel8.Table.Serialize ( Serializable, parse )
15+import Rel8.Table.Recontextualize ( Selects )
16+import Rel8.Table.Serialize ( Serializable )
4117
42−-- semigropuoids
43−import Data.Functor.Apply ( Apply, (<.>) )
4418
45−
46−-- | 'Rel8.Insert', 'Rel8.Update' and 'Rel8.Delete' all support returning either
47−-- the number of rows affected, or the actual rows modified.
19+-- | @INSERT@, @UPDATE@ and @DELETE@ all support returning either the number of
20+-- rows affected, or the actual rows modified. 'Projection' allows you to
21+-- project out of these returned rows, which can be useful if you want to log
22+-- exactly which rows were deleted, or to view a generated id (for example, if
23+-- using a column with an autoincrementing counter as a default value).
4824type Returning :: Type -> Type -> Type
4925data Returning names a where
50− Pure :: a -> Returning names a
51− Ap :: Returning names (a -> b) -> Returning names a -> Returning names b
52−
53− -- | Return the number of rows affected.
5426 NumberOfRowsAffected :: Returning names Int64
55−
56− -- | 'Projection' allows you to project out of the affected rows, which can
57− -- be useful if you want to log exactly which rows were deleted, or to view
58− -- a generated id (for example, if using a column with an autoincrementing
59− -- counter via 'Rel8.nextval').
60− Projection :: (Selects names exprs, Serializable returning a)
61− => (exprs -> returning)
27+ Projection :: (Selects names exprs, Serializable projection a)
28+ => (exprs -> projection)
6229 -> Returning names [a]
63−
64−
65−instance Functor (Returning names) where
66− fmap f = \case
67− Pure a -> Pure (f a)
68− Ap g a -> Ap (fmap (f .) g) a
69− m -> Ap (Pure f) m
70−
71−
72−instance Apply (Returning names) where
73− (<.>) = Ap
74−
75−
76−instance Applicative (Returning names) where
77− pure = Pure
78− (<*>) = Ap
79−
80−
81−projections :: ()
82− => TableSchema names -> Returning names a -> Maybe (NonEmpty Opaleye.PrimExpr)
83−projections schema@TableSchema {columns} = \case
84− Pure _ -> Nothing
85− Ap f a -> projections schema f <> projections schema a
86− NumberOfRowsAffected -> Nothing
87− Projection f -> Just (exprs (castTable (f (view columns))))
88−
89−
90−runReturning :: ()
91− => ((Int64 -> a) -> r)
92− -> (forall x. Hasql.Row x -> ([x] -> a) -> r)
93− -> Returning names a
94− -> r
95−runReturning rowCount rowList = \case
96− Pure a -> rowCount (const a)
97− Ap fs as ->
98− runReturning
99− (\withCount ->
100− runReturning
101− (\withCount' -> rowCount (withCount <*> withCount'))
102− (\decoder -> rowList decoder . liftA2 withCount length64)
103− as)
104− (\decoder withRows ->
105− runReturning
106− (\withCount -> rowList decoder $ withRows <*> withCount . length64)
107− (\decoder' withRows' ->
108− rowList (liftA2 (,) decoder decoder') $
109− withRows <$> fmap fst <*> withRows' . fmap snd)
110− as)
111− fs
112− NumberOfRowsAffected -> rowCount id
113− Projection (_ :: exprs -> returning) -> rowList decoder' id
114− where
115− decoder' = parse @returning
116− where
117− length64 :: Foldable f => f x -> Int64
118− length64 = fromIntegral . length
119−
120−
121−decodeReturning :: Returning names a -> Hasql.Result a
122−decodeReturning = runReturning
123− (<$> Hasql.rowsAffected)
124− (\decoder withRows -> withRows <$> Hasql.rowList decoder)
125−
126−
127−ppReturning :: TableSchema names -> Returning names a -> Doc
128−ppReturning schema returning = case projections schema returning of
129− Nothing -> mempty
130− Just columns ->
131− text "RETURNING" <+> Opaleye.commaV Opaleye.ppSqlExpr (toList sqlExprs)
132− where
133− sqlExprs = Opaleye.sqlExpr <$> columns
src/Rel8/Statement/SQL.hsdeleted−29
@@ -1,29 +0,0 @@
1−module Rel8.Statement.SQL
2− ( showDelete
3− , showInsert
4− , showUpdate
5− )
6−where
7−
8−-- base
9−import Prelude
10−
11−-- rel8
12−import Rel8.Statement.Delete ( Delete, ppDelete )
13−import Rel8.Statement.Insert ( Insert, ppInsert )
14−import Rel8.Statement.Update ( Update, ppUpdate )
15−
16−
17−-- | Convert a 'Delete' to a 'String' containing a @DELETE@ statement.
18−showDelete :: Delete a -> String
19−showDelete = show . ppDelete
20−
21−
22−-- | Convert an 'Insert' to a 'String' containing an @INSERT@ statement.
23−showInsert :: Insert a -> String
24−showInsert = show . ppInsert
25−
26−
27−-- | Convert an 'Update' to a 'String' containing an @UPDATE@ statement.
28−showUpdate :: Update a -> String
29−showUpdate = show . ppUpdate
src/Rel8/Statement/Select.hs+36−122
@@ -1,147 +1,61 @@
1−{-# language DeriveTraversable #-}
2−{-# language DerivingStrategies #-}
3−{-# language FlexibleContexts #-}
4−{-# language MonoLocalBinds #-}
51{-# language ScopedTypeVariables #-}
6−{-# language StandaloneKindSignatures #-}
72{-# language TypeApplications #-}
83
94module Rel8.Statement.Select
105 ( select
11− , ppSelect
12−
13− , Optimized(..)
14− , ppPrimSelect
15− , ppRows
6+ , selectWithNames
167 )
178where
189
1910-- base
20−import Data.Foldable ( toList )
21−import Data.Kind ( Type )
22−import Data.Void ( Void )
23−import Prelude hiding ( undefined )
11+import Control.Exception ( throwIO )
12+import Prelude
2413
2514-- hasql
15+import Hasql.Connection ( Connection )
2616import qualified Hasql.Decoders as Hasql
2717import qualified Hasql.Encoders as Hasql
18+import qualified Hasql.Session as Hasql
2819import qualified Hasql.Statement as Hasql
2920
30−-- opaleye
31−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
32−import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye
33−import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye
34−import qualified Opaleye.Internal.PrimQuery as Opaleye
35−import qualified Opaleye.Internal.Print as Opaleye
36−import qualified Opaleye.Internal.Optimize as Opaleye
37−import qualified Opaleye.Internal.QueryArr as Opaleye hiding ( Select )
38−import qualified Opaleye.Internal.Sql as Opaleye hiding ( Values )
39−import qualified Opaleye.Internal.Tag as Opaleye
40−
41−-- pretty
42−import Text.PrettyPrint ( Doc )
43−
4421-- rel8
45−import Rel8.Expr ( Expr )
46−import Rel8.Expr.Bool ( false )
47−import Rel8.Expr.Opaleye ( toPrimExpr )
4822import Rel8.Query ( Query )
49−import Rel8.Query.Opaleye ( toOpaleye )
50−import 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
23+import Rel8.Query.SQL ( sqlForQuery, sqlForQueryWithNames )
24+import Rel8.Table.Recontextualize ( Selects )
5625import Rel8.Table.Serialize ( Serializable, parse )
57−import Rel8.Table.Undefined ( undefined )
5826
5927-- text
6028import qualified Data.Text as Text
6129import Data.Text.Encoding ( encodeUtf8 )
6230
6331
64−-- | Run a @SELECT@ statement, returning all rows.
32+-- | Run a @SELECT@ query, returning all rows.
6533select :: forall exprs a. Serializable exprs a
66− => Query exprs -> Hasql.Statement () [a]
67−select query = Hasql.Statement bytes params decode prepare
68− where
69− bytes = encodeUtf8 (Text.pack sql)
70− params = Hasql.noParams
71− decode = Hasql.rowList (parse @exprs @a)
72− prepare = False
73− sql = show doc
74− doc = ppSelect query
75−
76−
77−ppSelect :: Table Expr a => Query a -> Doc
78−ppSelect query =
79− Opaleye.ppSql $ primSelectWith names (toCols exprs') primQuery'
80− where
81− names = namesFromLabels
82− (exprs, primQuery, _) =
83− Opaleye.runSimpleQueryArrStart (toOpaleye query) ()
84− (exprs', primQuery') = case optimize primQuery of
85− Empty -> (undefined, Opaleye.Product (pure (pure Opaleye.Unit)) never)
86− Unit -> (exprs, Opaleye.Unit)
87− Optimized pq -> (exprs, pq)
88− never = pure (toPrimExpr false)
89−
90−
91−ppRows :: Table Expr a => Query a -> Doc
92−ppRows query = case optimize primQuery of
93− -- Special case VALUES because we can't use DEFAULT inside a SELECT
94− Optimized (Opaleye.Values symbols rows)
95− | eqSymbols symbols (toList (T.exprs a)) ->
96− Opaleye.ppValues_ (map Opaleye.sqlExpr <$> toList rows)
97− _ -> ppSelect query
98− where
99− (a, primQuery, _) = Opaleye.runSimpleQueryArrStart (toOpaleye query) ()
100−
101− eqSymbols (symbol : symbols) (Opaleye.AttrExpr symbol' : exprs)
102− | eqSymbol symbol symbol' = eqSymbols symbols exprs
103− | otherwise = False
104− eqSymbols [] [] = True
105− eqSymbols _ _ = False
106−
107− eqSymbol
108− (Opaleye.Symbol name (Opaleye.UnsafeTag tag))
109− (Opaleye.Symbol name' (Opaleye.UnsafeTag tag'))
110− = name == name' && tag == tag'
111−
112−
113−ppPrimSelect :: Query a -> (Optimized Doc, a)
114−ppPrimSelect query =
115− (Opaleye.ppSql . primSelect <$> optimize primQuery, a)
116− where
117− (a, primQuery, _) = Opaleye.runSimpleQueryArrStart (toOpaleye query) ()
118−
119−
120−type Optimized :: Type -> Type
121−data Optimized a = Empty | Unit | Optimized a
122− deriving stock (Functor, Foldable, Traversable, Show)
123−
124−
125−optimize :: Opaleye.PrimQuery' a -> Optimized (Opaleye.PrimQuery' Void)
126−optimize query = case Opaleye.removeEmpty (Opaleye.optimize query) of
127− Nothing -> Empty
128− Just Opaleye.Unit -> Unit
129− Just query' -> Optimized query'
130−
131−
132−primSelect :: Opaleye.PrimQuery' Void -> Opaleye.Select
133−primSelect = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator
134−
135−
136−primSelectWith :: Selects names exprs
137− => names -> exprs -> Opaleye.PrimQuery' Void -> Opaleye.Select
138−primSelectWith names exprs query =
139− Opaleye.SelectFrom $ Opaleye.newSelect
140− { Opaleye.attrs = Opaleye.SelectAttrs attrs
141− , Opaleye.tables = Opaleye.oneTable (primSelect query)
142− }
143− where
144− attrs = makeAttr <$> exprsWithNames names (castTable exprs)
145− where
146− makeAttr (label, expr) =
147− (Opaleye.sqlExpr expr, Just (Opaleye.SqlColumn label))
34+ => Connection -> Query exprs -> IO [a]
35+select c query = case sqlForQuery query of
36+ Nothing -> pure []
37+ Just sql -> Hasql.run session c >>= either throwIO pure
38+ where
39+ session = Hasql.statement () statement
40+ statement = Hasql.Statement bytes params decode prepare
41+ bytes = encodeUtf8 (Text.pack sql)
42+ params = Hasql.noParams
43+ decode = Hasql.rowList (parse @exprs @a)
44+ prepare = False
45+
46+
47+selectWithNames :: forall exprs a names.
48+ ( Selects names exprs
49+ , Serializable exprs a
50+ )
51+ => Connection -> names -> Query exprs -> IO [a]
52+selectWithNames c names query = case sqlForQueryWithNames names query of
53+ Nothing -> pure []
54+ Just sql -> Hasql.run session c >>= either throwIO pure
55+ where
56+ session = Hasql.statement () statement
57+ statement = Hasql.Statement bytes params decode prepare
58+ bytes = encodeUtf8 (Text.pack sql)
59+ params = Hasql.noParams
60+ decode = Hasql.rowList (parse @exprs @a)
61+ prepare = False
src/Rel8/Statement/Set.hsdeleted−33
@@ -1,33 +0,0 @@
1−{-# language MonoLocalBinds #-}
2−{-# language NamedFieldPuns #-}
3−
4−module Rel8.Statement.Set
5− ( ppSet
6− )
7−where
8−
9−-- base
10−import Data.Foldable ( toList )
11−import Prelude ()
12−
13−-- opaleye
14−import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye
15−import qualified Opaleye.Internal.Sql as Opaleye
16−
17−-- pretty
18−import Text.PrettyPrint ( Doc, (<+>), equals, text )
19−
20−-- rel8
21−import Rel8.Schema.Name ( Selects, ppColumn )
22−import Rel8.Schema.Table ( TableSchema(..) )
23−import Rel8.Table.Opaleye ( attributes, exprsWithNames )
24−
25−
26−ppSet :: Selects names exprs
27− => TableSchema names -> (exprs -> exprs) -> Doc
28−ppSet schema@TableSchema {columns} f =
29− text "SET" <+> Opaleye.commaV ppAssign (toList assigns)
30− where
31− assigns = exprsWithNames columns (f (attributes schema))
32− ppAssign (column, expr) =
33− ppColumn column <+> equals <+> Opaleye.ppSqlExpr (Opaleye.sqlExpr expr)
src/Rel8/Statement/Update.hs+81−39
@@ -1,37 +1,43 @@
1−{-# language DuplicateRecordFields #-}
21{-# language GADTs #-}
32{-# language NamedFieldPuns #-}
4−{-# language RecordWildCards #-}
3+{-# language ScopedTypeVariables #-}
54{-# language StandaloneKindSignatures #-}
6−{-# language StrictData #-}
5+{-# language TypeApplications #-}
76
87module Rel8.Statement.Update
98 ( Update(..)
109 , update
11− , ppUpdate
1210 )
1311where
1412
1513-- base
14+import Control.Exception ( throwIO )
1615import Data.Kind ( Type )
1716import Prelude
1817
1918-- hasql
19+import Hasql.Connection ( Connection )
20+import qualified Hasql.Decoders as Hasql
2021import qualified Hasql.Encoders as Hasql
22+import qualified Hasql.Session as Hasql
2123import qualified Hasql.Statement as Hasql
2224
23−-- pretty
24−import Text.PrettyPrint ( Doc, (<+>), ($$), text )
25+-- opaleye
26+import qualified Opaleye.Internal.Manipulation as Opaleye
27+
28+-- profunctors
29+import Data.Profunctor ( lmap )
2530
2631-- rel8
2732import Rel8.Expr ( Expr )
28−import Rel8.Query ( Query )
29−import Rel8.Schema.Name ( Selects )
30−import Rel8.Schema.Table ( TableSchema(..), ppTable )
31−import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )
32−import Rel8.Statement.Set ( ppSet )
33−import Rel8.Statement.Using ( ppFrom )
34−import Rel8.Statement.Where ( ppWhere )
33+import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
34+import Rel8.Schema.Table ( TableSchema )
35+import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) )
36+import Rel8.Table ( fromColumns, toColumns )
37+import Rel8.Table.Insert ( toInsert )
38+import Rel8.Table.Opaleye ( table, unpackspec )
39+import Rel8.Table.Recontextualize ( Selects )
40+import Rel8.Table.Serialize ( Serializable, parse )
3541
3642-- text
3743import qualified Data.Text as Text
@@ -44,12 +50,9 @@ data Update a where
4450 Update :: Selects names exprs =>
4551 { target :: TableSchema names
4652 -- ^ Which table to update.
47− , from :: Query from
48− -- ^ @FROM@ clause — this can be used to join against other tables,
49− -- and its results can be referenced in the @SET@ and @WHERE@ clauses.
50− , set :: from -> exprs -> exprs
53+ , set :: exprs -> exprs
5154 -- ^ How to update each selected row.
52− , updateWhere :: from -> exprs -> Expr Bool
55+ , updateWhere :: exprs -> Expr Bool
5356 -- ^ Which rows to select for update.
5457 , returning :: Returning names a
5558 -- ^ What to return from the @UPDATE@ statement.
@@ -57,27 +60,66 @@ data Update a where
5760 -> Update a
5861
5962
60−ppUpdate :: Update a -> Doc
61−ppUpdate Update {..} = case ppFrom from of
62− Nothing ->
63− text "UPDATE" <+> ppTable target $$
64− ppSet target id $$
65− text "WHERE false"
66− Just (fromDoc, i) ->
67− text "UPDATE" <+> ppTable target $$
68− ppSet target (set i) $$
69− fromDoc $$
70− ppWhere target (updateWhere i) $$
71− ppReturning target returning
63+-- | Run an @UPDATE@ statement.
64+--
65+-- >>> mapM_ print =<< select c (each projectSchema)
66+-- Project {projectAuthorId = 1, projectName = "rel8"}
67+-- Project {projectAuthorId = 2, projectName = "aeson"}
68+-- Project {projectAuthorId = 2, projectName = "text"}
69+--
70+-- >>> :{
71+-- update c Update
72+-- { target = projectSchema
73+-- , set = \p -> p { projectName = "Rel8!" }
74+-- , updateWhere = \p -> projectName p ==. lit "rel8"
75+-- , returning = NumberOfRowsAffected
76+-- }
77+-- :}
78+-- 1
79+--
80+-- >>> mapM_ print =<< select c (each projectSchema)
81+-- Project {projectAuthorId = 2, projectName = "aeson"}
82+-- Project {projectAuthorId = 2, projectName = "text"}
83+-- Project {projectAuthorId = 1, projectName = "Rel8!"}
84+update :: Connection -> Update a -> IO a
85+update c Update {target, set, updateWhere, returning} =
86+ case returning of
87+ NumberOfRowsAffected -> Hasql.run session c >>= either throwIO pure
88+ where
89+ session = Hasql.statement () statement
90+ statement = Hasql.Statement bytes params decode prepare
91+ bytes = encodeUtf8 $ Text.pack sql
92+ params = Hasql.noParams
93+ decode = Hasql.rowsAffected
94+ prepare = False
95+ sql = Opaleye.arrangeUpdateSql target' set' where'
96+ where
97+ target' = lmap toInsert $ table $ toColumns <$> target
98+ set' = toColumns . set . fromColumns
99+ where' = toColumn . toPrimExpr . updateWhere . fromColumns
72100
101+ Projection project -> Hasql.run session c >>= either throwIO pure
102+ where
103+ session = Hasql.statement () statement
104+ statement = Hasql.Statement bytes params decode prepare
105+ bytes = encodeUtf8 $ Text.pack sql
106+ params = Hasql.noParams
107+ decode = decoder project
108+ prepare = False
109+ sql =
110+ Opaleye.arrangeUpdateReturningSql
111+ unpackspec
112+ target'
113+ set'
114+ where'
115+ project'
116+ where
117+ target' = lmap toInsert $ table $ toColumns <$> target
118+ set' = toColumns . set . fromColumns
119+ where' = toColumn . toPrimExpr . updateWhere . fromColumns
120+ project' = toColumns . project . fromColumns
73121
74−-- | Run an @UPDATE@ statement.
75−update :: Update a -> Hasql.Statement () a
76−update u@Update {returning} = Hasql.Statement bytes params decode prepare
77122 where
78− bytes = encodeUtf8 $ Text.pack sql
79− params = Hasql.noParams
80− decode = decodeReturning returning
81− prepare = False
82− sql = show doc
83− doc = ppUpdate u
123+ decoder :: forall exprs projection a. Serializable projection a
124+ => (exprs -> projection) -> Hasql.Result [a]
125+ decoder _ = Hasql.rowList (parse @projection @a)
src/Rel8/Statement/Using.hsdeleted−36
@@ -1,36 +0,0 @@
1−module Rel8.Statement.Using
2− ( ppFrom
3− , ppUsing
4− )
5−where
6−
7−-- base
8−import Prelude
9−
10−-- pretty
11−import Text.PrettyPrint ( Doc, (<+>), parens, text )
12−
13−-- rel8
14−import Rel8.Query ( Query )
15−import Rel8.Schema.Table ( TableSchema(..), ppTable )
16−import Rel8.Statement.Select ( Optimized(..), ppPrimSelect )
17−
18−
19−ppFrom :: Query a -> Maybe (Doc, a)
20−ppFrom = ppJoin "FROM"
21−
22−
23−ppUsing :: Query a -> Maybe (Doc, a)
24−ppUsing = ppJoin "USING"
25−
26−
27−ppJoin :: String -> Query a -> Maybe (Doc, a)
28−ppJoin clause join = do
29− doc <- case ofrom of
30− Empty -> Nothing
31− Unit -> Just mempty
32− Optimized doc -> Just $ text clause <+> parens doc <+> ppTable alias
33− pure (doc, a)
34− where
35− alias = TableSchema {name = "T1", schema = Nothing, columns = ()}
36− (ofrom, a) = ppPrimSelect join
src/Rel8/Statement/View.hs+29−48
@@ -1,78 +1,59 @@
11{-# language FlexibleContexts #-}
2−{-# language MonoLocalBinds #-}
32
43module Rel8.Statement.View
54 ( createView
6− , createOrReplaceView
75 )
86where
97
108-- base
9+import Control.Exception ( throwIO )
10+import Control.Monad ( (>=>) )
11+import Data.Foldable ( fold )
12+import Data.Maybe ( fromMaybe )
1113import Prelude
1214
1315-- hasql
16+import Hasql.Connection ( Connection )
1417import qualified Hasql.Decoders as Hasql
1518import qualified Hasql.Encoders as Hasql
19+import qualified Hasql.Session as Hasql
1620import qualified Hasql.Statement as Hasql
1721
1822-- rel8
1923import Rel8.Query ( Query )
20−import Rel8.Schema.Name ( Selects )
21−import Rel8.Schema.Table ( TableSchema )
22−import Rel8.Statement.Insert ( ppInto )
23−import Rel8.Statement.Select ( ppSelect )
24−
25−-- pretty
26−import Text.PrettyPrint ( Doc, (<+>), ($$), text )
24+import Rel8.Query.SQL ( sqlForQueryWithNames )
25+import Rel8.Schema.Table ( TableSchema( TableSchema ) )
26+import Rel8.Table.Alternative ( emptyTable )
27+import Rel8.Table.Recontextualize ( Selects )
2728
2829-- text
2930import qualified Data.Text as Text
3031import Data.Text.Encoding ( encodeUtf8 )
3132
3233
33−data CreateView = Create | CreateOrReplace
34−
35−
36−-- | Given a 'TableSchema' and 'Query', @createView@ runs a @CREATE VIEW@
37−-- statement that will save the given query as a view. This can be useful if
38−-- you want to share Rel8 queries with other applications.
3934createView :: Selects names exprs
40− => TableSchema names -> Query exprs -> Hasql.Statement () ()
41−createView =
42− createViewGeneric Create
43−
44−
45−-- | Given a 'TableSchema' and 'Query', @createOrReplaceView@ runs a
46−-- @CREATE OR REPLACE VIEW@ statement that will save the given query
47−-- as a view, replacing the current view definition if it exists and
48−-- adheres to the restrictions in place for replacing a view in
49−-- PostgreSQL.
50−createOrReplaceView :: Selects names exprs
51− => TableSchema names -> Query exprs -> Hasql.Statement () ()
52−createOrReplaceView =
53− createViewGeneric CreateOrReplace
54−
55−
56−createViewGeneric :: Selects names exprs
57− => CreateView -> TableSchema names -> Query exprs -> Hasql.Statement () ()
58−createViewGeneric replace schema query =
59− Hasql.Statement bytes params decode prepare
35+ => TableSchema names -> Query exprs -> Connection -> IO ()
36+createView (TableSchema name mschema names) query =
37+ Hasql.run session >=> either throwIO pure
6038 where
39+ session = Hasql.statement () statement
40+ statement = Hasql.Statement bytes params decode prepare
6141 bytes = encodeUtf8 (Text.pack sql)
6242 params = Hasql.noParams
6343 decode = Hasql.noResult
6444 prepare = False
65− sql = show doc
66− doc = ppCreateView schema query replace
67−
68−
69−ppCreateView :: Selects names exprs
70− => TableSchema names -> Query exprs -> CreateView -> Doc
71−ppCreateView schema query replace =
72− createOrReplace replace <+>
73− ppInto schema $$
74− text "AS" <+>
75− ppSelect query
45+ sql = "CREATE VIEW " <> title <> " WITH " <> select
46+ where
47+ title = case mschema of
48+ Nothing -> quote name
49+ Just schema -> quote schema <> "." <> quote name
50+ select = fromMaybe fallback $ sqlForQueryWithNames names query
51+ where
52+ fallback = fold $ sqlForQueryWithNames names emptyTable
53+
54+
55+quote :: String -> String
56+quote string = "\"" <> concatMap go string <> "\""
7657 where
77− createOrReplace Create = text "CREATE VIEW"
78− createOrReplace CreateOrReplace = text "CREATE OR REPLACE VIEW"
58+ go '"' = "\"\""
59+ go c = [c]
src/Rel8/Statement/Where.hsdeleted−31
@@ -1,31 +0,0 @@
1−{-# language MonoLocalBinds #-}
2−
3−module Rel8.Statement.Where
4− ( ppWhere
5− )
6−where
7−
8−-- base
9−import Prelude
10−
11−-- opaleye
12−import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye
13−import qualified Opaleye.Internal.Sql as Opaleye
14−
15−-- pretty
16−import Text.PrettyPrint ( Doc, (<+>), text )
17−
18−-- rel8
19−import Rel8.Expr ( Expr )
20−import Rel8.Expr.Opaleye ( toPrimExpr )
21−import Rel8.Schema.Name ( Selects )
22−import Rel8.Schema.Table ( TableSchema )
23−import Rel8.Table.Opaleye ( attributes )
24−
25−
26−ppWhere :: Selects names exprs
27− => TableSchema names -> (exprs -> Expr Bool) -> Doc
28−ppWhere schema where_ = text "WHERE" <+> ppExpr condition
29− where
30− ppExpr = Opaleye.ppSqlExpr . Opaleye.sqlExpr . toPrimExpr
31− condition = where_ (attributes schema)
src/Rel8/Table.hs+168−144
@@ -1,46 +1,41 @@
1−{-# language AllowAmbiguousTypes #-}
21{-# language DataKinds #-}
3−{-# language DefaultSignatures #-}
2+{-# language DisambiguateRecordFields #-}
43{-# language FlexibleContexts #-}
54{-# language FlexibleInstances #-}
65{-# language FunctionalDependencies #-}
7−{-# language ScopedTypeVariables #-}
86{-# language StandaloneKindSignatures #-}
9−{-# language TypeApplications #-}
107{-# language TypeFamilies #-}
118{-# language UndecidableInstances #-}
129
1310module Rel8.Table
14− ( Table
15− ( Columns, Context, fromColumns, toColumns
16− , FromExprs, fromResult, toResult
17− , Transpose
18− )
11+ ( Table (Columns, Context)
12+ , toColumns, fromColumns
1913 , Congruent
20− , TTable, TColumns, TContext, TFromExprs, TTranspose
21− , TSerialize
2214 )
2315where
2416
2517-- base
2618import Data.Functor.Identity ( Identity( Identity ) )
2719import Data.Kind ( Constraint, Type )
28−import GHC.Generics ( Generic, Rep, from, to )
29−import Prelude hiding ( null )
20+import Prelude
3021
3122-- rel8
32−import Rel8.FCF ( Eval, Exp )
33−import Rel8.Generic.Map ( Map )
34−import Rel8.Generic.Table.Record
35− ( GTable, GColumns, GContext, gfromColumns, gtoColumns
36− , GSerialize, gfromResult, gtoResult
37− )
38−import Rel8.Generic.Record ( Record(..) )
39−import Rel8.Schema.HTable ( HTable )
40−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
23+import Rel8.Aggregate ( Aggregate )
24+import Rel8.Expr ( Expr )
25+import Rel8.Opaque ( Opaque, Opaque1 )
26+import Rel8.Schema.Context ( Col(..), Insertion(..), Name(..) )
27+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
28+import Rel8.Schema.HTable ( HTable, hfield, hspecs, htabulate, htabulateA )
29+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
30+import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
31+import Rel8.Schema.HTable.Pair ( HPair(..) )
32+import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
33+import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
34+import Rel8.Schema.HTable.Trio ( HTrio(..) )
35+import Rel8.Schema.HTable.Type ( HType( HType ) )
4136import qualified Rel8.Schema.Kind as K
42−import Rel8.Schema.Null ( Sql )
43−import Rel8.Schema.Result ( Result )
37+import Rel8.Schema.Nullability ( Sql )
38+import Rel8.Schema.Spec ( SSpec( SSpec ), KnownSpec )
4439import Rel8.Type ( DBType )
4540
4641
@@ -48,173 +43,202 @@ import Rel8.Type ( DBType )
4843-- types that have a finite number of columns. Each of these columns contains
4944-- data under a shared context, and contexts describe how to interpret the
5045-- metadata about a column to a particular Haskell type. In Rel8, we have
51−-- contexts for expressions (the 'Rel8.Expr' context), aggregations (the
52−-- 'Rel8.Aggregate' context), insert values (the 'Rel8.Insert' contex), among
53−-- others.
46+-- contexts for expressions (the 'Expr' context), aggregations (the 'Aggregate'
47+-- context), insert values (the 'Insert' contex), among others.
5448--
5549-- In typical usage of Rel8 you don't need to derive instances of 'Table'
56−-- yourself, as anything that's an instance of 'Rel8.Rel8able' is always a
57−-- 'Table'.
50+-- yourself, as anything that's an instance of 'Rel8able' is always a 'Table'.
5851type Table :: K.Context -> Type -> Constraint
59−class
60− ( HTable (Columns a)
61− , context ~ Context a
62− , a ~ Transpose context a
63− )
64− => Table context a | a -> context
65− where
52+class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where
6653 -- | The 'HTable' functor that describes the schema of this table.
6754 type Columns a :: K.HTable
6855
6956 -- | The common context that all columns use as an interpretation.
7057 type Context a :: K.Context
7158
72− -- | The @FromExprs@ type family maps a type in the @Expr@ context to the
73− -- corresponding Haskell type.
74− type FromExprs a :: Type
75−
76− type Transpose (context' :: K.Context) a :: Type
59+ toColumns :: a -> Columns a (Col (Context a))
60+ fromColumns :: Columns a (Col (Context a)) -> a
7761
7862
79− toColumns :: a -> Columns a context
80− fromColumns :: Columns a context -> a
63+-- | Any 'HTable' is also a 'Table'.
64+instance HTable t => Table context (t (Col context)) where
65+ type Columns (t (Col context)) = t
66+ type Context (t (Col context)) = context
8167
82− fromResult :: Columns a Result -> FromExprs a
83− toResult :: FromExprs a -> Columns a Result
68+ toColumns = id
69+ fromColumns = id
8470
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
8971
90− default toColumns ::
91− ( Generic (Record a)
92− , GTable (TTable context) TColumns (Rep (Record a))
93− , Columns a ~ GColumns TColumns (Rep (Record a))
94− )
95− => a -> Columns a context
96− toColumns =
97− gtoColumns @(TTable context) @TColumns toColumns .
98− from .
99− Record
100−
101− default fromColumns ::
102− ( Generic (Record a)
103− , GTable (TTable context) TColumns (Rep (Record a))
104− , Columns a ~ GColumns TColumns (Rep (Record a))
105− )
106− => Columns a context -> a
107− fromColumns =
108− unrecord .
109− to .
110− gfromColumns @(TTable context) @TColumns fromColumns
111−
112− default toResult ::
113− ( Generic (Record (FromExprs a))
114− , GSerialize TSerialize TColumns (Rep (Record a)) (Rep (Record (FromExprs a)))
115− , Columns a ~ GColumns TColumns (Rep (Record a))
116− )
117− => FromExprs a -> Columns a Result
118− toResult =
119− gtoResult
120− @TSerialize
121− @TColumns
122− @(Rep (Record a))
123− @(Rep (Record (FromExprs a)))
124− (\(_ :: proxy x) -> toResult @(Context x) @x) .
125− from .
126− Record
127−
128− default fromResult ::
129− ( Generic (Record (FromExprs a))
130− , GSerialize TSerialize TColumns (Rep (Record a)) (Rep (Record (FromExprs a)))
131− , Columns a ~ GColumns TColumns (Rep (Record a))
132− )
133− => Columns a Result -> FromExprs a
134− fromResult =
135− unrecord .
136− to .
137− gfromResult
138− @TSerialize
139− @TColumns
140− @(Rep (Record a))
141− @(Rep (Record (FromExprs a)))
142− (\(_ :: proxy x) -> fromResult @(Context x) @x)
143−
144−
145−instance Sql DBType a => Table Result (Identity a) where
146− type Columns (Identity a) = HIdentity a
147− type Context (Identity a) = Result
148− type FromExprs (Identity a) = a
149− type Transpose to (Identity a) = to a
72+-- | Any context is trivially a table.
73+instance KnownSpec spec => Table context (Col context spec) where
74+ type Columns (Col context spec) = HIdentity spec
75+ type Context (Col context spec) = context
15076
15177 toColumns = HIdentity
152− fromColumns (HIdentity a) = a
153− toResult a = HIdentity (Identity a)
154− fromResult (HIdentity (Identity a)) = a
78+ fromColumns = unHIdentity
15579
15680
157−data TTable :: K.Context -> Type -> Exp Constraint
158−type instance Eval (TTable context a) = Table context a
81+instance Table Expr a => Table Aggregate (Aggregate a) where
82+ type Columns (Aggregate a) = Columns a
83+ type Context (Aggregate a) = Aggregate
15984
85+ toColumns a = htabulate $ \field -> case hfield hspecs field of
86+ SSpec {} -> Aggregation $ unDB . (`hfield` field) . toColumns <$> a
87+ fromColumns as = fmap fromColumns $ htabulateA $ \field ->
88+ case hfield as field of
89+ Aggregation a -> DB <$> a
16090
161−data TColumns :: Type -> Exp K.HTable
162−type instance Eval (TColumns a) = Columns a
16391
92+instance Sql DBType a => Table Expr (Expr a) where
93+ type Columns (Expr a) = HType a
94+ type Context (Expr a) = Expr
16495
165−data TContext :: Type -> Exp K.Context
166−type instance Eval (TContext a) = Context a
96+ toColumns a = HType (DB a)
97+ fromColumns (HType (DB a)) = a
16798
16899
169−data TFromExprs :: Type -> Exp Type
170−type instance Eval (TFromExprs a) = FromExprs a
100+instance Sql DBType a => Table Identity (Identity a) where
101+ type Columns (Identity a) = HType a
102+ type Context (Identity a) = Identity
171103
104+ toColumns (Identity a) = HType (Result a)
105+ fromColumns (HType (Result a)) = Identity a
172106
173−data TTranspose :: K.Context -> Type -> Exp Type
174−type instance Eval (TTranspose context a) = Transpose context a
175107
108+instance Sql DBType a => Table Insertion (Insertion a) where
109+ type Columns (Insertion a) = HType a
110+ type Context (Insertion a) = Insertion
176111
177−data TSerialize :: Type -> Type -> Exp Constraint
178−type instance Eval (TSerialize expr a) =
179− ( Table (Context expr) expr
180− , a ~ FromExprs expr
181− )
112+ toColumns (Insertion a) = HType (RequiredInsert a)
113+ fromColumns (HType (RequiredInsert a)) = Insertion a
114+
115+
116+instance Sql DBType a => Table Name (Name a) where
117+ type Columns (Name a) = HType a
118+ type Context (Name a) = Name
119+
120+ toColumns (Name a) = HType (NameCol a)
121+ fromColumns (HType (NameCol a)) = Name a
182122
183123
184−instance (Table context a, Table context b) => Table context (a, b)
124+instance
125+ ( Table context a, Table context b
126+ , Labelable context
127+ ) =>
128+ Table context (a, b)
129+ where
130+ type Columns (a, b) =
131+ HPair
132+ (HLabel "fst" (Columns a))
133+ (HLabel "snd" (Columns b))
134+ type Context (a, b) = Context a
135+
136+ toColumns (a, b) = HPair
137+ { hfst = hlabel labeler $ toColumns a
138+ , hsnd = hlabel labeler $ toColumns b
139+ }
140+ fromColumns (HPair a b) =
141+ ( fromColumns $ hunlabel unlabeler a
142+ , fromColumns $ hunlabel unlabeler b
143+ )
185144
186145
187146instance
188147 ( Table context a, Table context b, Table context c
189− )
190− => Table context (a, b, c)
148+ , Labelable context
149+ ) => Table context (a, b, c)
150+ where
151+ type Columns (a, b, c) =
152+ HTrio
153+ (HLabel "fst" (Columns a))
154+ (HLabel "snd" (Columns b))
155+ (HLabel "trd" (Columns c))
156+ type Context (a, b, c) = Context a
157+
158+ toColumns (a, b, c) = HTrio
159+ { hfst = hlabel labeler $ toColumns a
160+ , hsnd = hlabel labeler $ toColumns b
161+ , htrd = hlabel labeler $ toColumns c
162+ }
163+ fromColumns (HTrio a b c) =
164+ ( fromColumns $ hunlabel unlabeler a
165+ , fromColumns $ hunlabel unlabeler b
166+ , fromColumns $ hunlabel unlabeler c
167+ )
191168
192169
193170instance
194171 ( Table context a, Table context b, Table context c, Table context d
195− )
196− => Table context (a, b, c, d)
172+ , Labelable context
173+ ) => Table context (a, b, c, d)
174+ where
175+ type Columns (a, b, c, d) =
176+ HQuartet
177+ (HLabel "fst" (Columns a))
178+ (HLabel "snd" (Columns b))
179+ (HLabel "trd" (Columns c))
180+ (HLabel "frt" (Columns d))
181+ type Context (a, b, c, d) = Context a
182+
183+ toColumns (a, b, c, d) = HQuartet
184+ { hfst = hlabel labeler $ toColumns a
185+ , hsnd = hlabel labeler $ toColumns b
186+ , htrd = hlabel labeler $ toColumns c
187+ , hfrt = hlabel labeler $ toColumns d
188+ }
189+ fromColumns (HQuartet a b c d) =
190+ ( fromColumns $ hunlabel unlabeler a
191+ , fromColumns $ hunlabel unlabeler b
192+ , fromColumns $ hunlabel unlabeler c
193+ , fromColumns $ hunlabel unlabeler d
194+ )
197195
198196
199197instance
200198 ( Table context a, Table context b, Table context c, Table context d
201199 , Table context e
202− )
203− => Table context (a, b, c, d, e)
200+ , Labelable context
201+ ) => Table context (a, b, c, d, e)
202+ where
203+ type Columns (a, b, c, d, e) =
204+ HQuintet
205+ (HLabel "fst" (Columns a))
206+ (HLabel "snd" (Columns b))
207+ (HLabel "trd" (Columns c))
208+ (HLabel "frt" (Columns d))
209+ (HLabel "fft" (Columns e))
210+ type Context (a, b, c, d, e) = Context a
211+
212+ toColumns (a, b, c, d, e) = HQuintet
213+ { hfst = hlabel labeler $ toColumns a
214+ , hsnd = hlabel labeler $ toColumns b
215+ , htrd = hlabel labeler $ toColumns c
216+ , hfrt = hlabel labeler $ toColumns d
217+ , hfft = hlabel labeler $ toColumns e
218+ }
219+ fromColumns (HQuintet a b c d e) =
220+ ( fromColumns $ hunlabel unlabeler a
221+ , fromColumns $ hunlabel unlabeler b
222+ , fromColumns $ hunlabel unlabeler c
223+ , fromColumns $ hunlabel unlabeler d
224+ , fromColumns $ hunlabel unlabeler e
225+ )
204226
205227
206−instance
207− ( Table context a, Table context b, Table context c, Table context d
208− , Table context e, Table context f
209− )
210− => Table context (a, b, c, d, e, f)
228+instance Table Expr Opaque where
229+ type Columns Opaque = HType Opaque
230+ type Context Opaque = Expr
211231
232+ fromColumns = error "opaque"
233+ toColumns = error "opaque"
212234
213−instance
214− ( Table context a, Table context b, Table context c, Table context d
215− , Table context e, Table context f, Table context g
216− )
217− => Table context (a, b, c, d, e, f, g)
235+
236+instance Table context (Opaque1 context a) where
237+ type Columns (Opaque1 context a) = HType Opaque
238+ type Context (Opaque1 context a) = context
239+
240+ fromColumns = error "opaque"
241+ toColumns = error "opaque"
218242
219243
220244type Congruent :: Type -> Type -> Constraint
src/Rel8/Table/ADT.hsdeleted−173
@@ -1,173 +0,0 @@
1−{-# language AllowAmbiguousTypes #-}
2−{-# language DataKinds #-}
3−{-# language FlexibleContexts #-}
4−{-# language FlexibleInstances #-}
5−{-# language MultiParamTypeClasses #-}
6−{-# language RankNTypes #-}
7−{-# language ScopedTypeVariables #-}
8−{-# language StandaloneKindSignatures #-}
9−{-# language TypeApplications #-}
10−{-# language TypeFamilyDependencies #-}
11−{-# language UndecidableInstances #-}
12−{-# language UndecidableSuperClasses #-}
13−
14−module Rel8.Table.ADT
15− ( ADT( ADT )
16− , ADTable
17− , BuildableADT
18− , BuildADT, buildADT
19− , ConstructableADT
20− , ConstructADT, constructADT
21− , DeconstructADT, deconstructADT
22− , NameADT, nameADT
23− , AggregateADT, aggregateADT
24− , ADTRep
25− )
26−where
27−
28−-- base
29−import Data.Kind ( Constraint, Type )
30−import GHC.Generics ( Generic, from, to )
31−import GHC.TypeLits ( Symbol )
32−import Prelude
33−
34−-- rel8
35−import Rel8.Aggregate ( Aggregate )
36−import Rel8.Expr ( Expr )
37−import Rel8.FCF ( Eval, Exp )
38−import Rel8.Generic.Construction
39− ( GGBuildable
40− , GGBuild, ggbuild
41− , GGConstructable
42− , GGConstruct, ggconstruct
43− , GGDeconstruct, ggdeconstruct
44− , GGName, ggname
45− , GGAggregate, ggaggregate
46− )
47−import Rel8.Generic.Record ( Record( Record ), unrecord )
48−import Rel8.Generic.Rel8able
49− ( Rel8able
50− , GRep, GColumns, gfromColumns, gtoColumns
51− , GFromExprs, gfromResult, gtoResult
52− , TSerialize, deserialize, serialize
53− )
54−import qualified Rel8.Generic.Table.ADT as G
55−import qualified Rel8.Kind.Algebra as K
56−import Rel8.Schema.HTable ( HTable )
57−import qualified Rel8.Schema.Kind as K
58−import Rel8.Schema.Name ( Name )
59−import Rel8.Schema.Result ( Result )
60−import Rel8.Table ( Table, TColumns )
61−
62−
63−type ADT :: K.Rel8able -> K.Rel8able
64−newtype ADT t context = ADT (GColumnsADT t context)
65−
66−
67−instance ADTable t => Rel8able (ADT t) where
68− type GColumns (ADT t) = GColumnsADT t
69− type GFromExprs (ADT t) = t Result
70−
71− gfromColumns _ = ADT
72− gtoColumns _ (ADT a) = a
73−
74− gfromResult =
75− unrecord .
76− to .
77− G.gfromResultADT
78− @TSerialize
79− @TColumns
80− @(Eval (ADTRep t Expr))
81− @(Eval (ADTRep t Result))
82− (\(_ :: proxy x) -> deserialize @_ @x)
83−
84− gtoResult =
85− G.gtoResultADT
86− @TSerialize
87− @TColumns
88− @(Eval (ADTRep t Expr))
89− @(Eval (ADTRep t Result))
90− (\(_ :: proxy x) -> serialize @_ @x) .
91− from .
92− Record
93−
94−
95−type ADTable :: K.Rel8able -> Constraint
96−class
97− ( Generic (Record (t Result))
98− , HTable (GColumnsADT t)
99− , G.GSerializeADT TSerialize TColumns (Eval (ADTRep t Expr)) (Eval (ADTRep t Result))
100− )
101− => ADTable t
102−instance
103− ( Generic (Record (t Result))
104− , HTable (GColumnsADT t)
105− , G.GSerializeADT TSerialize TColumns (Eval (ADTRep t Expr)) (Eval (ADTRep t Result))
106− )
107− => ADTable t
108−
109−
110−type BuildableADT :: K.Rel8able -> Symbol -> Constraint
111−class GGBuildable 'K.Sum name (ADTRep t) => BuildableADT t name
112−instance GGBuildable 'K.Sum name (ADTRep t) => BuildableADT t name
113−
114−
115−type BuildADT :: K.Rel8able -> Symbol -> Type
116−type BuildADT t name = GGBuild 'K.Sum name (ADTRep t) (ADT t Expr)
117−
118−
119−buildADT :: forall t name. BuildableADT t name => BuildADT t name
120−buildADT =
121− ggbuild @'K.Sum @name @(ADTRep t) @(ADT t Expr) ADT
122−
123−
124−type ConstructableADT :: K.Rel8able -> Constraint
125−class GGConstructable 'K.Sum (ADTRep t) => ConstructableADT t
126−instance GGConstructable 'K.Sum (ADTRep t) => ConstructableADT t
127−
128−
129−type ConstructADT :: K.Rel8able -> Type
130−type ConstructADT t = forall r. GGConstruct 'K.Sum (ADTRep t) r
131−
132−
133−constructADT :: forall t. ConstructableADT t => ConstructADT t -> ADT t Expr
134−constructADT f =
135− ggconstruct @'K.Sum @(ADTRep t) @(ADT t Expr) ADT
136− (f @(ADT t Expr))
137−
138−
139−type DeconstructADT :: K.Rel8able -> Type -> Type
140−type DeconstructADT t r = GGDeconstruct 'K.Sum (ADTRep t) (ADT t Expr) r
141−
142−
143−deconstructADT :: forall t r. (ConstructableADT t, Table Expr r)
144− => DeconstructADT t r
145−deconstructADT =
146− ggdeconstruct @'K.Sum @(ADTRep t) @(ADT t Expr) @r (\(ADT a) -> a)
147−
148−
149−type NameADT :: K.Rel8able -> Type
150−type NameADT t = GGName 'K.Sum (ADTRep t) (ADT t Name)
151−
152−
153−nameADT :: forall t. ConstructableADT t => NameADT t
154−nameADT = ggname @'K.Sum @(ADTRep t) @(ADT t Name) ADT
155−
156−
157−type AggregateADT :: K.Rel8able -> Type
158−type AggregateADT t = forall r. GGAggregate 'K.Sum (ADTRep t) r
159−
160−
161−aggregateADT :: forall t. ConstructableADT t
162− => AggregateADT t -> ADT t Expr -> ADT t Aggregate
163−aggregateADT f =
164− ggaggregate @'K.Sum @(ADTRep t) @(ADT t Expr) @(ADT t Aggregate) ADT (\(ADT a) -> a)
165− (f @(ADT t Aggregate))
166−
167−
168−data ADTRep :: K.Rel8able -> K.Context -> Exp (Type -> Type)
169−type instance Eval (ADTRep t context) = GRep t context
170−
171−
172−type GColumnsADT :: K.Rel8able -> K.HTable
173−type GColumnsADT t = G.GColumnsADT TColumns (GRep t Expr)
src/Rel8/Table/Aggregate.hs+30−40
@@ -6,8 +6,10 @@
66{-# language ViewPatterns #-}
77
88module Rel8.Table.Aggregate
9− ( groupBy, hgroupBy
10− , listAgg, nonEmptyAgg
9+ ( groupBy
10+ , listAgg
11+ , nonEmptyAgg
12+ , runAggregation
1113 )
1214where
1315
@@ -16,49 +18,33 @@ import Data.Functor.Identity ( Identity( Identity ) )
1618import Prelude
1719
1820-- rel8
19−import Rel8.Aggregate ( Aggregate, Aggregates )
21+import Rel8.Aggregate ( Aggregate )
2022import Rel8.Expr ( Expr )
21−import Rel8.Expr.Aggregate
22− ( groupByExpr
23− , slistAggExpr
24− , snonEmptyAggExpr
25− )
23+import Rel8.Expr.Aggregate ( listAggExpr, nonEmptyAggExpr, sgroupByExpr )
24+import Rel8.Schema.Context ( Col(..) )
2625import Rel8.Schema.Dict ( Dict( Dict ) )
27−import Rel8.Schema.HTable ( HTable, hfield, htabulate )
26+import Rel8.Schema.HTable ( htabulate, hfield, hdicts, hspecs )
2827import Rel8.Schema.HTable.Vectorize ( hvectorize )
29−import Rel8.Schema.Null ( Sql )
30−import Rel8.Schema.Spec ( Spec( Spec, info ) )
31−import Rel8.Table ( toColumns, fromColumns )
32−import Rel8.Table.Eq ( EqTable, eqTable )
28+import Rel8.Schema.Spec ( SSpec(..) )
29+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
30+import Rel8.Table ( Table, Columns, toColumns, fromColumns )
31+import Rel8.Table.Eq ( EqTable )
3332import Rel8.Table.List ( ListTable )
3433import Rel8.Table.NonEmpty ( NonEmptyTable )
34+import Rel8.Table.Recontextualize ( Aggregates )
3535import Rel8.Type.Eq ( DBEq )
3636
3737
3838-- | Group equal tables together. This works by aggregating each column in the
3939-- given table with 'groupByExpr'.
40−--
41−-- For example, if we have a table of items, we could group the items by the
42−-- order they belong to:
43−--
44−-- @
45−-- itemsByOrder :: Query (OrderId Expr, ListTable Expr (Item Expr))
46−-- itemsByOrder = aggregate $ do
47−-- item <- each itemSchema
48−-- let orderId = groupBy (itemOrderId item)
49−-- let orderItems = listAgg item
50−-- pure (orderId, orderItems)
51−-- @
52−groupBy :: forall exprs aggregates. (EqTable exprs, Aggregates aggregates exprs)
53− => exprs -> aggregates
54−groupBy = fromColumns . hgroupBy (eqTable @exprs) . toColumns
55−
56−
57−hgroupBy :: HTable t => t (Dict (Sql DBEq)) -> t Expr -> t Aggregate
58−hgroupBy eqs exprs = htabulate $ \field ->
59− case hfield eqs field of
60− Dict -> case hfield exprs field of
61− expr -> groupByExpr expr
40+groupBy :: forall exprs. EqTable exprs => exprs -> Aggregate exprs
41+groupBy (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
42+ case hfield dicts field of
43+ Dict -> case hfield hspecs field of
44+ SSpec {nullability} -> case hfield exprs field of
45+ DB expr -> Aggregation $ sgroupByExpr nullability expr
46+ where
47+ dicts = hdicts @(Columns exprs) @(ConstrainDBType DBEq)
6248
6349
6450-- | Aggregate rows into a single row containing an array of all aggregated
@@ -71,22 +57,26 @@ hgroupBy eqs exprs = htabulate $ \field ->
7157-- items:
7258--
7359-- @
74−-- ordersWithItems :: Query (Order Expr, ListTable Expr (Item Expr))
60+-- ordersWithItems :: Query (Order Expr, ListTable (Item Expr))
7561-- ordersWithItems = do
7662-- order <- each orderSchema
7763-- items <- aggregate $ listAgg <$> itemsFromOrder order
7864-- return (order, items)
7965-- @
80−listAgg :: Aggregates aggregates exprs => exprs -> ListTable Aggregate aggregates
66+listAgg :: Table Expr exprs => exprs -> Aggregate (ListTable exprs)
8167listAgg (toColumns -> exprs) = fromColumns $
8268 hvectorize
83− (\Spec {info} (Identity a) -> slistAggExpr info a)
69+ (\_ (Identity (DB a)) -> Aggregation $ listAggExpr a)
8470 (pure exprs)
8571
8672
8773-- | Like 'listAgg', but the result is guaranteed to be a non-empty list.
88−nonEmptyAgg :: Aggregates aggregates exprs => exprs -> NonEmptyTable Aggregate aggregates
74+nonEmptyAgg :: Table Expr exprs => exprs -> Aggregate (NonEmptyTable exprs)
8975nonEmptyAgg (toColumns -> exprs) = fromColumns $
9076 hvectorize
91− (\Spec {info} (Identity a) -> snonEmptyAggExpr info a)
77+ (\_ (Identity (DB a)) -> Aggregation $ nonEmptyAggExpr a)
9278 (pure exprs)
79+
80+
81+runAggregation :: Aggregates aggregates exprs => aggregates -> Aggregate exprs
82+runAggregation = fromColumns . toColumns
src/Rel8/Table/Alternative.hs+2−2
@@ -20,8 +20,8 @@ import Rel8.Table ( Table )
2020-- | Like 'Alt' in Haskell. This class is purely a Rel8 concept, and allows you
2121-- to take a choice between two tables. See also 'AlternativeTable'.
2222--
23−-- For example, using '<|>:' on 'Rel8.MaybeTable' allows you to combine two
24−-- tables and to return the first one that is a "just" MaybeTable.
23+-- For example, using '<|>:' on 'MaybeTable' allows you to combine two tables
24+-- and to return the first one that is a "just" MaybeTable.
2525type AltTable :: (Type -> Type) -> Constraint
2626class AltTable f where
2727 -- | An associative binary operation on 'Table's.
src/Rel8/Table/Bool.hs+6−19
@@ -5,7 +5,6 @@
55module Rel8.Table.Bool
66 ( bool
77 , case_
8− , nullable
98 )
109where
1110
@@ -15,34 +14,22 @@ import Prelude
1514-- rel8
1615import Rel8.Expr ( Expr )
1716import Rel8.Expr.Bool ( boolExpr, caseExpr )
18−import Rel8.Expr.Null ( isNull, unsafeUnnullify )
17+import Rel8.Schema.Context ( Col(..) )
1918import Rel8.Schema.HTable ( htabulate, hfield )
2019import Rel8.Table ( Table, fromColumns, toColumns )
2120
2221
23−-- | An if-then-else expression on tables.
24−--
25−-- @bool x y p@ returns @x@ if @p@ is @False@, and returns @y@ if @p@ is
26−-- @True@.
2722bool :: Table Expr a => a -> a -> Expr Bool -> a
2823bool (toColumns -> false) (toColumns -> true) condition =
2924 fromColumns $ htabulate $ \field ->
3025 case (hfield false field, hfield true field) of
31− (falseExpr, trueExpr) -> boolExpr falseExpr trueExpr condition
32−{-# INLINABLE bool #-}
26+ (DB falseExpr, DB trueExpr) ->
27+ DB (boolExpr falseExpr trueExpr condition)
3328
3429
35−-- | Produce a table expression from a list of alternatives. Returns the first
36−-- table where the @Expr Bool@ expression is @True@. If no alternatives are
37−-- true, the given default is returned.
3830case_ :: Table Expr a => [(Expr Bool, a)] -> a -> a
3931case_ (map (fmap toColumns) -> branches) (toColumns -> fallback) =
4032 fromColumns $ htabulate $ \field -> case hfield fallback field of
41− fallbackExpr ->
42− case map (fmap (`hfield` field)) branches of
43− branchExprs -> caseExpr branchExprs fallbackExpr
44−
45−
46−-- | Like 'maybe', but to eliminate @null@.
47−nullable :: Table Expr b => b -> (Expr a -> b) -> Expr (Maybe a) -> b
48−nullable b f ma = bool (f (unsafeUnnullify ma)) b (isNull ma)
33+ DB fallbackExpr ->
34+ case map (fmap (unDB . (`hfield` field))) branches of
35+ branchExprs -> DB (caseExpr branchExprs fallbackExpr)
src/Rel8/Table/Cols.hsdeleted−50
@@ -1,50 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language FlexibleInstances #-}
3−{-# language MultiParamTypeClasses #-}
4−{-# language StandaloneKindSignatures #-}
5−{-# language TypeFamilies #-}
6−{-# language UndecidableInstances #-}
7−
8−module Rel8.Table.Cols
9− ( Cols( Cols )
10− , fromCols
11− , toCols
12− )
13−where
14−
15−-- base
16−import Data.Kind ( Type )
17−import Prelude
18−
19−-- rel8
20−import qualified Rel8.Schema.Kind as K
21−import Rel8.Schema.HTable ( HTable )
22−import Rel8.Schema.Result ( Result )
23−import Rel8.Table ( Table(..) )
24−
25−
26−type Cols :: K.Context -> K.HTable -> Type
27−newtype Cols context columns = Cols (columns context)
28−
29−
30−instance (HTable columns, context ~ context') =>
31− Table context' (Cols context columns)
32− where
33− type Columns (Cols context columns) = columns
34− type Context (Cols context columns) = context
35− type FromExprs (Cols context columns) = Cols Result columns
36− type Transpose to (Cols context columns) = Cols to columns
37−
38− toColumns (Cols a) = a
39− fromColumns = Cols
40−
41− toResult (Cols a) = a
42− fromResult = Cols
43−
44−
45−fromCols :: Table context a => Cols context (Columns a) -> a
46−fromCols (Cols a) = fromColumns a
47−
48−
49−toCols :: Table context a => a -> Cols context (Columns a)
50−toCols = Cols . toColumns
src/Rel8/Table/Either.hs+91−161
@@ -3,59 +3,45 @@
33{-# language DerivingStrategies #-}
44{-# language FlexibleContexts #-}
55{-# language FlexibleInstances #-}
6−{-# language LambdaCase #-}
76{-# language MultiParamTypeClasses #-}
87{-# language NamedFieldPuns #-}
9−{-# language ScopedTypeVariables #-}
108{-# language StandaloneKindSignatures #-}
11−{-# language TypeApplications #-}
129{-# language TypeFamilies #-}
1310{-# language UndecidableInstances #-}
1411
15−{-# options_ghc -fno-warn-orphans #-}
16−
1712module Rel8.Table.Either
1813 ( EitherTable(..)
1914 , eitherTable, leftTable, rightTable
2015 , isLeftTable, isRightTable
21− , aggregateEitherTable
22− , nameEitherTable
2316 )
2417where
2518
2619-- base
2720import Data.Bifunctor ( Bifunctor, bimap )
28−import Data.Functor.Identity ( Identity( Identity ) )
21+import Data.Functor.Identity ( runIdentity )
2922import Data.Kind ( Type )
3023import Prelude hiding ( undefined )
3124
32−-- comonad
33−import Control.Comonad ( extract )
34−
3525-- rel8
36−import Rel8.Aggregate ( Aggregate )
3726import Rel8.Expr ( Expr )
38−import Rel8.Expr.Aggregate ( groupByExpr )
3927import Rel8.Expr.Serialize ( litExpr )
40−import Rel8.Kind.Context ( Reifiable )
41−import Rel8.Schema.Context.Nullify ( Nullifiable )
42−import Rel8.Schema.Dict ( Dict( Dict ) )
28+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
29+import Rel8.Schema.Context.Nullify
30+ ( Nullifiable, NullifiableEq
31+ , encodeTag, decodeTag
32+ , nullifier, unnullifier
33+ )
4334import Rel8.Schema.HTable.Either ( HEitherTable(..) )
4435import Rel8.Schema.HTable.Identity ( HIdentity(..) )
45−import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
46−import qualified Rel8.Schema.Kind as K
47−import Rel8.Schema.Name ( Name )
48−import Rel8.Table
49− ( Table, Columns, Context, fromColumns, toColumns
50− , FromExprs, fromResult, toResult
51− , Transpose
52− )
36+import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
37+import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
38+import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
5339import Rel8.Table.Bool ( bool )
54−import Rel8.Table.Eq ( EqTable, eqTable )
55−import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )
56−import Rel8.Table.Ord ( OrdTable, ordTable )
57−import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )
58−import Rel8.Table.Serialize ( ToExprs )
40+import Rel8.Table.Lifted
41+ ( Table1, Columns1, ConstrainContext1, fromColumns1, toColumns1
42+ , Table2, Columns2, ConstrainContext2, fromColumns2, toColumns2
43+ )
44+import Rel8.Table.Recontextualize ( Recontextualize )
5945import Rel8.Table.Undefined ( undefined )
6046import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
6147
@@ -64,180 +50,124 @@ import Data.Functor.Apply ( Apply, (<.>) )
6450import Data.Functor.Bind ( Bind, (>>-) )
6551
6652
67−-- | An @EitherTable a b@ is a Rel8 table that contains either the table @a@ or
68−-- the table @b@. You can construct an @EitherTable@ using 'leftTable' and
69−-- 'rightTable', and eliminate/pattern match using 'eitherTable'.
70−--
71−-- An @EitherTable@ is operationally the same as Haskell's 'Either' type, but
72−-- adapted to work with Rel8.
73−type EitherTable :: K.Context -> Type -> Type -> Type
74−data EitherTable context a b = EitherTable
75− { tag :: context EitherTag
76− , left :: Nullify context a
77− , right :: Nullify context b
53+type EitherTable :: Type -> Type -> Type
54+data EitherTable a b = EitherTable
55+ { tag :: Expr EitherTag
56+ , left :: a
57+ , right :: b
7858 }
79− deriving stock Functor
80−
81−
82−instance Biprojectable (EitherTable context) where
83− biproject f g (EitherTable tag a b) =
84− EitherTable tag (project f a) (project g b)
85−
86−
87−instance Nullifiable context => Bifunctor (EitherTable context) where
88− bimap f g (EitherTable tag a b) = EitherTable tag (fmap f a) (fmap g b)
59+ deriving stock (Show, Functor)
8960
9061
91−instance Projectable (EitherTable context a) where
92− project f (EitherTable tag a b) = EitherTable tag a (project f b)
62+instance Bifunctor EitherTable where
63+ bimap f g (EitherTable tag a b) = EitherTable tag (f a) (g b)
9364
9465
95−instance (context ~ Expr, Table Expr a) => Apply (EitherTable context a) where
66+instance Table Expr a => Apply (EitherTable a) where
9667 EitherTable tag l1 f <.> EitherTable tag' l2 a =
97− EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f <.> a)
68+ EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f a)
9869
9970
100−instance (context ~ Expr, Table Expr a) => Applicative (EitherTable context a) where
71+instance Table Expr a => Applicative (EitherTable a) where
10172 pure = rightTable
10273 (<*>) = (<.>)
10374
10475
105−instance (context ~ Expr, Table Expr a) => Bind (EitherTable context a) where
106− EitherTable tag l1 a >>- f = case f (extract a) of
76+instance Table Expr a => Bind (EitherTable a) where
77+ EitherTable tag l1 a >>- f = case f a of
10778 EitherTable tag' l2 b ->
10879 EitherTable (tag <> tag') (bool l1 l2 (isRight tag)) b
10980
11081
111−instance (context ~ Expr, Table Expr a) => Monad (EitherTable context a) where
82+instance Table Expr a => Monad (EitherTable a) where
11283 (>>=) = (>>-)
11384
11485
115−instance (context ~ Expr, Table Expr a, Table Expr b) =>
116− Semigroup (EitherTable context a b)
117− where
86+instance (Table Expr a, Table Expr b) => Semigroup (EitherTable a b) where
11887 a <> b = bool a b (isRightTable a)
11988
12089
121−instance
122− ( Table context a, Table context b
123− , Reifiable context, context ~ context'
124− )
125− => Table context' (EitherTable context a b)
126− where
127− type Columns (EitherTable context a b) = HEitherTable (Columns a) (Columns b)
128− type Context (EitherTable context a b) = Context a
129− type FromExprs (EitherTable context a b) = Either (FromExprs a) (FromExprs b)
130− type Transpose to (EitherTable context a b) =
131− EitherTable to (Transpose to a) (Transpose to b)
132−
133− toColumns EitherTable {tag, left, right} = HEitherTable
134− { htag = hlabel $ HIdentity tag
135− , hleft = hlabel $ guard tag (== IsLeft) isLeft $ toColumns left
136− , hright = hlabel $ guard tag (== IsRight) isRight $ toColumns right
137− }
90+instance Table2 EitherTable where
91+ type Columns2 EitherTable = HEitherTable
92+ type ConstrainContext2 EitherTable = Nullifiable
13893
139− fromColumns HEitherTable {htag, hleft, hright} = EitherTable
140− { tag = unHIdentity $ hunlabel htag
141− , left = fromColumns $ hunlabel hleft
142− , right = fromColumns $ hunlabel hright
94+ toColumns2 f g EitherTable {tag, left, right} = HEitherTable
95+ { htag
96+ , hleft = hnullify (nullifier (isLeft tag)) $ f left
97+ , hright = hnullify (nullifier (isRight tag)) $ g right
14398 }
144−
145− toResult = \case
146− Left table -> HEitherTable
147− { htag = hlabel (HIdentity (Identity IsLeft))
148− , hleft = hlabel (toResult @_ @(Nullify context a) (Just table))
149− , hright = hlabel (toResult @_ @(Nullify context b) Nothing)
150− }
151− Right table -> HEitherTable
152− { htag = hlabel (HIdentity (Identity IsRight))
153− , hleft = hlabel (toResult @_ @(Nullify context a) Nothing)
154− , hright = hlabel (toResult @_ @(Nullify context b) (Just table))
99+ where
100+ htag = HIdentity (encodeTag tag)
101+
102+ fromColumns2 f g HEitherTable {htag = htag, hleft, hright} =
103+ EitherTable
104+ { tag
105+ , left = f $ runIdentity $
106+ hunnullify (\a -> pure . unnullifier (isLeft tag) a) hleft
107+ , right = g $ runIdentity $
108+ hunnullify (\a -> pure . unnullifier (isRight tag) a) hright
155109 }
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)
161110 where
162− err = error "Either.fromColumns: mismatch between tag and data"
111+ tag = decodeTag $ unHIdentity htag
163112
164−
165−instance (EqTable a, EqTable b, context ~ Expr) =>
166− EqTable (EitherTable context a b)
167− where
168− eqTable = HEitherTable
169− { htag = hlabel (HIdentity Dict)
170− , hleft = hlabel (eqTable @(Nullify context a))
171− , hright = hlabel (eqTable @(Nullify context b))
172− }
113+ {-# INLINABLE fromColumns2 #-}
114+ {-# INLINABLE toColumns2 #-}
173115
174116
175−instance (OrdTable a, OrdTable b, context ~ Expr) =>
176− OrdTable (EitherTable context a b)
177− where
178− ordTable = HEitherTable
179− { htag = hlabel (HIdentity Dict)
180− , hleft = hlabel (ordTable @(Nullify context a))
181− , hright = hlabel (ordTable @(Nullify context b))
182− }
117+instance Table context a => Table1 (EitherTable a) where
118+ type Columns1 (EitherTable a) = HEitherTable (Columns a)
119+ type ConstrainContext1 (EitherTable a) = NullifiableEq (Context a)
183120
121+ toColumns1 = toColumns2 toColumns
122+ fromColumns1 = fromColumns2 fromColumns
184123
185−instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable Expr exprs1 exprs2) =>
186− ToExprs x (Either a b)
187124
125+instance
126+ ( Table context a, Table context b
127+ , Labelable context, Nullifiable context
128+ ) =>
129+ Table context (EitherTable a b)
130+ where
131+ type Columns (EitherTable a b) =
132+ HEitherTable (HLabel "Left" (Columns a)) (HLabel "Right" (Columns b))
133+ type Context (EitherTable a b) = Context a
188134
189−-- | Test if an 'EitherTable' is a 'leftTable'.
190−isLeftTable :: EitherTable Expr a b -> Expr Bool
191−isLeftTable EitherTable {tag} = isLeft tag
135+ toColumns =
136+ toColumns2
137+ (hlabel labeler . toColumns)
138+ (hlabel labeler . toColumns)
139+ fromColumns =
140+ fromColumns2
141+ (fromColumns . hunlabel unlabeler)
142+ (fromColumns . hunlabel unlabeler)
192143
193144
194−-- | Test if an 'EitherTable' is a 'rightTable'.
195−isRightTable :: EitherTable Expr a b -> Expr Bool
196−isRightTable EitherTable {tag} = isRight tag
145+instance
146+ ( Nullifiable from, Labelable from
147+ , Nullifiable to, Labelable to
148+ , Recontextualize from to a1 b1
149+ , Recontextualize from to a2 b2
150+ ) =>
151+ Recontextualize from to (EitherTable a1 a2) (EitherTable b1 b2)
197152
198153
199−-- | Pattern match/eliminate an 'EitherTable', by providing mappings from a
200−-- 'leftTable' and 'rightTable'.
201−eitherTable :: Table Expr c
202− => (a -> c) -> (b -> c) -> EitherTable Expr a b -> c
203−eitherTable f g EitherTable {tag, left, right} =
204− bool (f (extract left)) (g (extract right)) (isRight tag)
154+isLeftTable :: EitherTable a b -> Expr Bool
155+isLeftTable = isLeft . tag
205156
206157
207−-- | Construct a left 'EitherTable'. Like 'Left'.
208−leftTable :: Table Expr b => a -> EitherTable Expr a b
209−leftTable a = EitherTable (litExpr IsLeft) (pure a) undefined
158+isRightTable :: EitherTable a b -> Expr Bool
159+isRightTable = isRight . tag
210160
211161
212−-- | Construct a right 'EitherTable'. Like 'Right'.
213−rightTable :: Table Expr a => b -> EitherTable Expr a b
214−rightTable = EitherTable (litExpr IsRight) undefined . pure
162+eitherTable :: Table Expr c
163+ => (a -> c) -> (b -> c) -> EitherTable a b -> c
164+eitherTable f g EitherTable {tag, left, right} =
165+ bool (f left) (g right) (isRight tag)
215166
216167
217−-- | Lift a pair of aggregating functions to operate on an 'EitherTable'.
218−-- @leftTable@s and @rightTable@s are grouped separately.
219−aggregateEitherTable :: ()
220− => (exprs -> aggregates)
221− -> (exprs' -> aggregates')
222− -> EitherTable Expr exprs exprs'
223− -> EitherTable Aggregate aggregates aggregates'
224−aggregateEitherTable f g (EitherTable tag a b) = EitherTable
225− { tag = groupByExpr tag
226− , left = aggregateNullify f a
227− , right = aggregateNullify g b
228− }
168+leftTable :: Table Expr b => a -> EitherTable a b
169+leftTable a = EitherTable (litExpr IsLeft) a undefined
229170
230171
231−-- | Construct a 'EitherTable' in the 'Name' context. This can be useful if you
232−-- have a 'EitherTable' that you are storing in a table and need to construct a
233−-- 'TableSchema'.
234−nameEitherTable
235− :: Name EitherTag
236− -- ^ The name of the column to track whether a row is a 'leftTable' or
237− -- 'rightTable'.
238− -> a
239− -- ^ Names of the columns in the @a@ table.
240− -> b
241− -- ^ Names of the columns in the @b@ table.
242− -> EitherTable Name a b
243−nameEitherTable tag left right = EitherTable tag (pure left) (pure right)
172+rightTable :: Table Expr a => b -> EitherTable a b
173+rightTable = EitherTable (litExpr IsRight) undefined
src/Rel8/Table/Eq.hs+35−65
@@ -1,20 +1,17 @@
1−{-# language AllowAmbiguousTypes #-}
2−{-# language BlockArguments #-}
31{-# language DataKinds #-}
4−{-# language DefaultSignatures #-}
5−{-# language DisambiguateRecordFields #-}
62{-# language FlexibleContexts #-}
73{-# language FlexibleInstances #-}
4+{-# language NamedFieldPuns #-}
85{-# language ScopedTypeVariables #-}
96{-# language StandaloneKindSignatures #-}
107{-# language TypeApplications #-}
118{-# language TypeFamilies #-}
12−{-# language TypeOperators #-}
139{-# language UndecidableInstances #-}
10+{-# language UndecidableSuperClasses #-}
1411{-# language ViewPatterns #-}
1512
1613module Rel8.Table.Eq
17− ( EqTable( eqTable ), (==:), (/=:)
14+ ( EqTable, (==:), (/=:)
1815 )
1916where
2017
@@ -23,71 +20,36 @@ import Data.Foldable ( foldl' )
2320import Data.Functor.Const ( Const( Const ), getConst )
2421import Data.Kind ( Constraint, Type )
2522import Data.List.NonEmpty ( NonEmpty( (:|) ) )
26−import GHC.Generics ( Rep )
27−import Prelude
23+import Prelude hiding ( seq )
2824
2925-- rel8
3026import Rel8.Expr ( Expr )
3127import Rel8.Expr.Bool ( (||.), (&&.) )
32−import Rel8.Expr.Eq ( (==.), (/=.) )
33−import Rel8.FCF ( Eval, Exp )
34−import Rel8.Generic.Record ( Record )
35−import Rel8.Generic.Table.Record ( GTable, GColumns, gtable )
28+import Rel8.Expr.Eq ( seq, sne )
29+import Rel8.Opaque ( Opaque )
30+import Rel8.Schema.Context ( Col(..) )
3631import Rel8.Schema.Dict ( Dict( Dict ) )
37−import Rel8.Schema.HTable ( htabulateA, hfield )
38−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
39−import Rel8.Schema.Null ( Sql )
40−import Rel8.Table ( Table, Columns, toColumns, TColumns )
32+import Rel8.Schema.HTable
33+ ( HConstrainTable
34+ , htabulateA, hfield
35+ , hdicts, hspecs
36+ )
37+import Rel8.Schema.Spec ( SSpec(..) )
38+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
39+import Rel8.Table ( Table, Columns, toColumns )
4140import Rel8.Type.Eq ( DBEq )
4241
4342
44−-- | The class of 'Table's that can be compared for equality. Equality on
45−-- tables is defined by equality of all columns all columns, so this class
46−-- means "all columns in a 'Table' have an instance of 'DBEq'".
4743type EqTable :: Type -> Constraint
48−class Table Expr a => EqTable a where
49− eqTable :: Columns a (Dict (Sql DBEq))
50−
51− default eqTable ::
52− ( GTable TEqTable TColumns (Rep (Record a))
53− , Columns a ~ GColumns TColumns (Rep (Record a))
54− )
55− => Columns a (Dict (Sql DBEq))
56− eqTable = gtable @TEqTable @TColumns @(Rep (Record a)) table
57− where
58− table (_ :: proxy x) = eqTable @x
59−
60−
61−data TEqTable :: Type -> Exp Constraint
62−type instance Eval (TEqTable a) = EqTable a
63−
64−
65−instance Sql DBEq a => EqTable (Expr a) where
66− eqTable = HIdentity Dict
67−
68−
69−instance (EqTable a, EqTable b) => EqTable (a, b)
70−
71−
72−instance (EqTable a, EqTable b, EqTable c) => EqTable (a, b, c)
73−
74−
75−instance (EqTable a, EqTable b, EqTable c, EqTable d) => EqTable (a, b, c, d)
76−
77−
78−instance (EqTable a, EqTable b, EqTable c, EqTable d, EqTable e) =>
79− EqTable (a, b, c, d, e)
80−
81−
82−instance (EqTable a, EqTable b, EqTable c, EqTable d, EqTable e, EqTable f) =>
83− EqTable (a, b, c, d, e, f)
84−
85−
44+class
45+ ( Table Expr a
46+ , HConstrainTable (Columns a) (ConstrainDBType DBEq)
47+ ) => EqTable a
8648instance
87− ( EqTable a, EqTable b, EqTable c, EqTable d, EqTable e, EqTable f
88− , EqTable g
89− )
90− => EqTable (a, b, c, d, e, f, g)
49+ ( Table Expr a
50+ , HConstrainTable (Columns a) (ConstrainDBType DBEq)
51+ ) => EqTable a
52+instance {-# OVERLAPPING #-} EqTable Opaque
9153
9254
9355-- | Compare two 'Table's for equality. This corresponds to comparing all
@@ -97,8 +59,12 @@ instance
9759(toColumns -> as) ==: (toColumns -> bs) =
9860 foldl1' (&&.) $ getConst $ htabulateA $ \field ->
9961 case (hfield as field, hfield bs field) of
100− (a, b) -> case hfield (eqTable @a) field of
101− Dict -> Const (pure (a ==. b))
62+ (DB a, DB b) -> case hfield dicts field of
63+ Dict -> case hfield specs field of
64+ SSpec {nullability} -> Const (pure (seq nullability a b))
65+ where
66+ dicts = hdicts @(Columns a) @(ConstrainDBType DBEq)
67+ specs = hspecs @(Columns a)
10268infix 4 ==:
10369
10470
@@ -109,8 +75,12 @@ infix 4 ==:
10975(toColumns -> as) /=: (toColumns -> bs) =
11076 foldl1' (||.) $ getConst $ htabulateA $ \field ->
11177 case (hfield as field, hfield bs field) of
112− (a, b) -> case hfield (eqTable @a) field of
113− Dict -> Const (pure (a /=. b))
78+ (DB a, DB b) -> case hfield dicts field of
79+ Dict -> case hfield specs field of
80+ SSpec {nullability} -> Const (pure (sne nullability a b))
81+ where
82+ dicts = hdicts @(Columns a) @(ConstrainDBType DBEq)
83+ specs = hspecs @(Columns a)
11484infix 4 /=:
11585
11686
src/Rel8/Table/HKD.hsdeleted−228
@@ -1,228 +0,0 @@
1−{-# language AllowAmbiguousTypes #-}
2−{-# language DataKinds #-}
3−{-# language FlexibleContexts #-}
4−{-# language FlexibleInstances #-}
5−{-# language MultiParamTypeClasses #-}
6−{-# language RankNTypes #-}
7−{-# language ScopedTypeVariables #-}
8−{-# language StandaloneKindSignatures #-}
9−{-# language TypeApplications #-}
10−{-# language TypeFamilies #-}
11−{-# language UndecidableInstances #-}
12−{-# language UndecidableSuperClasses #-}
13−
14−module Rel8.Table.HKD
15− ( HKD( HKD )
16− , HKDable
17− , BuildableHKD
18− , BuildHKD, buildHKD
19− , ConstructableHKD
20− , ConstructHKD, constructHKD
21− , DeconstructHKD, deconstructHKD
22− , NameHKD, nameHKD
23− , AggregateHKD, aggregateHKD
24− , HKDRep
25− )
26−where
27−
28−-- base
29−import Data.Kind ( Constraint, Type )
30−import GHC.Generics ( Generic, Rep, from, to )
31−import GHC.TypeLits ( Symbol )
32−import Prelude
33−
34−-- rel8
35−import Rel8.Aggregate ( Aggregate )
36−import Rel8.Column ( TColumn )
37−import Rel8.Expr ( Expr )
38−import Rel8.FCF ( Eval, Exp )
39−import Rel8.Kind.Algebra ( KnownAlgebra )
40−import Rel8.Generic.Construction
41− ( GGBuildable
42− , GGBuild, ggbuild
43− , GGConstructable
44− , GGConstruct, ggconstruct
45− , GGDeconstruct, ggdeconstruct
46− , GGName, ggname
47− , GGAggregate, ggaggregate
48− )
49−import Rel8.Generic.Map ( GMap )
50−import Rel8.Generic.Record
51− ( GRecord, GRecordable, grecord, gunrecord
52− , Record( Record ), unrecord
53− )
54−import Rel8.Generic.Rel8able
55− ( Rel8able
56− , GColumns, gfromColumns, gtoColumns
57− , GFromExprs, gfromResult, gtoResult
58− )
59−import Rel8.Generic.Table
60− ( GGSerialize, GGColumns, GAlgebra, ggfromResult, ggtoResult
61− )
62−import Rel8.Generic.Table.Record ( GTable, GContext )
63−import qualified Rel8.Generic.Table.Record as G
64−import qualified Rel8.Schema.Kind as K
65−import Rel8.Schema.HTable ( HTable )
66−import Rel8.Schema.Name ( Name )
67−import Rel8.Schema.Result ( Result )
68−import Rel8.Table
69− ( Table, fromColumns, toColumns, fromResult, toResult
70− , TTable, TColumns, TContext
71− , TSerialize
72− )
73−
74−
75−type GColumnsHKD :: Type -> K.HTable
76−type GColumnsHKD a =
77− Eval (GGColumns (GAlgebra (Rep a)) TColumns (GRecord (GMap (TColumn Expr) (Rep a))))
78−
79−
80−type HKD :: Type -> K.Rel8able
81−newtype HKD a f = HKD (GColumnsHKD a f)
82−
83−
84−instance HKDable a => Rel8able (HKD a) where
85− type GColumns (HKD a) = GColumnsHKD a
86− type GFromExprs (HKD a) = a
87−
88− gfromColumns _ = HKD
89− gtoColumns _ (HKD a) = a
90−
91− gfromResult =
92− unrecord .
93− to .
94− ggfromResult
95− @(GAlgebra (Rep a))
96− @TSerialize
97− @TColumns
98− @(Eval (HKDRep a Expr))
99− @(Eval (HKDRep a Result))
100− (\(_ :: proxy x) -> fromResult @_ @x)
101−
102− gtoResult =
103− ggtoResult
104− @(GAlgebra (Rep a))
105− @TSerialize
106− @TColumns
107− @(Eval (HKDRep a Expr))
108− @(Eval (HKDRep a Result))
109− (\(_ :: proxy x) -> toResult @_ @x) .
110− from .
111− Record
112−
113−
114−instance
115− ( GTable (TTable f) TColumns (GRecord (GMap (TColumn f) (Rep a)))
116− , G.GColumns TColumns (GRecord (GMap (TColumn f) (Rep a))) ~ GColumnsHKD a
117− , GContext TContext (GRecord (GMap (TColumn f) (Rep a))) ~ f
118− , GRecordable (GMap (TColumn f) (Rep a))
119− )
120− => Generic (HKD a f)
121− where
122− type Rep (HKD a f) = GMap (TColumn f) (Rep a)
123−
124− from =
125− gunrecord @(GMap (TColumn f) (Rep a)) .
126− G.gfromColumns
127− @(TTable f)
128− @TColumns
129− fromColumns .
130− (\(HKD a) -> a)
131−
132− to =
133− HKD .
134− G.gtoColumns
135− @(TTable f)
136− @TColumns
137− toColumns .
138− grecord @(GMap (TColumn f) (Rep a))
139−
140−
141−type HKDable :: Type -> Constraint
142−class
143− ( Generic (Record a)
144− , HTable (GColumns (HKD a))
145− , KnownAlgebra (GAlgebra (Rep a))
146− , Eval (GGSerialize (GAlgebra (Rep a)) TSerialize TColumns (Eval (HKDRep a Expr)) (Eval (HKDRep a Result)))
147− , GRecord (GMap (TColumn Result) (Rep a)) ~ Rep (Record a)
148− )
149− => HKDable a
150−instance
151− ( Generic (Record a)
152− , HTable (GColumns (HKD a))
153− , KnownAlgebra (GAlgebra (Rep a))
154− , Eval (GGSerialize (GAlgebra (Rep a)) TSerialize TColumns (Eval (HKDRep a Expr)) (Eval (HKDRep a Result)))
155− , GRecord (GMap (TColumn Result) (Rep a)) ~ Rep (Record a)
156− )
157− => HKDable a
158−
159−
160−type Top_ :: Constraint
161−class Top_
162−instance Top_
163−
164−
165−data Top :: Type -> Exp Constraint
166−type instance Eval (Top _) = Top_
167−
168−
169−type BuildableHKD :: Type -> Symbol -> Constraint
170−class GGBuildable (GAlgebra (Rep a)) name (HKDRep a) => BuildableHKD a name
171−instance GGBuildable (GAlgebra (Rep a)) name (HKDRep a) => BuildableHKD a name
172−
173−
174−type BuildHKD :: Type -> Symbol -> Type
175−type BuildHKD a name = GGBuild (GAlgebra (Rep a)) name (HKDRep a) (HKD a Expr)
176−
177−
178−buildHKD :: forall a name. BuildableHKD a name => BuildHKD a name
179−buildHKD =
180− ggbuild @(GAlgebra (Rep a)) @name @(HKDRep a) @(HKD a Expr) HKD
181−
182−
183−type ConstructableHKD :: Type -> Constraint
184−class GGConstructable (GAlgebra (Rep a)) (HKDRep a) => ConstructableHKD a
185−instance GGConstructable (GAlgebra (Rep a)) (HKDRep a) => ConstructableHKD a
186−
187−
188−type ConstructHKD :: Type -> Type
189−type ConstructHKD a = forall r. GGConstruct (GAlgebra (Rep a)) (HKDRep a) r
190−
191−
192−constructHKD :: forall a. ConstructableHKD a => ConstructHKD a -> HKD a Expr
193−constructHKD f =
194− ggconstruct @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) HKD
195− (f @(HKD a Expr))
196−
197−
198−type DeconstructHKD :: Type -> Type -> Type
199−type DeconstructHKD a r = GGDeconstruct (GAlgebra (Rep a)) (HKDRep a) (HKD a Expr) r
200−
201−
202−deconstructHKD :: forall a r. (ConstructableHKD a, Table Expr r)
203− => DeconstructHKD a r
204−deconstructHKD = ggdeconstruct @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) @r (\(HKD a) -> a)
205−
206−
207−type NameHKD :: Type -> Type
208−type NameHKD a = GGName (GAlgebra (Rep a)) (HKDRep a) (HKD a Name)
209−
210−
211−nameHKD :: forall a. ConstructableHKD a => NameHKD a
212−nameHKD = ggname @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Name) HKD
213−
214−
215−type AggregateHKD :: Type -> Type
216−type AggregateHKD a = forall r. GGAggregate (GAlgebra (Rep a)) (HKDRep a) r
217−
218−
219−aggregateHKD :: forall a. ConstructableHKD a
220− => AggregateHKD a -> HKD a Expr -> HKD a Aggregate
221−aggregateHKD f =
222− ggaggregate @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) @(HKD a Aggregate) HKD (\(HKD a) -> a)
223− (f @(HKD a Aggregate))
224−
225−
226−data HKDRep :: Type -> K.Context -> Exp (Type -> Type)
227−type instance Eval (HKDRep a context) =
228− GRecord (GMap (TColumn context) (Rep a))
src/Rel8/Table/Insert.hsnew file+51
@@ -0,0 +1,51 @@
1+{-# language FlexibleContexts #-}
2+{-# language NamedFieldPuns #-}
3+{-# language TypeFamilies #-}
4+{-# language ViewPatterns #-}
5+
6+module Rel8.Table.Insert
7+ ( toInsert
8+ , toInsertDefaults
9+ )
10+where
11+
12+-- base
13+import Prelude
14+
15+-- rel8
16+import Rel8.Kind.Necessity ( SNecessity( SOptional, SRequired ) )
17+import Rel8.Schema.Context ( Col(..) )
18+import Rel8.Schema.HTable ( hfield, htabulate, hspecs )
19+import Rel8.Schema.Spec ( SSpec(..) )
20+import Rel8.Table ( fromColumns, toColumns )
21+import Rel8.Table.Recontextualize ( Inserts )
22+
23+
24+-- | @toInsert@ converts a 'Table' of 'Expr's into a 'Table' that can be used
25+-- with 'insert'. This will override any columns that have default values to
26+-- use exactly what is given. If you want to use default values, you can either
27+-- override the result of @toInsert@, or use 'toInsertDefaults'.
28+toInsert :: Inserts exprs inserts => exprs -> inserts
29+toInsert (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
30+ case hfield hspecs field of
31+ SSpec {necessity} -> case hfield exprs field of
32+ DB expr -> case necessity of
33+ SRequired -> RequiredInsert expr
34+ SOptional -> OptionalInsert (Just expr)
35+
36+
37+-- | @toInsertDefaults@ converts a 'Table' of 'Expr's into a 'Table' that can
38+-- be used with 'insert'. Any columns that have a default value will override
39+-- whatever is in the input expression.
40+--
41+-- One example where this is useful is for any table that has a special @id@
42+-- column, which has a default value to draw a new value from a sequence. If we
43+-- use 'toInsertDefaults', we can provide a dummy value that will be replaced
44+-- with a call to @DEFAULT@.
45+toInsertDefaults :: Inserts exprs inserts => exprs -> inserts
46+toInsertDefaults (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
47+ case hfield hspecs field of
48+ SSpec {necessity} -> case hfield exprs field of
49+ DB expr -> case necessity of
50+ SRequired -> RequiredInsert expr
51+ SOptional -> OptionalInsert Nothing
src/Rel8/Table/Lifted.hsnew file+57
@@ -0,0 +1,57 @@
1+{-# language ConstrainedClassMethods #-}
2+{-# language DataKinds #-}
3+{-# language FlexibleContexts #-}
4+{-# language FlexibleInstances #-}
5+{-# language StandaloneKindSignatures #-}
6+{-# language TypeFamilies #-}
7+
8+module Rel8.Table.Lifted
9+ ( Table1( Columns1, ConstrainContext1, toColumns1, fromColumns1 )
10+ , Table2( Columns2, ConstrainContext2, toColumns2, fromColumns2 )
11+ )
12+where
13+
14+-- base
15+import Data.Kind ( Constraint, Type )
16+import Prelude ()
17+
18+-- rel8
19+import Rel8.Schema.Context ( Interpretation, Col )
20+import Rel8.Schema.HTable ( HTable )
21+import qualified Rel8.Schema.Kind as K
22+
23+
24+type Table1 :: (Type -> Type) -> Constraint
25+class Table1 f where
26+ type Columns1 f :: K.HTable -> K.HTable
27+ type ConstrainContext1 f :: K.Context -> Constraint
28+ type ConstrainContext1 _ = Interpretation
29+
30+ toColumns1 :: (ConstrainContext1 f context, HTable t)
31+ => (a -> t (Col context))
32+ -> f a
33+ -> Columns1 f t (Col context)
34+
35+ fromColumns1 :: (ConstrainContext1 f context, HTable t)
36+ => (t (Col context) -> a)
37+ -> Columns1 f t (Col context)
38+ -> f a
39+
40+
41+type Table2 :: (Type -> Type -> Type) -> Constraint
42+class Table2 p where
43+ type Columns2 p :: K.HTable -> K.HTable -> K.HTable
44+ type ConstrainContext2 p :: K.Context -> Constraint
45+ type ConstrainContext2 _ = Interpretation
46+
47+ toColumns2 :: (ConstrainContext2 p context, HTable t, HTable u)
48+ => (a -> t (Col context))
49+ -> (b -> u (Col context))
50+ -> p a b
51+ -> Columns2 p t u (Col context)
52+
53+ fromColumns2 :: (ConstrainContext2 p context, HTable t, HTable u)
54+ => (t (Col context) -> a)
55+ -> (u (Col context) -> b)
56+ -> Columns2 p t u (Col context)
57+ -> p a b
src/Rel8/Table/List.hs+21−106
@@ -1,149 +1,64 @@
1−{-# language DataKinds #-}
21{-# language FlexibleContexts #-}
32{-# language FlexibleInstances #-}
43{-# language MultiParamTypeClasses #-}
5−{-# language NamedFieldPuns #-}
6−{-# language ScopedTypeVariables #-}
74{-# language StandaloneKindSignatures #-}
8−{-# language TypeApplications #-}
95{-# language TypeFamilies #-}
106{-# language UndecidableInstances #-}
117
128module Rel8.Table.List
139 ( ListTable(..)
14− , ($*)
15− , listTable
16− , nameListTable
1710 )
1811where
1912
2013-- base
21−import Data.Functor.Identity ( Identity( Identity ) )
2214import Data.Kind ( Type )
2315import Prelude
2416
2517-- rel8
2618import Rel8.Expr ( Expr )
27−import Rel8.Expr.Array ( sappend, sempty, slistOf )
28−import Rel8.Schema.Dict ( Dict( Dict ) )
19+import Rel8.Expr.Array ( sappend, sempty )
20+import Rel8.Schema.Context ( Col(..) )
2921import Rel8.Schema.HTable.List ( HListTable )
30−import Rel8.Schema.HTable.Vectorize
31− ( hvectorize, hunvectorize
32− , happend, hempty
33− , hproject, hcolumn
34− )
35−import qualified Rel8.Schema.Kind as K
36−import Rel8.Schema.Name ( Name( Name ) )
37−import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
38−import Rel8.Schema.Result ( vectorizer, unvectorizer )
39−import Rel8.Schema.Spec ( Spec(..) )
40−import Rel8.Table
41− ( Table, Context, Columns, fromColumns, toColumns
42− , FromExprs, fromResult, toResult
43− , Transpose
44− )
22+import Rel8.Schema.HTable.Vectorize ( happend, hempty )
23+import Rel8.Table ( Table, Context, Columns, fromColumns, toColumns )
4524import Rel8.Table.Alternative
4625 ( AltTable, (<|>:)
4726 , AlternativeTable, emptyTable
4827 )
49−import Rel8.Table.Eq ( EqTable, eqTable )
50−import Rel8.Table.Ord ( OrdTable, ordTable )
51−import Rel8.Table.Projection
52− ( Projectable, Projecting, Projection, project, apply
53− )
54−import Rel8.Table.Serialize ( ToExprs )
28+import Rel8.Table.Recontextualize ( Recontextualize )
5529
5630
5731-- | A @ListTable@ value contains zero or more instances of @a@. You construct
58−-- @ListTable@s with 'Rel8.many' or 'Rel8.listAgg'.
59−type ListTable :: K.Context -> Type -> Type
60−newtype ListTable context a =
61− ListTable (HListTable (Columns a) (Context a))
62−
32+-- @ListTable@s with 'many' or 'listAgg'.
33+type ListTable :: Type -> Type
34+newtype ListTable a = ListTable (HListTable (Columns a) (Col (Context a)))
6335
64−instance Projectable (ListTable context) where
65− project f (ListTable a) = ListTable (hproject (apply f) a)
6636
67−
68−instance (Table context a, context ~ context') =>
69− Table context' (ListTable context a)
70− where
71− type Columns (ListTable context a) = HListTable (Columns a)
72− type Context (ListTable context a) = Context a
73− type FromExprs (ListTable context a) = [FromExprs a]
74− type Transpose to (ListTable context a) = ListTable to (Transpose to a)
37+instance Table context a => Table context (ListTable a) where
38+ type Columns (ListTable a) = HListTable (Columns a)
39+ type Context (ListTable a) = Context a
7540
7641 fromColumns = ListTable
7742 toColumns (ListTable a) = a
78− fromResult = fmap (fromResult @_ @a) . hunvectorize unvectorizer
79− toResult = hvectorize vectorizer . fmap (toResult @_ @a)
80−
81−
82−instance (EqTable a, context ~ Expr) => EqTable (ListTable context a) where
83− eqTable =
84− hvectorize
85− (\Spec {nullity} (Identity Dict) -> case nullity of
86− Null -> Dict
87− NotNull -> Dict)
88− (Identity (eqTable @a))
89−
9043
91−instance (OrdTable a, context ~ Expr) => OrdTable (ListTable context a) where
92− ordTable =
93− hvectorize
94− (\Spec {nullity} (Identity Dict) -> case nullity of
95− Null -> Dict
96− NotNull -> Dict)
97− (Identity (ordTable @a))
9844
45+instance Recontextualize from to a b =>
46+ Recontextualize from to (ListTable a) (ListTable b)
9947
100−instance (ToExprs exprs a, context ~ Expr) =>
101− ToExprs (ListTable context exprs) [a]
10248
103−
104−instance context ~ Expr => AltTable (ListTable context) where
49+instance AltTable ListTable where
10550 (<|>:) = (<>)
10651
10752
108−instance context ~ Expr => AlternativeTable (ListTable context) where
53+instance AlternativeTable ListTable where
10954 emptyTable = mempty
11055
11156
112−instance (context ~ Expr, Table Expr a) => Semigroup (ListTable context a)
113− where
114− ListTable as <> ListTable bs = ListTable $ happend (const sappend) as bs
115−
116−
117−instance (context ~ Expr, Table Expr a) =>
118− Monoid (ListTable context a)
119− where
120− mempty = ListTable $ hempty $ \Spec {info} -> sempty info
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 $*
128−
129−
130−-- | Construct a @ListTable@ from a list of expressions.
131−listTable :: Table Expr a => [a] -> ListTable Expr a
132−listTable =
133− ListTable .
134− hvectorize (\Spec {info} -> slistOf info) .
135− fmap toColumns
57+instance Table Expr a => Semigroup (ListTable a) where
58+ ListTable as <> ListTable bs = ListTable $
59+ happend (\_ _ (DB a) (DB b) -> DB (sappend a b)) as bs
13660
13761
138−-- | Construct a 'ListTable' in the 'Name' context. This can be useful if you
139−-- have a 'ListTable' that you are storing in a table and need to construct a
140−-- 'TableSchema'.
141−nameListTable
142− :: Table Name a
143− => a -- ^ The names of the columns of elements of the list.
144− -> ListTable Name a
145−nameListTable =
146− ListTable .
147− hvectorize (\_ (Identity (Name a)) -> Name a) .
148− pure .
149− toColumns
62+instance Table Expr a => Monoid (ListTable a) where
63+ mempty = ListTable $ hempty $ \nullability info ->
64+ DB (sempty nullability info)
src/Rel8/Table/Maybe.hs+90−132
@@ -15,53 +15,45 @@ module Rel8.Table.Maybe
1515 ( MaybeTable(..)
1616 , maybeTable, nothingTable, justTable
1717 , isNothingTable, isJustTable
18− , fromMaybeTable
1918 , ($?)
20− , aggregateMaybeTable
21− , nameMaybeTable
2219 )
2320where
2421
2522-- base
26−import Data.Functor ( ($>) )
27−import Data.Functor.Identity ( Identity( Identity ) )
23+import Data.Functor.Identity ( runIdentity )
2824import Data.Kind ( Type )
29−import Data.Maybe ( fromMaybe, isJust )
30−import Prelude hiding ( null, undefined )
31−
32−-- comonad
33−import Control.Comonad ( extract )
25+import Prelude hiding ( null, repeat, undefined, zipWith )
3426
3527-- rel8
36−import Rel8.Aggregate ( Aggregate )
3728import Rel8.Expr ( Expr )
38−import Rel8.Expr.Aggregate ( groupByExpr )
3929import Rel8.Expr.Bool ( boolExpr )
4030import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )
41−import Rel8.Kind.Context ( Reifiable )
42−import Rel8.Schema.Dict ( Dict( Dict ) )
43−import qualified Rel8.Schema.Kind as K
31+import Rel8.Expr.Serialize ( litExpr )
32+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
33+import Rel8.Schema.Context.Nullify
34+ ( Nullifiable
35+ , encodeTag, decodeTag
36+ , nullifier, unnullifier
37+ )
4438import Rel8.Schema.HTable.Identity ( HIdentity(..) )
45−import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
39+import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
4640import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
47−import Rel8.Schema.Name ( Name )
48−import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
49−import qualified Rel8.Schema.Null as N
50−import Rel8.Table
51− ( Table, Columns, Context, fromColumns, toColumns
52− , FromExprs, fromResult, toResult
53− , Transpose
41+import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
42+import Rel8.Schema.Nullability
43+ ( Nullify
44+ , Nullability( Nullable, NonNullable )
45+ , Sql, nullabilization
5446 )
47+import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
5548import Rel8.Table.Alternative
5649 ( AltTable, (<|>:)
5750 , AlternativeTable, emptyTable
5851 )
5952import Rel8.Table.Bool ( bool )
60−import Rel8.Table.Eq ( EqTable, eqTable )
61−import Rel8.Table.Ord ( OrdTable, ordTable )
62−import Rel8.Table.Projection ( Projectable, project )
63−import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )
64−import Rel8.Table.Serialize ( ToExprs )
53+import Rel8.Table.Lifted
54+ ( Table1, Columns1, ConstrainContext1, fromColumns1, toColumns1
55+ )
56+import Rel8.Table.Recontextualize ( Recontextualize )
6557import Rel8.Table.Undefined ( undefined )
6658import Rel8.Type ( DBType )
6759import Rel8.Type.Tag ( MaybeTag( IsJust ) )
@@ -79,168 +71,134 @@ import Data.Functor.Bind ( Bind, (>>-) )
7971-- entirely of nulls, you can't distinguish if you matched an all null row, or
8072-- if the match failed. For this reason @MaybeTable@ contains an extra field -
8173-- a "nullTag" - to track whether or not the outer join produced any rows.
82−type MaybeTable :: K.Context -> Type -> Type
83−data MaybeTable context a = MaybeTable
84− { tag :: context (Maybe MaybeTag)
85− , just :: Nullify context a
74+type MaybeTable :: Type -> Type
75+data MaybeTable a = MaybeTable
76+ { tag :: Expr (Maybe MaybeTag)
77+ , just :: a
8678 }
87− deriving stock Functor
88−
89−
90−instance Projectable (MaybeTable context) where
91− project f (MaybeTable tag a) = MaybeTable tag (project f a)
79+ deriving stock (Show, Functor)
9280
9381
94−instance context ~ Expr => Apply (MaybeTable context) where
95− MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f <.> a)
82+instance Apply MaybeTable where
83+ MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f a)
9684
9785
9886-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:
99−-- 'Rel8.traverseMaybeTable'.
100−instance context ~ Expr => Applicative (MaybeTable context) where
87+-- 'traverseMaybeTable'.
88+instance Applicative MaybeTable where
10189 (<*>) = (<.>)
10290 pure = justTable
10391
10492
105−instance context ~ Expr => Bind (MaybeTable context) where
106− MaybeTable tag a >>- f = case f (extract a) of
93+instance Bind MaybeTable where
94+ MaybeTable tag a >>- f = case f a of
10795 MaybeTable tag' b -> MaybeTable (tag <> tag') b
10896
10997
110−-- | Has the same behavior as the @Monad@ instance for @Maybe@.
111−instance context ~ Expr => Monad (MaybeTable context) where
98+-- | Has the same behavior as the @Monad@ instance for @Maybe@. See also:
99+-- 'bindMaybeTable'.
100+instance Monad MaybeTable where
112101 (>>=) = (>>-)
113102
114103
115−instance context ~ Expr => AltTable (MaybeTable context) where
116− ma <|>: mb = bool ma mb (isNothingTable ma)
104+instance AltTable MaybeTable where
105+ ma@(MaybeTable tag a) <|>: MaybeTable tag' b = MaybeTable
106+ { tag = boolExpr tag tag' condition
107+ , just = bool a b condition
108+ }
109+ where
110+ condition = isNothingTable ma
117111
118112
119−instance context ~ Expr => AlternativeTable (MaybeTable context) where
113+instance AlternativeTable MaybeTable where
120114 emptyTable = nothingTable
121115
122116
123−instance (context ~ Expr, Table Expr a, Semigroup a) =>
124− Semigroup (MaybeTable context a)
125− where
117+instance (Table Expr a, Semigroup a) => Semigroup (MaybeTable a) where
126118 ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma
127119
128120
129−instance (context ~ Expr, Table Expr a, Semigroup a) =>
130− Monoid (MaybeTable context a)
131− where
121+instance (Table Expr a, Semigroup a) => Monoid (MaybeTable a) where
132122 mempty = nothingTable
133123
134124
135−instance (Table context a, Reifiable context, context ~ context') =>
136− Table context' (MaybeTable context a)
137− where
138− type Columns (MaybeTable context a) = HMaybeTable (Columns a)
139− type Context (MaybeTable context a) = Context a
140− type FromExprs (MaybeTable context a) = Maybe (FromExprs a)
141− type Transpose to (MaybeTable context a) = MaybeTable to (Transpose to a)
142−
143− toColumns MaybeTable {tag, just} = HMaybeTable
144− { htag = hlabel $ HIdentity tag
145− , hjust = hlabel $ guard tag isJust isNonNull $ toColumns just
146− }
125+instance Table1 MaybeTable where
126+ type Columns1 MaybeTable = HMaybeTable
127+ type ConstrainContext1 MaybeTable = Nullifiable
147128
148− fromColumns HMaybeTable {htag, hjust} = MaybeTable
149− { tag = unHIdentity $ hunlabel htag
150− , just = fromColumns $ hunlabel hjust
129+ toColumns1 f MaybeTable {tag, just} = HMaybeTable
130+ { htag
131+ , hjust = hnullify (nullifier (isNonNull tag)) $ f just
151132 }
133+ where
134+ htag = HIdentity (encodeTag tag)
152135
153− toResult ma = HMaybeTable
154− { htag = hlabel (HIdentity (Identity (IsJust <$ ma)))
155− , hjust = hlabel (toResult @_ @(Nullify context a) ma)
136+ fromColumns1 f HMaybeTable {htag = HIdentity htag, hjust} = MaybeTable
137+ { tag
138+ , just = f $ runIdentity $
139+ hunnullify (\a -> pure . unnullifier (isNonNull tag) a) hjust
156140 }
157−
158− fromResult HMaybeTable {htag, hjust} = case hunlabel htag of
159− HIdentity (Identity tag) -> tag $>
160− fromMaybe err (fromResult @_ @(Nullify context a) (hunlabel hjust))
161141 where
162− err = error "Maybe.fromColumns: mismatch between tag and data"
142+ tag = decodeTag htag
163143
144+ {-# INLINABLE fromColumns1 #-}
145+ {-# INLINABLE toColumns1 #-}
164146
165−instance (EqTable a, context ~ Expr) => EqTable (MaybeTable context a) where
166− eqTable = HMaybeTable
167− { htag = hlabel (HIdentity Dict)
168− , hjust = hlabel (eqTable @(Nullify context a))
169− }
170147
148+instance
149+ ( Table context a
150+ , Labelable context, Nullifiable context
151+ ) => Table context (MaybeTable a)
152+ where
153+ type Columns (MaybeTable a) = HMaybeTable (HLabel "Just" (Columns a))
154+ type Context (MaybeTable a) = Context a
171155
172−instance (OrdTable a, context ~ Expr) => OrdTable (MaybeTable context a) where
173− ordTable = HMaybeTable
174− { htag = hlabel (HIdentity Dict)
175− , hjust = hlabel (ordTable @(Nullify context a))
176− }
156+ toColumns = toColumns1 (hlabel labeler . toColumns)
157+ fromColumns = fromColumns1 (fromColumns . hunlabel unlabeler)
177158
178159
179−instance (ToExprs exprs a, context ~ Expr) =>
180− ToExprs (MaybeTable context exprs) (Maybe a)
160+instance
161+ ( Labelable from, Nullifiable from
162+ , Labelable to, Nullifiable to
163+ , Recontextualize from to a b
164+ ) => Recontextualize from to (MaybeTable a) (MaybeTable b)
181165
182166
183−-- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.
184−isNothingTable :: MaybeTable Expr a -> Expr Bool
167+-- | Check if a @MaybeTable@ is absent of any row.. Like 'isNothing'.
168+isNothingTable :: MaybeTable a -> Expr Bool
185169isNothingTable (MaybeTable tag _) = isNull tag
186170
187171
188−-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.
189−isJustTable :: MaybeTable Expr a -> Expr Bool
172+-- | Check if a @MaybeTable@ contains a row. Like 'isJust'.
173+isJustTable :: MaybeTable a -> Expr Bool
190174isJustTable (MaybeTable tag _) = isNonNull tag
191175
192176
193177-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.
194−maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable Expr a -> b
195−maybeTable b f ma@(MaybeTable _ a) = bool (f (extract a)) b (isNothingTable ma)
196−{-# INLINABLE maybeTable #-}
178+maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable a -> b
179+maybeTable b f ma@(MaybeTable _ a) = bool (f a) b (isNothingTable ma)
197180
198181
199182-- | The null table. Like 'Nothing'.
200−nothingTable :: Table Expr a => MaybeTable Expr a
201−nothingTable = MaybeTable null (pure undefined)
183+nothingTable :: Table Expr a => MaybeTable a
184+nothingTable = MaybeTable null undefined
202185
203186
204187-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use
205188-- 'pure'.
206−justTable :: a -> MaybeTable Expr a
207−justTable = MaybeTable mempty . pure
208−
209−
210−-- | 'Data.Maybe.fromMaybe' for 'MaybeTable's.
211−fromMaybeTable :: Table Expr a => a -> MaybeTable Expr a -> a
212−fromMaybeTable fallback = maybeTable fallback id
189+justTable :: a -> MaybeTable a
190+justTable = MaybeTable (nullify (litExpr IsJust))
213191
214192
215193-- | Project a single expression out of a 'MaybeTable'. You can think of this
216194-- operator like the '$' operator, but it also has the ability to return
217195-- @null@.
196+--
197+-- >>> select c $ fmap (fst $?) (optional (values [lit (True, False)]))
198+-- [Just True]
218199($?) :: forall a b. Sql DBType b
219− => (a -> Expr b) -> MaybeTable Expr a -> Expr (N.Nullify b)
220−f $? ma@(MaybeTable _ a) = case nullable @b of
221− Null -> boolExpr (f (extract a)) null (isNothingTable ma)
222− NotNull -> boolExpr (nullify (f (extract a))) null (isNothingTable ma)
200+ => (a -> Expr b) -> MaybeTable a -> Expr (Nullify b)
201+f $? ma@(MaybeTable _ a) = case nullabilization @b of
202+ Nullable -> boolExpr (f a) null (isNothingTable ma)
203+ NonNullable -> boolExpr (nullify (f a)) null (isNothingTable ma)
223204infixl 4 $?
224−
225−
226−-- | Lift an aggregating function to operate on a 'MaybeTable'.
227−-- @nothingTable@s and @justTable@s are grouped separately.
228−aggregateMaybeTable :: ()
229− => (exprs -> aggregates)
230− -> MaybeTable Expr exprs
231− -> MaybeTable Aggregate aggregates
232−aggregateMaybeTable f (MaybeTable tag a) =
233− MaybeTable (groupByExpr tag) (aggregateNullify f a)
234−
235−
236−-- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you
237−-- have a 'MaybeTable' that you are storing in a table and need to construct a
238−-- 'TableSchema'.
239−nameMaybeTable
240− :: Name (Maybe MaybeTag)
241− -- ^ The name of the column to track whether a row is a 'justTable' or
242− -- 'nothingTable'.
243− -> a
244− -- ^ Names of the columns in @a@.
245− -> MaybeTable Name a
246−nameMaybeTable tag = MaybeTable tag . pure
src/Rel8/Table/Name.hs+22−37
@@ -1,17 +1,14 @@
1−{-# language DataKinds #-}
21{-# language FlexibleContexts #-}
3−{-# language FlexibleInstances #-}
4−{-# language MultiParamTypeClasses #-}
52{-# language NamedFieldPuns #-}
63{-# language ScopedTypeVariables #-}
74{-# language TypeApplications #-}
85{-# language TypeFamilies #-}
9−{-# language UndecidableInstances #-}
106{-# language ViewPatterns #-}
117
128module Rel8.Table.Name
139 ( namesFromLabels
1410 , namesFromLabelsWith
11+ , showExprs
1512 , showLabels
1613 , showNames
1714 )
@@ -20,60 +17,48 @@ where
2017-- base
2118import Data.Foldable ( fold )
2219import Data.Functor.Const ( Const( Const ), getConst )
23−import Data.List.NonEmpty ( NonEmpty, intersperse, nonEmpty )
24−import Data.Maybe ( fromMaybe )
20+import Data.List.NonEmpty ( NonEmpty, intersperse )
2521import Prelude
2622
23+-- casing
24+import Text.Casing ( quietSnake )
25+
2726-- rel8
27+import Rel8.Expr ( Expr )
28+import Rel8.Kind.Labels ( renderLabels )
29+import Rel8.Schema.Context ( Col(..), Name )
2830import Rel8.Schema.HTable ( htabulate, htabulateA, hfield, hspecs )
29−import Rel8.Schema.Name ( Name( Name ) )
30−import Rel8.Schema.Spec ( Spec(..) )
31−import Rel8.Table ( Table(..) )
31+import Rel8.Schema.Spec ( SSpec(..) )
32+import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
3233
3334
34−-- | Construct a table in the 'Name' context containing the names of all
35−-- columns. Nested column names will be combined with @/@.
36−--
37−-- See also: 'namesFromLabelsWith'.
3835namesFromLabels :: Table Name a => a
3936namesFromLabels = namesFromLabelsWith go
4037 where
41− go = fold . intersperse "/"
38+ go = fold . intersperse "/" . fmap quietSnake
4239
4340
44−-- | Construct a table in the 'Name' context containing the names of all
45−-- columns. The supplied function can be used to transform column names.
46−--
47−-- This function can be used to generically derive the columns for a
48−-- 'TableSchema'. For example,
49−--
50−-- @
51−-- myTableSchema :: TableSchema (MyTable Name)
52−-- myTableSchema = TableSchema
53−-- { columns = namesFromLabelsWith last
54−-- }
55−-- @
56−--
57−-- will construct a 'TableSchema' where each columns names exactly corresponds
58−-- to the name of the Haskell field.
5941namesFromLabelsWith :: Table Name a
6042 => (NonEmpty String -> String) -> a
6143namesFromLabelsWith f = fromColumns $ htabulate $ \field ->
6244 case hfield hspecs field of
63− Spec {labels} -> Name (f (renderLabels labels))
45+ SSpec {labels} -> NameCol (f (renderLabels labels))
46+
47+
48+showExprs :: Table Expr a => a -> [(String, String)]
49+showExprs as = case (namesFromLabels, toColumns as) of
50+ (names, exprs) -> getConst $ htabulateA $ \field ->
51+ case (hfield names field, hfield exprs field) of
52+ (NameCol name, DB expr) -> Const [(name, show expr)]
6453
6554
6655showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]
6756showLabels _ = getConst $
6857 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
69− Spec {labels} -> Const (pure (renderLabels labels))
58+ SSpec {labels} -> Const [renderLabels labels]
7059
7160
72−showNames :: forall a. Table Name a => a -> NonEmpty String
61+showNames :: forall a. Table Name a => a -> [String]
7362showNames (toColumns -> names) = getConst $
7463 htabulateA @(Columns a) $ \field -> case hfield names field of
75− Name name -> Const (pure name)
76−
77−
78−renderLabels :: [String] -> NonEmpty String
79−renderLabels labels = fromMaybe (pure "anon") (nonEmpty labels )
64+ NameCol name -> Const [name]
src/Rel8/Table/NonEmpty.hs+19−109
@@ -1,143 +1,53 @@
1−{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
31{-# language FlexibleInstances #-}
42{-# language MultiParamTypeClasses #-}
5−{-# language NamedFieldPuns #-}
6−{-# language ScopedTypeVariables #-}
73{-# language StandaloneKindSignatures #-}
8−{-# language TypeApplications #-}
94{-# language TypeFamilies #-}
105{-# language UndecidableInstances #-}
116
127module Rel8.Table.NonEmpty
138 ( NonEmptyTable(..)
14− , ($+)
15− , nonEmptyTable
16− , nameNonEmptyTable
9+ , HNonEmptyTable
1710 )
1811where
1912
2013-- base
21−import Data.Functor.Identity ( Identity( Identity ) )
2214import Data.Kind ( Type )
23−import Data.List.NonEmpty ( NonEmpty )
24−import Prelude hiding ( id )
15+import Prelude
2516
2617-- rel8
2718import Rel8.Expr ( Expr )
28−import Rel8.Expr.Array ( sappend1, snonEmptyOf )
29−import Rel8.Schema.Dict ( Dict( Dict ) )
19+import Rel8.Expr.Array ( sappend1 )
20+import Rel8.Schema.Context ( Col(..) )
3021import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
31−import Rel8.Schema.HTable.Vectorize
32− ( hvectorize, hunvectorize
33− , happend
34− , hproject, hcolumn
35− )
36−import qualified Rel8.Schema.Kind as K
37−import Rel8.Schema.Name ( Name( Name ) )
38−import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
39−import Rel8.Schema.Result ( vectorizer, unvectorizer )
40−import Rel8.Schema.Spec ( Spec(..) )
41−import Rel8.Table
42− ( Table, Context, Columns, fromColumns, toColumns
43− , FromExprs, fromResult, toResult
44− , Transpose
45− )
22+import Rel8.Schema.HTable.Vectorize ( happend )
23+import Rel8.Table ( Table, Context, Columns, fromColumns, toColumns )
4624import Rel8.Table.Alternative ( AltTable, (<|>:) )
47−import Rel8.Table.Eq ( EqTable, eqTable )
48−import Rel8.Table.Ord ( OrdTable, ordTable )
49−import Rel8.Table.Projection
50− ( Projectable, Projecting, Projection, project, apply
51− )
52−import Rel8.Table.Serialize ( ToExprs )
25+import Rel8.Table.Recontextualize ( Recontextualize )
5326
5427
5528-- | A @NonEmptyTable@ value contains one or more instances of @a@. You
56−-- construct @NonEmptyTable@s with 'Rel8.some' or 'nonEmptyAgg'.
57−type NonEmptyTable :: K.Context -> Type -> Type
58−newtype NonEmptyTable context a =
59− NonEmptyTable (HNonEmptyTable (Columns a) (Context a))
60−
29+-- construct @NonEmptyTable@s with 'some' or 'nonEmptyAgg'.
30+type NonEmptyTable :: Type -> Type
31+newtype NonEmptyTable a =
32+ NonEmptyTable (HNonEmptyTable (Columns a) (Col (Context a)))
6133
62−instance Projectable (NonEmptyTable context) where
63− project f (NonEmptyTable a) = NonEmptyTable (hproject (apply f) a)
6434
65−
66−instance (Table context a, context ~ context') =>
67− Table context' (NonEmptyTable context a)
68− where
69− type Columns (NonEmptyTable context a) = HNonEmptyTable (Columns a)
70− type Context (NonEmptyTable context a) = Context a
71− type FromExprs (NonEmptyTable context a) = NonEmpty (FromExprs a)
72− type Transpose to (NonEmptyTable context a) =
73− NonEmptyTable to (Transpose to a)
35+instance Table context a => Table context (NonEmptyTable a) where
36+ type Columns (NonEmptyTable a) = HNonEmptyTable (Columns a)
37+ type Context (NonEmptyTable a) = Context a
7438
7539 fromColumns = NonEmptyTable
7640 toColumns (NonEmptyTable a) = a
77− fromResult = fmap (fromResult @_ @a) . hunvectorize unvectorizer
78− toResult = hvectorize vectorizer . fmap (toResult @_ @a)
79−
80−
81−instance (EqTable a, context ~ Expr) =>
82− EqTable (NonEmptyTable context a)
83− where
84− eqTable =
85− hvectorize
86− (\Spec {nullity} (Identity Dict) -> case nullity of
87− Null -> Dict
88− NotNull -> Dict)
89− (Identity (eqTable @a))
90−
9141
92−instance (OrdTable a, context ~ Expr) =>
93− OrdTable (NonEmptyTable context a)
94− where
95− ordTable =
96− hvectorize
97− (\Spec {nullity} (Identity Dict) -> case nullity of
98− Null -> Dict
99− NotNull -> Dict)
100− (Identity (ordTable @a))
10142
43+instance Recontextualize from to a b =>
44+ Recontextualize from to (NonEmptyTable a) (NonEmptyTable b)
10245
103−instance (ToExprs exprs a, context ~ Expr) =>
104− ToExprs (NonEmptyTable context exprs) (NonEmpty a)
10546
106−
107−instance context ~ Expr => AltTable (NonEmptyTable context) where
47+instance AltTable NonEmptyTable where
10848 (<|>:) = (<>)
10949
11050
111−instance (Table Expr a, context ~ Expr) => Semigroup (NonEmptyTable context a)
112− where
51+instance Table Expr a => Semigroup (NonEmptyTable a) where
11352 NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $
114− happend (const sappend1) as bs
115−
116−
117−-- | Project a single expression out of a 'NonEmptyTable'.
118−($+) :: Projecting a (Expr b)
119− => Projection a (Expr b) -> NonEmptyTable Expr a -> Expr (NonEmpty b)
120−f $+ NonEmptyTable a = hcolumn $ hproject (apply f) a
121−infixl 4 $+
122−
123−
124−-- | Construct a @NonEmptyTable@ from a non-empty list of expressions.
125−nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable Expr a
126−nonEmptyTable =
127− NonEmptyTable .
128− hvectorize (\Spec {info} -> snonEmptyOf info) .
129− fmap toColumns
130−
131−
132−-- | Construct a 'NonEmptyTable' in the 'Name' context. This can be useful if
133−-- you have a 'NonEmptyTable' that you are storing in a table and need to
134−-- construct a 'TableSchema'.
135−nameNonEmptyTable
136− :: Table Name a
137− => a -- ^ The names of the columns of elements of the list.
138− -> NonEmptyTable Name a
139−nameNonEmptyTable =
140− NonEmptyTable .
141− hvectorize (\_ (Identity (Name a)) -> Name a) .
142− pure .
143− toColumns
53+ happend (\_ _ (DB a) (DB b) -> DB (sappend1 a b)) as bs
src/Rel8/Table/Null.hsdeleted−147
@@ -1,147 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
3−{-# language FlexibleInstances #-}
4−{-# language MultiParamTypeClasses #-}
5−{-# language ScopedTypeVariables #-}
6−{-# language StandaloneKindSignatures #-}
7−{-# language TypeApplications #-}
8−{-# language TypeFamilies #-}
9−{-# language UndecidableInstances #-}
10−
11−module Rel8.Table.Null
12− ( NullTable(..)
13− , nullableTable, nullTable, nullifyTable, unsafeUnnullifyTable
14− , isNullTable, isNonNullTable
15− , nameNullTable
16− , toMaybeTable, toNullTable
17− )
18−where
19−
20−-- base
21−import Data.Kind ( Type )
22−import Prelude hiding ( null, undefined )
23−
24−-- comonad
25−import Control.Comonad ( extract )
26−
27−-- rel8
28−import Rel8.Expr ( Expr )
29−import Rel8.Expr.Bool ( not_ )
30−import Rel8.Kind.Context ( Reifiable )
31−import qualified Rel8.Schema.Kind as K
32−import Rel8.Schema.Name ( Name )
33−import Rel8.Table
34− ( Table, Columns, Context, fromColumns, toColumns
35− , FromExprs, fromResult, toResult
36− , Transpose
37− )
38−import Rel8.Table.Alternative
39− ( AltTable, (<|>:)
40− , AlternativeTable, emptyTable
41− )
42−import Rel8.Table.Bool ( bool )
43−import Rel8.Table.Eq ( EqTable, eqTable )
44−import Rel8.Table.Maybe ( MaybeTable, justTable, maybeTable, nothingTable )
45−import Rel8.Table.Nullify ( Nullify, isNull )
46−import Rel8.Table.Ord ( OrdTable, ordTable )
47−import Rel8.Table.Projection ( Projectable, project )
48−import Rel8.Table.Serialize ( ToExprs )
49−import Rel8.Table.Undefined ( undefined )
50−
51−
52−-- | @NullTable t@ is the table @t@, but where all the columns in @t@ have the
53−-- possibility of being 'Rel8.null'. This is very similar to
54−-- 'Rel8.MaybeTable', except that it does not use an extra tag field, so it
55−-- cannot distinguish between @Nothing@ and @Just Nothing@ if nested. In other
56−-- words, if all of the columns of the @t@ passed to @NullTable@ are already
57−-- nullable, then @NullTable@ has no effect.
58−type NullTable :: K.Context -> Type -> Type
59−newtype NullTable context a = NullTable (Nullify context a)
60−
61−
62−instance Projectable (NullTable context) where
63− project f (NullTable a) = NullTable (project f a)
64−
65−
66−instance context ~ Expr => AltTable (NullTable context) where
67− ma <|>: mb = bool ma mb (isNullTable ma)
68−
69−
70−instance context ~ Expr => AlternativeTable (NullTable context) where
71− emptyTable = nullTable
72−
73−
74−instance (Table context a, Reifiable context, context ~ context') =>
75− Table context' (NullTable context a)
76− where
77− type Columns (NullTable context a) = Columns (Nullify context a)
78− type Context (NullTable context a) = Context (Nullify context a)
79− type FromExprs (NullTable context a) = FromExprs (Nullify context a)
80− type Transpose to (NullTable context a) = NullTable to (Transpose to a)
81−
82− toColumns (NullTable a) = toColumns a
83− fromColumns = NullTable . fromColumns
84−
85− toResult = toResult @_ @(Nullify context a)
86− fromResult = fromResult @_ @(Nullify context a)
87−
88−
89−instance (EqTable a, context ~ Expr) => EqTable (NullTable context a) where
90− eqTable = eqTable @(Nullify context a)
91−
92−
93−instance (OrdTable a, context ~ Expr) => OrdTable (NullTable context a) where
94− ordTable = ordTable @(Nullify context a)
95−
96−
97−instance (ToExprs exprs a, context ~ Expr) =>
98− ToExprs (NullTable context exprs) (Maybe a)
99−
100−
101−-- | Check if any of the non-nullable fields of @a@ are 'Rel8.null' under the
102−-- 'NullTable'. Returns 'Rel8.false' if @a@ has no non-nullable fields.
103−isNullTable :: Table Expr a => NullTable Expr a -> Expr Bool
104−isNullTable (NullTable a) = isNull a
105−
106−
107−-- | The inverse of 'isNullTable'.
108−isNonNullTable :: Table Expr a => NullTable Expr a -> Expr Bool
109−isNonNullTable = not_ . isNullTable
110−
111−
112−-- | Like 'Rel8.nullable'.
113−nullableTable :: (Table Expr a, Table Expr b)
114− => b -> (a -> b) -> NullTable Expr a -> b
115−nullableTable b f ma@(NullTable a) = bool (f (extract a)) b (isNullTable ma)
116−
117−
118−-- | The null table. Like 'Rel8.null'.
119−nullTable :: Table Expr a => NullTable Expr a
120−nullTable = NullTable (pure undefined)
121−
122−
123−-- | Lift any table into 'NullTable'. Like 'Rel8.nullify'.
124−nullifyTable :: a -> NullTable Expr a
125−nullifyTable = NullTable . pure
126−
127−
128−unsafeUnnullifyTable :: NullTable Expr a -> a
129−unsafeUnnullifyTable (NullTable a) = extract a
130−
131−
132−-- | Construct a 'NullTable' in the 'Name' context. This can be useful if you
133−-- have a 'NullTable' that you are storing in a table and need to construct a
134−-- 'TableSchema'.
135−nameNullTable :: a -> NullTable Name a
136−nameNullTable = NullTable . pure
137−
138−
139−-- | Convert a 'NullTable' to a 'MaybeTable'.
140−toMaybeTable :: Table Expr a => NullTable Expr a -> MaybeTable Expr a
141−toMaybeTable = nullableTable nothingTable justTable
142−
143−
144−-- | Convert a 'MaybeTable' to a 'NullTable'. Note that if the underlying @a@
145−-- has no non-nullable fields, this is a lossy conversion.
146−toNullTable :: Table Expr a => MaybeTable Expr a -> NullTable Expr a
147−toNullTable = maybeTable nullTable nullifyTable
src/Rel8/Table/Nullify.hsdeleted−211
@@ -1,211 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
3−{-# language FlexibleInstances #-}
4−{-# language LambdaCase #-}
5−{-# language MultiParamTypeClasses #-}
6−{-# language NamedFieldPuns #-}
7−{-# language ScopedTypeVariables #-}
8−{-# language StandaloneKindSignatures #-}
9−{-# language TypeApplications #-}
10−{-# language TypeFamilies #-}
11−{-# language UndecidableInstances #-}
12−
13−module Rel8.Table.Nullify
14− ( Nullify
15− , aggregateNullify
16− , guard
17− , isNull
18− )
19−where
20−
21−-- base
22−import Control.Applicative ( liftA2 )
23−import Data.Functor.Const ( Const( Const ), getConst )
24−import Data.Functor.Identity ( runIdentity )
25−import Data.Kind ( Type )
26−import Prelude
27−
28−-- comonad
29−import Control.Comonad ( Comonad, duplicate, extract, ComonadApply, (<@>) )
30−
31−-- rel8
32−import Rel8.Aggregate ( Aggregate )
33−import Rel8.Expr ( Expr )
34−import Rel8.Expr.Bool ( (||.), false )
35−import qualified Rel8.Expr.Null as Expr
36−import Rel8.Kind.Context ( Reifiable, contextSing )
37−import Rel8.Schema.Context.Nullify
38− ( Nullifiability( NAggregate, NExpr )
39− , NonNullifiability
40− , Nullifiable, nullifiability
41− , nullifiableOrNot, absurd
42− , guarder
43− , nullifier
44− , unnullifier
45− )
46−import Rel8.Schema.Dict ( Dict( Dict ) )
47−import Rel8.Schema.HTable ( HTable )
48−import Rel8.Schema.HTable.Nullify
49− ( HNullify, hnulls, hnullify, hunnullify
50− , hguard
51− , hproject
52− )
53−import qualified Rel8.Schema.Kind as K
54−import Rel8.Schema.Null ( Nullity( NotNull, Null ) )
55−import qualified Rel8.Schema.Result as R
56−import Rel8.Table
57− ( Table, Columns, Context, toColumns, fromColumns
58− , FromExprs, fromResult, toResult
59− , Transpose
60− )
61−import Rel8.Schema.Spec ( Spec( Spec, nullity ) )
62−import Rel8.Table.Eq ( EqTable, eqTable )
63−import Rel8.Table.Ord ( OrdTable, ordTable )
64−import Rel8.Table.Projection ( Projectable, apply, project )
65−
66−-- semigroupoids
67−import Data.Functor.Apply ( Apply, (<.>), liftF2 )
68−import Data.Functor.Bind ( Bind, (>>-) )
69−import Data.Functor.Extend ( Extend, duplicated )
70−
71−
72−type Nullify :: K.Context -> Type -> Type
73−data Nullify context a
74− = Table (Nullifiability context) a
75− | Fields (NonNullifiability context) (HNullify (Columns a) (Context a))
76−
77−
78−instance Projectable (Nullify context) where
79− project f = \case
80− Table nullifiable a -> Table nullifiable (fromColumns (apply f (toColumns a)))
81− Fields nonNullifiable a -> Fields nonNullifiable (hproject (apply f) a)
82−
83−
84−instance Nullifiable context => Functor (Nullify context) where
85− fmap f = \case
86− Table nullifiable a -> Table nullifiable (f a)
87− Fields notNullifiable _ -> absurd nullifiability notNullifiable
88−
89−
90−instance Nullifiable context => Foldable (Nullify context) where
91− foldMap f = \case
92− Table _ a -> f a
93− Fields notNullifiable _ -> absurd nullifiability notNullifiable
94−
95−
96−instance Nullifiable context => Traversable (Nullify context) where
97− traverse f = \case
98− Table nullifiable a -> Table nullifiable <$> f a
99− Fields notNullifiable _ -> absurd nullifiability notNullifiable
100−
101−
102−instance Nullifiable context => Apply (Nullify context) where
103− liftF2 f = \case
104− Table nullifiable a -> \case
105− Table _ b -> Table nullifiable (f a b)
106− Fields notNullifiable _ -> absurd nullifiable notNullifiable
107− Fields notNullifiable _ -> absurd nullifiability notNullifiable
108−
109−
110−instance Nullifiable context => Applicative (Nullify context) where
111− pure = Table nullifiability
112− liftA2 = liftF2
113−
114−
115−instance Nullifiable context => Bind (Nullify context) where
116− Table _ a >>- f = f a
117− Fields notNullifiable _ >>- _ = absurd nullifiability notNullifiable
118−
119−
120−instance Nullifiable context => Monad (Nullify context) where
121− (>>=) = (>>-)
122−
123−
124−instance Nullifiable context => Extend (Nullify context) where
125− duplicated = \case
126− Table nullifiable a -> Table nullifiable (Table nullifiable a)
127− Fields notNullifiable _ -> absurd nullifiability notNullifiable
128−
129−
130−instance Nullifiable context => Comonad (Nullify context) where
131− extract = \case
132− Table _ a -> a
133− Fields notNullifiable _ -> absurd nullifiability notNullifiable
134− duplicate = duplicated
135−
136−
137−instance Nullifiable context => ComonadApply (Nullify context) where
138− (<@>) = (<.>)
139−
140−
141−instance (Table context a, Reifiable context, context ~ context') =>
142− Table context' (Nullify context a)
143− where
144− type Columns (Nullify context a) = HNullify (Columns a)
145− type Context (Nullify context a) = Context a
146− type FromExprs (Nullify context a) = Maybe (FromExprs a)
147− type Transpose to (Nullify context a) = Nullify to (Transpose to a)
148−
149− fromColumns = case nullifiableOrNot contextSing of
150− Left notNullifiable -> Fields notNullifiable
151− Right nullifiable ->
152− Table nullifiable .
153− fromColumns .
154− runIdentity .
155− hunnullify (\spec -> pure . unnullifier nullifiable spec)
156−
157− toColumns = \case
158− Table nullifiable a -> hnullify (nullifier nullifiable) (toColumns a)
159− Fields _ a -> a
160−
161− fromResult = fmap (fromResult @_ @a) . hunnullify R.unnullifier
162−
163− toResult =
164− maybe (hnulls (const R.null)) (hnullify R.nullifier) .
165− fmap (toResult @_ @a)
166−
167−
168−instance (EqTable a, context ~ Expr) => EqTable (Nullify context a) where
169− eqTable = hnullify (\_ Dict -> Dict) (eqTable @a)
170−
171−
172−instance (OrdTable a, context ~ Expr) => OrdTable (Nullify context a) where
173− ordTable = hnullify (\_ Dict -> Dict) (ordTable @a)
174−
175−
176−aggregateNullify :: ()
177− => (exprs -> aggregates)
178− -> Nullify Expr exprs
179− -> Nullify Aggregate aggregates
180−aggregateNullify f = \case
181− Table _ a -> Table NAggregate (f a)
182− Fields notNullifiable _ -> absurd NExpr notNullifiable
183−
184−
185−guard :: (Reifiable context, HTable t)
186− => context tag
187− -> (tag -> Bool)
188− -> (Expr tag -> Expr Bool)
189− -> HNullify t context
190− -> HNullify t context
191−guard tag isNonNull isNonNullExpr =
192− hguard (guarder contextSing tag isNonNull isNonNullExpr)
193−
194−
195−isNull :: forall a. Table Expr a => Nullify Expr a -> Expr Bool
196−isNull =
197− maybe false getAny .
198− getConst .
199− hunnullify (\Spec {nullity} a -> Const $ case nullity of
200− NotNull -> Just $ Any $ Expr.isNull a
201− Null -> Nothing) .
202− toColumns
203−
204−
205−newtype Any = Any
206− { getAny :: Expr Bool
207− }
208−
209−
210−instance Semigroup Any where
211− Any a <> Any b = Any (a ||. b)
src/Rel8/Table/Opaleye.hs+73−93
@@ -1,150 +1,130 @@
1−{-# language BlockArguments #-}
2−{-# language DataKinds #-}
31{-# language DisambiguateRecordFields #-}
42{-# language FlexibleContexts #-}
53{-# language NamedFieldPuns #-}
6−{-# language RankNTypes #-}
74{-# language TypeFamilies #-}
85{-# language ViewPatterns #-}
96
10−{-# options_ghc -Wno-deprecations #-}
11−
127module Rel8.Table.Opaleye
138 ( aggregator
14− , attributes
159 , binaryspec
1610 , distinctspec
17− , exprs
18− , exprsWithNames
1911 , table
2012 , tableFields
2113 , unpackspec
2214 , valuesspec
23− , view
24− , castTable
2515 )
2616where
2717
2818-- base
29−import Data.Functor.Const ( Const( Const ), getConst )
30−import Data.List.NonEmpty ( NonEmpty )
31−import Prelude
19+import Prelude hiding ( undefined )
3220
3321-- opaleye
34−import qualified Opaleye.Adaptors as Opaleye
35−import qualified Opaleye.Field as Opaleye ( Field_ )
3622import qualified Opaleye.Internal.Aggregate as Opaleye
23+import qualified Opaleye.Internal.Binary as Opaleye
24+import qualified Opaleye.Internal.Distinct as Opaleye
3725import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
26+import qualified Opaleye.Internal.PackMap as Opaleye
27+import qualified Opaleye.Internal.Unpackspec as Opaleye
3828import qualified Opaleye.Internal.Values as Opaleye
39−import qualified Opaleye.Table as Opaleye
29+import qualified Opaleye.Internal.Table as Opaleye
4030
4131-- profunctors
4232import Data.Profunctor ( dimap, lmap )
4333
4434-- rel8
45−import Rel8.Aggregate ( Aggregate( Aggregate ), Aggregates )
35+import Rel8.Aggregate ( Aggregate( Aggregate ) )
4636import Rel8.Expr ( Expr )
4737import Rel8.Expr.Opaleye
48− ( fromPrimExpr, toPrimExpr
49− , scastExpr, traverseFieldP
38+ ( scastExpr
39+ , fromPrimExpr, toPrimExpr
40+ , traversePrimExpr
41+ , fromColumn, toColumn
5042 )
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 )
43+import Rel8.Kind.Necessity ( SNecessity( SRequired, SOptional ) )
44+import Rel8.Schema.Context ( Col(..), Insertion, Name(..) )
45+import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs )
46+import Rel8.Schema.Spec ( SSpec(..) )
47+import Rel8.Schema.Table ( TableSchema(..) )
5648import Rel8.Table ( Table, fromColumns, toColumns )
57−import Rel8.Type.Information ( typeName )
49+import Rel8.Table.Recontextualize ( Selects, Inserts )
50+import Rel8.Table.Undefined ( undefined )
5851
5952-- semigroupoids
6053import Data.Functor.Apply ( WrappedApplicative(..) )
61−import Data.Profunctor.Product ( ProductProfunctor )
62−
63−
64−aggregator :: Aggregates aggregates exprs => Opaleye.Aggregator aggregates exprs
65−aggregator = dimap toColumns fromColumns $
66− htraverseP $
67− lmap (\(Aggregate a) -> (a, ())) Opaleye.aggregatorApply
68−
6954
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)
7655
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))
56+aggregator :: Opaleye.Aggregator (Aggregate exprs) exprs
57+aggregator = Opaleye.Aggregator $ Opaleye.PackMap $
58+ \f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner))) -> inner f ()
8359
8460
8561binaryspec :: Table Expr a => Opaleye.Binaryspec a a
86−binaryspec = fromOpaleyespec Opaleye.binaryspecField
62+binaryspec = Opaleye.Binaryspec $ Opaleye.PackMap $ \f (as, bs) ->
63+ fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->
64+ WrapApplicative $
65+ case (hfield (toColumns as) field, hfield (toColumns bs) field) of
66+ (DB a, DB b) -> DB . fromPrimExpr <$> f (toPrimExpr a, toPrimExpr b)
8767
8868
8969distinctspec :: Table Expr a => Opaleye.Distinctspec a a
90−distinctspec = fromOpaleyespec Opaleye.distinctspecField
91−
92−
93−exprs :: Table Expr a => a -> NonEmpty Opaleye.PrimExpr
94−exprs (toColumns -> as) = getConst $ htabulateA $ \field ->
95− case hfield as field of
96− expr -> Const (pure (toPrimExpr expr))
97−
98−
99−exprsWithNames :: Selects names exprs
100− => names -> exprs -> NonEmpty (String, Opaleye.PrimExpr)
101−exprsWithNames names as = getConst $ htabulateA $ \field ->
102− case (hfield (toColumns names) field, hfield (toColumns as) field) of
103− (Name name, expr) -> Const (pure (name, toPrimExpr expr))
104−
105−
106−table :: Selects names exprs => TableSchema names -> Opaleye.Table exprs exprs
70+distinctspec =
71+ Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap $ \f ->
72+ fmap fromColumns .
73+ unwrapApplicative .
74+ htraverse
75+ (\(DB a) ->
76+ WrapApplicative $ DB . fromPrimExpr <$> f (Nothing, toPrimExpr a)) .
77+ toColumns
78+
79+
80+table ::(Selects names exprs, Inserts exprs inserts)
81+ => TableSchema names -> Opaleye.Table inserts exprs
10782table (TableSchema name schema columns) =
108− case schema of
109− Nothing -> Opaleye.table name (tableFields columns)
110− Just schemaName -> Opaleye.tableWithSchema schemaName name (tableFields columns)
83+ Opaleye.Table qualified (tableFields columns)
84+ where
85+ qualified = case schema of
86+ Nothing -> name
87+ Just qualifier -> qualifier <> "." <> name
11188
11289
113−tableFields :: Selects names exprs
114− => names -> Opaleye.TableFields exprs exprs
90+tableFields :: (Selects names exprs, Inserts exprs inserts)
91+ => names -> Opaleye.TableFields inserts exprs
11592tableFields (toColumns -> names) = dimap toColumns fromColumns $
11693 unwrapApplicative $ htabulateA $ \field -> WrapApplicative $
117− case hfield names field of
118− name -> lmap (`hfield` field) (go name)
94+ case hfield hspecs field of
95+ specs -> case hfield names field of
96+ name -> lmap (`hfield` field) (go specs name)
11997 where
120− go :: Name a -> Opaleye.TableFields (Expr a) (Expr a)
121− go (Name name) =
122− traverseFieldP $
123− Opaleye.requiredTableField name
98+ go :: SSpec spec -> Col Name spec -> Opaleye.TableFields (Col Insertion spec) (Col Expr spec)
99+ go SSpec {necessity, info, nullability} (NameCol name) =
100+ case necessity of
101+ SRequired ->
102+ lmap (\(RequiredInsert a) -> toColumn $ toPrimExpr a) $
103+ DB . scastExpr nullability info . fromPrimExpr . fromColumn <$>
104+ Opaleye.requiredTableField name
105+ SOptional ->
106+ lmap (\(OptionalInsert ma) -> toColumn . toPrimExpr <$> ma) $
107+ DB . scastExpr nullability info . fromPrimExpr . fromColumn <$>
108+ Opaleye.optionalTableField name
124109
125110
126111unpackspec :: Table Expr a => Opaleye.Unpackspec a a
127−unpackspec = fromOpaleyespec Opaleye.unpackspecField
112+unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->
113+ fmap fromColumns .
114+ unwrapApplicative .
115+ htraverse (\(DB a) -> WrapApplicative $ DB <$> traversePrimExpr f a) .
116+ toColumns
128117{-# INLINABLE unpackspec #-}
129118
130119
131−valuesspec :: Table Expr a => Opaleye.Valuesspec a a
132−valuesspec = dimap toColumns fromColumns $
133− htraversePWithField (traverseFieldP . Opaleye.valuesspecFieldType . typeName)
134− where typeName = Rel8.Type.Information.typeName . info . hfield hspecs
135−
136−
137−view :: Selects names exprs => names -> exprs
138−view columns = fromColumns $ htabulate $ \field ->
139− case hfield (toColumns columns) field of
140− Name column -> fromPrimExpr $ Opaleye.BaseTableAttrExpr column
120+valuesspec :: Table Expr a => Opaleye.ValuesspecSafe a a
121+valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec
141122
142123
143−-- | Transform a table by adding 'CAST' to all columns. This is most useful for
144−-- finalising a SELECT or RETURNING statement, guaranteed that the output
145−-- matches what is encoded in each columns TypeInformation.
146−castTable :: Table Expr a => a -> a
147−castTable (toColumns -> as) = fromColumns $ htabulate \field ->
148− case hfield hspecs field of
149− Spec {info} -> case hfield as field of
150− expr -> scastExpr info expr
124+toPackMap :: Table Expr a
125+ => a -> Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () a
126+toPackMap as = Opaleye.PackMap $ \f () ->
127+ fmap fromColumns $
128+ unwrapApplicative .
129+ htraverse (\(DB a) -> WrapApplicative $ DB <$> traversePrimExpr f a) $
130+ toColumns as
src/Rel8/Table/Ord.hs+49−70
@@ -1,41 +1,40 @@
1−{-# language AllowAmbiguousTypes #-}
21{-# language DataKinds #-}
3−{-# language DefaultSignatures #-}
4−{-# language DisambiguateRecordFields #-}
5−{-# language FlexibleContexts #-}
62{-# language FlexibleInstances #-}
3+{-# language NamedFieldPuns #-}
74{-# language ScopedTypeVariables #-}
85{-# language StandaloneKindSignatures #-}
96{-# language TypeApplications #-}
107{-# language TypeFamilies #-}
11−{-# language TypeOperators #-}
128{-# language UndecidableInstances #-}
9+{-# language UndecidableSuperClasses #-}
1310{-# language ViewPatterns #-}
1411
1512module Rel8.Table.Ord
16− ( OrdTable( ordTable ), (<:), (<=:), (>:), (>=:), least, greatest
13+ ( OrdTable, (<:), (<=:), (>:), (>=:), least, greatest
1714 )
1815where
1916
2017-- base
2118import Data.Functor.Const ( Const( Const ), getConst )
2219import Data.Kind ( Constraint, Type )
23−import GHC.Generics ( Rep )
2420import Prelude hiding ( seq )
2521
2622-- rel8
2723import Rel8.Expr ( Expr )
2824import Rel8.Expr.Bool ( (||.), (&&.), false, true )
29−import Rel8.Expr.Eq ( (==.) )
30−import Rel8.Expr.Ord ( (<.), (>.) )
31−import Rel8.FCF ( Eval, Exp )
32−import Rel8.Generic.Record ( Record )
33−import Rel8.Generic.Table.Record ( GTable, GColumns, gtable )
25+import Rel8.Expr.Eq ( seq )
26+import Rel8.Expr.Ord ( slt, sgt)
27+import Rel8.Opaque ( Opaque )
28+import Rel8.Schema.Context ( Col(..) )
3429import Rel8.Schema.Dict ( Dict( Dict ) )
35−import Rel8.Schema.HTable ( htabulateA, hfield )
36−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
37−import Rel8.Schema.Null (Sql)
38−import Rel8.Table ( Columns, toColumns, TColumns )
30+import Rel8.Schema.HTable
31+ ( HConstrainTable
32+ , htabulateA, hfield
33+ , hdicts, hspecs
34+ )
35+import Rel8.Schema.Spec ( SSpec(..) )
36+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
37+import Rel8.Table ( Columns, toColumns )
3938import Rel8.Table.Bool ( bool )
4039import Rel8.Table.Eq ( EqTable )
4140import Rel8.Type.Ord ( DBOrd )
@@ -45,51 +44,15 @@ import Rel8.Type.Ord ( DBOrd )
4544-- by their lexicographic ordering of all columns, so this class means "all
4645-- columns in a 'Table' have an instance of 'DBOrd'".
4746type OrdTable :: Type -> Constraint
48−class EqTable a => OrdTable a where
49− ordTable :: Columns a (Dict (Sql DBOrd))
50−
51− default ordTable ::
52− ( GTable TOrdTable TColumns (Rep (Record a))
53− , Columns a ~ GColumns TColumns (Rep (Record a))
54− )
55− => Columns a (Dict (Sql DBOrd))
56− ordTable = gtable @TOrdTable @TColumns @(Rep (Record a)) table
57− where
58− table (_ :: proxy x) = ordTable @x
59−
60−
61−data TOrdTable :: Type -> Exp Constraint
62−type instance Eval (TOrdTable a) = OrdTable a
63−
64−
65−instance Sql DBOrd a => OrdTable (Expr a) where
66− ordTable = HIdentity Dict
67−
68−
69−instance (OrdTable a, OrdTable b) => OrdTable (a, b)
70−
71−
72−instance (OrdTable a, OrdTable b, OrdTable c) => OrdTable (a, b, c)
73−
74−
75−instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d) => OrdTable (a, b, c, d)
76−
77−
78−instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e) =>
79− OrdTable (a, b, c, d, e)
80−
81−
47+class
48+ ( EqTable a
49+ , HConstrainTable (Columns a) (ConstrainDBType DBOrd)
50+ ) => OrdTable a
8251instance
83− ( OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e, OrdTable f
84− )
85− => OrdTable (a, b, c, d, e, f)
86−
87−
88−instance
89− ( OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e, OrdTable f
90− , OrdTable g
91− )
92− => OrdTable (a, b, c, d, e, f, g)
52+ ( EqTable a
53+ , HConstrainTable (Columns a) (ConstrainDBType DBOrd)
54+ ) => OrdTable a
55+instance {-# OVERLAPPING #-} OrdTable Opaque
9356
9457
9558-- | Test if one 'Table' sorts before another. Corresponds to comparing all
@@ -98,9 +61,13 @@ instance
9861(toColumns -> as) <: (toColumns -> bs) =
9962 foldr @[] go false $ getConst $ htabulateA $ \field ->
10063 case (hfield as field, hfield bs field) of
101− (a, b) -> case hfield (ordTable @a) field of
102− Dict -> Const [(a <. b, a ==. b)]
64+ (DB a, DB b) -> case hfield dicts field of
65+ Dict -> case hfield specs field of
66+ SSpec {nullability} ->
67+ Const [(slt nullability a b, seq nullability a b)]
10368 where
69+ dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
70+ specs = hspecs @(Columns a)
10471 go (lt, eq) a = lt ||. (eq &&. a)
10572infix 4 <:
10673
@@ -111,9 +78,13 @@ infix 4 <:
11178(toColumns -> as) <=: (toColumns -> bs) =
11279 foldr @[] go true $ getConst $ htabulateA $ \field ->
11380 case (hfield as field, hfield bs field) of
114− (a, b) -> case hfield (ordTable @a) field of
115− Dict -> Const [(a <. b, a ==. b)]
81+ (DB a, DB b) -> case hfield dicts field of
82+ Dict -> case hfield specs field of
83+ SSpec {nullability} ->
84+ Const [(slt nullability a b, seq nullability a b)]
11685 where
86+ dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
87+ specs = hspecs @(Columns a)
11788 go (lt, eq) a = lt ||. (eq &&. a)
11889infix 4 <=:
11990
@@ -124,9 +95,13 @@ infix 4 <=:
12495(toColumns -> as) >: (toColumns -> bs) =
12596 foldr @[] go false $ getConst $ htabulateA $ \field ->
12697 case (hfield as field, hfield bs field) of
127− (a, b) -> case hfield (ordTable @a) field of
128− Dict -> Const [(a >. b, a ==. b)]
98+ (DB a, DB b) -> case hfield dicts field of
99+ Dict -> case hfield specs field of
100+ SSpec {nullability} ->
101+ Const [(slt nullability a b, seq nullability a b)]
129102 where
103+ dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
104+ specs = hspecs @(Columns a)
130105 go (gt, eq) a = gt ||. (eq &&. a)
131106infix 4 >:
132107
@@ -137,18 +112,22 @@ infix 4 >:
137112(toColumns -> as) >=: (toColumns -> bs) =
138113 foldr @[] go true $ getConst $ htabulateA $ \field ->
139114 case (hfield as field, hfield bs field) of
140− (a, b) -> case hfield (ordTable @a) field of
141− Dict -> Const [(a >. b, a ==. b)]
115+ (DB a, DB b) -> case hfield dicts field of
116+ Dict -> case hfield specs field of
117+ SSpec {nullability} ->
118+ Const [(sgt nullability a b, seq nullability a b)]
142119 where
120+ dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
121+ specs = hspecs @(Columns a)
143122 go (gt, eq) a = gt ||. (eq &&. a)
144123infix 4 >=:
145124
146125
147126-- | Given two 'Table's, return the table that sorts before the other.
148127least :: OrdTable a => a -> a -> a
149−least a b = bool b a (a <: b)
128+least a b = bool a b (a <: b)
150129
151130
152131-- | Given two 'Table's, return the table that sorts after the other.
153132greatest :: OrdTable a => a -> a -> a
154−greatest a b = bool b a (a >: b)
133+greatest a b = bool a b (a >: b)
src/Rel8/Table/Order.hs+20−16
@@ -1,4 +1,3 @@
1−{-# language DataKinds #-}
21{-# language NamedFieldPuns #-}
32{-# language ScopedTypeVariables #-}
43{-# language TypeApplications #-}
@@ -18,12 +17,15 @@ import Prelude
1817-- rel8
1918import Rel8.Expr.Order ( asc, desc, nullsFirst, nullsLast )
2019import Rel8.Order ( Order )
20+import Rel8.Schema.Context ( unDB )
2121import Rel8.Schema.Dict ( Dict( Dict ) )
22−import Rel8.Schema.HTable (htabulateA, hfield, hspecs)
23−import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
24−import Rel8.Schema.Spec ( Spec( Spec, nullity ) )
25−import Rel8.Table ( Columns, toColumns )
26−import Rel8.Table.Ord ( OrdTable, ordTable )
22+import Rel8.Schema.HTable (htabulateA, hfield, hdicts, hspecs)
23+import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
24+import Rel8.Schema.Spec ( SSpec(..) )
25+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
26+import Rel8.Table
27+import Rel8.Table.Ord
28+import Rel8.Type.Ord
2729
2830
2931-- | Construct an 'Order' for a 'Table' by sorting all columns into ascending
@@ -31,11 +33,12 @@ import Rel8.Table.Ord ( OrdTable, ordTable )
3133ascTable :: forall a. OrdTable a => Order a
3234ascTable = contramap toColumns $ getConst $
3335 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
34− Spec {nullity} -> case hfield (ordTable @a) field of
35− Dict -> Const $ (`hfield` field) >$<
36− case nullity of
37− Null -> nullsFirst asc
38− NotNull -> asc
36+ SSpec {nullability} -> case hfield ords field of
37+ Dict -> Const $ unDB . (`hfield` field) >$< case nullability of
38+ Nullable -> nullsFirst asc
39+ NonNullable -> asc
40+ where
41+ ords = hdicts @(Columns a) @(ConstrainDBType DBOrd)
3942
4043
4144-- | Construct an 'Order' for a 'Table' by sorting all columns into descending
@@ -43,8 +46,9 @@ ascTable = contramap toColumns $ getConst $
4346descTable :: forall a. OrdTable a => Order a
4447descTable = contramap toColumns $ getConst $
4548 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
46− Spec {nullity} -> case hfield (ordTable @a) field of
47− Dict -> Const $ (`hfield` field) >$<
48− case nullity of
49− Null -> nullsLast desc
50− NotNull -> desc
49+ SSpec {nullability} -> case hfield ords field of
50+ Dict -> Const $ unDB . (`hfield` field) >$< case nullability of
51+ Nullable -> nullsLast desc
52+ NonNullable -> desc
53+ where
54+ ords = hdicts @(Columns a) @(ConstrainDBType DBOrd)
src/Rel8/Table/Projection.hsdeleted−73
@@ -1,73 +0,0 @@
1−{-# language FlexibleContexts #-}
2−{-# language FlexibleInstances #-}
3−{-# language MonoLocalBinds #-}
4−{-# language MultiParamTypeClasses #-}
5−{-# language StandaloneKindSignatures #-}
6−{-# language UndecidableInstances #-}
7−
8−module Rel8.Table.Projection
9− ( Projection
10− , Projectable( project )
11− , Biprojectable( biproject )
12− , Projecting
13− , apply
14− )
15−where
16−
17−-- base
18−import Data.Kind ( Constraint, Type )
19−import Prelude
20−
21−-- rel8
22−import Rel8.Schema.Field ( Field( Field ), fields )
23−import Rel8.Schema.HTable ( hfield, htabulate )
24−import Rel8.Table ( Columns, Context, Transpose, toColumns )
25−import Rel8.Table.Transpose ( Transposes )
26−
27−
28−-- | The constraint @'Projecting' a b@ ensures that @'Projection' a b@ is a
29−-- usable 'Projection'.
30−type Projecting :: Type -> Type -> Constraint
31−class
32− ( Transposes (Context a) (Field a) a (Transpose (Field a) a)
33− , Transposes (Context a) (Field a) b (Transpose (Field a) b)
34− )
35− => Projecting a b
36−instance
37− ( Transposes (Context a) (Field a) a (Transpose (Field a) a)
38− , Transposes (Context a) (Field a) b (Transpose (Field a) b)
39− )
40− => Projecting a b
41−
42−
43−-- | A @'Projection' a b@s is a special type of function @a -> b@ whereby the
44−-- resulting @b@ is guaranteed to be composed only from columns contained in
45−-- @a@.
46−type Projection :: Type -> Type -> Type
47−type Projection a b = Transpose (Field a) a -> Transpose (Field a) b
48−
49−
50−-- | @'Projectable' f@ means that @f@ is a kind of functor on 'Rel8.Table's
51−-- that allows the mapping of a 'Projection' over its underlying columns.
52−type Projectable :: (Type -> Type) -> Constraint
53−class Projectable f where
54− -- | Map a 'Projection' over @f@.
55− project :: Projecting a b
56− => Projection a b -> f a -> f b
57−
58−
59−-- | @'Biprojectable' p@ means that @p@ is a kind of bifunctor on
60−-- 'Rel8.Table's that allows the mapping of a pair of 'Projection's over its
61−-- underlying columns.
62−type Biprojectable :: (Type -> Type -> Type) -> Constraint
63−class Biprojectable p where
64− -- | Map a pair of 'Projection's over @p@.
65− biproject :: (Projecting a b, Projecting c d)
66− => Projection a b -> Projection c d -> p a c -> p b d
67−
68−
69−apply :: Projecting a b
70− => Projection a b -> Columns a context -> Columns b context
71−apply f a = case toColumns (f fields) of
72− bs -> htabulate $ \field -> case hfield bs field of
73− Field field' -> hfield a field'
src/Rel8/Table/Recontextualize.hsnew file+218
@@ -0,0 +1,218 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language FlexibleInstances #-}
4+{-# language FunctionalDependencies #-}
5+{-# language StandaloneKindSignatures #-}
6+{-# language TypeFamilies #-}
7+{-# language UndecidableInstances #-}
8+{-# language UndecidableSuperClasses #-}
9+
10+module Rel8.Table.Recontextualize
11+ ( Recontextualize
12+ , Aggregates
13+ , Encodes
14+ , Selects
15+ , Inserts
16+ )
17+where
18+
19+-- base
20+import Data.Functor.Identity ( Identity )
21+import Data.Kind ( Constraint, Type )
22+import Prelude ()
23+
24+-- rel8
25+import Rel8.Aggregate ( Aggregate )
26+import Rel8.Expr ( Expr )
27+import Rel8.Opaque ( Opaque, Opaque1 )
28+import Rel8.Schema.Context ( Col(..), Insertion, Name )
29+import Rel8.Schema.Context.Label ( Labelable )
30+import Rel8.Schema.HTable ( HTable )
31+import qualified Rel8.Schema.Kind as K
32+import Rel8.Schema.Nullability ( Sql )
33+import Rel8.Schema.Spec ( KnownSpec )
34+import Rel8.Table ( Table, Congruent )
35+import Rel8.Type ( DBType )
36+
37+
38+type Recontextualize :: K.Context -> K.Context -> Type -> Type -> Constraint
39+class
40+ ( Table from a
41+ , Table to b
42+ , Congruent a b
43+ , Recontextualize from from a a
44+ , Recontextualize to to b b
45+ , Recontextualize to from b a
46+ ) => Recontextualize from to a b
47+ | a -> from
48+ , b -> to
49+ , a to -> b
50+ , b from -> a
51+
52+
53+instance KnownSpec spec =>
54+ Recontextualize from to (Col from spec) (Col to spec)
55+
56+
57+instance Sql DBType a =>
58+ Recontextualize Aggregate Aggregate (Aggregate (Expr a)) (Aggregate (Expr a))
59+
60+
61+instance Sql DBType a =>
62+ Recontextualize Aggregate Expr (Aggregate (Expr a)) (Expr a)
63+
64+
65+instance Sql DBType a =>
66+ Recontextualize Aggregate Identity (Aggregate (Expr a)) (Identity a)
67+
68+
69+instance Sql DBType a =>
70+ Recontextualize Aggregate Insertion (Aggregate (Expr a)) (Insertion a)
71+
72+
73+instance Sql DBType a =>
74+ Recontextualize Aggregate Name (Aggregate (Expr a)) (Name a)
75+
76+
77+instance Sql DBType a =>
78+ Recontextualize Expr Aggregate (Expr a) (Aggregate (Expr a))
79+
80+
81+instance Sql DBType a => Recontextualize Expr Expr (Expr a) (Expr a)
82+
83+
84+instance Sql DBType a => Recontextualize Expr Identity (Expr a) (Identity a)
85+
86+
87+instance Sql DBType a => Recontextualize Expr Insertion (Expr a) (Insertion a)
88+
89+
90+instance Sql DBType a => Recontextualize Expr Name (Expr a) (Name a)
91+
92+
93+instance Sql DBType a =>
94+ Recontextualize Identity Aggregate (Identity a) (Aggregate (Expr a))
95+
96+
97+instance Sql DBType a => Recontextualize Identity Expr (Identity a) (Expr a)
98+
99+
100+instance Sql DBType a => Recontextualize Identity Identity (Identity a) (Identity a)
101+
102+
103+instance Sql DBType a =>
104+ Recontextualize Identity Insertion (Identity a) (Insertion a)
105+
106+
107+instance Sql DBType a => Recontextualize Identity Name (Identity a) (Name a)
108+
109+
110+instance Sql DBType a =>
111+ Recontextualize Insertion Aggregate (Insertion a) (Aggregate (Expr a))
112+
113+
114+instance Sql DBType a => Recontextualize Insertion Expr (Insertion a) (Expr a)
115+
116+
117+instance Sql DBType a =>
118+ Recontextualize Insertion Identity (Insertion a) (Identity a)
119+
120+
121+instance Sql DBType a => Recontextualize Insertion Insertion (Insertion a) (Insertion a)
122+
123+
124+instance Sql DBType a => Recontextualize Insertion Name (Insertion a) (Name a)
125+
126+
127+instance Sql DBType a =>
128+ Recontextualize Name Aggregate (Name a) (Aggregate (Expr a))
129+
130+
131+instance Sql DBType a => Recontextualize Name Expr (Name a) (Expr a)
132+
133+
134+instance Sql DBType a => Recontextualize Name Identity (Name a) (Identity a)
135+
136+
137+instance Sql DBType a => Recontextualize Name Insertion (Name a) (Insertion a)
138+
139+
140+instance Sql DBType a => Recontextualize Name Name (Name a) (Name a)
141+
142+
143+instance Recontextualize from to (Opaque1 from a) (Opaque1 to a)
144+
145+
146+instance HTable t => Recontextualize from to (t (Col from)) (t (Col to))
147+
148+
149+instance
150+ ( Table from (t from)
151+ , Table to (t to)
152+ , Congruent (t from) (t to)
153+ ) => Recontextualize from to (t from) (t to)
154+
155+
156+instance
157+ ( Recontextualize from to a1 b1
158+ , Recontextualize from to a2 b2
159+ , Labelable from
160+ , Labelable to
161+ ) => Recontextualize from to (a1, a2) (b1, b2)
162+
163+
164+instance
165+ ( Recontextualize from to a1 b1
166+ , Recontextualize from to a2 b2
167+ , Recontextualize from to a3 b3
168+ , Labelable from, Labelable to
169+ ) => Recontextualize from to (a1, a2, a3) (b1, b2, b3)
170+
171+
172+instance
173+ ( Recontextualize from to a1 b1
174+ , Recontextualize from to a2 b2
175+ , Recontextualize from to a3 b3
176+ , Recontextualize from to a4 b4
177+ , Labelable from, Labelable to
178+ ) => Recontextualize from to (a1, a2, a3, a4) (b1, b2, b3, b4)
179+
180+
181+instance
182+ ( Recontextualize from to a1 b1
183+ , Recontextualize from to a2 b2
184+ , Recontextualize from to a3 b3
185+ , Recontextualize from to a4 b4
186+ , Recontextualize from to a5 b5
187+ , Labelable from, Labelable to
188+ ) => Recontextualize from to (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5)
189+
190+
191+-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate' 'Expr's
192+-- for the columns in @b@.
193+type Aggregates :: Type -> Type -> Constraint
194+class Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs
195+instance Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs
196+instance {-# OVERLAPPING #-} Aggregates (Opaque1 Aggregate Opaque) (Opaque1 Expr Opaque)
197+
198+
199+type Encodes :: Type -> Type -> Constraint
200+class Recontextualize Identity Expr a exprs => Encodes a exprs
201+instance Recontextualize Identity Expr a exprs => Encodes a exprs
202+instance {-# OVERLAPPING #-} Encodes (Opaque1 Identity Opaque) (Opaque1 Expr Opaque)
203+
204+
205+-- | @Inserts a b@ means that the columns in @a@ are compatible for inserting
206+-- with the table @b@.
207+type Inserts :: Type -> Type -> Constraint
208+class Recontextualize Expr Insertion exprs inserts => Inserts exprs inserts
209+instance Recontextualize Expr Insertion exprs inserts => Inserts exprs inserts
210+instance {-# OVERLAPPING #-} Inserts (Opaque1 Expr Opaque) (Opaque1 Insertion Opaque)
211+
212+
213+-- | @Selects a b@ means that @a@ is a schema (i.e., a 'Table' of 'Name's) for
214+-- the 'Expr' columns in @b@.
215+type Selects :: Type -> Type -> Constraint
216+class Recontextualize Name Expr names exprs => Selects names exprs
217+instance Recontextualize Name Expr names exprs => Selects names exprs
218+instance {-# OVERLAPPING #-} Selects (Opaque1 Name Opaque) (Opaque1 Expr Opaque)
src/Rel8/Table/Rel8able.hsdeleted−92
@@ -1,92 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language FlexibleInstances #-}
3−{-# language MultiParamTypeClasses #-}
4−{-# language ScopedTypeVariables #-}
5−{-# language StandaloneKindSignatures #-}
6−{-# language TypeApplications #-}
7−{-# language TypeFamilies #-}
8−{-# language UndecidableInstances #-}
9−
10−{-# options_ghc -fno-warn-orphans #-}
11−
12−module Rel8.Table.Rel8able
13− (
14− )
15−where
16−
17−-- base
18−import Prelude ()
19−
20−-- rel8
21−import Rel8.Expr ( Expr )
22−import qualified Rel8.Kind.Algebra as K
23−import Rel8.Kind.Context ( Reifiable, contextSing )
24−import Rel8.Generic.Rel8able
25− ( Rel8able, Algebra
26− , GColumns, gfromColumns, gtoColumns
27− , GFromExprs, gfromResult, gtoResult
28− )
29−import qualified Rel8.Schema.Kind as K
30−import Rel8.Schema.HTable ( HConstrainTable, hdicts )
31−import Rel8.Schema.Null ( Sql )
32−import Rel8.Schema.Result ( Result )
33−import Rel8.Table
34− ( Table, Columns, Context, fromColumns, toColumns
35− , FromExprs, fromResult, toResult
36− , Transpose
37− )
38−import Rel8.Table.ADT ( ADT )
39−import Rel8.Table.Eq ( EqTable, eqTable )
40−import Rel8.Table.Ord ( OrdTable, ordTable )
41−import Rel8.Table.Serialize ( ToExprs )
42−import Rel8.Type.Eq ( DBEq )
43−import Rel8.Type.Ord ( DBOrd )
44−
45−
46−instance (Rel8able t, Reifiable context, context ~ context') =>
47− Table context' (t context)
48− where
49− type Columns (t context) = GColumns t
50− type Context (t context) = context
51− type FromExprs (t context) = GFromExprs t
52− type Transpose to (t context) = t to
53−
54− fromColumns = gfromColumns contextSing
55− toColumns = gtoColumns contextSing
56− fromResult = gfromResult @t
57− toResult = gtoResult @t
58−
59−
60−instance
61− ( context ~ Expr
62− , Rel8able t
63− , HConstrainTable (Columns (t context)) (Sql DBEq)
64− )
65− => EqTable (t context)
66− where
67− eqTable = hdicts @(Columns (t context)) @(Sql DBEq)
68−
69−
70−instance
71− ( context ~ Expr
72− , Rel8able t
73− , HConstrainTable (Columns (t context)) (Sql DBEq)
74− , HConstrainTable (Columns (t context)) (Sql DBOrd)
75− )
76− => OrdTable (t context)
77− where
78− ordTable = hdicts @(Columns (t context)) @(Sql DBOrd)
79−
80−
81−instance
82− ( Rel8able t', t' ~ Choose (Algebra t) t
83− , x ~ t' Expr
84− , result ~ Result
85− )
86− => ToExprs x (t result)
87−
88−
89−type Choose :: K.Algebra -> K.Rel8able -> K.Rel8able
90−type family Choose algebra t where
91− Choose 'K.Sum t = ADT t
92− Choose 'K.Product t = t
src/Rel8/Table/Serialize.hs+373−69
@@ -1,4 +1,6 @@
11{-# language AllowAmbiguousTypes #-}
2+{-# language DataKinds #-}
3+{-# language DisambiguateRecordFields #-}
24{-# language FlexibleContexts #-}
35{-# language FlexibleInstances #-}
46{-# language FunctionalDependencies #-}
@@ -7,16 +9,17 @@
79{-# language StandaloneKindSignatures #-}
810{-# language TypeApplications #-}
911{-# language TypeFamilies #-}
12+{-# language ViewPatterns #-}
1013{-# language UndecidableInstances #-}
1114
1215module Rel8.Table.Serialize
13− ( Serializable, lit, litHTable, parse
14− , ToExprs
16+ ( Serializable, lit, parse
1517 )
1618where
1719
1820-- base
19−import Data.Functor.Identity ( Identity( Identity ) )
21+import Data.Bifunctor ( bimap )
22+import Data.Functor.Identity ( Identity )
2023import Data.Kind ( Constraint, Type )
2124import Data.List.NonEmpty ( NonEmpty )
2225import Prelude
@@ -27,122 +30,423 @@ import qualified Hasql.Decoders as Hasql
2730-- rel8
2831import Rel8.Expr ( Expr )
2932import Rel8.Expr.Serialize ( slitExpr, sparseValue )
33+import Rel8.Opaque ( Opaque )
34+import Rel8.Schema.Context ( Col(..) )
35+import Rel8.Schema.Context.Identity
36+ ( fromHEitherTable, toHEitherTable
37+ , fromHListTable, toHListTable
38+ , fromHMaybeTable, toHMaybeTable
39+ , fromHNonEmptyTable, toHNonEmptyTable
40+ , fromHTheseTable, toHTheseTable
41+ )
42+import Rel8.Schema.Context.Label ( labeler, unlabeler )
3043import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )
31−import Rel8.Schema.Null ( NotNull, Sql )
32−import Rel8.Schema.Result ( Result )
33−import Rel8.Schema.Spec ( Spec(..) )
34−import Rel8.Table ( Table, fromColumns, FromExprs, fromResult, toResult )
44+import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
45+import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
46+import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
47+import Rel8.Schema.HTable.Pair ( HPair(..) )
48+import Rel8.Schema.HTable.Trio ( HTrio(..) )
49+import Rel8.Schema.HTable.Type ( HType(..) )
50+import Rel8.Schema.Nullability ( IsMaybe, Sql )
51+import Rel8.Schema.Spec ( SSpec(..), KnownSpec )
52+import Rel8.Table ( Table, Columns, fromColumns, toColumns )
53+import Rel8.Table.Either ( EitherTable )
54+import Rel8.Table.List ( ListTable )
55+import Rel8.Table.Maybe ( MaybeTable )
56+import Rel8.Table.NonEmpty ( NonEmptyTable )
57+import Rel8.Table.Recontextualize ( Encodes )
58+import Rel8.Table.These ( TheseTable )
3559import Rel8.Type ( DBType )
3660
3761-- semigroupoids
3862import Data.Functor.Apply ( WrappedApplicative(..) )
3963
64+-- these
65+import Data.These ( These )
66+
67+
68+type IsPlainColumn :: Type -> Bool
69+type family IsPlainColumn a where
70+ IsPlainColumn (Either _ _) = 'False
71+ IsPlainColumn [_] = 'False
72+ IsPlainColumn (Maybe _) = 'False
73+ IsPlainColumn (NonEmpty _) = 'False
74+ IsPlainColumn (These _ _) = 'False
75+ IsPlainColumn (_, _) = 'False
76+ IsPlainColumn (_, _, _) = 'False
77+ IsPlainColumn (_, _, _, _) = 'False
78+ IsPlainColumn (_, _, _, _, _) = 'False
79+ IsPlainColumn (_ Identity) = 'False
80+ IsPlainColumn (_ (Col Identity _)) = 'False
81+ IsPlainColumn (Identity _) = 'False
82+ IsPlainColumn _ = 'True
83+
84+
85+type IsTabular :: Type -> Bool
86+type family IsTabular a where
87+ IsTabular (Either _ _) = 'True
88+ IsTabular [a] = IsListTabular a
89+ IsTabular (Maybe a) = IsMaybeTabular a
90+ IsTabular (NonEmpty a) = IsListTabular a
91+ IsTabular (These _ _) = 'True
92+ IsTabular (_, _) = 'True
93+ IsTabular (_, _, _) = 'True
94+ IsTabular (_, _, _, _) = 'True
95+ IsTabular (_, _, _, _, _) = 'True
96+ IsTabular (_ Identity) = 'True
97+ IsTabular (_ (Col Identity)) = 'True
98+ IsTabular (Col Identity _) = 'True
99+ IsTabular _ = 'False
100+
101+
102+type IsTabular' :: Bool -> Type -> Bool
103+type family IsTabular' isTabular exprs where
104+ IsTabular' _ (Expr _) = 'False
105+ IsTabular' 'False _ = 'False
106+ IsTabular' _ _ = 'True
107+
108+
109+type IsMaybeTabular :: Type -> Bool
110+type family IsMaybeTabular a where
111+ IsMaybeTabular (Maybe _) = 'True
112+ IsMaybeTabular a = IsTabular a
113+
114+
115+type IsListTabular :: Type -> Bool
116+type family IsListTabular a where
117+ IsListTabular (Maybe a) = IsMaybeTabular a
118+ IsListTabular a = IsTabular a
119+
40120
41−-- | @ToExprs exprs a@ is evidence that the types @exprs@ and @a@ describe
42−-- essentially the same type, but @exprs@ is in the 'Expr' context, and @a@ is
43−-- a normal Haskell type.
44121type ToExprs :: Type -> Type -> Constraint
45−class Table Expr exprs => ToExprs exprs a
122+class ExprsFor (IsPlainColumn a) (IsTabular' (IsTabular a) exprs) a exprs => ToExprs a exprs
123+instance ExprsFor (IsPlainColumn a) (IsTabular' (IsTabular a) exprs) a exprs => ToExprs a exprs
124+
125+
126+fromIdentity' :: forall exprs a. ToExprs a exprs => Columns exprs (Col Identity) -> a
127+fromIdentity' = fromIdentity @(IsPlainColumn a) @_ @_ @exprs
128+
129+
130+toIdentity' :: forall exprs a. ToExprs a exprs => a -> Columns exprs (Col Identity)
131+toIdentity' = toIdentity @(IsPlainColumn a) @_ @_ @exprs
132+
133+
134+type ExprsFor :: Bool -> Bool -> Type -> Type -> Constraint
135+class (Table Expr exprs, isTabular ~ IsTabular a) =>
136+ ExprsFor isPlainColumn isTabular a exprs where
137+ fromIdentity :: Columns exprs (Col Identity) -> a
138+ toIdentity :: a -> Columns exprs (Col Identity)
139+
140+
141+instance
142+ ( DBType a
143+ , IsMaybe a ~ 'False
144+ , IsTabular a ~ 'False
145+ , x ~ Expr a
146+ )
147+ => ExprsFor 'True 'False a x
148+ where
149+ fromIdentity (HType (Result a)) = a
150+ toIdentity = HType . Result
151+
152+
153+instance
154+ ( Sql DBType a
155+ , IsListTabular a ~ 'False
156+ , x ~ [a]
157+ ) => ExprsFor 'False 'False [a] (Expr x)
158+ where
159+ fromIdentity (HType (Result a)) = a
160+ toIdentity = HType . Result
161+
162+
163+instance
164+ ( Sql DBType a
165+ , isTabular ~ 'False
166+ , IsMaybe a ~ 'False
167+ , IsMaybeTabular a ~ 'False
168+ , x ~ Maybe a
169+ ) => ExprsFor 'False 'False (Maybe a) (Expr x)
170+ where
171+ fromIdentity (HType (Result a)) = a
172+ toIdentity = HType . Result
173+
174+
175+instance
176+ ( Sql DBType a
177+ , IsListTabular a ~ 'False
178+ , x ~ NonEmpty a
179+ ) => ExprsFor 'False 'False (NonEmpty a) (Expr x)
180+ where
181+ fromIdentity (HType (Result a)) = a
182+ toIdentity = HType . Result
183+
184+
185+instance
186+ ( ToExprs a exprs
187+ , IsListTabular a ~ 'False
188+ ) => ExprsFor 'False 'False [a] (ListTable exprs)
189+ where
190+ fromIdentity = fmap (fromIdentity' @exprs) . fromHListTable
191+ toIdentity = toHListTable . fmap (toIdentity' @exprs)
192+
193+
194+instance
195+ ( ToExprs a exprs
196+ , IsMaybeTabular a ~ 'False
197+ ) => ExprsFor 'False 'False (Maybe a) (MaybeTable exprs)
198+ where
199+ fromIdentity =
200+ fmap (fromIdentity' @exprs . hunlabel unlabeler) .
201+ fromHMaybeTable
202+ toIdentity =
203+ toHMaybeTable .
204+ fmap (hlabel labeler . toIdentity' @exprs)
205+
206+
207+instance
208+ ( ToExprs a exprs
209+ , IsListTabular a ~ 'False
210+ ) => ExprsFor 'False 'False (NonEmpty a) (NonEmptyTable exprs)
211+ where
212+ fromIdentity = fmap (fromIdentity' @exprs) . fromHNonEmptyTable
213+ toIdentity = toHNonEmptyTable . fmap (toIdentity' @exprs)
46214
47215
48−instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a
216+instance
217+ ( ToExprs a exprs1
218+ , ToExprs b exprs2
219+ , isTabular ~ 'True
220+ , x ~ EitherTable exprs1 exprs2
221+ ) => ExprsFor 'False isTabular (Either a b) x
222+ where
223+ fromIdentity =
224+ bimap
225+ (fromIdentity' @exprs1 . hunlabel unlabeler)
226+ (fromIdentity' @exprs2 . hunlabel unlabeler) .
227+ fromHEitherTable
228+ toIdentity =
229+ toHEitherTable .
230+ bimap
231+ (hlabel labeler . toIdentity' @exprs1)
232+ (hlabel labeler . toIdentity' @exprs2)
49233
50234
51−instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a]
235+instance
236+ ( ToExprs a exprs
237+ , IsListTabular a ~ 'True
238+ , x ~ ListTable exprs
239+ ) => ExprsFor 'False 'True [a] x
240+ where
241+ fromIdentity = fmap (fromIdentity' @exprs) . fromHListTable
242+ toIdentity = toHListTable . fmap (toIdentity' @exprs)
52243
53244
54−instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a)
245+instance
246+ ( ToExprs a exprs
247+ , IsMaybeTabular a ~ 'True
248+ , x ~ MaybeTable exprs
249+ ) => ExprsFor 'False 'True (Maybe a) x
250+ where
251+ fromIdentity =
252+ fmap (fromIdentity' @exprs . hunlabel unlabeler) .
253+ fromHMaybeTable
254+ toIdentity =
255+ toHMaybeTable .
256+ fmap (hlabel labeler . toIdentity' @exprs)
55257
56258
57−instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a)
259+instance
260+ ( ToExprs a exprs
261+ , IsListTabular a ~ 'True
262+ , x ~ NonEmptyTable exprs
263+ ) => ExprsFor 'False 'True (NonEmpty a) x
264+ where
265+ fromIdentity = fmap (fromIdentity' @exprs) . fromHNonEmptyTable
266+ toIdentity = toHNonEmptyTable . fmap (toIdentity' @exprs)
58267
59268
60−instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>
61− ToExprs x (a, b)
269+instance
270+ ( ToExprs a exprs1
271+ , ToExprs b exprs2
272+ , isTabular ~ 'True
273+ , x ~ TheseTable exprs1 exprs2
274+ ) => ExprsFor 'False isTabular (These a b) x
275+ where
276+ fromIdentity =
277+ bimap
278+ (fromIdentity' @exprs1 . hunlabel unlabeler)
279+ (fromIdentity' @exprs2 . hunlabel unlabeler) .
280+ fromHTheseTable
281+ toIdentity =
282+ toHTheseTable .
283+ bimap
284+ (hlabel labeler . toIdentity' @exprs1)
285+ (hlabel labeler . toIdentity' @exprs2)
62286
63287
64288instance
65− ( ToExprs exprs1 a
66− , ToExprs exprs2 b
67− , ToExprs exprs3 c
289+ ( ToExprs a exprs1
290+ , ToExprs b exprs2
291+ , isTabular ~ 'True
292+ , x ~ (exprs1, exprs2)
293+ ) => ExprsFor 'False isTabular (a, b) x
294+ where
295+ fromIdentity (HPair a b) =
296+ ( fromIdentity' @exprs1 $ hunlabel unlabeler a
297+ , fromIdentity' @exprs2 $ hunlabel unlabeler b
298+ )
299+ toIdentity (a, b) = HPair
300+ { hfst = hlabel labeler $ toIdentity' @exprs1 a
301+ , hsnd = hlabel labeler $ toIdentity' @exprs2 b
302+ }
303+
304+
305+instance
306+ ( ToExprs a exprs1
307+ , ToExprs b exprs2
308+ , ToExprs c exprs3
309+ , isTabular ~ 'True
68310 , x ~ (exprs1, exprs2, exprs3)
69− )
70− => ToExprs x (a, b, c)
311+ ) => ExprsFor 'False isTabular (a, b, c) x
312+ where
313+ fromIdentity (HTrio a b c) =
314+ ( fromIdentity' @exprs1 $ hunlabel unlabeler a
315+ , fromIdentity' @exprs2 $ hunlabel unlabeler b
316+ , fromIdentity' @exprs3 $ hunlabel unlabeler c
317+ )
318+ toIdentity (a, b, c) = HTrio
319+ { hfst = hlabel labeler $ toIdentity' @exprs1 a
320+ , hsnd = hlabel labeler $ toIdentity' @exprs2 b
321+ , htrd = hlabel labeler $ toIdentity' @exprs3 c
322+ }
71323
72324
73325instance
74− ( ToExprs exprs1 a
75− , ToExprs exprs2 b
76− , ToExprs exprs3 c
77− , ToExprs exprs4 d
326+ ( ToExprs a exprs1
327+ , ToExprs b exprs2
328+ , ToExprs c exprs3
329+ , ToExprs d exprs4
330+ , isTabular ~ 'True
78331 , x ~ (exprs1, exprs2, exprs3, exprs4)
79− )
80− => ToExprs x (a, b, c, d)
332+ ) => ExprsFor 'False isTabular (a, b, c, d) x
333+ where
334+ fromIdentity (HQuartet a b c d) =
335+ ( fromIdentity' @exprs1 $ hunlabel unlabeler a
336+ , fromIdentity' @exprs2 $ hunlabel unlabeler b
337+ , fromIdentity' @exprs3 $ hunlabel unlabeler c
338+ , fromIdentity' @exprs4 $ hunlabel unlabeler d
339+ )
340+ toIdentity (a, b, c, d) = HQuartet
341+ { hfst = hlabel labeler $ toIdentity' @exprs1 a
342+ , hsnd = hlabel labeler $ toIdentity' @exprs2 b
343+ , htrd = hlabel labeler $ toIdentity' @exprs3 c
344+ , hfrt = hlabel labeler $ toIdentity' @exprs4 d
345+ }
81346
82347
83348instance
84− ( ToExprs exprs1 a
85− , ToExprs exprs2 b
86− , ToExprs exprs3 c
87− , ToExprs exprs4 d
88− , ToExprs exprs5 e
349+ ( ToExprs a exprs1
350+ , ToExprs b exprs2
351+ , ToExprs c exprs3
352+ , ToExprs d exprs4
353+ , ToExprs e exprs5
354+ , isTabular ~ 'True
89355 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
90− )
91− => ToExprs x (a, b, c, d, e)
356+ ) => ExprsFor 'False isTabular (a, b, c, d, e) x
357+ where
358+ fromIdentity (HQuintet a b c d e) =
359+ ( fromIdentity' @exprs1 $ hunlabel unlabeler a
360+ , fromIdentity' @exprs2 $ hunlabel unlabeler b
361+ , fromIdentity' @exprs3 $ hunlabel unlabeler c
362+ , fromIdentity' @exprs4 $ hunlabel unlabeler d
363+ , fromIdentity' @exprs5 $ hunlabel unlabeler e
364+ )
365+ toIdentity (a, b, c, d, e) = HQuintet
366+ { hfst = hlabel labeler $ toIdentity' @exprs1 a
367+ , hsnd = hlabel labeler $ toIdentity' @exprs2 b
368+ , htrd = hlabel labeler $ toIdentity' @exprs3 c
369+ , hfrt = hlabel labeler $ toIdentity' @exprs4 d
370+ , hfft = hlabel labeler $ toIdentity' @exprs5 e
371+ }
92372
93373
94374instance
95− ( ToExprs exprs1 a
96− , ToExprs exprs2 b
97− , ToExprs exprs3 c
98− , ToExprs exprs4 d
99− , ToExprs exprs5 e
100− , ToExprs exprs6 f
101− , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6)
102− )
103− => ToExprs x (a, b, c, d, e, f)
375+ ( HTable t
376+ , isTabular ~ 'True
377+ , result ~ Col Identity
378+ , x ~ t (Col Expr)
379+ ) => ExprsFor 'False isTabular (t result) x
380+ where
381+ fromIdentity = id
382+ toIdentity = id
104383
105384
106385instance
107− ( ToExprs exprs1 a
108− , ToExprs exprs2 b
109− , ToExprs exprs3 c
110− , ToExprs exprs4 d
111− , ToExprs exprs5 e
112− , ToExprs exprs6 f
113− , ToExprs exprs7 g
114− , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6, exprs7)
115− )
116− => ToExprs x (a, b, c, d, e, f, g)
386+ ( Encodes (t Identity) (t Expr)
387+ , isTabular ~ 'True
388+ , result ~ Identity
389+ , x ~ t Expr
390+ ) => ExprsFor 'False isTabular (t result) x
391+ where
392+ fromIdentity = fromColumns
393+ toIdentity = toColumns
394+
395+
396+instance
397+ ( KnownSpec spec
398+ , isTabular ~ 'True
399+ , isSpecial ~ 'True
400+ , x ~ Col Expr spec
401+ ) => ExprsFor 'False isTabular (Col Identity spec) x
402+ where
403+ fromIdentity = fromColumns
404+ toIdentity = toColumns
405+
406+
407+type FromExprs :: Type -> Type
408+type family FromExprs a where
409+ FromExprs (Expr a) = a
410+ FromExprs (Col Expr spec) = Col Identity spec
411+ FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
412+ FromExprs (ListTable a) = [FromExprs a]
413+ FromExprs (MaybeTable a) = Maybe (FromExprs a)
414+ FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)
415+ FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
416+ FromExprs (a, b) = (FromExprs a, FromExprs b)
417+ FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)
418+ FromExprs (a, b, c, d) =
419+ (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
420+ FromExprs (a, b, c, d, e) =
421+ (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
422+ FromExprs (t Expr) = t Identity
423+ FromExprs (t (Col Expr)) = t (Col Identity)
117424
118425
119426-- | @Serializable@ witnesses the one-to-one correspondence between the type
120427-- @sql@, which contains SQL expressions, and the type @haskell@, which
121428-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
122−type Serializable :: Type -> Type -> Constraint
123−class (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
124−instance (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a
125−instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a
429+class (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
430+instance (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a
431+instance Serializable (Expr Opaque) Opaque
126432
127433
128−-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is
129−-- capable of lifting single @Expr@s to full tables.
130434lit :: forall exprs a. Serializable exprs a => a -> exprs
131−lit = fromColumns . litHTable . toResult @_ @exprs
435+lit = fromColumns . litTable . toIdentity' @exprs
132436
133437
134438parse :: forall exprs a. Serializable exprs a => Hasql.Row a
135−parse = fromResult @_ @exprs <$> parseHTable
439+parse = fromIdentity' @exprs <$> parseTable
136440
137441
138−litHTable :: HTable t => t Result -> t Expr
139−litHTable as = htabulate $ \field ->
442+litTable :: Encodes a b => a -> b
443+litTable (toColumns -> as) = fromColumns $ htabulate $ \field ->
140444 case hfield hspecs field of
141− Spec {nullity, info} -> case hfield as field of
142− Identity value -> slitExpr nullity info value
445+ SSpec {nullability, info} -> case hfield as field of
446+ Result value -> DB (slitExpr nullability info value)
143447
144448
145−parseHTable :: HTable t => Hasql.Row (t Result)
146−parseHTable = unwrapApplicative $ htabulateA $ \field ->
449+parseTable :: Table Identity a => Hasql.Row a
450+parseTable = fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->
147451 WrapApplicative $ case hfield hspecs field of
148− Spec {nullity, info} -> Identity <$> sparseValue nullity info
452+ SSpec {nullability, info} -> Result <$> sparseValue nullability info
src/Rel8/Table/These.hs+108−233
@@ -5,122 +5,84 @@
55{-# language FlexibleInstances #-}
66{-# language MultiParamTypeClasses #-}
77{-# language NamedFieldPuns #-}
8−{-# language ScopedTypeVariables #-}
98{-# language StandaloneKindSignatures #-}
109{-# language TupleSections #-}
11−{-# language TypeApplications #-}
1210{-# language TypeFamilies #-}
1311{-# language UndecidableInstances #-}
1412
15−{-# options_ghc -fno-warn-orphans #-}
16−
1713module Rel8.Table.These
1814 ( TheseTable(..)
1915 , theseTable, thisTable, thatTable, thoseTable
2016 , isThisTable, isThatTable, isThoseTable
2117 , hasHereTable, hasThereTable
2218 , justHereTable, justThereTable
23− , alignMaybeTable
24− , aggregateTheseTable
25− , nameTheseTable
2619 )
2720where
2821
2922-- base
3023import Data.Bifunctor ( Bifunctor, bimap )
24+import Data.Functor.Identity ( runIdentity )
3125import Data.Kind ( Type )
32−import Data.Maybe ( isJust )
33−import Prelude hiding ( null, undefined )
26+import Prelude hiding ( undefined )
3427
3528-- rel8
36−import Rel8.Aggregate ( Aggregate )
3729import Rel8.Expr ( Expr )
38−import Rel8.Expr.Bool ( (&&.), (||.), boolExpr, not_ )
39−import Rel8.Expr.Null ( null, isNonNull )
40−import Rel8.Kind.Context ( Reifiable )
41−import Rel8.Schema.Context.Nullify ( Nullifiable )
42−import Rel8.Schema.Dict ( Dict( Dict ) )
43−import Rel8.Schema.HTable.Label ( hlabel, hrelabel, hunlabel )
30+import Rel8.Expr.Bool ( (&&.), not_ )
31+import Rel8.Expr.Null ( isNonNull )
32+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
33+import Rel8.Schema.Context.Nullify
34+ ( Nullifiable, NullifiableEq
35+ , encodeTag, decodeTag
36+ , nullifier, unnullifier
37+ )
38+import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
4439import Rel8.Schema.HTable.Identity ( HIdentity(..) )
45−import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
40+import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
4641import Rel8.Schema.HTable.These ( HTheseTable(..) )
47−import qualified Rel8.Schema.Kind as K
48−import Rel8.Schema.Name ( Name )
49−import Rel8.Table
50− ( Table, Columns, Context, fromColumns, toColumns
51− , FromExprs, fromResult, toResult
52− , Transpose
42+import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
43+import Rel8.Table.Lifted
44+ ( Table1, Columns1, ConstrainContext1, fromColumns1, toColumns1
45+ , Table2, Columns2, ConstrainContext2, fromColumns2, toColumns2
5346 )
54−import Rel8.Table.Eq ( EqTable, eqTable )
5547import Rel8.Table.Maybe
5648 ( MaybeTable(..)
5749 , maybeTable, justTable, nothingTable
5850 , isJustTable
59− , aggregateMaybeTable
60− , nameMaybeTable
6151 )
62−import Rel8.Table.Nullify ( Nullify, guard )
63−import Rel8.Table.Ord ( OrdTable, ordTable )
64−import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )
65−import Rel8.Table.Serialize ( ToExprs )
52+import Rel8.Table.Recontextualize ( Recontextualize )
6653import Rel8.Table.Undefined ( undefined )
67−import Rel8.Type.Tag ( MaybeTag )
6854
6955-- semigroupoids
7056import Data.Functor.Apply ( Apply, (<.>) )
7157import Data.Functor.Bind ( Bind, (>>-) )
7258
73−-- these
74−import Data.These ( These( This, That, These ) )
75−import Data.These.Combinators ( justHere, justThere )
76−
77−
78−-- | @TheseTable a b@ is a Rel8 table that contains either the table @a@, the
79−-- table @b@, or both tables @a@ and @b@. You can construct @TheseTable@s using
80−-- 'thisTable', 'thatTable' and 'thoseTable'. @TheseTable@s can be
81−-- eliminated/pattern matched using 'theseTable'.
82−--
83−-- @TheseTable@ is operationally the same as Haskell's 'These' type, but
84−-- adapted to work with Rel8.
85−type TheseTable :: K.Context -> Type -> Type -> Type
86−data TheseTable context a b = TheseTable
87− { here :: MaybeTable context a
88− , there :: MaybeTable context b
89− }
90− deriving stock Functor
9159
92−
93−instance Biprojectable (TheseTable context) where
94− biproject f g (TheseTable a b) = TheseTable (project f a) (project g b)
60+type TheseTable :: Type -> Type -> Type
61+data TheseTable a b = TheseTable
62+ { here :: MaybeTable a
63+ , there :: MaybeTable b
64+ }
65+ deriving stock (Show, Functor)
9566
9667
97−instance Nullifiable context => Bifunctor (TheseTable context) where
68+instance Bifunctor TheseTable where
9869 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
9970
10071
101−instance Projectable (TheseTable context a) where
102− project f (TheseTable a b) = TheseTable a (project f b)
103−
104−
105−instance (context ~ Expr, Table Expr a, Semigroup a) =>
106− Apply (TheseTable context a)
107− where
72+instance (Table Expr a, Semigroup a) => Apply (TheseTable a) where
10873 fs <.> as = TheseTable
10974 { here = here fs <> here as
11075 , there = there fs <.> there as
11176 }
11277
11378
114−instance (context ~ Expr, Table Expr a, Semigroup a) =>
115− Applicative (TheseTable context a)
79+instance (Table Expr a, Semigroup a) => Applicative (TheseTable a)
11680 where
11781 pure = thatTable
11882 (<*>) = (<.>)
11983
12084
121−instance (context ~ Expr, Table Expr a, Semigroup a) =>
122− Bind (TheseTable context a)
123− where
85+instance (Table Expr a, Semigroup a) => Bind (TheseTable a) where
12486 TheseTable here1 ma >>- f = case ma >>- f' of
12587 mtb -> TheseTable
12688 { here = maybeTable here1 ((here1 <>) . fst) mtb
@@ -131,14 +93,12 @@ instance (context ~ Expr, Table Expr a, Semigroup a) =>
13193 TheseTable here2 mb -> (here2,) <$> mb
13294
13395
134−instance (context ~ Expr, Table Expr a, Semigroup a) =>
135− Monad (TheseTable context a)
136− where
96+instance (Table Expr a, Semigroup a) => Monad (TheseTable a) where
13797 (>>=) = (>>-)
13898
13999
140−instance (context ~ Expr, Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
141− Semigroup (TheseTable context a b)
100+instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
101+ Semigroup (TheseTable a b)
142102 where
143103 a <> b = TheseTable
144104 { here = here a <> here b
@@ -146,212 +106,127 @@ instance (context ~ Expr, Table Expr a, Table Expr b, Semigroup a, Semigroup b)
146106 }
147107
148108
149−instance
150− ( Table context a, Table context b
151− , Reifiable context, context ~ context'
152− )
153− => Table context' (TheseTable context a b)
154− where
155− type Columns (TheseTable context a b) = HTheseTable (Columns a) (Columns b)
156− type Context (TheseTable context a b) = Context a
157− type FromExprs (TheseTable context a b) =
158− These (FromExprs a) (FromExprs b)
159− type Transpose to (TheseTable context a b) =
160− TheseTable to (Transpose to a) (Transpose to b)
161−
162− toColumns TheseTable {here, there} = HTheseTable
163− { hhereTag = hlabel $ HIdentity $ tag here
164− , hhere =
165− hlabel $ guard (tag here) isJust isNonNull $ toColumns $ just here
166− , hthereTag = hlabel $ HIdentity $ tag there
167− , hthere =
168− hlabel $ guard (tag there) isJust isNonNull $ toColumns $ just there
169− }
109+instance Table2 TheseTable where
110+ type Columns2 TheseTable = HTheseTable
111+ type ConstrainContext2 TheseTable = Nullifiable
170112
171− fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable
172− { here = MaybeTable
173− { tag = unHIdentity $ hunlabel hhereTag
174− , just = fromColumns $ hunlabel hhere
175− }
176− , there = MaybeTable
177− { tag = unHIdentity $ hunlabel hthereTag
178− , just = fromColumns $ hunlabel hthere
179− }
113+ toColumns2 f g TheseTable {here, there} = HTheseTable
114+ { hhereTag = HIdentity $ encodeTag (tag here)
115+ , hhere = hnullify (nullifier (isNonNull (tag here))) $ f (just here)
116+ , hthereTag = HIdentity $ encodeTag (tag there)
117+ , hthere = hnullify (nullifier (isNonNull (tag there))) $ g (just there)
180118 }
181119
182− toResult tables = HTheseTable
183− { hhereTag = hrelabel hhereTag
184− , hhere = hrelabel hhere
185− , hthereTag = hrelabel hthereTag
186− , hthere = hrelabel hthere
187− }
188− where
189− HMaybeTable
190− { htag = hhereTag
191− , hjust = hhere
192− } = toResult @_ @(MaybeTable context a) (justHere tables)
193− HMaybeTable
194− { htag = hthereTag
195− , hjust = hthere
196− } = toResult @_ @(MaybeTable context b) (justThere tables)
197−
198− fromResult HTheseTable {hhereTag, hhere, hthereTag, hthere} =
199− case (here, there) of
200− (Just a, Nothing) -> This a
201− (Nothing, Just b) -> That b
202− (Just a, Just b) -> These a b
203− _ -> error "These.fromColumns: mismatch between tags and data"
204− where
205− here = fromResult @_ @(MaybeTable context a) mhere
206− there = fromResult @_ @(MaybeTable context b) mthere
207− mhere = HMaybeTable
208− { htag = hrelabel hhereTag
209− , hjust = hrelabel hhere
210− }
211− mthere = HMaybeTable
212− { htag = hrelabel hthereTag
213− , hjust = hrelabel hthere
214− }
215−
216−
217−instance (EqTable a, EqTable b, context ~ Expr) =>
218− EqTable (TheseTable context a b)
219− where
220− eqTable = HTheseTable
221− { hhereTag = hlabel (HIdentity Dict)
222− , hhere = hlabel (eqTable @(Nullify context a))
223− , hthereTag = hlabel (HIdentity Dict)
224− , hthere = hlabel (eqTable @(Nullify context b))
225− }
120+ fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} =
121+ TheseTable
122+ { here =
123+ let
124+ tag = decodeTag $ unHIdentity hhereTag
125+ in
126+ MaybeTable
127+ { tag
128+ , just = f $
129+ runIdentity $
130+ hunnullify (\a -> pure . unnullifier (isNonNull tag) a)
131+ hhere
132+ }
133+ , there =
134+ let
135+ tag = decodeTag $ unHIdentity hthereTag
136+ in
137+ MaybeTable
138+ { tag
139+ , just = g $
140+ runIdentity $
141+ hunnullify (\a -> pure . unnullifier (isNonNull tag) a)
142+ hthere
143+ }
144+ }
145+
146+ {-# INLINABLE fromColumns2 #-}
147+ {-# INLINABLE toColumns2 #-}
148+
149+
150+instance Table context a => Table1 (TheseTable a) where
151+ type Columns1 (TheseTable a) = HTheseTable (Columns a)
152+ type ConstrainContext1 (TheseTable a) = NullifiableEq (Context a)
226153
154+ toColumns1 = toColumns2 toColumns
155+ fromColumns1 = fromColumns2 fromColumns
227156
228−instance (OrdTable a, OrdTable b, context ~ Expr) =>
229− OrdTable (TheseTable context a b)
157+
158+instance
159+ ( Table context a, Table context b
160+ , Labelable context, Nullifiable context
161+ ) => Table context (TheseTable a b)
230162 where
231− ordTable = HTheseTable
232− { hhereTag = hlabel (HIdentity Dict)
233− , hhere = hlabel (ordTable @(Nullify context a))
234− , hthereTag = hlabel (HIdentity Dict)
235− , hthere = hlabel (ordTable @(Nullify context b))
236− }
163+ type Columns (TheseTable a b) =
164+ HTheseTable (HLabel "Here" (Columns a)) (HLabel "There" (Columns b))
165+ type Context (TheseTable a b) = Context a
237166
167+ toColumns =
168+ toColumns2
169+ (hlabel labeler . toColumns)
170+ (hlabel labeler . toColumns)
171+ fromColumns =
172+ fromColumns2
173+ (fromColumns . hunlabel unlabeler)
174+ (fromColumns . hunlabel unlabeler)
238175
239−instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable Expr exprs1 exprs2) =>
240− ToExprs x (These a b)
241176
177+instance
178+ ( Labelable from, Nullifiable from
179+ , Labelable to, Nullifiable to
180+ , Recontextualize from to a1 b1
181+ , Recontextualize from to a2 b2
182+ ) =>
183+ Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2)
242184
243−-- | Test if a 'TheseTable' was constructed with 'thisTable'.
244−--
245−-- Corresponds to 'Data.These.Combinators.isThis'.
246−isThisTable :: TheseTable Expr a b -> Expr Bool
185+
186+isThisTable :: TheseTable a b -> Expr Bool
247187isThisTable a = hasHereTable a &&. not_ (hasThereTable a)
248188
249189
250−-- | Test if a 'TheseTable' was constructed with 'thatTable'.
251−--
252−-- Corresponds to 'Data.These.Combinators.isThat'.
253−isThatTable :: TheseTable Expr a b -> Expr Bool
190+isThatTable :: TheseTable a b -> Expr Bool
254191isThatTable a = not_ (hasHereTable a) &&. hasThereTable a
255192
256193
257−-- | Test if a 'TheseTable' was constructed with 'thoseTable'.
258−--
259−-- Corresponds to 'Data.These.Combinators.isThese'.
260−isThoseTable :: TheseTable Expr a b -> Expr Bool
194+isThoseTable :: TheseTable a b -> Expr Bool
261195isThoseTable a = hasHereTable a &&. hasThereTable a
262196
263197
264−-- | Test if the @a@ side of @TheseTable a b@ is present.
265−--
266−-- Corresponds to 'Data.These.Combinators.hasHere'.
267−hasHereTable :: TheseTable Expr a b -> Expr Bool
198+hasHereTable :: TheseTable a b -> Expr Bool
268199hasHereTable TheseTable {here} = isJustTable here
269200
270201
271−-- | Test if the @b@ table of @TheseTable a b@ is present.
272−--
273−-- Corresponds to 'Data.These.Combinators.hasThere'.
274−hasThereTable :: TheseTable Expr a b -> Expr Bool
202+hasThereTable :: TheseTable a b -> Expr Bool
275203hasThereTable TheseTable {there} = isJustTable there
276204
277205
278−-- | Attempt to project out the @a@ table of a @TheseTable a b@.
279−--
280−-- Corresponds to 'Data.These.Combinators.justHere'.
281−justHereTable :: TheseTable context a b -> MaybeTable context a
206+justHereTable :: TheseTable a b -> MaybeTable a
282207justHereTable = here
283208
284209
285−-- | Attempt to project out the @b@ table of a @TheseTable a b@.
286−--
287−-- Corresponds to 'Data.These.Combinators.justThere'.
288−justThereTable :: TheseTable context a b -> MaybeTable context b
210+justThereTable :: TheseTable a b -> MaybeTable b
289211justThereTable = there
290212
291213
292−-- | Construct a @TheseTable@ from two 'MaybeTable's.
293−alignMaybeTable :: ()
294− => MaybeTable Expr a
295− -> MaybeTable Expr b
296− -> MaybeTable Expr (TheseTable Expr a b)
297−alignMaybeTable a b = MaybeTable tag (pure (TheseTable a b))
298− where
299− tag = boolExpr null mempty (isJustTable a ||. isJustTable b)
300−
301−
302−-- | Construct a @TheseTable@. Corresponds to 'This'.
303−thisTable :: Table Expr b => a -> TheseTable Expr a b
214+thisTable :: Table Expr b => a -> TheseTable a b
304215thisTable a = TheseTable (justTable a) nothingTable
305216
306217
307−-- | Construct a @TheseTable@. Corresponds to 'That'.
308−thatTable :: Table Expr a => b -> TheseTable Expr a b
218+thatTable :: Table Expr a => b -> TheseTable a b
309219thatTable b = TheseTable nothingTable (justTable b)
310220
311221
312−-- | Construct a @TheseTable@. Corresponds to 'These'.
313−thoseTable :: a -> b -> TheseTable Expr a b
222+thoseTable :: a -> b -> TheseTable a b
314223thoseTable a b = TheseTable (justTable a) (justTable b)
315224
316225
317−-- | Pattern match on a 'TheseTable'. Corresponds to 'these'.
318226theseTable :: Table Expr c
319− => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable Expr a b -> c
227+ => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable a b -> c
320228theseTable f g h TheseTable {here, there} =
321229 maybeTable
322230 (maybeTable undefined f here)
323231 (\b -> maybeTable (g b) (`h` b) here)
324232 there
325−
326−
327−-- | Lift a pair of aggregating functions to operate on an 'TheseTable'.
328−-- @thisTable@s, @thatTable@s and @thoseTable@s are grouped separately.
329−aggregateTheseTable :: ()
330− => (exprs -> aggregates)
331− -> (exprs' -> aggregates')
332− -> TheseTable Expr exprs exprs'
333− -> TheseTable Aggregate aggregates aggregates'
334−aggregateTheseTable f g (TheseTable here there) = TheseTable
335− { here = aggregateMaybeTable f here
336− , there = aggregateMaybeTable g there
337− }
338−
339−
340−-- | Construct a 'TheseTable' in the 'Name' context. This can be useful if you
341−-- have a 'TheseTable' that you are storing in a table and need to construct a
342−-- 'TableSchema'.
343−nameTheseTable :: ()
344− => Name (Maybe MaybeTag)
345− -- ^ The name of the column to track the presence of the @a@ table.
346− -> Name (Maybe MaybeTag)
347− -- ^ The name of the column to track the presence of the @b@ table.
348− -> a
349− -- ^ Names of the columns in the @a@ table.
350− -> b
351− -- ^ Names of the columns in the @b@ table.
352− -> TheseTable Name a b
353−nameTheseTable here there a b =
354− TheseTable
355− { here = nameMaybeTable here a
356− , there = nameMaybeTable there b
357− }
src/Rel8/Table/Transpose.hsdeleted−46
@@ -1,46 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language FlexibleInstances #-}
3−{-# language FunctionalDependencies #-}
4−{-# language StandaloneKindSignatures #-}
5−{-# language TypeFamilies #-}
6−{-# language UndecidableInstances #-}
7−
8−module Rel8.Table.Transpose
9− ( Transposes
10− )
11−where
12−
13−-- base
14−import Data.Kind ( Constraint, Type )
15−import Prelude ()
16−
17−-- rel8
18−import qualified Rel8.Schema.Kind as K
19−import Rel8.Table ( Table, Transpose, Congruent )
20−
21−
22−-- | @'Transposes' from to a b@ means that @a@ and @b@ are 'Table's, in the
23−-- @from@ and @to@ contexts respectively, which share the same underlying
24−-- structure. In other words, @b@ is a version of @a@ transposed from the
25−-- @from@ context to the @to@ context (and vice versa).
26−type Transposes :: K.Context -> K.Context -> Type -> Type -> Constraint
27−class
28− ( Table from a
29− , Table to b
30− , Congruent a b
31− , b ~ Transpose to a
32− , a ~ Transpose from b
33− )
34− => Transposes from to a b
35− | a -> from
36− , b -> to
37− , a to -> b
38− , b from -> a
39−instance
40− ( Table from a
41− , Table to b
42− , Congruent a b
43− , b ~ Transpose to a
44− , a ~ Transpose from b
45− )
46− => Transposes from to a b
src/Rel8/Table/Undefined.hs+6−5
@@ -13,14 +13,15 @@ import Prelude hiding ( undefined )
1313-- rel8
1414import Rel8.Expr ( Expr )
1515import Rel8.Expr.Null ( snull, unsafeUnnullify )
16+import Rel8.Schema.Context ( Col(..) )
1617import Rel8.Schema.HTable ( htabulate, hfield, hspecs )
17−import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
18−import Rel8.Schema.Spec ( Spec(..) )
18+import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
19+import Rel8.Schema.Spec ( SSpec(..) )
1920import Rel8.Table ( Table, fromColumns )
2021
2122
2223undefined :: Table Expr a => a
2324undefined = fromColumns $ htabulate $ \field -> case hfield hspecs field of
24− Spec {nullity, info} -> case nullity of
25− Null -> snull info
26− NotNull -> unsafeUnnullify (snull info)
25+ SSpec {nullability, info} -> case nullability of
26+ Nullable -> DB (snull Nullable info)
27+ NonNullable -> DB (unsafeUnnullify (snull Nullable info))
src/Rel8/Table/Window.hsdeleted−43
@@ -1,43 +0,0 @@
1−{-# language MonoLocalBinds #-}
2−
3−module Rel8.Table.Window
4− ( cumulative
5− , cumulative_
6− , currentRow
7− )
8−where
9−
10−-- base
11−import Prelude
12−
13−-- opaleye
14−import qualified Opaleye.Window as Opaleye
15−
16−-- rel8
17−import Rel8.Aggregate ( Aggregates )
18−import qualified Rel8.Expr.Window as Expr
19−import Rel8.Schema.HTable ( hfield, htabulateA )
20−import Rel8.Table ( fromColumns, toColumns )
21−import Rel8.Window ( Window( Window ) )
22−
23−
24−-- | 'cumulative' allows the use of aggregation functions in 'Window'
25−-- expressions. In particular, @'cumulative' 'Rel8.sum'@
26−-- (when combined with 'Rel8.Window.orderPartitionBy') gives a running total,
27−-- also known as a \"cumulative sum\", hence the name @cumulative@.
28−cumulative :: Aggregates aggregates exprs => (a -> aggregates) -> Window a exprs
29−cumulative f =
30− fmap fromColumns $
31− htabulateA $ \field ->
32− Expr.cumulative ((`hfield` field) . toColumns . f)
33−
34−
35−-- | A version of 'cumulative' for use with nullary aggregators like
36−-- 'Rel8.Expr.Aggregate.countStar'.
37−cumulative_ :: Aggregates aggregates exprs => aggregates -> Window a exprs
38−cumulative_ = cumulative . const
39−
40−
41−-- | Return every column of the current row of a window query.
42−currentRow :: Window a a
43−currentRow = Window $ Opaleye.over (Opaleye.noWindowFunction id) mempty mempty
src/Rel8/Tabulate.hs+140−549
@@ -1,640 +1,231 @@
1+{-# language DeriveFunctor #-}
2+{-# language DerivingStrategies #-}
13{-# language FlexibleContexts #-}
2−{-# language MonoLocalBinds #-}
3−{-# language ScopedTypeVariables #-}
4−{-# language StandaloneKindSignatures #-}
5−{-# language TypeApplications #-}
64{-# language TupleSections #-}
7−{-# language UndecidableInstances #-}
8−
9−-- | "Rel8.Tabulate" provides an alternative API ('Tabulation') for writing
10−-- queries that complements the main "Rel8" API ('Query').
115
126module Rel8.Tabulate
13− (
14− Tabulation
15−
16− -- * Interfacing with 'Query's
7+ ( Tabulation
8+ , runTabulation
9+ , tabulate
10+ , tabulateA
1711 , fromQuery
18− , toQuery
1912 , liftQuery
20− , through
13+ , prebind
14+ , postbind
15+ , indexed
16+ , ifilter
2117 , lookup
22−
23− -- * Aggregation and Ordering
24− , aggregate
25− , distinct
26− , order
27−
28− -- ** Magic 'Tabulation's
29− -- $magic
30− , count
31− , optional
32− , many
33− , some
34− , exists
35− , present
36− , absent
37−
38− -- * Natural joins
3918 , align
4019 , alignWith
4120 , leftAlign
4221 , leftAlignWith
43− , rightAlign
44− , rightAlignWith
4522 , zip
4623 , zipWith
4724 , similarity
4825 , difference
26+ , aggregateTabulation
27+ , optionalTabulation
4928 )
5029where
5130
5231-- base
53−import Control.Applicative ( (<|>), empty, liftA2 )
54−import Control.Monad ( liftM2 )
55−import Data.Bifunctor ( Bifunctor, bimap, first, second )
32+import Control.Applicative ( liftA2 )
33+import Control.Monad ( join, liftM2 )
34+import Data.Bifunctor ( bimap, first )
5635import Data.Foldable ( traverse_ )
57−import Data.Function ( on )
58−import Data.Functor.Contravariant ( Contravariant, (>$<), contramap )
59−import Data.Int ( Int64 )
60−import Data.Kind ( Type )
61−import Data.Maybe ( fromJust, fromMaybe )
62−import Prelude hiding ( lookup, zip, zipWith )
63−
64−-- bifunctors
65−import Data.Bifunctor.Clown ( Clown( Clown ), runClown )
66−
67−-- comonad
68−import Control.Comonad ( extract )
69−
70−-- opaleye
71−import qualified Opaleye.Aggregate as Opaleye
72−import qualified Opaleye.Order as Opaleye ( orderBy, distinctOnExplicit )
73−
74−-- profunctors
75−import Data.Profunctor ( dimap, lmap )
76−
77−-- product-profunctors
78−import Data.Profunctor.Product
79− ( ProductProfunctor, (***!)
80− , SumProfunctor, (+++!)
81− )
82−import qualified Data.Profunctor.Product as PP
36+import Data.Maybe ( fromMaybe )
37+import Prelude hiding ( filter, lookup, undefined, zip, zipWith )
8338
8439-- rel8
85−import Rel8.Aggregate ( Aggregates )
40+import Rel8.Aggregate ( Aggregate )
8641import Rel8.Expr ( Expr )
87−import Rel8.Expr.Aggregate ( countStar )
88−import Rel8.Expr.Bool ( true )
89−import Rel8.Order ( Order( Order ) )
42+import Rel8.Expr.Bool ( not_, true )
9043import Rel8.Query ( Query )
91−import qualified Rel8.Query.Exists as Q ( exists, present, absent )
92−import Rel8.Query.Filter ( where_ )
93−import Rel8.Query.List ( catNonEmptyTable )
94−import qualified Rel8.Query.Maybe as Q ( optional )
95−import Rel8.Query.Opaleye ( mapOpaleye, unsafePeekQuery )
96−import Rel8.Query.Rebind ( rebind )
44+import Rel8.Query.Aggregate ( aggregate )
45+import Rel8.Query.Exists ( withBy, withoutBy )
46+import Rel8.Query.Filter ( filter, where_ )
47+import Rel8.Query.Maybe ( optional )
9748import Rel8.Query.These ( alignBy )
98−import Rel8.Table ( Table, fromColumns, toColumns )
99−import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )
100−import Rel8.Table.Alternative
101− ( AltTable, (<|>:)
102− , AlternativeTable, emptyTable
103− )
104−import Rel8.Table.Cols ( fromCols, toCols )
105−import Rel8.Table.Eq ( EqTable, (==:), eqTable )
106−import Rel8.Table.List ( ListTable( ListTable ) )
107−import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), maybeTable )
108−import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )
109−import Rel8.Table.Opaleye ( aggregator, unpackspec )
110−import Rel8.Table.Ord ( OrdTable )
111−import Rel8.Table.Order ( ascTable )
112−import Rel8.Table.Projection
113− ( Biprojectable, biproject
114− , Projectable, project
115− , apply
116− )
117−import Rel8.Table.These ( TheseTable( TheseTable ), theseTable )
49+import Rel8.Table ( Table )
50+import Rel8.Table.Aggregate ( groupBy )
51+import Rel8.Table.Eq ( EqTable, (==:) )
52+import Rel8.Table.Maybe ( MaybeTable )
53+import Rel8.Table.These ( TheseTable, theseTable )
54+import Rel8.Table.Undefined ( undefined )
11855
11956-- semigroupoids
12057import Data.Functor.Apply ( Apply, liftF2 )
121−import Data.Functor.Bind ( Bind, (>>-) )
122−
123−
124−type Key :: Type -> Type
125−type Key = Maybe
126−
127−
128−cat :: Table Expr k => Key k -> Query k
129−cat = maybe emptyTable pure
130−
131−
132−key :: (ProductProfunctor p, SumProfunctor p)
133− => p a b -> p (Key a) (Key b)
134−key a = dimap from to (PP.empty +++! a)
135− where
136− from = maybe (Left ()) Right
137− to = either (const Nothing) Just
138−
139−
140−keyed :: (ProductProfunctor p, SumProfunctor p)
141− => p k l -> p a b -> p (Key k, a) (Key l, b)
142−keyed k a = key k ***! a
143−
144−
145−type Predicate :: Type -> Type
146−newtype Predicate a = Predicate (Maybe (a -> Expr Bool))
147−
148−
149−instance Contravariant Predicate where
150− contramap f (Predicate a) = Predicate (lmap f <$> a)
151−
152−
153−instance Semigroup (Predicate k) where
154− Predicate ma <> Predicate mb = Predicate $ ma <|> mb
155−
156−
157−instance Monoid (Predicate k) where
158− mempty = Predicate Nothing
159−
160−
161−match :: EqTable k => Key k -> Predicate k
162−match = Predicate . fmap (==:)
163−
164−
165−ensure :: Predicate k -> Key k -> Query ()
166−ensure (Predicate mp) = traverse_ (\k -> traverse_ (\p -> where_ (p k)) mp)
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))
58+import Data.Functor.Bind ( Bind )
59+import qualified Data.Functor.Bind
60+import Data.Semigroup.Traversable.Class ( bitraverse1 )
18561
18662
187−instance Biprojectable Tabulation where
188− biproject f g =
189− bimap
190− (fromColumns . apply f . toColumns)
191− (fromColumns . apply g . toColumns)
63+newtype Tabulation k a = Tabulation (k -> Query (Maybe k, a))
64+ deriving stock Functor
19265
19366
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 (<*>))@
20967instance EqTable k => Apply (Tabulation k) where
21068 liftF2 = liftA2
21169
21270
213−-- | @pure = 'liftQuery' . pure@
21471instance EqTable k => Applicative (Tabulation k) where
21572 pure = liftQuery . pure
21673 liftA2 = liftM2
21774
21875
21976instance 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)
77+ join = join
22878
22979
23080instance EqTable k => Monad (Tabulation k) where
231− (>>=) = (>>-)
81+ Tabulation as >>= f = Tabulation $ \i -> do
82+ (mk, a) <- as i
83+ case mk of
84+ Nothing -> case f a of
85+ Tabulation bs -> bs i
86+ Just k -> case f a of
87+ Tabulation bs -> do
88+ (mk', b) <- bs k
89+ case mk' of
90+ Nothing -> pure (mk, b)
91+ Just k' -> do
92+ where_ $ k ==: k'
93+ pure (mk', b)
94+
95+
96+runTabulation :: EqTable k => Tabulation k a -> Query (k, a)
97+runTabulation (Tabulation f) = do
98+ (mk, a) <- f i
99+ case mk of
100+ Nothing -> do
101+ -- Opaleye tries to be too clever optimising "WHERE FALSE" and generates
102+ -- invalid SQL, so we use "WHERE NOT TRUE" instead
103+ where_ $ not_ true
104+ pure (i, a)
105+ Just k -> pure (k, a)
106+ where
107+ i = undefined
232108
233109
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
110+liftQuery :: Query a -> Tabulation k a
111+liftQuery query = Tabulation $ const $ fmap (Nothing,) query
244112
245113
246−instance EqTable k => AlternativeTable (Tabulation k) where
247− emptyTable = Tabulation $ const $ fmap (empty,) emptyTable
114+tabulate :: (a -> k) -> a -> Tabulation k a
115+tabulate key a = fromQuery $ pure (key a, a)
248116
249117
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 (<>))
118+tabulateA :: (a -> Query k) -> a -> Tabulation k a
119+tabulateA key a = fromQuery $ (,a) <$> key a
255120
256121
257−instance (EqTable k, Table Expr a, Semigroup a) => Monoid (Tabulation k a)
258− where
259− mempty = emptyTable
122+fromQuery :: Query (k, a) -> Tabulation k a
123+fromQuery = Tabulation . const . fmap (first Just)
260124
261125
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,)
126+indexed :: Tabulation k a -> Tabulation k (k, a)
127+indexed (Tabulation query) = Tabulation $ \i ->
128+ (\(mk, a) -> (mk, (fromMaybe i mk, a))) <$> query i
306129
307130
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`
131+ifilter :: (k -> a -> Expr Bool) -> Tabulation k a -> Tabulation k a
132+ifilter f tabulation = snd <$> do
133+ filter (uncurry f) `postbind` indexed tabulation
320134
321135
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)
136+prebind :: (a -> Tabulation k b) -> Query a -> Tabulation k b
137+prebind f as = Tabulation $ \k -> do
138+ a <- as
139+ case f a of
140+ Tabulation query -> query k
141+infixr 1 `prebind`
330142
331143
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
144+postbind :: (a -> Query b) -> Tabulation k a -> Tabulation k b
145+postbind f (Tabulation as) = Tabulation $ \i -> do
146+ (k, a) <- as i
147+ case f a of
148+ bs -> do
149+ b <- bs
150+ pure (k, b)
151+infixr 1 `postbind`
345152
346153
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
154+lookup :: EqTable k => k -> Tabulation k a -> Query a
155+lookup key (Tabulation query) = do
156+ (mk, a) <- query key
157+ traverse_ (where_ . (key ==:)) mk
158+ pure a
354159
355160
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)
161+align :: (EqTable k, Table Expr a, Table Expr b)
162+ => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable a b)
501163align = alignWith id
502164
503165
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)
166+alignWith :: (EqTable k, Table Expr a, Table Expr b)
167+ => (TheseTable a b -> c)
509168 -> 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.
169+alignWith f kas kbs = do
170+ as <- toQuery kas
171+ bs <- toQuery kbs
172+ fromQuery $ do
173+ tkab <- alignBy (\(l, _) (m, _) -> l ==: m) as bs
174+ let
175+ k' = theseTable fst fst (const fst) tkab
176+ tab = bimap snd snd tkab
177+ pure (k', f tab)
178+
179+
535180leftAlign :: EqTable k
536− => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable Expr b)
181+ => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable b)
537182leftAlign = leftAlignWith (,)
538183
539184
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.
548185leftAlignWith :: EqTable k
549− => (a -> MaybeTable Expr b -> c)
186+ => (a -> MaybeTable b -> c)
550187 -> 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)
188+leftAlignWith f left right = liftA2 f left (optionalTabulation right)
579189
580190
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.
588191zip :: EqTable k
589192 => Tabulation k a -> Tabulation k b -> Tabulation k (a, b)
590193zip = zipWith (,)
591194
592195
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.
600196zipWith :: EqTable k
601197 => (a -> b -> c) -> Tabulation k a -> Tabulation k b -> Tabulation k c
602198zipWith = liftA2
603199
604200
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.
615201similarity :: 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.
202+similarity kas kbs = do
203+ as <- toQuery kas
204+ bs <- toQuery kbs
205+ fromQuery $ as >>= withBy (\(k, _) (l, _) -> k ==: l) bs
206+
207+
629208difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
630−difference a b = a <* absent b
209+difference kas kbs = do
210+ as <- toQuery kas
211+ bs <- toQuery kbs
212+ fromQuery $ as >>= withoutBy (\(k, _) (l, _) -> k ==: l) bs
213+
214+
215+aggregateTabulation :: EqTable k
216+ => Tabulation k (Aggregate a) -> Tabulation k a
217+aggregateTabulation kas = do
218+ as <- toQuery kas
219+ fromQuery $ aggregate $ bitraverse1 groupBy id <$> as
220+
221+
222+optionalTabulation :: EqTable k
223+ => Tabulation k a -> Tabulation k (MaybeTable a)
224+optionalTabulation as = Tabulation $ \k -> do
225+ ma <- optional $ lookup k as
226+ pure (Just k, ma)
631227
632228
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)
229+toQuery :: Tabulation k a -> Tabulation k (Query (k, a))
230+toQuery (Tabulation as) = Tabulation $ \k ->
231+ pure (Nothing, first (fromMaybe k) <$> as k)
src/Rel8/Type.hs+51−26
@@ -1,8 +1,6 @@
1−{-# language FlexibleContexts #-}
21{-# language FlexibleInstances #-}
3−{-# language MonoLocalBinds #-}
4−{-# language MultiWayIf #-}
52{-# language StandaloneKindSignatures #-}
3+{-# language TypeApplications #-}
64{-# language UndecidableInstances #-}
75
86module Rel8.Type
@@ -37,7 +35,8 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
3735import qualified Opaleye.Internal.HaskellDB.Sql.Default as Opaleye ( quote )
3836
3937-- rel8
40−import Rel8.Schema.Null ( NotNull, Sql, nullable )
38+import Rel8.Opaque ( Opaque )
39+import Rel8.Schema.Nullability ( Sql, nullabilization )
4140import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
4241import Rel8.Type.Information ( TypeInformation(..), mapTypeInformation )
4342
@@ -53,12 +52,8 @@ import qualified Data.Text.Lazy.Encoding as Lazy ( decodeUtf8 )
5352
5453-- time
5554import Data.Time.Calendar ( Day )
56−import Data.Time.Clock ( UTCTime )
57−import Data.Time.LocalTime
58− ( CalendarDiffTime( CalendarDiffTime )
59− , LocalTime
60− , TimeOfDay
61− )
55+import Data.Time.Clock ( DiffTime, NominalDiffTime, UTCTime )
56+import Data.Time.LocalTime ( LocalTime, TimeOfDay )
6257import Data.Time.Format ( formatTime, defaultTimeLocale )
6358
6459-- uuid
@@ -74,8 +69,20 @@ import qualified Data.UUID as UUID
7469-- should only need to derive instances of this class for custom database
7570-- types, such as types defined in PostgreSQL extensions, or custom domain
7671-- types.
72+--
73+-- [ Creating @DBType@s using @newtype@ ]
74+--
75+-- Generalized newtype deriving can be used when you want use a @newtype@
76+-- around a database type for clarity and accuracy in your Haskell code. A
77+-- common example is to @newtype@ row id types:
78+--
79+-- >>> newtype UserId = UserId { toInt32 :: Int32 } deriving newtype (DBType)
80+--
81+-- You can now write queries using @UserId@ instead of @Int32@, which may help
82+-- avoid making bad joins. However, when SQL is generated, it will be as if you
83+-- just used integers (the type distinction does not impact query generation).
7784type DBType :: Type -> Constraint
78−class NotNull a => DBType a where
85+class DBType a where
7986 typeInformation :: TypeInformation a
8087
8188
@@ -85,6 +92,7 @@ instance DBType Bool where
8592 { encode = Opaleye.ConstExpr . Opaleye.BoolLit
8693 , decode = Hasql.bool
8794 , typeName = "bool"
95+ , out = id
8896 }
8997
9098
@@ -94,6 +102,7 @@ instance DBType Char where
94102 { encode = Opaleye.ConstExpr . Opaleye.StringLit . pure
95103 , decode = Hasql.char
96104 , typeName = "char"
105+ , out = id
97106 }
98107
99108
@@ -103,6 +112,7 @@ instance DBType Int16 where
103112 { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger
104113 , decode = Hasql.int2
105114 , typeName = "int2"
115+ , out = id
106116 }
107117
108118
@@ -112,6 +122,7 @@ instance DBType Int32 where
112122 { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger
113123 , decode = Hasql.int4
114124 , typeName = "int4"
125+ , out = id
115126 }
116127
117128
@@ -121,32 +132,27 @@ instance DBType Int64 where
121132 { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger
122133 , decode = Hasql.int8
123134 , typeName = "int8"
135+ , out = id
124136 }
125137
126138
127139-- | Corresponds to @float4@
128140instance DBType Float where
129141 typeInformation = TypeInformation
130− { encode = \x -> Opaleye.ConstExpr
131− if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'"
132− | isNaN x -> Opaleye.OtherLit "'NaN'"
133− | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"
134− | otherwise -> Opaleye.NumericLit $ realToFrac x
142+ { encode = Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac
135143 , decode = Hasql.float4
136144 , typeName = "float4"
145+ , out = id
137146 }
138147
139148
140149-- | Corresponds to @float8@
141150instance DBType Double where
142151 typeInformation = TypeInformation
143− { encode = \x -> Opaleye.ConstExpr
144− if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'"
145− | isNaN x -> Opaleye.OtherLit "'NaN'"
146− | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"
147− | otherwise -> Opaleye.NumericLit $ realToFrac x
152+ { encode = Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac
148153 , decode = Hasql.float8
149154 , typeName = "float8"
155+ , out = id
150156 }
151157
152158
@@ -156,6 +162,7 @@ instance DBType Scientific where
156162 { encode = Opaleye.ConstExpr . Opaleye.NumericLit
157163 , decode = Hasql.numeric
158164 , typeName = "numeric"
165+ , out = id
159166 }
160167
161168
@@ -167,6 +174,7 @@ instance DBType UTCTime where
167174 formatTime defaultTimeLocale "'%FT%T%QZ'"
168175 , decode = Hasql.timestamptz
169176 , typeName = "timestamptz"
177+ , out = id
170178 }
171179
172180
@@ -178,6 +186,7 @@ instance DBType Day where
178186 formatTime defaultTimeLocale "'%F'"
179187 , decode = Hasql.date
180188 , typeName = "date"
189+ , out = id
181190 }
182191
183192
@@ -189,6 +198,7 @@ instance DBType LocalTime where
189198 formatTime defaultTimeLocale "'%FT%T%Q'"
190199 , decode = Hasql.timestamp
191200 , typeName = "timestamp"
201+ , out = id
192202 }
193203
194204
@@ -200,26 +210,34 @@ instance DBType TimeOfDay where
200210 formatTime defaultTimeLocale "'%T%Q'"
201211 , decode = Hasql.time
202212 , typeName = "time"
213+ , out = id
203214 }
204215
205216
206217-- | Corresponds to @interval@
207−instance DBType CalendarDiffTime where
218+instance DBType DiffTime where
208219 typeInformation = TypeInformation
209220 { encode =
210221 Opaleye.ConstExpr . Opaleye.OtherLit .
211− formatTime defaultTimeLocale "'%bmon %0Es'"
212− , decode = CalendarDiffTime 0 . realToFrac <$> Hasql.interval
222+ formatTime defaultTimeLocale "'%-6Es'"
223+ , decode = Hasql.interval
213224 , typeName = "interval"
225+ , out = id
214226 }
215227
216228
229+instance DBType NominalDiffTime where
230+ typeInformation =
231+ mapTypeInformation @DiffTime realToFrac realToFrac typeInformation
232+
233+
217234-- | Corresponds to @text@
218235instance DBType Text where
219236 typeInformation = TypeInformation
220237 { encode = Opaleye.ConstExpr . Opaleye.StringLit . Text.unpack
221238 , decode = Hasql.text
222239 , typeName = "text"
240+ , out = id
223241 }
224242
225243
@@ -249,6 +267,7 @@ instance DBType ByteString where
249267 { encode = Opaleye.ConstExpr . Opaleye.ByteStringLit
250268 , decode = Hasql.bytea
251269 , typeName = "bytea"
270+ , out = id
252271 }
253272
254273
@@ -265,6 +284,7 @@ instance DBType UUID where
265284 { encode = Opaleye.ConstExpr . Opaleye.StringLit . UUID.toString
266285 , decode = Hasql.uuid
267286 , typeName = "uuid"
287+ , out = id
268288 }
269289
270290
@@ -277,12 +297,17 @@ instance DBType Value where
277297 Lazy.unpack . Lazy.decodeUtf8 . Aeson.encode
278298 , decode = Hasql.jsonb
279299 , typeName = "jsonb"
300+ , out = id
280301 }
281302
282303
283304instance Sql DBType a => DBType [a] where
284− typeInformation = listTypeInformation nullable typeInformation
305+ typeInformation = listTypeInformation nullabilization typeInformation
285306
286307
287308instance Sql DBType a => DBType (NonEmpty a) where
288− typeInformation = nonEmptyTypeInformation nullable typeInformation
309+ typeInformation = nonEmptyTypeInformation nullabilization typeInformation
310+
311+
312+instance {-# OVERLAPPING #-} DBType Opaque where
313+ typeInformation = error "opaque"
src/Rel8/Type/Array.hs+36−56

This diff is too big to show here.

src/Rel8/Type/Array1D.hsnew file+136

This diff is too big to show here.

src/Rel8/Type/Composite.hsdeleted−135

This diff is too big to show here.

src/Rel8/Type/Enum.hsdeleted−139

This diff is too big to show here.

src/Rel8/Type/Eq.hs+37−6

This diff is too big to show here.

src/Rel8/Type/Information.hs+34−11

This diff is too big to show here.

src/Rel8/Type/JSONBEncoded.hs+2−5

This diff is too big to show here.

src/Rel8/Type/JSONEncoded.hs+13−4

This diff is too big to show here.

src/Rel8/Type/Monoid.hs+11−8

This diff is too big to show here.

src/Rel8/Type/Num.hs+2−18

This diff is too big to show here.

src/Rel8/Type/Ord.hs+13−8

This diff is too big to show here.

src/Rel8/Type/ReadShow.hs+14−14

This diff is too big to show here.

src/Rel8/Type/Semigroup.hs+13−10

This diff is too big to show here.

src/Rel8/Type/String.hs−3

This diff is too big to show here.

src/Rel8/Type/Sum.hs+3−6

This diff is too big to show here.

src/Rel8/Type/Tag.hs+1−14

This diff is too big to show here.

src/Rel8/Window.hsdeleted−97

This diff is too big to show here.

tests/Main.hs+193−341

This diff is too big to show here.

tests/Rel8/Generic/Rel8able/Test.hsdeleted−188

This diff is too big to show here.