git.iko.soy/rel8
on 8a441e6 help sign in
6c038ec
swap
0 ahead, 403 behind
.github/workflows/build.yamldeleted−26
since splitsnapshots
unifiedsplit
@@ -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+33
@@ -0,0 +1,33 @@
1+{-# language BlockArguments #-}
2+{-# language OverloadedStrings #-}
3+
4+module Main where
5+
6+import Build_doctests ( flags, pkgs, module_sources )
7+import Control.Exception ( bracket, throwIO )
8+import Data.ByteString.Char8 ( unpack )
9+import Data.Foldable ( traverse_ )
10+import Database.PostgreSQL.Simple ( connectPostgreSQL, close, execute_ )
11+import Database.Postgres.Temp ( toConnectionString, with, withConfig, verboseConfig )
12+import System.Environment ( setEnv )
13+import System.Environment.Compat ( unsetEnv )
14+import Test.DocTest ( doctest )
15+
16+main :: IO ()
17+main = do
18+ unsetEnv "GHC_ENVIRONMENT" -- see 'Notes'; you may not need this
19+ either throwIO return =<< with \db -> do
20+ setEnv "TEST_DATABASE_URL" (unpack (toConnectionString db))
21+ bracket (connectPostgreSQL (toConnectionString db)) close \conn -> do
22+ execute_ conn "create table author ( author_id serial primary key, name text not null, url text )"
23+ execute_ conn "create table project ( author_id int not null references author (author_id), name text not null )"
24+
25+ execute_ conn "insert into author ( name, url ) values ( 'Ollie', 'https://ocharles.org.uk' )"
26+ execute_ conn "insert into author ( name, url ) values ( 'Bryan O''Sullivan', null )"
27+ execute_ conn "insert into project ( author_id, name ) values ( 1, 'rel8' )"
28+ execute_ conn "insert into project ( author_id, name ) values ( 2, 'aeson' )"
29+
30+ doctest args
31+
32+ where
33+ args = flags ++ pkgs ++ module_sources
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright 2021 Oliver Charles
1+Copyright 2020 Oliver Charles
2
2
3All rights reserved.
3All rights reserved.
4
4
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
2 haskellNix = import (import ./nix/sources.nix)."haskell.nix" {};
2 haskellNix = import (import ./nix/sources.nix)."haskell.nix" {};
3
3
4− nixpkgsSrc = haskellNix.sources.nixpkgs-unstable;
4+ nixpkgsSrc = haskellNix.sources.nixpkgs-2009;
5
5
6 nixpkgsArgs = haskellNix.nixpkgsArgs;
6 nixpkgsArgs = haskellNix.nixpkgsArgs;
7
7
8− compiler-nix-name = "ghc924";
8+ compiler-nix-name = "ghc8103";
9
9
10 pkgs = import nixpkgsSrc nixpkgsArgs;
10 pkgs = import nixpkgsSrc nixpkgsArgs;
11
11
12−in
12+in
13pkgs.haskell-nix.project {
13pkgs.haskell-nix.project {
14 inherit compiler-nix-name;
14 inherit compiler-nix-name;
15
15
16− cabalProjectLocal = builtins.readFile ./cabal.project.haskell-nix;
17−
18 src = pkgs.haskell-nix.haskellLib.cleanGit {
16 src = pkgs.haskell-nix.haskellLib.cleanGit {
19 name = "rel8";
17 name = "rel8";
20 src = ./.;
18 src = ./.;
21 };
19 };
22
20
23− modules = [
21+ modules = [
24 { packages.rel8 = {
22 { packages.rel8 = {
25 preCheck = ''
23 preCheck = ''
26 export PATH="${pkgs.postgresql}/bin:${"$PATH"}"
24 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 @@
1{
1{
2− "haskell.nix": {
2+ "haskell.nix": {
3− "branch": "master",
3+ "branch": "circuithub",
4− "description": "Alternative Haskell Infrastructure for Nixpkgs",
4+ "description": "Alternative Haskell Infrastructure for Nixpkgs",
5− "homepage": "https://input-output-hk.github.io/haskell.nix",
5+ "homepage": "https://input-output-hk.github.io/haskell.nix",
6− "owner": "input-output-hk",
6+ "owner": "circuithub",
7− "repo": "haskell.nix",
7+ "repo": "haskell.nix",
8− "rev": "0837156c56cb5350dd9bd84eb424187e00aa1e8a",
8+ "rev": "2902f9b49484a87afb0e1a33b1d88a2c7b8ca0a0",
9− "sha256": "1djmv5a0vfj78csw2cad6nicrs8iqrp928b9b3v4h7lwwhhzliwl",
9+ "sha256": "0a01g5b46z5yaf2mnl415hc4lciwiyqhj22qhgwgwd261w4068iy",
10− "type": "tarball",
10+ "type": "tarball",
11− "url": "https://github.com/input-output-hk/haskell.nix/archive/0837156c56cb5350dd9bd84eb424187e00aa1e8a.tar.gz",
11+ "url": "https://github.com/circuithub/haskell.nix/archive/2902f9b49484a87afb0e1a33b1d88a2c7b8ca0a0.tar.gz",
12− "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
12+ "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
13− },
13+ },
14− "niv": {
14+ "niv": {
15− "branch": "master",
15+ "branch": "master",
16− "description": "Easy dependency management for Nix projects",
16+ "description": "Easy dependency management for Nix projects",
17− "homepage": "https://github.com/nmattia/niv",
17+ "homepage": "https://github.com/nmattia/niv",
18− "owner": "nmattia",
18+ "owner": "nmattia",
19− "repo": "niv",
19+ "repo": "niv",
20− "rev": "acdb1726783637852c01e0ad639ac9cbec28d8c8",
20+ "rev": "ba57d5a29b4e0f2085917010380ef3ddc3cf380f",
21− "sha256": "1wszl8q70z6wfgkh2dvgmhhry6qp9nar421qq2ifd17hq2jj9ck3",
21+ "sha256": "1kpsvc53x821cmjg1khvp1nz7906gczq8mp83664cr15h94sh8i4",
22− "type": "tarball",
22+ "type": "tarball",
23− "url": "https://github.com/nmattia/niv/archive/acdb1726783637852c01e0ad639ac9cbec28d8c8.tar.gz",
23+ "url": "https://github.com/nmattia/niv/archive/ba57d5a29b4e0f2085917010380ef3ddc3cf380f.tar.gz",
24− "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
24+ "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
25− },
25+ },
26− "nixpkgs": {
26+ "nixpkgs": {
27− "branch": "nixos-20.09",
27+ "branch": "nixos-20.09",
28− "description": "Nix Packages collection",
28+ "description": "Nix Packages collection",
29− "homepage": null,
29+ "homepage": null,
30− "owner": "nixos",
30+ "owner": "nixos",
31− "repo": "nixpkgs",
31+ "repo": "nixpkgs",
32− "rev": "1c1f5649bb9c1b0d98637c8c365228f57126f361",
32+ "rev": "6e7f25001fe6874f7ae271891f709bbf50a22c45",
33− "sha256": "0f2nvdijyxfgl5kwyb4465pppd5vkhqxddx6v40k2s0z9jfhj0xl",
33+ "sha256": "1x04j4351pqiqbpkq6g308mxcvb5aqnwv8l2vmlxkgvq5phzky7z",
34− "type": "tarball",
34+ "type": "tarball",
35− "url": "https://github.com/nixos/nixpkgs/archive/1c1f5649bb9c1b0d98637c8c365228f57126f361.tar.gz",
35+ "url": "https://github.com/nixos/nixpkgs/archive/6e7f25001fe6874f7ae271891f709bbf50a22c45.tar.gz",
36− "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
36+ "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
37− }
37+ }
38}
38}
nix/sources.nix+20−66
@@ -6,53 +6,25 @@ let
6 # The fetchers. fetch_<type> fetches specs of type <type>.
6 # The fetchers. fetch_<type> fetches specs of type <type>.
7 #
7 #
8
8
9− fetch_file = pkgs: name: spec:
9+ fetch_file = pkgs: spec:
10− let
11− name' = sanitizeName name + "-src";
12− in
13− if spec.builtin or true then
10+ if spec.builtin or true then
14− builtins_fetchurl { inherit (spec) url sha256; name = name'; }
11+ builtins_fetchurl { inherit (spec) url sha256; }
15− else
12+ else
16− pkgs.fetchurl { inherit (spec) url sha256; name = name'; };
13+ pkgs.fetchurl { inherit (spec) url sha256; };
17
14
18 fetch_tarball = pkgs: name: spec:
15 fetch_tarball = pkgs: name: spec:
19 let
16 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";
21 in
20 in
22 if spec.builtin or true then
21 if spec.builtin or true then
23 builtins_fetchTarball { name = name'; inherit (spec) url sha256; }
22 builtins_fetchTarball { name = name'; inherit (spec) url sha256; }
24 else
23 else
25 pkgs.fetchzip { name = name'; inherit (spec) url sha256; };
24 pkgs.fetchzip { name = name'; inherit (spec) url sha256; };
26
25
27− fetch_git = name: spec:
26+ fetch_git = 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);
27+ builtins.fetchGit { url = spec.repo; inherit (spec) rev ref; };
56
28
57 fetch_local = spec: spec.path;
29 fetch_local = spec: spec.path;
58
30
@@ -68,21 +40,11 @@ let
68 # Various helpers
40 # Various helpers
69 #
41 #
70
42
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−
81 # The set of packages used when specs are fetched using non-builtins.
43 # The set of packages used when specs are fetched using non-builtins.
82− mkPkgs = sources: system:
44+ mkPkgs = sources:
83 let
45 let
84 sourcesNixpkgs =
46 sourcesNixpkgs =
85− import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; };
47+ import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) {};
86 hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath;
48 hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath;
87 hasThisAsNixpkgsPath = <nixpkgs> == ./.;
49 hasThisAsNixpkgsPath = <nixpkgs> == ./.;
88 in
50 in
@@ -102,9 +64,9 @@ let
102
64
103 if ! builtins.hasAttr "type" spec then
65 if ! builtins.hasAttr "type" spec then
104 abort "ERROR: niv spec ${name} does not have a 'type' attribute"
66 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
106 else if spec.type == "tarball" then fetch_tarball pkgs name spec
68 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
108 else if spec.type == "local" then fetch_local spec
70 else if spec.type == "local" then fetch_local spec
109 else if spec.type == "builtin-tarball" then fetch_builtin-tarball name
71 else if spec.type == "builtin-tarball" then fetch_builtin-tarball name
110 else if spec.type == "builtin-url" then fetch_builtin-url name
72 else if spec.type == "builtin-url" then fetch_builtin-url name
@@ -118,10 +80,7 @@ let
118 saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name;
80 saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name;
119 ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}";
81 ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}";
120 in
82 in
121− if ersatz == "" then drv else
83+ if ersatz == "" then drv else ersatz;
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}";
125
84
126 # Ports of functions for older nix versions
85 # Ports of functions for older nix versions
127
86
@@ -139,29 +98,25 @@ let
139
98
140 # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269
99 # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269
141 stringAsChars = f: s: concatStrings (map f (stringToCharacters s));
100 stringAsChars = f: s: concatStrings (map f (stringToCharacters s));
142− concatMapStrings = f: list: concatStrings (map f list);
143 concatStrings = builtins.concatStringsSep "";
101 concatStrings = builtins.concatStringsSep "";
144
102
145− # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331
146− optionalAttrs = cond: as: if cond then as else {};
147−
148 # fetchTarball version that is compatible between all the versions of Nix
103 # 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:
150 let
105 let
151 inherit (builtins) lessThan nixVersion fetchTarball;
106 inherit (builtins) lessThan nixVersion fetchTarball;
152 in
107 in
153 if lessThan nixVersion "1.12" then
108 if lessThan nixVersion "1.12" then
154− fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; }))
109+ fetchTarball { inherit name url; }
155 else
110 else
156 fetchTarball attrs;
111 fetchTarball attrs;
157
112
158 # fetchurl version that is compatible between all the versions of Nix
113 # 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:
160 let
115 let
161 inherit (builtins) lessThan nixVersion fetchurl;
116 inherit (builtins) lessThan nixVersion fetchurl;
162 in
117 in
163 if lessThan nixVersion "1.12" then
118 if lessThan nixVersion "1.12" then
164− fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; }))
119+ fetchurl { inherit url; }
165 else
120 else
166 fetchurl attrs;
121 fetchurl attrs;
167
122
@@ -180,8 +135,7 @@ let
180 mkConfig =
135 mkConfig =
181 { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null
136 { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null
182 , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile)
137 , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile)
183− , system ? builtins.currentSystem
184− , pkgs ? mkPkgs sources system
138+ , pkgs ? mkPkgs sources
185 }: rec {
139 }: rec {
186 # The sources, i.e. the attribute set of spec name to spec
140 # The sources, i.e. the attribute set of spec name to spec
187 inherit sources;
141 inherit sources;
rel8.cabal+58−87
@@ -1,36 +1,30 @@
1cabal-version: 2.0
1cabal-version: 2.0
2name: rel8
2name: rel8
3−version: 1.4.0.0
3+version: 0.1.0.0
4synopsis: Hey! Hey! Can u rel8?
4synopsis: Hey! Hey! Can u rel8?
5license: BSD3
5license: BSD3
6license-file: LICENSE
6license-file: LICENSE
7author: Oliver Charles
7author: Oliver Charles
8maintainer: ollie@ocharles.org.uk
8maintainer: ollie@ocharles.org.uk
9−homepage: https://github.com/circuithub/rel8
10−bug-reports: https://github.com/circuithub/rel8/issues
11−build-type: Simple
9+build-type: Custom
12−extra-doc-files:
13− README.md
14− Changelog.md
15
10
16−source-repository head
11+custom-setup
17− type: git
12+ setup-depends:
18− location: https://github.com/circuithub/rel8
13+ base >= 4 && <5,
14+ Cabal,
15+ cabal-doctest >= 1 && <1.1
19
16
20library
17library
21 build-depends:
18 build-depends:
22 aeson
19 aeson
23− , base ^>= 4.14 || ^>=4.15 || ^>=4.16
20+ , base ^>=4.12 || ^>= 4.13 || ^>= 4.14
24− , bifunctors
25 , bytestring
21 , bytestring
26 , case-insensitive
22 , case-insensitive
27− , comonad
23+ , casing
28 , contravariant
24 , contravariant
29− , hasql ^>= 1.4.5.1 || ^>= 1.5.0.0 || ^>= 1.6.0.0
25+ , hasql
30− , opaleye ^>= 0.9.6.1
26+ , opaleye ^>= 0.7.1.0
31− , pretty
32 , profunctors
27 , profunctors
33− , product-profunctors
34 , scientific
28 , scientific
35 , semialign
29 , semialign
36 , semigroupoids
30 , semigroupoids
@@ -41,63 +35,35 @@ library
41 default-language:
35 default-language:
42 Haskell2010
36 Haskell2010
43 ghc-options:
37 ghc-options:
44− -Werror=missing-methods -Werror=incomplete-patterns -Werror=missing-fields
45 -Weverything -Wno-unsafe -Wno-safe -Wno-missing-safe-haskell-mode
38 -Weverything -Wno-unsafe -Wno-safe -Wno-missing-safe-haskell-mode
46 -Wno-missing-import-lists -Wno-prepositive-qualified-module
39 -Wno-missing-import-lists -Wno-prepositive-qualified-module
47 -Wno-monomorphism-restriction
40 -Wno-monomorphism-restriction
48− -Wno-missing-local-signatures
41+ -Wno-missing-local-signatures
49− -Wno-missing-kind-signatures
50 hs-source-dirs:
42 hs-source-dirs:
51 src
43 src
52 exposed-modules:
44 exposed-modules:
53 Rel8
45 Rel8
54− Rel8.Expr.Num
55− Rel8.Expr.Text
56− Rel8.Expr.Time
57− Rel8.Tabulate
58
46
59 other-modules:
47 other-modules:
60 Rel8.Aggregate
48 Rel8.Aggregate
61
49
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−
72 Rel8.Expr
50 Rel8.Expr
73 Rel8.Expr.Aggregate
51 Rel8.Expr.Aggregate
74 Rel8.Expr.Array
52 Rel8.Expr.Array
75 Rel8.Expr.Bool
53 Rel8.Expr.Bool
76− Rel8.Expr.Default
77 Rel8.Expr.Eq
54 Rel8.Expr.Eq
78 Rel8.Expr.Function
55 Rel8.Expr.Function
79 Rel8.Expr.Null
56 Rel8.Expr.Null
57+ Rel8.Expr.Num
80 Rel8.Expr.Opaleye
58 Rel8.Expr.Opaleye
81 Rel8.Expr.Ord
59 Rel8.Expr.Ord
82 Rel8.Expr.Order
60 Rel8.Expr.Order
83− Rel8.Expr.Sequence
84 Rel8.Expr.Serialize
61 Rel8.Expr.Serialize
85− Rel8.Expr.Window
62+ Rel8.Expr.Text
86−
87− Rel8.FCF
63+ Rel8.Expr.Time
88−
89− Rel8.Kind.Algebra
90− Rel8.Kind.Context
91
64
92− Rel8.Generic.Construction
65+ Rel8.Kind.Labels
93− Rel8.Generic.Construction.ADT
66+ Rel8.Kind.Necessity
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
101
67
102 Rel8.Order
68 Rel8.Order
103
69
@@ -106,88 +72,84 @@ library
106 Rel8.Query.Distinct
72 Rel8.Query.Distinct
107 Rel8.Query.Each
73 Rel8.Query.Each
108 Rel8.Query.Either
74 Rel8.Query.Either
109− Rel8.Query.Evaluate
110 Rel8.Query.Exists
75 Rel8.Query.Exists
111 Rel8.Query.Filter
76 Rel8.Query.Filter
112− Rel8.Query.Indexed
113 Rel8.Query.Limit
77 Rel8.Query.Limit
114 Rel8.Query.List
78 Rel8.Query.List
115 Rel8.Query.Maybe
79 Rel8.Query.Maybe
116 Rel8.Query.Null
80 Rel8.Query.Null
117 Rel8.Query.Opaleye
81 Rel8.Query.Opaleye
82+ Rel8.Query.Optimize
118 Rel8.Query.Order
83 Rel8.Query.Order
119− Rel8.Query.Rebind
120 Rel8.Query.Set
84 Rel8.Query.Set
121 Rel8.Query.SQL
85 Rel8.Query.SQL
122 Rel8.Query.These
86 Rel8.Query.These
123 Rel8.Query.Values
87 Rel8.Query.Values
124− Rel8.Query.Window
125
88
89+ Rel8.Schema.Column
90+ Rel8.Schema.Context
91+ Rel8.Schema.Context.Label
126 Rel8.Schema.Context.Nullify
92 Rel8.Schema.Context.Nullify
93+ Rel8.Schema.Context.Result
127 Rel8.Schema.Dict
94 Rel8.Schema.Dict
128 Rel8.Schema.Field
95 Rel8.Schema.Field
96+ Rel8.Schema.Generic
97+ Rel8.Schema.Generic.Test
129 Rel8.Schema.HTable
98 Rel8.Schema.HTable
99+ Rel8.Schema.HTable.Context
130 Rel8.Schema.HTable.Either
100 Rel8.Schema.HTable.Either
131 Rel8.Schema.HTable.Identity
101 Rel8.Schema.HTable.Identity
132 Rel8.Schema.HTable.Label
102 Rel8.Schema.HTable.Label
133 Rel8.Schema.HTable.List
103 Rel8.Schema.HTable.List
134− Rel8.Schema.HTable.MapTable
135 Rel8.Schema.HTable.Maybe
104 Rel8.Schema.HTable.Maybe
136 Rel8.Schema.HTable.NonEmpty
105 Rel8.Schema.HTable.NonEmpty
137 Rel8.Schema.HTable.Nullify
106 Rel8.Schema.HTable.Nullify
138− Rel8.Schema.HTable.Product
107+ Rel8.Schema.HTable.Pair
108+ Rel8.Schema.HTable.Quartet
109+ Rel8.Schema.HTable.Quintet
139 Rel8.Schema.HTable.These
110 Rel8.Schema.HTable.These
111+ Rel8.Schema.HTable.Trio
112+ Rel8.Schema.HTable.Type
140 Rel8.Schema.HTable.Vectorize
113 Rel8.Schema.HTable.Vectorize
141− Rel8.Schema.Kind
114+ Rel8.Schema.Nullability
142− Rel8.Schema.Name
143− Rel8.Schema.Null
144− Rel8.Schema.Result
145 Rel8.Schema.Spec
115 Rel8.Schema.Spec
116+ Rel8.Schema.Spec.ConstrainContext
117+ Rel8.Schema.Spec.ConstrainDBType
118+ Rel8.Schema.Spec.ConstrainType
146 Rel8.Schema.Table
119 Rel8.Schema.Table
147
120
148 Rel8.Statement.Delete
121 Rel8.Statement.Delete
149 Rel8.Statement.Insert
122 Rel8.Statement.Insert
150− Rel8.Statement.OnConflict
151 Rel8.Statement.Returning
123 Rel8.Statement.Returning
152 Rel8.Statement.Select
124 Rel8.Statement.Select
153− Rel8.Statement.Set
154− Rel8.Statement.SQL
155 Rel8.Statement.Update
125 Rel8.Statement.Update
156− Rel8.Statement.Using
157 Rel8.Statement.View
126 Rel8.Statement.View
158− Rel8.Statement.Where
159
127
160 Rel8.Table
128 Rel8.Table
161− Rel8.Table.ADT
162 Rel8.Table.Aggregate
129 Rel8.Table.Aggregate
163 Rel8.Table.Alternative
130 Rel8.Table.Alternative
164 Rel8.Table.Bool
131 Rel8.Table.Bool
165− Rel8.Table.Cols
166 Rel8.Table.Either
132 Rel8.Table.Either
167 Rel8.Table.Eq
133 Rel8.Table.Eq
168− Rel8.Table.HKD
134+ Rel8.Table.Insert
135+ Rel8.Table.Lifted
169 Rel8.Table.List
136 Rel8.Table.List
170 Rel8.Table.Maybe
137 Rel8.Table.Maybe
171 Rel8.Table.Name
138 Rel8.Table.Name
172 Rel8.Table.NonEmpty
139 Rel8.Table.NonEmpty
173− Rel8.Table.Null
174− Rel8.Table.Nullify
175 Rel8.Table.Opaleye
140 Rel8.Table.Opaleye
176 Rel8.Table.Ord
141 Rel8.Table.Ord
177 Rel8.Table.Order
142 Rel8.Table.Order
178− Rel8.Table.Projection
143+ Rel8.Table.Recontextualize
179− Rel8.Table.Rel8able
180 Rel8.Table.Serialize
144 Rel8.Table.Serialize
181 Rel8.Table.These
145 Rel8.Table.These
182− Rel8.Table.Transpose
183 Rel8.Table.Undefined
146 Rel8.Table.Undefined
184− Rel8.Table.Window
147+
148+ Rel8.Tabulate
185
149
186 Rel8.Type
150 Rel8.Type
187− Rel8.Type.Array
151+ Rel8.Type.Array1D
188− Rel8.Type.Composite
189 Rel8.Type.Eq
152 Rel8.Type.Eq
190− Rel8.Type.Enum
191 Rel8.Type.Information
153 Rel8.Type.Information
192 Rel8.Type.JSONEncoded
154 Rel8.Type.JSONEncoded
193 Rel8.Type.JSONBEncoded
155 Rel8.Type.JSONBEncoded
@@ -200,8 +162,8 @@ library
200 Rel8.Type.Sum
162 Rel8.Type.Sum
201 Rel8.Type.Tag
163 Rel8.Type.Tag
202
164
203− Rel8.Window
165+ Rel8.Opaque
204−
166+ Rel8.Schema.Structure
205
167
206test-suite tests
168test-suite tests
207 type: exitcode-stdio-1.0
169 type: exitcode-stdio-1.0
@@ -211,9 +173,9 @@ test-suite tests
211 , case-insensitive
173 , case-insensitive
212 , containers
174 , containers
213 , hasql
175 , hasql
214− , hasql-transaction
215− , hedgehog ^>= 1.0 || ^>= 1.1
176+ , hedgehog ^>=1.0.2
216− , mmorph
177+ , lifted-base ^>=0.2.3.12
178+ , monad-control ^>=1.0.2.3
217 , rel8
179 , rel8
218 , scientific
180 , scientific
219 , tasty
181 , tasty
@@ -221,12 +183,8 @@ test-suite tests
221 , text
183 , text
222 , time
184 , time
223 , tmp-postgres ^>=1.34.1.0
185 , tmp-postgres ^>=1.34.1.0
224− , transformers
225 , uuid
186 , uuid
226
187
227− other-modules:
228− Rel8.Generic.Rel8able.Test
229−
230 main-is: Main.hs
188 main-is: Main.hs
231 hs-source-dirs: tests
189 hs-source-dirs: tests
232 default-language: Haskell2010
190 default-language: Haskell2010
@@ -235,3 +193,16 @@ test-suite tests
235 -Wno-missing-import-lists -Wno-prepositive-qualified-module
193 -Wno-missing-import-lists -Wno-prepositive-qualified-module
236 -Wno-deprecations -Wno-monomorphism-restriction
194 -Wno-deprecations -Wno-monomorphism-restriction
237 -Wno-missing-local-signatures -Wno-implicit-prelude
195 -Wno-missing-local-signatures -Wno-implicit-prelude
196+
197+test-suite doctests
198+ type: exitcode-stdio-1.0
199+ build-depends:
200+ base
201+ , base-compat
202+ , bytestring
203+ , doctest
204+ , hasql
205+ , tmp-postgres
206+
207+ main-is: Doctest.hs
208+ default-language: Haskell2010
shell.nix+4−4
@@ -1,11 +1,11 @@
1let
1let
2 sources = import ./nix/sources.nix;
2 sources = import ./nix/sources.nix;
3− pkgs = import sources.nixpkgs {overlays = [];};
3+ pkgs = import sources.nixpkgs {};
4 hsPkgs = import ./default.nix;
4 hsPkgs = import ./default.nix;
5in
5in
6 hsPkgs.shellFor {
6 hsPkgs.shellFor {
7− withHoogle = false;
7+ withHoogle = true;
8− tools = { cabal = "latest"; };
8+ tools = { cabal = "3.2.0.0"; haskell-language-server = "latest"; };
9 exactDeps = false;
9 exactDeps = false;
10− buildInputs = [ pkgs.postgresql pkgs.pythonPackages.sphinx ];
10+ buildInputs = [ pkgs.postgresql ];
11 }
11 }
src/Rel8.hs+429−438
@@ -1,7 +1,19 @@
1{-# language DuplicateRecordFields #-}
1{-# language DuplicateRecordFields #-}
2
2
3module Rel8
3module Rel8
4+ ( -- * Getting Started
5+ -- $setup
6+
7+ -- ** Writing Queries
8+ -- $guideQueries
9+
10+ -- ** Joins
11+ -- $guideJoins
12+
13+ -- ** Aggregation
14+ -- $guideAggregation
15+
4− ( -- * Database types
16+ -- * Database types
5 -- ** @DBType@
17 -- ** @DBType@
6 DBType(..)
18 DBType(..)
7
19
@@ -13,10 +25,6 @@ module Rel8
13 -- **** @ReadShow@
25 -- **** @ReadShow@
14 , ReadShow(..)
26 , ReadShow(..)
15
27
16− -- **** Generic
17− , Composite(..), DBComposite(..), compose, decompose
18− , Enum(..), DBEnum(..), Enumable
19−
20 -- *** @TypeInformation@
28 -- *** @TypeInformation@
21 , TypeInformation(..)
29 , TypeInformation(..)
22 , mapTypeInformation
30 , mapTypeInformation
@@ -26,44 +34,25 @@ module Rel8
26 , DBSemigroup(..)
34 , DBSemigroup(..)
27 , DBMonoid(..)
35 , DBMonoid(..)
28 , DBNum
36 , DBNum
29− , DBIntegral
30 , DBFractional
37 , DBFractional
31− , DBFloating
32
38
33 -- * Tables and higher-kinded tables
39 -- * Tables and higher-kinded tables
34− , Rel8able, KRel8able
35− , Column
36− , HADT
37− , HEither
38− , HMaybe
39− , HList
40− , HNonEmpty
41− , HNull
42− , HThese
43− , Lift
44−
45− , Table(..)
40+ , Table
46− , HTable
47− , Transposes
48 , AltTable((<|>:))
41 , AltTable((<|>:))
49− , AlternativeTable( emptyTable )
50− , EqTable(..), (==:), (/=:)
42+ , EqTable, (==:), (/=:)
51− , OrdTable(..), (<:), (<=:), (>:), (>=:), ascTable, descTable, greatest, least
43+ , OrdTable, ascTable, descTable
52 , lit
44 , lit
53 , bool
45 , bool
54 , case_
46 , case_
55− , castTable
56
47
57 -- ** @MaybeTable@
48 -- ** @MaybeTable@
58− , MaybeTable
49+ , MaybeTable(..)
59− , maybeTable, ($?), nothingTable, justTable
50+ , maybeTable, nothingTable, justTable
60 , isNothingTable, isJustTable
51 , isNothingTable, isJustTable
61− , fromMaybeTable
62 , optional
52 , optional
63 , catMaybeTable
53 , catMaybeTable
54+ , bindMaybeTable
64 , traverseMaybeTable
55 , traverseMaybeTable
65− , aggregateMaybeTable
66− , nameMaybeTable
67
56
68 -- ** @EitherTable@
57 -- ** @EitherTable@
69 , EitherTable
58 , EitherTable
@@ -71,9 +60,8 @@ module Rel8
71 , isLeftTable, isRightTable
60 , isLeftTable, isRightTable
72 , keepLeftTable
61 , keepLeftTable
73 , keepRightTable
62 , keepRightTable
63+ , bindEitherTable
74 , bitraverseEitherTable
64 , bitraverseEitherTable
75− , aggregateEitherTable
76− , nameEitherTable
77
65
78 -- ** @TheseTable@
66 -- ** @TheseTable@
79 , TheseTable
67 , TheseTable
@@ -81,110 +69,45 @@ module Rel8
81 , isThisTable, isThatTable, isThoseTable
69 , isThisTable, isThatTable, isThoseTable
82 , hasHereTable, hasThereTable
70 , hasHereTable, hasThereTable
83 , justHereTable, justThereTable
71 , justHereTable, justThereTable
84− , alignMaybeTable
85 , alignBy
72 , alignBy
86 , keepHereTable, loseHereTable
73 , keepHereTable, loseHereTable
87 , keepThereTable, loseThereTable
74 , keepThereTable, loseThereTable
88 , keepThisTable, loseThisTable
75 , keepThisTable, loseThisTable
89 , keepThatTable, loseThatTable
76 , keepThatTable, loseThatTable
90 , keepThoseTable, loseThoseTable
77 , keepThoseTable, loseThoseTable
78+ , bindTheseTable
91 , bitraverseTheseTable
79 , bitraverseTheseTable
92− , aggregateTheseTable
93− , nameTheseTable
94
80
95 -- ** @ListTable@
81 -- ** @ListTable@
96 , ListTable
82 , ListTable
97− , listTable, ($*)
98− , nameListTable
99 , many
83 , many
100− , manyExpr
101− , catListTable
102− , catList
103
84
104 -- ** @NonEmptyTable@
85 -- ** @NonEmptyTable@
105 , NonEmptyTable
86 , NonEmptyTable
106− , nonEmptyTable, ($+)
107− , nameNonEmptyTable
108 , some
87 , 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
151
88
152 -- ** Table schemas
89 -- ** Table schemas
153 , TableSchema(..)
90 , TableSchema(..)
154− , Name
155− , namesFromLabels
156− , namesFromLabelsWith
157
91
158 -- * Expressions
92 -- * Expressions
159 , Expr
93 , Expr
160− , Sql
161 , litExpr
94 , litExpr
162− , unsafeCastExpr
163− , unsafeLiteral
164
95
165 -- ** @null@
96 -- ** @null@
166− , NotNull
167− , Nullable
168− , Homonullable
169− , null
170 , nullify
97 , nullify
171 , nullable
98 , nullable
172 , isNull
99 , isNull
173 , isNonNull
100 , isNonNull
174− , mapNull
101+ , mapNullable
175− , liftOpNull
102+ , catNullable
176− , catNull
177− , coalesce
178
103
179 -- ** Boolean operations
104 -- ** Boolean operations
180− , DBEq
181 , true, false, not_
105 , true, false, not_
182 , (&&.), and_
106 , (&&.), and_
183 , (||.), or_
107 , (||.), or_
184 , (==.), (/=.), (==?), (/=?)
108 , (==.), (/=.), (==?), (/=?)
185 , in_
109 , in_
186 , boolExpr, caseExpr
110 , boolExpr, caseExpr
187− , like, ilike
188
111
189 -- ** Ordering
112 -- ** Ordering
190 , DBOrd
113 , DBOrd
@@ -196,19 +119,11 @@ module Rel8
196 , Function
119 , Function
197 , function
120 , function
198 , nullaryFunction
121 , nullaryFunction
199− , binaryOperator
200
122
201 -- * Queries
123 -- * Queries
202 , Query
124 , Query
203 , showQuery
125 , showQuery
204
126
205− -- ** Projection
206− , Projection
207− , Projectable( project )
208− , Biprojectable( biproject )
209− , Projecting
210− , Field
211−
212 -- ** Selecting rows
127 -- ** Selecting rows
213 , Selects
128 , Selects
214 , each
129 , each
@@ -217,8 +132,8 @@ module Rel8
217 -- ** Filtering
132 -- ** Filtering
218 , filter
133 , filter
219 , where_
134 , where_
220− , present
135+ , whereExists
221− , absent
136+ , whereNotExists
222 , distinct
137 , distinct
223 , distinctOn
138 , distinctOn
224 , distinctOnBy
139 , distinctOnBy
@@ -248,16 +163,13 @@ module Rel8
248
163
249 -- ** Aggregation
164 -- ** Aggregation
250 , Aggregate
165 , Aggregate
251− , Aggregates
252 , aggregate
166 , aggregate
253− , countRows
167+ , listAgg
168+ , nonEmptyAgg
254 , groupBy
169 , groupBy
255− , listAgg, listAggExpr
256− , mode
257− , nonEmptyAgg, nonEmptyAggExpr
258 , DBMax, max
170 , DBMax, max
259 , DBMin, min
171 , DBMin, min
260− , DBSum, sum, sumWhere, avg
172+ , DBSum, sum
261 , DBString, stringAgg
173 , DBString, stringAgg
262 , count
174 , count
263 , countStar
175 , countStar
@@ -274,383 +186,462 @@ module Rel8
274 , nullsFirst
186 , nullsFirst
275 , nullsLast
187 , nullsLast
276
188
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−
303 -- * IO
189 -- * IO
304 , Serializable
190 , Serializable
305− , ToExprs
306− , Result
307
191
308 -- * Running statements
192 -- * Running statements
309− -- $running
310−
311 -- ** @SELECT@
193 -- ** @SELECT@
312 , select
194 , select
313
195
314 -- ** @INSERT@
196 -- ** @INSERT@
315 , Insert(..)
197 , Insert(..)
316 , OnConflict(..)
198 , OnConflict(..)
317− , Upsert(..)
318 , insert
199 , insert
319− , unsafeDefault
200+ , toInsert
320− , showInsert
201+ , toInsertDefaults
321
202
322 -- ** @DELETE@
203 -- ** @DELETE@
323 , Delete(..)
204 , Delete(..)
324 , delete
205 , delete
325− , showDelete
326
206
327 -- ** @UPDATE@
207 -- ** @UPDATE@
328− , Update(..)
329 , update
208 , update
330− , showUpdate
209+ , Update(..)
331
210
332 -- ** @.. RETURNING@
211 -- ** @.. RETURNING@
333 , Returning(..)
212 , Returning(..)
334
213
335− -- ** @CREATE VIEW@
214+ -- * TODO
336− , createView
215+ -- TODO
337− , createOrReplaceView
216+ -- These need organizing, but are reachable from Rel8's documentation so we
338−
217+ -- do need to export and document them.
339− -- ** Sequences
218+ , Nullabilizes
340− , nextval
219+ , HTable
341− , evaluate
220+ , Labelable
221+ , Context
342 ) where
222 ) where
343
223
344-- base
224-- base
345import Prelude ()
225import Prelude ()
346
226
347-- rel8
227-- rel8
348−import Rel8.Aggregate
228+import Rel8.Type
349−import Rel8.Column
229+import Rel8.Type.Information
350−import Rel8.Column.ADT
351−import Rel8.Column.Either
230+import Rel8.Type.Ord
352−import Rel8.Column.Lift
231+import Rel8.Type.Semigroup
353−import Rel8.Column.List
232+import Rel8.Type.Monoid
354−import Rel8.Column.Maybe
233+import Rel8.Type.Num
355−import Rel8.Column.NonEmpty
234+import Rel8.Table
356−import Rel8.Column.Null
357−import Rel8.Column.These
358import Rel8.Expr
235import Rel8.Expr
359−import Rel8.Expr.Aggregate
360import Rel8.Expr.Bool
236import Rel8.Expr.Bool
361−import Rel8.Expr.Default
362import Rel8.Expr.Eq
237import Rel8.Expr.Eq
363import Rel8.Expr.Function
238import Rel8.Expr.Function
364−import Rel8.Expr.Null
365−import Rel8.Expr.Opaleye (unsafeCastExpr, unsafeLiteral)
366−import Rel8.Expr.Ord
367−import Rel8.Expr.Order
368−import 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 )
373−import Rel8.Order
374import Rel8.Query
239import Rel8.Query
375−import Rel8.Query.Aggregate
240+import Rel8.Query.SQL (showQuery)
376−import Rel8.Query.Distinct
377import Rel8.Query.Each
241import Rel8.Query.Each
378−import Rel8.Query.Either
242+import Rel8.Query.Values
379−import Rel8.Query.Evaluate
380−import Rel8.Query.Exists
381import Rel8.Query.Filter
243import Rel8.Query.Filter
382−import Rel8.Query.Indexed
244+import Rel8.Query.Exists
245+import Rel8.Query.Distinct
383import Rel8.Query.Limit
246import Rel8.Query.Limit
384−import Rel8.Query.List
247+import Rel8.Query.Set
248+import Rel8.Table.Maybe
385import Rel8.Query.Maybe
249import Rel8.Query.Maybe
386−import Rel8.Query.Null
250+import Rel8.Aggregate
251+import Rel8.Query.Aggregate
252+import Rel8.Query.List
253+import Rel8.Table.NonEmpty
254+import Rel8.Table.List
387import Rel8.Query.Order
255import Rel8.Query.Order
388−import Rel8.Query.Rebind
256+import Rel8.Order
389−import Rel8.Query.SQL (showQuery)
390−import Rel8.Query.Set
391−import Rel8.Query.These
392−import Rel8.Query.Values
393−import Rel8.Query.Window
394−import Rel8.Schema.Field
395−import Rel8.Schema.HTable
396−import Rel8.Schema.Name
397−import Rel8.Schema.Null hiding ( nullable )
398−import Rel8.Schema.Result ( Result )
399−import Rel8.Schema.Table
257+import Rel8.Table.Serialize
400−import Rel8.Statement.Delete
258+import Rel8.Statement.Select
401import Rel8.Statement.Insert
259import Rel8.Statement.Insert
402−import Rel8.Statement.OnConflict
260+import Rel8.Statement.Delete
403import Rel8.Statement.Returning
261import Rel8.Statement.Returning
404−import Rel8.Statement.Select
405−import Rel8.Statement.SQL
406import Rel8.Statement.Update
262import Rel8.Statement.Update
407−import Rel8.Statement.View
408−import Rel8.Table
409−import Rel8.Table.ADT
410import Rel8.Table.Aggregate
263import Rel8.Table.Aggregate
264+import Rel8.Expr.Aggregate
265+import Rel8.Type.String
266+import Rel8.Type.Sum
267+import Rel8.Expr.Null
268+import Rel8.Query.Null
269+import Rel8.Expr.Order
270+import Rel8.Schema.Nullability
271+import Rel8.Schema.HTable
272+import Rel8.Schema.Context.Label
273+import Rel8.Schema.Table
274+import Rel8.Table.These
275+import Rel8.Query.These
276+import Rel8.Table.Recontextualize
277+import Rel8.Expr.Ord
411import Rel8.Table.Alternative
278import Rel8.Table.Alternative
412−import Rel8.Table.Bool
413import Rel8.Table.Either
279import Rel8.Table.Either
280+import Rel8.Table.Bool
281+import Rel8.Query.Either
414import Rel8.Table.Eq
282import Rel8.Table.Eq
415−import Rel8.Table.HKD
416−import Rel8.Table.List
417−import Rel8.Table.Maybe
418−import Rel8.Table.Name
419−import Rel8.Table.NonEmpty
420−import Rel8.Table.Null
421−import Rel8.Table.Opaleye ( castTable )
422import Rel8.Table.Ord
283import Rel8.Table.Ord
423import Rel8.Table.Order
284import Rel8.Table.Order
424−import Rel8.Table.Projection
285+import Rel8.Expr.Serialize
425−import Rel8.Table.Rel8able ()
426−import Rel8.Table.Serialize
427−import Rel8.Table.These
286+import Rel8.Table.Insert
428−import Rel8.Table.Transpose
429−import Rel8.Table.Window
430−import Rel8.Type
431−import Rel8.Type.Composite
432−import Rel8.Type.Eq
433−import Rel8.Type.Enum
434−import Rel8.Type.Information
435−import Rel8.Type.JSONBEncoded
436import Rel8.Type.JSONEncoded
287import Rel8.Type.JSONEncoded
437−import Rel8.Type.Monoid
288+import Rel8.Type.JSONBEncoded
438−import Rel8.Type.Num
439−import Rel8.Type.Ord
440import Rel8.Type.ReadShow
289import Rel8.Type.ReadShow
441−import Rel8.Type.Semigroup
442−import Rel8.Type.String
443−import Rel8.Type.Sum
444−import Rel8.Window
445−
446
290
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
291
453−-- $adts
292+-- $setup
454−-- Algebraic data types can be modelled between Haskell and SQL.
293+--
294+-- In this section, we'll take a look at using Rel8 to work with a small
295+-- database for Haskell packages. We'll take a look at idiomatic usage of Rel8,
296+-- mapping tables to Haskell, and then look at writing some simple queries.
297+--
298+-- The documentation in this library uses the following language extensions:
299+--
300+-- >>> :set -XBlockArguments
301+-- >>> :set -XDeriveAnyClass
302+-- >>> :set -XDeriveGeneric
303+-- >>> :set -XDerivingStrategies
304+-- >>> :set -XDerivingVia
305+-- >>> :set -XDuplicateRecordFields
306+-- >>> :set -XGeneralizedNewtypeDeriving
307+-- >>> :set -XOverloadedStrings
308+-- >>> :set -XStandaloneDeriving
309+-- >>> :set -XTypeApplications
310+-- >>> :set -XTypeFamilies
311+--
312+-- Before we start writing any Haskell, let's take a look at the schema we'll
313+-- work with.
314+--
315+-- > author: project:
316+-- >
317+-- > Column │ Type │ Nullable Column │ Type │ Nullable
318+-- > ═══════════╪═════════╪══════════ ═══════════╪═════════╪══════════
319+-- > author_id │ integer │ not null author_id │ integer │ not null
320+-- > name │ text │ not null name │ text │ not null
321+-- > url │ text │
322+--
323+-- Our schema consists of two tables - @author@ and @project@. A @project@
324+-- always has an @author@, but not all @author@s have projects. Each @author@
325+-- has a name and (maybe) an associated website, and each project has a name.
326+--
327+-- Now that we've seen our schema, we can begin writing a mapping in Rel8. The
328+-- idiomatic way to map a table is to use a record that is parameterised what
329+-- Rel8 calls an /interpretation functor/, and to define each field with
330+-- 'Column'. For this type to be usable with Rel8 we need it to be an instance
331+-- of 'HigherKindedTable', which can be derived with a combination of
332+-- @DeriveAnyClass@ and @DeriveGeneric@.
333+--
334+-- Following these steps for @author@, we have:
335+--
336+-- > data Author f = Author
337+-- > { authorId :: Column f Int64
338+-- > , name :: Column f Text
339+-- > , url :: Column f (Maybe Text)
340+-- > } deriving (Generic, HigherKindedTable)
341+--
342+-- This is a perfectly reasonable definition, but cautious readers might notice
343+-- a problem - in particular, with the type of the @authorId@ field. While
344+-- @Int64@ is correct, it's not the best type. If we had other identifier types
345+-- in our project, it would be too easy to accidentally mix them up and create
346+-- nonsensical joins. As Haskell programmers, we often solve this problem by
347+-- creating @newtype@ wrappers, and we can also use this technique with Rel8:
348+--
349+-- >>> :{
350+-- newtype AuthorId = AuthorId { toInt64 :: Int64 }
351+-- deriving newtype (DBEq, DBType, Eq, Show)
352+-- :}
455--
353--
456−-- * Your SQL table needs a certain text field that tags which Haskell constructor is in use.
354+-- Now we can write our final schema mapping. First, the @author@ table:
457−-- * You have to use a few combinators to specify the sum type's individual constructors.
458−-- * If you want to do case analysis at the @Expr@ (SQL) level, you can use 'maybe'/'either'-like eliminators.
459--
355--
460−-- The documentation in this section will assume a set of database types like this:
356+-- >>> :{
357+-- data Author f = Author
358+-- { authorId :: Column f AuthorId
359+-- , authorName :: Column f Text
360+-- , authorUrl :: Column f (Maybe Text)
361+-- }
362+-- deriving stock Generic
363+-- deriving anyclass HigherKindedTable
364+-- :}
461--
365--
462−-- @
366+-- And similarly, the @project@ table:
463−-- data Thing f = ThingEmployer (Employer f) | ThingPotato (Potato f) | Nullary
464−-- deriving stock Generic
465--
367--
466−-- data Employer f = Employer { employerId :: f Int32, employerName :: f Text}
368+-- >>> :{
369+-- data Project f = Project
370+-- { projectAuthorId :: Column f AuthorId
371+-- , projectName :: Column f Text
372+-- }
467-- deriving stock Generic
373-- deriving stock Generic
468−-- deriving anyclass Rel8able
374+-- deriving anyclass HigherKindedTable
375+-- :}
469--
376--
470−-- data Potato f = Potato { size :: f Int32, grower :: f Text }
377+-- To show query results in this documentation, we'll also need @Show@
471−-- deriving stock Generic
378+-- instances: Unfortunately these definitions look a bit scary, but they are
472−-- deriving anyclass Rel8able
379+-- essentially just @deriving (Show)@:
473−-- @
380+--
474−
381+-- >>> deriving stock instance f ~ Identity => Show (Author f)
475−-- $naming
382+-- >>> deriving stock instance f ~ Identity => Show (Project f)
383+--
384+-- These data types describe the structural mapping of the tables, but we also
385+-- need to specify a 'TableSchema' for each table. A @TableSchema@ contains the
386+-- name of the table and the name of all columns in the table, which will
387+-- ultimately allow us to @SELECT@ and @INSERT@ rows for these tables.
388+--
389+-- To define a @TableSchema@, we just need to fill construct appropriate
390+-- @TableSchema@ values. When it comes to the @tableColumns@ field, we
391+-- construct values of our data types above, and set each field to the name of
392+-- the column that it maps to:
393+--
394+-- First, @authorSchema@ describes the column names of the @author@ table when
395+-- associated with the @Author@ type:
396+--
397+-- >>> :{
398+-- authorSchema :: TableSchema (Author ColumnSchema)
399+-- authorSchema = TableSchema
400+-- { tableName = "author"
401+-- , tableSchema = Nothing
402+-- , tableColumns = Author
403+-- { authorId = "author_id"
404+-- , authorName = "name"
405+-- , authorUrl = "url"
406+-- }
407+-- }
408+-- :}
409+--
410+-- And likewise for @project@ and @Project@:
411+--
412+-- >>> :{
413+-- projectSchema :: TableSchema (Project ColumnSchema)
414+-- projectSchema = TableSchema
415+-- { tableName = "project"
416+-- , tableSchema = Nothing
417+-- , tableColumns = Project
418+-- { projectAuthorId = "author_id"
419+-- , projectName = "name"
420+-- }
421+-- }
422+-- :}
423+--
424+-- Aside: you might be wondering why this information isn't in the definitions
425+-- of @Author@ and @Project@ above. Rel8 decouples @TableSchema@ from the data
426+-- types themselves, as not all tables you define will necessarily have a
427+-- schema. For example, Rel8 allows you to define helper types to simplify the
428+-- types of queries - these tables only exist at query time, but there is no
429+-- corresponding base table. We'll see more on this idea later!
430+--
431+-- With these table definitions, we can now start writing some queries! To
432+-- actually run a query, we'll need a database connection. Rel8 uses the
433+-- @hasql@ library, and for this documentation we'll get the connection string
434+-- from the @$TEST_DATABASE_URL@ environment variable.
476−--
435+--
477−-- First, in your 'TableSchema', name your type like this:
436+-- >>> connectionString <- System.Environment.getEnv "TEST_DATABASE_URL"
478−--
437+-- >>> Right c <- Hasql.Connection.acquire (Data.ByteString.Char8.pack connectionString)
438+-- >>> Control.Monad.void $ Hasql.Session.run (Hasql.Session.sql "BEGIN") c
439+
440+-- $guideQueries
441+--
442+-- First, we'll take a look at @SELECT@ statements - usually the bulk of most
443+-- database heavy applications.
444+--
445+-- In Rel8, @SELECT@ statements are built using the 'Query' monad. You can
446+-- think of this monad like the ordinary @[]@ (List) monad - but this isn't
447+-- required knowledge.
448+--
449+-- To start, we'll look at one of the simplest queries possible - a basic
450+-- @SELECT * FROM@ statement. To select all rows from a table, we use 'each',
451+-- and supply a 'TableSchema'. So to select all @project@ rows, we can write:
452+--
453+-- >>> :t each projectSchema
454+-- each projectSchema :: Query (Project Expr)
455+--
456+-- Notice that @each@ gives us a @Query@ that yields @Project Expr@ rows. To
457+-- see what this means, let's have a look at a single field of a
458+-- @Project Expr@:
459+--
460+-- >>> let aProjectExpr = undefined :: Project Expr
461+-- >>> :t projectAuthorId aProjectExpr
462+-- projectAuthorId aProjectExpr :: Expr AuthorId
463+--
464+-- Recall we defined @projectAuthorId@ as @Column f AuthorId@. Now we have @f@
465+-- is @Expr@, and @Column Expr AuthorId@ reduces to @Expr AuthorId@. We'll see
466+-- more about @Expr@ soon, but you can think of @Expr a@ as "SQL expressions of
467+-- type @a@".
468+--
469+-- To execute this @Query@, we pass it to 'select':
470+--
471+-- >>> :t select c (each projectSchema)
472+-- select c (each projectSchema) :: MonadIO m => m [Project Identity]
473+--
474+-- When we @select@ things containing @Expr@s, Rel8 builds a new response table
475+-- with the @Identity@ interpretation. This means you'll get back plain Haskell
476+-- values. Studying @projectAuthorId@ again, we have:
477+--
478+-- >>> let aProjectIdentity = undefined :: Project Identity
479+-- >>> :t projectAuthorId aProjectIdentity
480+-- projectAuthorId aProjectIdentity :: AuthorId
481+--
482+-- Here @Column Identity AuthorId@ reduces to just @AuthorId@, with no
483+-- wrappping type at all.
484+--
485+-- Putting this all together, we can run our first query:
486+--
487+-- >>> select c (each projectSchema) >>= mapM_ print
488+-- Project {projectAuthorId = 1, projectName = "rel8"}
489+-- Project {projectAuthorId = 2, projectName = "aeson"}
490+-- Project {projectAuthorId = 2, projectName = "text"}
491+--
492+-- Cool!
493+--
494+-- We now know that 'each' is the equivalent of a @SELECT *@ query, but
495+-- sometimes we're only interested in a subset of the columns of a table. To
496+-- restrict the returned columns, we can specify a projection by using 'Query's
497+-- @Functor@ instance:
479−-- @
498+--
480−-- thingSchema :: TableSchema (ADT Thing Name)
499+-- >>> select c $ projectName <$> each projectSchema
481−-- thingSchema =
500+-- ["rel8","aeson","text"]
482−-- TableSchema
501+
483−-- { schema = Nothing,
502+-- $guideJoins
484−-- name = \"thing\",
503+--
485−-- columns =
504+-- Another common operation in relational databases is to take the @JOIN@ of
486−-- nameADT @Thing
505+-- multiple tables. Rel8 doesn't have a specific join operation, but we can
487−-- \"tag\"
506+-- recover the functionality of a join by selecting all rows of two tables, and
488−-- Employer
507+-- then using 'where_' to filter them.
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−--
508+--
502−-- To deconstruct sum types at the SQL level, use 'deconstructADT',
509+-- To see how this works, first let's look at taking the product of two tables.
503−-- which is also variadic, and has one argument for each
510+-- We can do this by simply calling 'each' twice, and then returning a tuple of
504−-- constructor. Similar to 'maybe'.
511+-- their results.
505−--
512+--
506−-- @
513+-- >>> :{
507−-- query :: Query (ADT Thing Expr)
514+-- mapM_ print =<< select c do
508−-- query = do
515+-- author <- each authorSchema
509−-- thingExpr <- each thingSchema
516+-- project <- each projectSchema
510−-- where_ $
517+-- return (projectName project, authorName author)
511−-- deconstructADT @Thing
518+-- :}
512−-- (\employer -> employerName employer ==. lit \"Mary\")
519+-- ("rel8","Ollie")
513−-- (\potato -> grower potato ==. lit \"Mary\")
520+-- ("rel8","Bryan O'Sullivan")
514−-- (lit False) -- Nullary case
521+-- ("rel8","Emily Pillmore")
515−-- thingExpr
522+-- ("aeson","Ollie")
516−-- pure thingExpr
523+-- ("aeson","Bryan O'Sullivan")
517−-- @
524+-- ("aeson","Emily Pillmore")
518−--
525+-- ("text","Ollie")
519−-- SQL output:
526+-- ("text","Bryan O'Sullivan")
520−--
527+-- ("text","Emily Pillmore")
521−-- @
528+--
522−-- SELECT
529+-- This isn't quite right, though, as we have ended up pairing up the wrong
523−-- CAST("tag0_1" AS text) as "tag",
530+-- projects and authors. To fix this, we can use 'where_' to restrict the
524−-- CAST("id1_1" AS int4) as "ThingEmployer/_1/employerId",
531+-- returned rows. We could write:
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−-- *
532+--
530−-- FROM (SELECT
533+-- > select c $ do
531−-- "tag" as "tag0_1",
534+-- > author <- each authorSchema
532−-- "id" as "id1_1",
535+-- > project <- each projectSchema
533−-- "name" as "name2_1",
536+-- > where_ $ projectAuthorId project ==. authorId author
534−-- "size" as "size3_1",
537+-- > return (project, author)
535−-- "Mary" as "Mary4_1"
538+--
536−-- FROM "thing" as "T1") as "T1"
539+-- but doing this every time you need a join can obscure the meaning of the
537−-- WHERE (CASE WHEN ("tag0_1") = (CAST(E'ThingPotato' AS text)) THEN ("Mary4_1") = (CAST(E'Mary' AS text))
540+-- query you're writing. A good practice is to introduce specialised functions
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"
541+-- for the particular joins in your database. In our case, this would be:
539−-- @
542+--
540−
543+-- >>> :{
541−-- $construction
544+-- projectsForAuthor :: Author Expr -> Query (Project Expr)
545+-- projectsForAuthor a = each projectSchema >>= filter \p ->
546+-- projectAuthorId p ==. authorId a
547+-- :}
542−--
548+--
543−-- To construct an ADT, you can use 'buildADT' or 'constructADT'. Consider the following type:
549+-- Our final query is then:
544−--
550+--
545−-- @
551+-- >>> :{
546−-- data Task f = Pending | Complete (CompletedTask f)
552+-- mapM_ print =<< select c do
553+-- author <- each authorSchema
554+-- project <- projectsForAuthor author
555+-- return (projectName project, authorName author)
556+-- :}
557+-- ("rel8","Ollie")
558+-- ("aeson","Bryan O'Sullivan")
559+-- ("text","Bryan O'Sullivan")
547−-- @
560+--
561+-- == @LEFT JOIN@s
548−--
562+--
549−-- 'buildADT' is for constructing values of 'Task' in the 'Expr'
563+-- Rel8 is also capable of performing @LEFT JOIN@s. To perform @LEFT JOIN@s, we
550−-- context. 'buildADT' needs two type-level arguments before its type
564+-- follow the same approach as before, but use the 'optional' query transformer
551−-- makes any sense. The first argument is the type of the "ADT", which
565+-- to allow for the possibility of the join to fail.
552−-- in our case is 'Task'. The second is the name of the constructor we
566+--
553−-- want to use. So that means we have the following possible
567+-- In our test database, we can see that there's another author who we haven't
554−-- instantiations of 'buildADT' for 'Task':
568+-- seen yet:
569+--
570+-- >>> select c $ authorName <$> each authorSchema
571+-- ["Ollie","Bryan O'Sullivan","Emily Pillmore"]
572+--
573+-- Emily wasn't returned in our earlier query because - in our database - she
574+-- doesn't have any registered projects. We can account for this partiality in
575+-- our original query by wrapping the @projectsForAuthor@ call with 'optional':
576+--
577+-- >>> :{
578+-- mapM_ print =<< select c do
579+-- author <- each authorSchema
580+-- mproject <- optional $ projectsForAuthor author
581+-- return (authorName author, projectName <$> mproject)
555−--
582+-- :}
556−-- @
583+-- ("Ollie",Just "rel8")
557−-- > :t buildADT @Task @\"Pending\"
584+-- ("Bryan O'Sullivan",Just "aeson")
558−-- buildADT @Task @\"Pending\" :: ADT Task Expr
585+-- ("Bryan O'Sullivan",Just "text")
559−-- > :t buildADT @Task @\"Complete\"
586+-- ("Emily Pillmore",Nothing)
560−-- buildADT @Task @\"Complete\" :: CompletedTask Expr -> ADT Task Expr
587+
561−-- @
588+-- $guideAggregation
562−--
589+--
563−-- Note that as the "Pending" constructor has no fields, @buildADT
590+-- Aggregations are operations like @sum@ and @count@ - operations that reduce
564−-- \@Task \@"Pending"@ is equivalent to @lit Pending@. But @buildADT
591+-- multiple rows to single values. To perform aggregations in Rel8, we can use
565−-- \@Task \@"Complete"@ is not the same as @lit . Complete@:
592+-- the 'aggregate' function, which takes a 'Query' of aggregated expressions,
593+-- runs the aggregation, and returns aggregated rows.
566−--
594+--
567−-- @
595+-- To start, let's look at a simple aggregation that tells us how many projects
568−-- > :t lit . Complete
596+-- exist:
569−-- lit . Complete :: CompletedTask Result -> ADT Task Expr
570−-- @
597+--
571−--
598+-- >>> error "TODO"
572−--
599+--
573−-- Note that the former takes a @CompletedTask Expr@ while the latter
600+-- Rel8 is also capable of aggregating multiple rows into a single row by
574−-- takes a @CompletedTask Result@. The former is more powerful because
601+-- concatenating all rows as a list. This aggregation allows us to break free
575−-- you can construct @Task@s using dynamic values coming a database
602+-- of the row-orientated nature of SQL and write queries that return tree-like
576−-- query.
603+-- structures. Earlier we saw an example of returning authors with their
577−--
604+-- projects, but the query didn't do a great job of describing the one-to-many
578−-- To show what this can look like in SQL, consider:
605+-- relationship between authors and their projects.
579−--
606+--
607+-- Let's look again at a query that returns authors and their projects, and
608+-- focus on the /type/ of that query.
609+--
610+-- >>> :{
611+-- projectsForAuthor a = each projectSchema >>= filter \p ->
612+-- projectAuthorId p ==. authorId a
580−-- @
613+-- :}
614+--
581−-- > :{
615+-- >>> :{
582−-- showQuery $ values
616+-- let authorsAndProjects = do
583−-- [ buildADT @Task @\"Pending\"
617+-- author <- each authorSchema
584−-- , buildADT @Task @\"Complete\" CompletedTask {date = Rel8.Expr.Time.now}
618+-- project <- projectsForAuthor author
585−-- ]
619+-- return (author, project)
620+-- where
621+-- :}
622+--
623+-- >>> :t select c authorsAndProjects
624+-- select c authorsAndProjects
625+-- :: MonadIO m => m [(Author Identity, Project Identity)]
626+--
627+-- Our query gives us a single list of pairs of authors and projects. However,
628+-- with our domain knowledge of the schema, this isn't a great type - what we'd
629+-- rather have is a list of pairs of authors and /lists/ of projects. That is,
630+-- what we'd like is:
631+--
632+-- > [(Author Identity, [Project Identity])]
633+--
634+-- This would be a much better type! Rel8 can produce a query with this type by
635+-- simply wrapping the call to @projectsForAuthor@ with either 'some' or
636+-- 'many'. Here we'll use 'many', which allows for the possibility of an author
637+-- to have no projects:
638+--
639+-- >>> :{
640+-- mapM_ print =<< select c do
641+-- author <- each authorSchema
642+-- projectNames <- many $ projectName <$> projectsForAuthor author
643+-- return (authorName author, projectNames)
586-- :}
644-- :}
587−-- @
645+-- ("Ollie",["rel8"])
588−--
646+-- ("Bryan O'Sullivan",["aeson","text"])
589−-- This produces the following SQL:
647+-- ("Emily Pillmore",[])
590−--
591−-- @
592−-- SELECT
593−-- CAST(\"values0_1\" AS text) as \"tag\",
594−-- CAST(\"values1_1\" AS timestamptz) as \"Complete/_1/date\"
595−-- FROM (SELECT
596−-- *
597−-- FROM (SELECT \"column1\" as \"values0_1\",
598−-- \"column2\" as \"values1_1\"
599−-- FROM
600−-- (VALUES
601−-- (CAST(E'Pending' AS text),CAST(NULL AS timestamptz)),
602−-- (CAST(E'Complete' AS text),CAST(now() AS timestamptz))) as \"V\") as \"T1\") as \"T1\"
603−-- @
604−--
605−-- This is what you get if you run it in @psql@:
606−--
607−--
608−-- @
609−-- tag | Complete/_1/date
610−-- ----------+-------------------------------
611−-- Pending |
612−-- Complete | 2022-05-19 21:28:23.969065+00
613−-- (2 rows)
614−-- @
615−--
616−-- "constructADT" is less convenient but more general alternative to
617−-- "buildADT". It requires only one type-level argument for its type
618−-- to make sense:
619−--
620−-- @
621−-- > :t constructADT @Task
622−-- constructADT @Task
623−-- :: (forall r. r -> (CompletedTask Expr -> r) -> r) -> ADT Task Expr
624−-- @
625−--
626−-- This might still seem a bit opaque, but basically it gives you a
627−-- Church-encoded constructor for arbitrary algebraic data types. You
628−-- might use it as follows:
629−--
630−-- @
631−-- let
632−-- pending :: ADT Task Expr
633−-- pending = constructADT @Task $ \pending _complete -> pending
634−--
635−-- complete :: ADT Task Expr
636−-- complete = constructADT @Task $ \_pending complete -> complete CompletedTask {date = Rel8.Expr.Time.now}
637−-- @
638−--
639−-- These values are otherwise identical to the ones we saw above with
640−-- @buildADT@, it's just a different style of constructing them.
641−--
642−
643−-- $misc-notes
644−--
645−-- 1. Note that the order of the arguments for all of these functions
646−-- is determined by the order of the constructors in the data
647−-- definition. If it were @data Task = Complete (CompletedTask f) |
648−-- Pending@ then the order of all the invocations of @constructADT@
649−-- and @deconstructADT@ would need to change.
650−--
651−-- 2. Maybe this is obvious, but just to spell it out: once you're in
652−-- the @Result@ context, you can of course construct @Task@ values
653−-- normally and use standard Haskell pattern-matching. @constructADT@
654−-- and @deconstructADT@ are specifically only needed in the @Expr@
655−-- context, and they allow you to do the equivalent of pattern
656−-- matching in PostgreSQL.
src/Rel8/Aggregate.hs+44−59
@@ -1,83 +1,68 @@
1−{-# language DataKinds #-}
1+{-# language DerivingVia #-}
2−{-# language FlexibleContexts #-}
2+{-# language GeneralizedNewtypeDeriving #-}
3−{-# language FlexibleInstances #-}
3+{-# language NamedFieldPuns #-}
4−{-# language MultiParamTypeClasses #-}
5−{-# language RankNTypes #-}
6{-# language StandaloneKindSignatures #-}
4{-# language StandaloneKindSignatures #-}
7−{-# language TypeFamilies #-}
8−{-# language UndecidableInstances #-}
9
5
10module Rel8.Aggregate
6module Rel8.Aggregate
11− ( Aggregate(..), zipOutputs
7+ ( Aggregate(..), foldInputs, mapInputs
12− , unsafeMakeAggregate
8+ , Aggregator(..), unsafeMakeAggregate
13− , Aggregates
14 )
9 )
15where
10where
16
11
17-- base
12-- base
18−import Control.Applicative ( liftA2 )
13+import Data.Functor.Const ( Const( Const ), getConst )
19−import Data.Functor.Identity ( Identity( Identity ) )
20−import Data.Kind ( Constraint, Type )
14+import Data.Kind ( Type )
21import Prelude
15import Prelude
22
16
23−-- profunctors
24−import Data.Profunctor ( dimap )
25−
26-- opaleye
17-- opaleye
27−import qualified Opaleye.Aggregate as Opaleye
18+import qualified Opaleye.Internal.Aggregate as Opaleye
28import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
19import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
29−import qualified Opaleye.Internal.Column as Opaleye
20+import qualified Opaleye.Internal.PackMap 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 )
43
21
22+-- semigroupoids
23+import Data.Functor.Apply ( Apply, WrappedApplicative(..) )
44
24
45−-- | 'Aggregate' is a special context used by 'Rel8.aggregate'.
46−type Aggregate :: K.Context
47−newtype Aggregate a = Aggregate (Opaleye.Aggregator () (Expr a))
48
25
26+type Aggregate :: Type -> Type
27+newtype Aggregate a = Aggregate (Opaleye.Aggregator () a)
28+ deriving newtype Functor
29+ deriving Apply via (WrappedApplicative (Opaleye.Aggregator ()))
49
30
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
55
31
56− toColumns = HIdentity
32+foldInputs :: Monoid b
57− fromColumns (HIdentity a) = a
33+ => (Maybe Aggregator -> Opaleye.PrimExpr -> b) -> Aggregate a -> b
58− toResult = HIdentity . Identity
34+foldInputs f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =
59− fromResult (HIdentity (Identity a)) = a
35+ getConst $ flip agg () $ \(aggregator, a) ->
36+ Const $ f (detuplize <$> aggregator) a
37+ where
38+ detuplize (operation, ordering, distinction) =
39+ Aggregator {operation, ordering, distinction}
60
40
61
41
62−-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate's
42+mapInputs :: ()
63−-- for the 'Expr' columns in @b@.
43+ => (Opaleye.PrimExpr -> Opaleye.PrimExpr) -> Aggregate a -> Aggregate a
64−type Aggregates :: Type -> Type -> Constraint
44+mapInputs transform (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =
65−class Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs
45+ Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ agg . \f input ->
66−instance Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs
46+ f (fmap transform input)
67
47
68
48
69−zipOutputs :: ()
49+type Aggregator :: Type
70− => (Expr a -> Expr b -> Expr c) -> Aggregate a -> Aggregate b -> Aggregate c
50+data Aggregator = Aggregator
71−zipOutputs f (Aggregate a) (Aggregate b) = Aggregate (liftA2 f a b)
51+ { operation :: Opaleye.AggrOp
52+ , ordering :: [Opaleye.OrderExpr]
53+ , distinction :: Opaleye.AggrDistinct
54+ }
72
55
73
56
74−unsafeMakeAggregate :: forall (input :: Type) (output :: Type) n n' a a'. ()
57+unsafeMakeAggregate :: ()
75− => (Expr input -> Opaleye.PrimExpr)
58+ => (input -> Opaleye.PrimExpr)
76− -> (Opaleye.PrimExpr -> Expr output)
59+ -> (Opaleye.PrimExpr -> output)
77− -> Opaleye.Aggregator (Opaleye.Field_ n a) (Opaleye.Field_ n' a')
60+ -> Maybe Aggregator
78− -> Expr input
61+ -> input
79 -> Aggregate output
62 -> Aggregate output
80unsafeMakeAggregate input output aggregator expr =
63unsafeMakeAggregate input output aggregator expr =
81− Aggregate $ dimap in_ out aggregator
64+ Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ \f _ ->
82− where out = output . Opaleye.unColumn
65+ output <$> f (tuplize <$> aggregator, input expr)
83− in_ = Opaleye.Column . input . const expr
66+ where
67+ tuplize Aggregator {operation, ordering, distinction} =
68+ (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+24−65
@@ -1,12 +1,11 @@
1{-# language DataKinds #-}
1{-# language DataKinds #-}
2{-# language DerivingStrategies #-}
2{-# language DerivingStrategies #-}
3{-# language FlexibleContexts #-}
3{-# language FlexibleContexts #-}
4−{-# language FlexibleInstances #-}
4+{-# language GADTs #-}
5−{-# language MultiParamTypeClasses #-}
5+{-# language RoleAnnotations #-}
6{-# language ScopedTypeVariables #-}
6{-# language ScopedTypeVariables #-}
7{-# language StandaloneKindSignatures #-}
7{-# language StandaloneKindSignatures #-}
8{-# language TypeApplications #-}
8{-# language TypeApplications #-}
9−{-# language TypeFamilies #-}
10{-# language UndecidableInstances #-}
9{-# language UndecidableInstances #-}
11
10
12module Rel8.Expr
11module Rel8.Expr
@@ -15,7 +14,7 @@ module Rel8.Expr
15where
14where
16
15
17-- base
16-- base
18−import Data.Functor.Identity ( Identity( Identity ) )
17+import Data.Kind ( Type )
19import Data.String ( IsString, fromString )
18import Data.String ( IsString, fromString )
20import Prelude hiding ( null )
19import Prelude hiding ( null )
21
20
@@ -23,8 +22,7 @@ import Prelude hiding ( null )
23import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
22import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
24
23
25-- rel8
24-- rel8
26−import Rel8.Expr.Function ( function, nullaryFunction )
25+import Rel8.Expr.Null ( liftOpNullable, nullify )
27−import Rel8.Expr.Null ( liftOpNull, nullify )
28import Rel8.Expr.Opaleye
26import Rel8.Expr.Opaleye
29 ( castExpr
27 ( castExpr
30 , fromPrimExpr
28 , fromPrimExpr
@@ -32,47 +30,41 @@ import Rel8.Expr.Opaleye
32 , zipPrimExprsWith
30 , zipPrimExprsWith
33 )
31 )
34import Rel8.Expr.Serialize ( litExpr )
32import Rel8.Expr.Serialize ( litExpr )
35−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
33+import Rel8.Schema.Nullability
36−import qualified Rel8.Schema.Kind as K
34+ ( Nullability( Nullable, NonNullable )
37−import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
35+ , Nullabilizes, nullabilization
38−import Rel8.Table
39− ( Table, Columns, Context, fromColumns, toColumns
40− , FromExprs, fromResult, toResult
41− , Transpose
42 )
36 )
43import Rel8.Type ( DBType )
37import Rel8.Type ( DBType )
44import Rel8.Type.Monoid ( DBMonoid, memptyExpr )
38import Rel8.Type.Monoid ( DBMonoid, memptyExpr )
45−import Rel8.Type.Num ( DBFloating, DBFractional, DBNum )
39+import Rel8.Type.Num ( DBFractional, DBNum )
46import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )
40import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )
47
41
48
42
49−-- | Typed SQL expressions.
43+type role Expr representational
50−type Expr :: K.Context
44+type Expr :: Type -> Type
51newtype Expr a = Expr Opaleye.PrimExpr
45newtype Expr a = Expr Opaleye.PrimExpr
52 deriving stock Show
46 deriving stock Show
53
47
54
48
55−instance Sql DBSemigroup a => Semigroup (Expr a) where
49+instance (DBSemigroup db, Nullabilizes db a) => Semigroup (Expr a) where
56− (<>) = case nullable @a of
50+ (<>) = case nullabilization @a of
57− Null -> liftOpNull (<>.)
51+ Nullable -> liftOpNullable (<>.)
58− NotNull -> (<>.)
52+ NonNullable -> (<>.)
59− {-# INLINABLE (<>) #-}
60
53
61
54
62−instance Sql DBMonoid a => Monoid (Expr a) where
55+instance (DBMonoid db, Nullabilizes db a) => Monoid (Expr a) where
63− mempty = case nullable @a of
56+ mempty = case nullabilization @a of
64− Null -> nullify memptyExpr
57+ Nullable -> nullify memptyExpr
65− NotNull -> memptyExpr
58+ NonNullable -> memptyExpr
66− {-# INLINABLE mempty #-}
67
59
68
60
69−instance (Sql IsString a, Sql DBType a) => IsString (Expr a) where
61+instance (IsString db, DBType db, Nullabilizes db a) => IsString (Expr a) where
70− fromString = litExpr . case nullable @a of
62+ fromString = litExpr . case nullabilization @a of
71− Null -> Just . fromString
63+ Nullable -> Just . fromString
72− NotNull -> fromString
64+ NonNullable -> fromString
73
65
74
66
75−instance Sql DBNum a => Num (Expr a) where
67+instance (DBNum db, Nullabilizes db a) => Num (Expr a) where
76 (+) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:+))
68 (+) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:+))
77 (*) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:*))
69 (*) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:*))
78 (-) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:-))
70 (-) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:-))
@@ -85,41 +77,8 @@ instance Sql DBNum a => Num (Expr a) where
85 fromInteger = castExpr . fromPrimExpr . Opaleye.ConstExpr . Opaleye.IntegerLit
77 fromInteger = castExpr . fromPrimExpr . Opaleye.ConstExpr . Opaleye.IntegerLit
86
78
87
79
88−instance Sql DBFractional a => Fractional (Expr a) where
80+instance (DBFractional db, Nullabilizes db a) => Fractional (Expr a) where
89 (/) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:/))
81 (/) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:/))
90
82
91 fromRational =
83 fromRational =
92 castExpr . Expr . Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac
84 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 #-}
2{-# language StandaloneKindSignatures #-}
2{-# language StandaloneKindSignatures #-}
3
3
4module Rel8.Expr
4module Rel8.Expr
@@ -7,14 +7,13 @@ module Rel8.Expr
7where
7where
8
8
9-- base
9-- base
10+import Data.Kind ( Type )
10import Prelude ()
11import Prelude ()
11
12
12-- opaleye
13-- opaleye
13import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
14import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
14
15
15−-- rel8
16−import Rel8.Schema.Kind ( Context )
17
16
18−
17+type role Expr representational
19−type Expr :: Context
18+type Expr :: Type -> Type
20newtype Expr a = Expr Opaleye.PrimExpr
19newtype Expr a = Expr Opaleye.PrimExpr
src/Rel8/Expr/Aggregate.hs+88−75
@@ -1,6 +1,6 @@
1{-# language DataKinds #-}
1{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
3{-# language ScopedTypeVariables #-}
2{-# language ScopedTypeVariables #-}
3+{-# language TypeApplications #-}
4{-# language TypeFamilies #-}
4{-# language TypeFamilies #-}
5
5
6{-# options_ghc -fno-warn-redundant-constraints #-}
6{-# options_ghc -fno-warn-redundant-constraints #-}
@@ -10,11 +10,10 @@ module Rel8.Expr.Aggregate
10 , and, or
10 , and, or
11 , min, max
11 , min, max
12 , sum, sumWhere
12 , sum, sumWhere
13− , avg
14 , stringAgg
13 , stringAgg
15 , groupByExpr
14 , groupByExpr
16 , listAggExpr, nonEmptyAggExpr
15 , listAggExpr, nonEmptyAggExpr
17− , slistAggExpr, snonEmptyAggExpr
16+ , sgroupByExpr
18 )
17 )
19where
18where
20
19
@@ -24,12 +23,10 @@ import Data.List.NonEmpty ( NonEmpty )
24import Prelude hiding ( and, max, min, null, or, sum )
23import Prelude hiding ( and, max, min, null, or, sum )
25
24
26-- opaleye
25-- opaleye
27−import qualified Opaleye.Internal.Aggregate as Opaleye
26+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
28−import Opaleye.Internal.Column ( Field_( Column ) )
29−import qualified Opaleye.Aggregate as Opaleye
30
27
31-- rel8
28-- rel8
32−import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )
29+import Rel8.Aggregate ( Aggregate, Aggregator(..), unsafeMakeAggregate )
33import Rel8.Expr ( Expr )
30import Rel8.Expr ( Expr )
34import Rel8.Expr.Bool ( caseExpr )
31import Rel8.Expr.Bool ( caseExpr )
35import Rel8.Expr.Opaleye
32import Rel8.Expr.Opaleye
@@ -40,111 +37,127 @@ import Rel8.Expr.Opaleye
40 )
37 )
41import Rel8.Expr.Null ( null )
38import Rel8.Expr.Null ( null )
42import Rel8.Expr.Serialize ( litExpr )
39import Rel8.Expr.Serialize ( litExpr )
43−import Rel8.Schema.Null ( Sql, Unnullify )
40+import Rel8.Schema.Nullability ( Nullability, Nullabilizes, nullabilization )
44−import Rel8.Type ( DBType, typeInformation )
45−import Rel8.Type.Array ( encodeArrayElement )
41+import Rel8.Type.Array ( fromPrimArray )
46import Rel8.Type.Eq ( DBEq )
42import Rel8.Type.Eq ( DBEq )
47−import Rel8.Type.Information ( TypeInformation )
48import Rel8.Type.Num ( DBNum )
43import Rel8.Type.Num ( DBNum )
49import Rel8.Type.Ord ( DBMax, DBMin )
44import Rel8.Type.Ord ( DBMax, DBMin )
50import Rel8.Type.String ( DBString )
45import Rel8.Type.String ( DBString )
51import Rel8.Type.Sum ( DBSum )
46import Rel8.Type.Sum ( DBSum )
52
47
53
48
54−-- | Count the occurances of a single column. Corresponds to @COUNT(a)@
55−count :: Expr a -> Aggregate Int64
49+count :: Expr a -> Aggregate (Expr Int64)
56−count = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.count
50+count = unsafeMakeAggregate toPrimExpr fromPrimExpr $
51+ Just Aggregator
52+ { operation = Opaleye.AggrCount
53+ , ordering = []
54+ , distinction = Opaleye.AggrAll
55+ }
57
56
58−-- | Count the number of distinct occurances of a single column. Corresponds to
57+
59−-- @COUNT(DISTINCT a)@
60−countDistinct :: Sql DBEq a => Expr a -> Aggregate Int64
58+countDistinct :: DBEq a => Expr a -> Aggregate (Expr Int64)
61countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $
59countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $
62− Opaleye.distinctAggregator Opaleye.count
60+ Just Aggregator
61+ { operation = Opaleye.AggrCount
62+ , ordering = []
63+ , distinction = Opaleye.AggrDistinct
64+ }
63
65
64
66
65−-- | Corresponds to @COUNT(*)@.
66−countStar :: Aggregate Int64
67+countStar :: Aggregate (Expr Int64)
67countStar = count (litExpr True)
68countStar = count (litExpr True)
68
69
69
70
70−-- | A count of the number of times a given expression is @true@.
71−countWhere :: Expr Bool -> Aggregate Int64
71+countWhere :: Expr Bool -> Aggregate (Expr Int64)
72countWhere condition = count (caseExpr [(condition, litExpr (Just True))] null)
72countWhere condition = count (caseExpr [(condition, litExpr (Just True))] null)
73
73
74
74
75−-- | Corresponds to @bool_and@.
76−and :: Expr Bool -> Aggregate Bool
75+and :: Expr Bool -> Aggregate (Expr Bool)
77−and = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolAnd
76+and = unsafeMakeAggregate toPrimExpr fromPrimExpr $
77+ Just Aggregator
78+ { operation = Opaleye.AggrBoolAnd
79+ , ordering = []
80+ , distinction = Opaleye.AggrAll
81+ }
78
82
79
83
80−-- | Corresponds to @bool_or@.
81−or :: Expr Bool -> Aggregate Bool
84+or :: Expr Bool -> Aggregate (Expr Bool)
82−or = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolOr
85+or = unsafeMakeAggregate toPrimExpr fromPrimExpr $
86+ Just Aggregator
87+ { operation = Opaleye.AggrBoolOr
88+ , ordering = []
89+ , distinction = Opaleye.AggrAll
90+ }
83
91
84
92
85−-- | Produce an aggregation for @Expr a@ using the @max@ function.
86−max :: Sql DBMax a => Expr a -> Aggregate a
93+max :: (DBMax db, Nullabilizes db a) => Expr a -> Aggregate (Expr a)
87−max = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMax
94+max = unsafeMakeAggregate toPrimExpr fromPrimExpr $
95+ Just Aggregator
96+ { operation = Opaleye.AggrSum
97+ , ordering = []
98+ , distinction = Opaleye.AggrAll
99+ }
88
100
89
101
90−-- | Produce an aggregation for @Expr a@ using the @max@ function.
91−min :: Sql DBMin a => Expr a -> Aggregate a
102+min :: (DBMin db, Nullabilizes db a) => Expr a -> Aggregate (Expr a)
92−min = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMin
103+min = unsafeMakeAggregate toPrimExpr fromPrimExpr $
104+ Just Aggregator
105+ { operation = Opaleye.AggrSum
106+ , ordering = []
107+ , distinction = Opaleye.AggrAll
108+ }
93
109
94−-- | Corresponds to @sum@. Note that in SQL, @sum@ is type changing - for
95−-- 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
97−-- lead to overflows, and if you anticipate very large sums, you should upcast
98−-- your input.
99−sum :: Sql DBSum a => Expr a -> Aggregate a
100−sum = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) Opaleye.unsafeSum
101
110
111+sum :: (DBSum db, Nullabilizes db a) => Expr a -> Aggregate (Expr a)
112+sum = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $
113+ Just Aggregator
114+ { operation = Opaleye.AggrSum
115+ , ordering = []
116+ , distinction = Opaleye.AggrAll
117+ }
102
118
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
110
119
111−-- | Take the sum of all expressions that satisfy a predicate.
112−sumWhere :: (Sql DBNum a, Sql DBSum a)
120+sumWhere :: (DBNum db, DBSum db, Nullabilizes db a)
113− => Expr Bool -> Expr a -> Aggregate a
121+ => Expr Bool -> Expr a -> Aggregate (Expr a)
114sumWhere condition a = sum (caseExpr [(condition, a)] 0)
122sumWhere condition a = sum (caseExpr [(condition, a)] 0)
115
123
116
124
117−-- | Corresponds to @string_agg()@.
118−stringAgg :: Sql DBString a
125+stringAgg :: (DBString db, Nullabilizes db a)
119− => Expr db -> Expr a -> Aggregate a
126+ => Expr db -> Expr a -> Aggregate (Expr a)
120stringAgg delimiter =
127stringAgg delimiter =
121− unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) (Opaleye.stringAgg (Column (toPrimExpr delimiter)))
128+ unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $
122−
129+ Just Aggregator
123−
130+ { operation = Opaleye.AggrStringAggr (toPrimExpr delimiter)
124−-- | Aggregate a value by grouping by it.
131+ , ordering = []
125−groupByExpr :: Sql DBEq a => Expr a -> Aggregate a
132+ , distinction = Opaleye.AggrAll
126−groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.groupBy
133+ }
127
134
128
135
129−-- | Collect expressions values as a list.
136+groupByExpr :: (DBEq db, Nullabilizes db a) => Expr a -> Aggregate (Expr a)
130−listAggExpr :: Sql DBType a => Expr a -> Aggregate [a]
137+groupByExpr = sgroupByExpr nullabilization
131−listAggExpr = slistAggExpr typeInformation
132
138
133
139
134−-- | Collect expressions values as a non-empty list.
140+listAggExpr :: Expr a -> Aggregate (Expr [a])
135−nonEmptyAggExpr :: Sql DBType a => Expr a -> Aggregate (NonEmpty a)
141+listAggExpr = unsafeMakeAggregate toPrimExpr from $ Just
136−nonEmptyAggExpr = snonEmptyAggExpr typeInformation
142+ Aggregator
143+ { operation = Opaleye.AggrArr
144+ , ordering = []
145+ , distinction = Opaleye.AggrAll
146+ }
147+ where
148+ from = fromPrimExpr . fromPrimArray
137
149
138
150
139−slistAggExpr :: ()
151+nonEmptyAggExpr :: Expr a -> Aggregate (Expr (NonEmpty a))
140− => TypeInformation (Unnullify a) -> Expr a -> Aggregate [a]
152+nonEmptyAggExpr = unsafeMakeAggregate toPrimExpr from $ Just
141−slistAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg
153+ Aggregator
154+ { operation = Opaleye.AggrArr
155+ , ordering = []
156+ , distinction = Opaleye.AggrAll
157+ }
142 where
158 where
143− to = encodeArrayElement info . toPrimExpr
159+ from = fromPrimExpr . fromPrimArray
144
160
145
161
146−snonEmptyAggExpr :: ()
162+sgroupByExpr :: DBEq db => Nullability db a -> Expr a -> Aggregate (Expr a)
147− => TypeInformation (Unnullify a) -> Expr a -> Aggregate (NonEmpty a)
163+sgroupByExpr _ = unsafeMakeAggregate toPrimExpr fromPrimExpr Nothing
148−snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg
149− where
150− to = encodeArrayElement info . toPrimExpr
src/Rel8/Expr/Array.hs+14−19
@@ -1,12 +1,13 @@
1{-# language DataKinds #-}
1{-# language DataKinds #-}
2{-# language FlexibleContexts #-}
2{-# language FlexibleContexts #-}
3+{-# language ScopedTypeVariables #-}
4+{-# language TypeApplications #-}
3{-# language TypeFamilies #-}
5{-# language TypeFamilies #-}
4
6
5{-# options_ghc -fno-warn-redundant-constraints #-}
7{-# options_ghc -fno-warn-redundant-constraints #-}
6
8
7module Rel8.Expr.Array
9module Rel8.Expr.Array
8 ( listOf, nonEmptyOf
10 ( listOf, nonEmptyOf
9− , slistOf, snonEmptyOf
10 , sappend, sappend1, sempty
11 , sappend, sappend1, sempty
11 )
12 )
12where
13where
@@ -25,34 +26,28 @@ import Rel8.Expr.Opaleye
25 , zipPrimExprsWith
26 , zipPrimExprsWith
26 )
27 )
27import Rel8.Type ( DBType, typeInformation )
28import Rel8.Type ( DBType, typeInformation )
28−import Rel8.Type.Array ( array )
29+import Rel8.Type.Array ( array, zipPrimArraysWith )
29import Rel8.Type.Information ( TypeInformation(..) )
30import Rel8.Type.Information ( TypeInformation(..) )
30−import Rel8.Schema.Null ( Unnullify, Sql )
31+import Rel8.Schema.Nullability ( Nullability, Nullabilizes )
31
32
32
33
33sappend :: Expr [a] -> Expr [a] -> Expr [a]
34sappend :: Expr [a] -> Expr [a] -> Expr [a]
34−sappend = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
35+sappend = zipPrimExprsWith (zipPrimArraysWith (Opaleye.BinExpr (Opaleye.:||)))
35
36
36
37
37sappend1 :: Expr (NonEmpty a) -> Expr (NonEmpty a) -> Expr (NonEmpty a)
38sappend1 :: Expr (NonEmpty a) -> Expr (NonEmpty a) -> Expr (NonEmpty a)
38−sappend1 = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
39+sappend1 = zipPrimExprsWith (zipPrimArraysWith (Opaleye.BinExpr (Opaleye.:||)))
39
40
40
41
41−sempty :: TypeInformation (Unnullify a) -> Expr [a]
42+sempty :: Nullability t a -> TypeInformation t -> Expr [a]
42−sempty info = fromPrimExpr $ array info []
43+sempty _ info = fromPrimExpr $ array info []
43
44
44
45
45−slistOf :: TypeInformation (Unnullify a) -> [Expr a] -> Expr [a]
46+listOf :: forall a t. (Nullabilizes t a, DBType t)
47+ => [Expr a] -> Expr [a]
46−slistOf info = fromPrimExpr . array info . fmap toPrimExpr
48+listOf = fromPrimExpr . array (typeInformation @t) . fmap toPrimExpr
47
49
48
50
51+nonEmptyOf :: forall a t. (Nullabilizes t a, DBType t)
49−snonEmptyOf :: TypeInformation (Unnullify a) -> NonEmpty (Expr a) -> Expr (NonEmpty a)
52+ => NonEmpty (Expr a) -> Expr (NonEmpty a)
50−snonEmptyOf info = fromPrimExpr . array info . fmap toPrimExpr
53+nonEmptyOf = fromPrimExpr . array (typeInformation @t) . 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
src/Rel8/Expr/Bool.hs+42−8
@@ -1,5 +1,3 @@
1−{-# language GADTs #-}
2−
3module Rel8.Expr.Bool
1module Rel8.Expr.Bool
4 ( false, true
2 ( false, true
5 , (&&.), (||.), not_
3 , (&&.), (||.), not_
@@ -19,7 +17,7 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
19
17
20-- rel8
18-- rel8
21import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
19import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
22−import Rel8.Expr.Opaleye ( mapPrimExpr, toPrimExpr, zipPrimExprsWith )
20+import Rel8.Expr.Opaleye ( mapPrimExpr, zipPrimExprsWith )
23import Rel8.Expr.Serialize ( litExpr )
21import Rel8.Expr.Serialize ( litExpr )
24
22
25
23
@@ -34,28 +32,68 @@ true = litExpr True
34
32
35
33
36-- | The SQL @AND@ operator.
34-- | 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)
37(&&.) :: Expr Bool -> Expr Bool -> Expr Bool
46(&&.) :: Expr Bool -> Expr Bool -> Expr Bool
38(&&.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpAnd)
47(&&.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpAnd)
39infixr 3 &&.
48infixr 3 &&.
40
49
41
50
42-- | The SQL @OR@ operator.
51-- | 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)
43(||.) :: Expr Bool -> Expr Bool -> Expr Bool
63(||.) :: Expr Bool -> Expr Bool -> Expr Bool
44(||.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpOr)
64(||.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpOr)
45infixr 2 ||.
65infixr 2 ||.
46
66
47
67
48-- | The SQL @NOT@ operator.
68-- | The SQL @NOT@ operator.
69+--
70+-- >>> select c $ pure $ not_ $ lit True
71+-- [False]
72+--
73+-- >>> select c $ pure $ not_ $ lit False
74+-- [True]
49not_ :: Expr Bool -> Expr Bool
75not_ :: Expr Bool -> Expr Bool
50not_ = mapPrimExpr (Opaleye.UnExpr Opaleye.OpNot)
76not_ = mapPrimExpr (Opaleye.UnExpr Opaleye.OpNot)
51
77
52
78
53-- | Fold @AND@ over a collection of expressions.
79-- | 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]
54and_ :: Foldable f => f (Expr Bool) -> Expr Bool
86and_ :: Foldable f => f (Expr Bool) -> Expr Bool
55and_ = foldl' (&&.) true
87and_ = foldl' (&&.) true
56
88
57
89
58-- | Fold @OR@ over a collection of expressions.
90-- | 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]
59or_ :: Foldable f => f (Expr Bool) -> Expr Bool
97or_ :: Foldable f => f (Expr Bool) -> Expr Bool
60or_ = foldl' (||.) false
98or_ = foldl' (||.) false
61
99
@@ -77,13 +115,9 @@ caseExpr :: [(Expr Bool, Expr a)] -> Expr a -> Expr a
77caseExpr branches (Expr fallback) =
115caseExpr branches (Expr fallback) =
78 Expr $ Opaleye.CaseExpr (map go branches) fallback
116 Expr $ Opaleye.CaseExpr (map go branches) fallback
79 where
117 where
80− go (condition, value) = (toPrimExpr condition, toPrimExpr value)
118+ go (Expr condition, Expr value) = (condition, value)
81
119
82
120
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.
87coalesce :: Expr (Maybe Bool) -> Expr Bool
121coalesce :: Expr (Maybe Bool) -> Expr Bool
88coalesce (Expr a) = Expr a &&. Expr (Opaleye.FunExpr "COALESCE" [a, untrue])
122coalesce (Expr a) = Expr a &&. Expr (Opaleye.FunExpr "COALESCE" [a, untrue])
89 where
123 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+49−52
@@ -1,13 +1,12 @@
1−{-# language FlexibleContexts #-}
2{-# language GADTs #-}
1{-# language GADTs #-}
3−{-# language ScopedTypeVariables #-}
2+{-# language LambdaCase #-}
4−{-# language TypeApplications #-}
5{-# language ViewPatterns #-}
3{-# language ViewPatterns #-}
6
4
7{-# options_ghc -fno-warn-redundant-constraints #-}
5{-# options_ghc -fno-warn-redundant-constraints #-}
8
6
9module Rel8.Expr.Eq
7module Rel8.Expr.Eq
8+ ( seq, sne
10− ( (==.), (/=.)
9+ , (==.), (/=.)
11 , (==?), (/=?)
10 , (==?), (/=?)
12 , in_
11 , in_
13 )
12 )
@@ -16,7 +15,7 @@ where
16-- base
15-- base
17import Data.Foldable ( toList )
16import Data.Foldable ( toList )
18import Data.List.NonEmpty ( nonEmpty )
17import Data.List.NonEmpty ( nonEmpty )
19−import Prelude
18+import Prelude hiding ( seq, sin )
20
19
21-- opaleye
20-- opaleye
22import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
21import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
@@ -24,9 +23,12 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
24-- rel8
23-- rel8
25import Rel8.Expr ( Expr )
24import Rel8.Expr ( Expr )
26import Rel8.Expr.Bool ( (&&.), (||.), false, or_, coalesce )
25import Rel8.Expr.Bool ( (&&.), (||.), false, or_, coalesce )
27−import Rel8.Expr.Null ( isNull, unsafeLiftOpNull )
26+import Rel8.Expr.Null ( isNull, unsafeLiftOpNullable )
28import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr, zipPrimExprsWith )
27import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr, zipPrimExprsWith )
29−import Rel8.Schema.Null ( Nullity( NotNull, Null ), Sql, nullable )
28+import Rel8.Schema.Nullability
29+ ( Nullability( NonNullable, Nullable )
30+ , Nullabilizes, nullabilization
31+ )
30import Rel8.Type.Eq ( DBEq )
32import Rel8.Type.Eq ( DBEq )
31
33
32
34
@@ -38,64 +40,59 @@ ne :: DBEq a => Expr a -> Expr a -> Expr Bool
38ne = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:<>))
40ne = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:<>))
39
41
40
42
41−-- | Compare two expressions for equality.
42−--
43−-- This corresponds to the SQL @IS NOT DISTINCT FROM@ operator, and will equate
44−-- @null@ values as @true@. This differs from @=@ which would return @null@.
45−-- This operator matches Haskell's '==' operator. For an operator identical to
46−-- SQL @=@, see '==?'.
47−(==.) :: forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool
43+seq :: DBEq db => Nullability db a -> Expr a -> Expr a -> Expr Bool
48−(==.) = case nullable @a of
44+seq = \case
49− Null -> \ma mb -> isNull ma &&. isNull mb ||. ma ==? mb
45+ Nullable -> \ma mb -> isNull ma &&. isNull mb ||. ma ==? mb
50− NotNull -> eq
46+ NonNullable -> eq
47+
48+
49+sne :: DBEq db => Nullability db a -> Expr a -> Expr a -> Expr Bool
50+sne = \case
51+ Nullable -> \ma mb -> isNull ma `ne` isNull mb ||. ma /=? mb
52+ NonNullable -> ne
53+
54+
55+sin :: (DBEq db, Foldable f)
56+ => Nullability db a -> f (Expr a) -> Expr a -> Expr Bool
57+sin nullability (toList -> as) a = case nullability of
58+ Nullable -> or_ $ map (seq Nullable a) as
59+ NonNullable -> case nonEmpty as of
60+ Nothing -> false
61+ Just xs ->
62+ fromPrimExpr $
63+ Opaleye.BinExpr Opaleye.OpIn
64+ (toPrimExpr a)
65+ (Opaleye.ListExpr (toPrimExpr <$> xs))
66+
67+
68+(==.) :: (DBEq db, Nullabilizes db a) => Expr a -> Expr a -> Expr Bool
69+(==.) = seq nullabilization
51infix 4 ==.
70infix 4 ==.
52−{-# INLINABLE (==.) #-}
53
71
54
72
55−-- | Test if two expressions are different (not equal).
56−--
57−-- This corresponds to the SQL @IS DISTINCT FROM@ operator, and will return
58−-- @false@ when comparing two @null@ values. This differs from ordinary @=@
59−-- which would return @null@. This operator is closer to Haskell's '=='
60−-- operator. For an operator identical to SQL @=@, see '/=?'.
61−(/=.) :: forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool
73+(/=.) :: (DBEq db, Nullabilizes db a) => Expr a -> Expr a -> Expr Bool
62−(/=.) = case nullable @a of
74+(/=.) = sne nullabilization
63− Null -> \ma mb -> isNull ma `ne` isNull mb ||. ma /=? mb
64− NotNull -> ne
65infix 4 /=.
75infix 4 /=.
66−{-# INLINABLE (/=.) #-}
67
76
68
77
69−-- | Test if two expressions are equal. This operator is usually the best
70−-- choice when forming join conditions, as PostgreSQL has a much harder time
71−-- optimizing a join that has multiple 'True' conditions.
72−--
73−-- This corresponds to the SQL @=@ operator, though it will always return a
74−-- 'Bool'.
75(==?) :: DBEq a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
78(==?) :: DBEq a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
76−a ==? b = coalesce $ unsafeLiftOpNull eq a b
79+a ==? b = coalesce $ unsafeLiftOpNullable eq a b
77infix 4 ==?
80infix 4 ==?
78
81
79
82
80−-- | Test if two expressions are different.
81−--
82−-- This corresponds to the SQL @<>@ operator, though it will always return a
83−-- 'Bool'.
84(/=?) :: DBEq a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
83(/=?) :: DBEq a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
85−a /=? b = coalesce $ unsafeLiftOpNull ne a b
84+a /=? b = coalesce $ unsafeLiftOpNullable ne a b
86infix 4 /=?
85infix 4 /=?
87
86
88
87
89-- | Like the SQL @IN@ operator, but implemented by folding over a list with
88-- | Like the SQL @IN@ operator, but implemented by folding over a list with
90-- '==.' and '||.'.
89-- '==.' and '||.'.
90+--
91+-- >>> select c $ return $ lit (5 :: Int32) `in_` [ lit x | x <- [1..5] ]
92+-- [True]
93+--
94+-- >>> select c $ return $ lit (42 :: Int32) `in_` [ lit x | x <- [1..5] ]
95+-- [False]
91−in_ :: forall a f. (Sql DBEq a, Foldable f)
96+in_ :: (DBEq db, Nullabilizes db a, Foldable f)
92− => Expr a -> f (Expr a) -> Expr Bool
97+ => f (Expr a) -> Expr a -> Expr Bool
93−in_ a (toList -> as) = case nullable @a of
98+in_ = sin nullabilization
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))
src/Rel8/Expr/Function.hs+38−8
@@ -20,24 +20,22 @@ import Prelude
20import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
20import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
21
21
22-- rel8
22-- rel8
23−import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
23+import Rel8.Expr ( Expr( Expr ) )
24import Rel8.Expr.Opaleye
24import Rel8.Expr.Opaleye
25 ( castExpr
25 ( castExpr
26 , fromPrimExpr, toPrimExpr, zipPrimExprsWith
26 , fromPrimExpr, toPrimExpr, zipPrimExprsWith
27 )
27 )
28−import Rel8.Schema.Null ( Sql )
28+import Rel8.Schema.Nullability ( Nullabilizes )
29import Rel8.Type ( DBType )
29import Rel8.Type ( DBType )
30
30
31
31
32−-- | This type class exists to allow 'function' to have arbitrary arity. It's
33−-- mostly an implementation detail, and typical uses of 'Function' shouldn't
34−-- need this to be specified.
35type Function :: Type -> Type -> Constraint
32type Function :: Type -> Type -> Constraint
36class Function arg res where
33class Function arg res where
37 applyArgument :: ([Opaleye.PrimExpr] -> Opaleye.PrimExpr) -> arg -> res
34 applyArgument :: ([Opaleye.PrimExpr] -> Opaleye.PrimExpr) -> arg -> res
38
35
39
36
40−instance (arg ~ Expr a, Sql DBType b) => Function arg (Expr b) where
37+instance (arg ~ Expr a, DBType db, Nullabilizes db b) => Function arg (Expr b)
38+ where
41 applyArgument f a = castExpr $ fromPrimExpr $ f [toPrimExpr a]
39 applyArgument f a = castExpr $ fromPrimExpr $ f [toPrimExpr a]
42
40
43
41
@@ -47,17 +45,49 @@ instance (arg ~ Expr a, Function args res) => Function arg (args -> res) where
47
45
48-- | Construct an n-ary function that produces an 'Expr' that when called runs
46-- | Construct an n-ary function that produces an 'Expr' that when called runs
49-- a SQL function.
47-- a SQL function.
48+--
49+-- For example, here's how we can wrap PostgreSQL's @factorial@ function:
50+--
51+-- >>> :{
52+-- factorial :: Expr Int64 -> Expr Data.Scientific.Scientific
53+-- factorial = function "factorial"
54+-- :}
55+--
56+-- >>> select c $ pure $ factorial 5
57+-- [120.0]
58+--
59+-- The same approach works for any number of arguments:
60+--
61+-- >>> :{
62+-- power :: Expr Float -> Expr Float -> Expr Double
63+-- power = function "power"
64+-- :}
65+--
66+-- >>> select c $ pure $ power 9 3
67+-- [729.0]
50function :: Function args result => String -> args -> result
68function :: Function args result => String -> args -> result
51function = applyArgument . Opaleye.FunExpr
69function = applyArgument . Opaleye.FunExpr
52
70
53
71
54-- | Construct a function call for functions with no arguments.
72-- | Construct a function call for functions with no arguments.
73+--
74+-- For example, we can call the database function @pi()@ by using
55−nullaryFunction :: Sql DBType a => String -> Expr a
75+-- @nullaryFunction@:
76+--
77+-- >>> :{
78+-- sqlPi :: Expr Double
79+-- sqlPi = nullaryFunction "pi"
80+-- :}
81+--
82+-- >>> select c $ pure $ sqlPi
83+-- [3.141592653589793]
84+nullaryFunction :: (DBType db, Nullabilizes db a) => String -> Expr a
56nullaryFunction name = castExpr $ Expr (Opaleye.FunExpr name [])
85nullaryFunction name = castExpr $ Expr (Opaleye.FunExpr name [])
57
86
58
87
59-- | Construct an expression by applying an infix binary operator to two
88-- | Construct an expression by applying an infix binary operator to two
60-- operands.
89-- operands.
90+binaryOperator :: (DBType db, Nullabilizes db c)
61−binaryOperator :: Sql DBType c => String -> Expr a -> Expr b -> Expr c
91+ => String -> Expr a -> Expr b -> Expr c
62binaryOperator operator a b =
92binaryOperator operator a b =
63 castExpr $ zipPrimExprsWith (Opaleye.BinExpr (Opaleye.OpOther operator)) a b
93 castExpr $ zipPrimExprsWith (Opaleye.BinExpr (Opaleye.OpOther operator)) a b
src/Rel8/Expr/Null.hs+39−26
@@ -5,11 +5,11 @@
5{-# options -fno-warn-redundant-constraints #-}
5{-# options -fno-warn-redundant-constraints #-}
6
6
7module Rel8.Expr.Null
7module Rel8.Expr.Null
8− ( null, snull, nullableExpr, nullableOf
8+ ( null, snull, nullable, nullableOf
9 , isNull, isNonNull
9 , isNull, isNonNull
10 , nullify, unsafeUnnullify
10 , nullify, unsafeUnnullify
11− , mapNull, liftOpNull
11+ , mapNullable, liftOpNullable
12− , unsafeMapNull, unsafeLiftOpNull
12+ , unsafeMapNullable, unsafeLiftOpNullable
13 )
13 )
14where
14where
15
15
@@ -23,7 +23,7 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
23import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
23import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
24import Rel8.Expr.Bool ( (||.), boolExpr )
24import Rel8.Expr.Bool ( (||.), boolExpr )
25import Rel8.Expr.Opaleye ( scastExpr, mapPrimExpr )
25import Rel8.Expr.Opaleye ( scastExpr, mapPrimExpr )
26−import Rel8.Schema.Null ( NotNull )
26+import Rel8.Schema.Nullability ( Nullability( Nullable ), IsMaybe )
27import Rel8.Type ( DBType, typeInformation )
27import Rel8.Type ( DBType, typeInformation )
28import Rel8.Type.Information ( TypeInformation )
28import Rel8.Type.Information ( TypeInformation )
29
29
@@ -31,7 +31,7 @@ import Rel8.Type.Information ( TypeInformation )
31-- | Lift an expression that can't be @null@ to a type that might be @null@.
31-- | Lift an expression that can't be @null@ to a type that might be @null@.
32-- This is an identity operation in terms of any generated query, and just
32-- This is an identity operation in terms of any generated query, and just
33-- modifies the query's type.
33-- modifies the query's type.
34−nullify :: NotNull a => Expr a -> Expr (Maybe a)
34+nullify :: IsMaybe a ~ 'False => Expr a -> Expr (Maybe a)
35nullify (Expr a) = Expr a
35nullify (Expr a) = Expr a
36
36
37
37
@@ -40,63 +40,76 @@ unsafeUnnullify (Expr a) = Expr a
40
40
41
41
42-- | Like 'maybe', but to eliminate @null@.
42-- | Like 'maybe', but to eliminate @null@.
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]
43−nullableExpr :: Expr b -> (Expr a -> Expr b) -> Expr (Maybe a) -> Expr b
49+nullable :: Expr b -> (Expr a -> Expr b) -> Expr (Maybe a) -> Expr b
44−nullableExpr b f ma = boolExpr (f (unsafeUnnullify ma)) b (isNull ma)
50+nullable b f ma = boolExpr (f (unsafeUnnullify ma)) b (isNull ma)
45
51
46
52
53+nullableOf :: (IsMaybe a ~ 'False, DBType a)
47−nullableOf :: DBType a => Maybe (Expr a) -> Expr (Maybe a)
54+ => Maybe (Expr a) -> Expr (Maybe a)
48nullableOf = maybe null nullify
55nullableOf = maybe null nullify
49
56
50
57
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]
52isNull :: Expr (Maybe a) -> Expr Bool
65isNull :: Expr (Maybe a) -> Expr Bool
53isNull = mapPrimExpr (Opaleye.UnExpr Opaleye.OpIsNull)
66isNull = mapPrimExpr (Opaleye.UnExpr Opaleye.OpIsNull)
54
67
55
68
56−-- | Like 'Data.Maybe.isJust', but for @null@.
69+-- | Like 'isJust', but for @null@.
57isNonNull :: Expr (Maybe a) -> Expr Bool
70isNonNull :: Expr (Maybe a) -> Expr Bool
58isNonNull = mapPrimExpr (Opaleye.UnExpr Opaleye.OpIsNotNull)
71isNonNull = mapPrimExpr (Opaleye.UnExpr Opaleye.OpIsNotNull)
59
72
60
73
61-- | Lift an operation on non-@null@ values to an operation on possibly @null@
74-- | 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@.
63--
76--
64-- This is like 'fmap' for 'Maybe'.
77-- This is like 'fmap' for 'Maybe'.
65−mapNull :: DBType b
78+mapNullable :: (IsMaybe b ~ 'False, DBType b)
66 => (Expr a -> Expr b) -> Expr (Maybe a) -> Expr (Maybe b)
79 => (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)
68
81
69
82
70-- | Lift a binary operation on non-@null@ expressions to an equivalent binary
83-- | Lift a binary operation on non-@null@ expressions to an equivalent binary
71-- operator on possibly @null@ expressions. If either of the final arguments
84-- operator on possibly @null@ expressions. If either of the final arguments
72−-- are @null@, @liftOpNull@ returns @null@.
85+-- are @null@, @liftOpNullable@ returns @null@.
73--
86--
74-- This is like 'liftA2' for 'Maybe'.
87-- This is like 'liftA2' for 'Maybe'.
75−liftOpNull :: DBType c
88+liftOpNullable :: (IsMaybe c ~ 'False, DBType c)
76 => (Expr a -> Expr b -> Expr c)
89 => (Expr a -> Expr b -> Expr c)
77 -> Expr (Maybe a) -> Expr (Maybe b) -> Expr (Maybe c)
90 -> Expr (Maybe a) -> Expr (Maybe b) -> Expr (Maybe c)
78−liftOpNull f ma mb =
91+liftOpNullable f ma mb =
79− boolExpr (unsafeLiftOpNull f ma mb) null
92+ boolExpr (unsafeLiftOpNullable f ma mb) null
80 (isNull ma ||. isNull mb)
93 (isNull ma ||. isNull mb)
81−{-# INLINABLE liftOpNull #-}
82
94
83
95
84−snull :: TypeInformation a -> Expr (Maybe a)
96+snull :: Nullability a (Maybe a) -> TypeInformation a -> Expr (Maybe a)
97+snull nullability info =
85−snull info = scastExpr info $ Expr $ Opaleye.ConstExpr Opaleye.NullLit
98+ scastExpr nullability info $ Expr $ Opaleye.ConstExpr Opaleye.NullLit
86
99
87
100
88-- | Corresponds to SQL @null@.
101-- | Corresponds to SQL @null@.
89−null :: DBType a => Expr (Maybe a)
102+null :: (IsMaybe a ~ 'False, DBType a) => Expr (Maybe a)
90−null = snull typeInformation
103+null = snull Nullable typeInformation
91
104
92
105
93−unsafeMapNull :: NotNull b
106+unsafeMapNullable :: IsMaybe b ~ 'False
94 => (Expr a -> Expr b) -> Expr (Maybe a) -> Expr (Maybe b)
107 => (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))
96
109
97
110
98−unsafeLiftOpNull :: NotNull c
111+unsafeLiftOpNullable :: IsMaybe c ~ 'False
99 => (Expr a -> Expr b -> Expr c)
112 => (Expr a -> Expr b -> Expr c)
100 -> Expr (Maybe a) -> Expr (Maybe b) -> Expr (Maybe c)
113 -> Expr (Maybe a) -> Expr (Maybe b) -> Expr (Maybe c)
101−unsafeLiftOpNull f ma mb =
114+unsafeLiftOpNullable f ma mb =
102 nullify (f (unsafeUnnullify ma) (unsafeUnnullify mb))
115 nullify (f (unsafeUnnullify ma) (unsafeUnnullify mb))
src/Rel8/Expr/Num.hs+41−71
@@ -1,110 +1,80 @@
1−{-# language FlexibleContexts #-}
2{-# language TypeFamilies #-}
1{-# language TypeFamilies #-}
3
2
4{-# options_ghc -fno-warn-redundant-constraints #-}
3{-# options_ghc -fno-warn-redundant-constraints #-}
5
4
6module Rel8.Expr.Num
5module Rel8.Expr.Num
7− ( fromIntegral
8− , realToFrac
9− , div, mod, divMod
10− , quot, rem, quotRem
11− , ceiling, floor, round, truncate
6+ ( fromIntegral, realToFrac, div, mod, ceiling, floor, round, truncate
12 )
7 )
13where
8where
14
9
15-- base
10-- base
16−import Prelude ( (+), (-), fst, negate, signum, snd )
11+import Prelude ()
17
12
18-- rel
13-- rel
19import Rel8.Expr ( Expr( Expr ) )
14import Rel8.Expr ( Expr( Expr ) )
20−import Rel8.Expr.Eq ( (==.) )
21import Rel8.Expr.Function ( function )
15import Rel8.Expr.Function ( function )
22import Rel8.Expr.Opaleye ( castExpr )
16import Rel8.Expr.Opaleye ( castExpr )
23−import Rel8.Schema.Null ( Homonullable, Sql )
17+import Rel8.Schema.Nullability ( IsMaybe, Nullabilizes )
24−import Rel8.Table.Bool ( bool )
25import Rel8.Type.Num ( DBFractional, DBIntegral, DBNum )
18import Rel8.Type.Num ( DBFractional, DBIntegral, DBNum )
26
19
27
20
28−-- | Cast 'DBIntegral' types to 'DBNum' types. For example, this can be useful
21+fromIntegral ::
29−-- if you need to turn an @Expr Int32@ into an @Expr Double@.
22+ ( DBIntegral _a, Nullabilizes _a a
30−fromIntegral :: (Sql DBIntegral a, Sql DBNum b, Homonullable a b)
23+ , DBNum _b, Nullabilizes _b b
24+ , IsMaybe a ~ IsMaybe b
25+ )
31 => Expr a -> Expr b
26 => Expr a -> Expr b
32fromIntegral (Expr a) = castExpr (Expr a)
27fromIntegral (Expr a) = castExpr (Expr a)
33
28
34
29
35−-- | Cast 'DBNum' types to 'DBFractional' types. For example, his can be useful
30+realToFrac ::
36−-- to convert @Expr Float@ to @Expr Double@.
31+ ( DBNum _a, Nullabilizes _a a
37−realToFrac :: (Sql DBNum a, Sql DBFractional b, Homonullable a b)
32+ , DBFractional _b, Nullabilizes _b b
33+ , IsMaybe a ~ IsMaybe b
34+ )
38 => Expr a -> Expr b
35 => Expr a -> Expr b
39realToFrac (Expr a) = castExpr (Expr a)
36realToFrac (Expr a) = castExpr (Expr a)
40
37
41
38
42−-- | Round a 'DBFractional' to a 'DBIntegral' by rounding to the nearest larger
39+ceiling ::
43−-- integer.
40+ ( DBFractional _a, Nullabilizes _a a
44−--
41+ , DBIntegral _b, Nullabilizes _b b
45−-- Corresponds to the @ceiling()@ function.
42+ , IsMaybe a ~ IsMaybe b
46−ceiling :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)
43+ )
47 => Expr a -> Expr b
44 => Expr a -> Expr b
48−ceiling = function "ceiling"
45+ceiling = function "CEILING"
49−
50−
51−-- | Emulates the behaviour of the Haskell function 'Prelude.div' in
52−-- PostgreSQL.
53−div :: Sql DBIntegral a => Expr a -> Expr a -> Expr a
54−div n d = fst (divMod n d)
55−
56−
57−-- | Emulates the behaviour of the Haskell function 'Prelude.mod' in
58−-- PostgreSQL.
59−mod :: Sql DBIntegral a => Expr a -> Expr a -> Expr a
60−mod n d = snd (divMod n d)
61
46
62
47
63−-- | Simultaneous 'div' and 'mod'.
64−divMod :: Sql DBIntegral a => Expr a -> Expr a -> (Expr a, Expr a)
48+div :: (DBIntegral _a, Nullabilizes _a a) => Expr a -> Expr a -> Expr a
65−divMod n d = bool qr (q - 1, r + d) (signum r ==. negate (signum d))
49+div = function "DIV"
66− where
67− qr@(q, r) = quotRem n d
68
50
69
51
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
52+mod :: (DBIntegral _a, Nullabilizes _a a) => Expr a -> Expr a -> Expr a
74−quot = function "div"
53+mod = function "MOD"
75
54
76
55
77−-- | Corresponds to the @mod()@ function in PostgreSQL, which behaves like
56+floor ::
78−-- Haskell's 'Prelude.rem' rather than 'Prelude.mod'.
57+ ( DBFractional _a, Nullabilizes _a a
79−rem :: Sql DBIntegral a => Expr a -> Expr a -> Expr a
58+ , DBIntegral _b, Nullabilizes _b b
80−rem = function "mod"
59+ , IsMaybe a ~ IsMaybe b
81−
60+ )
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)
93 => Expr a -> Expr b
61 => Expr a -> Expr b
94−floor = function "floor"
62+floor = function "FLOOR"
95
63
96
64
97−-- | Round a 'DBFractional' to a 'DBIntegral' by rounding to the nearest
65+round ::
98−-- integer.
66+ ( DBFractional _a, Nullabilizes _a a
99−--
67+ , DBIntegral _b, Nullabilizes _b b
100−-- Corresponds to the @round()@ function.
68+ , IsMaybe a ~ IsMaybe b
101−round :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)
69+ )
102 => Expr a -> Expr b
70 => Expr a -> Expr b
103−round = function "round"
71+round = function "ROUND"
104
72
105
73
106−-- | Round a 'DBFractional' to a 'DBIntegral' by rounding to the nearest
74+truncate ::
107−-- integer towards zero.
75+ ( DBFractional _a, Nullabilizes _a a
108−truncate :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)
76+ , DBIntegral _b, Nullabilizes _b b
77+ , IsMaybe a ~ IsMaybe b
78+ )
109 => Expr a -> Expr b
79 => Expr a -> Expr b
110−truncate = function "trunc"
80+truncate = function "TRUNC"
src/Rel8/Expr/Opaleye.hs+15−29
@@ -1,6 +1,8 @@
1{-# language FlexibleContexts #-}
1{-# language FlexibleContexts #-}
2+{-# language LambdaCase #-}
2{-# language NamedFieldPuns #-}
3{-# language NamedFieldPuns #-}
3{-# language ScopedTypeVariables #-}
4{-# language ScopedTypeVariables #-}
5+{-# language TypeApplications #-}
4{-# language TypeFamilies #-}
6{-# language TypeFamilies #-}
5
7
6{-# options_ghc -fno-warn-redundant-constraints #-}
8{-# options_ghc -fno-warn-redundant-constraints #-}
@@ -10,7 +12,7 @@ module Rel8.Expr.Opaleye
10 , scastExpr, sunsafeCastExpr
12 , scastExpr, sunsafeCastExpr
11 , unsafeLiteral
13 , unsafeLiteral
12 , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith, traversePrimExpr
14 , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith, traversePrimExpr
13− , toColumn, fromColumn, traverseFieldP
15+ , toColumn, fromColumn
14 )
16 )
15where
17where
16
18
@@ -23,41 +25,31 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
23
25
24-- rel8
26-- rel8
25import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
27import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
26−import Rel8.Schema.Null ( Unnullify, Sql )
28+import Rel8.Schema.Nullability ( Nullability, Nullabilizes, nullabilization )
27import Rel8.Type ( DBType, typeInformation )
29import Rel8.Type ( DBType, typeInformation )
28import Rel8.Type.Information ( TypeInformation(..) )
30import Rel8.Type.Information ( TypeInformation(..) )
29
31
30−-- profunctors
31−import Data.Profunctor ( Profunctor, dimap )
32
32
33+castExpr :: (DBType db, Nullabilizes db a) => Expr a -> Expr a
34+castExpr = scastExpr nullabilization typeInformation
33
35
34−castExpr :: Sql DBType a => Expr a -> Expr a
35−castExpr = scastExpr typeInformation
36
36
37+unsafeCastExpr :: (DBType db, Nullabilizes db b) => Expr a -> Expr b
38+unsafeCastExpr = sunsafeCastExpr nullabilization typeInformation
37
39
38−-- | Cast an expression to a different type. Corresponds to a @CAST()@ function
39−-- call.
40−unsafeCastExpr :: Sql DBType b => Expr a -> Expr b
41−unsafeCastExpr = sunsafeCastExpr typeInformation
42
40
43−
44−scastExpr :: TypeInformation (Unnullify a) -> Expr a -> Expr a
41+scastExpr :: Nullability db a -> TypeInformation db -> Expr a -> Expr a
45scastExpr = sunsafeCastExpr
42scastExpr = sunsafeCastExpr
46
43
47
44
48sunsafeCastExpr :: ()
45sunsafeCastExpr :: ()
49− => TypeInformation (Unnullify b) -> Expr a -> Expr b
46+ => Nullability db b -> TypeInformation db -> Expr a -> Expr b
50−sunsafeCastExpr TypeInformation {typeName} =
47+sunsafeCastExpr _ TypeInformation {typeName} =
51 fromPrimExpr . Opaleye.CastExpr typeName . toPrimExpr
48 fromPrimExpr . Opaleye.CastExpr typeName . toPrimExpr
52
49
53
50
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
51+unsafeLiteral :: (DBType db, Nullabilizes db a) => String -> Expr a
60−unsafeLiteral = Expr . Opaleye.ConstExpr . Opaleye.OtherLit
52+unsafeLiteral = castExpr . Expr . Opaleye.ConstExpr . Opaleye.OtherLit
61
53
62
54
63fromPrimExpr :: Opaleye.PrimExpr -> Expr a
55fromPrimExpr :: Opaleye.PrimExpr -> Expr a
@@ -83,15 +75,9 @@ traversePrimExpr :: Functor f
83traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr
75traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr
84
76
85
77
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
93toColumn = Opaleye.Column
79toColumn = Opaleye.Column
94
80
95
81
96−fromColumn :: Opaleye.Field_ n b -> Opaleye.PrimExpr
82+fromColumn :: Opaleye.Column b -> Opaleye.PrimExpr
97fromColumn (Opaleye.Column a) = a
83fromColumn (Opaleye.Column a) = a
src/Rel8/Expr/Ord.hs+57−64
@@ -1,5 +1,5 @@
1{-# language DataKinds #-}
1{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
2+{-# language LambdaCase #-}
3{-# language GADTs #-}
3{-# language GADTs #-}
4{-# language ScopedTypeVariables #-}
4{-# language ScopedTypeVariables #-}
5{-# language TypeApplications #-}
5{-# language TypeApplications #-}
@@ -7,7 +7,8 @@
7{-# options_ghc -fno-warn-redundant-constraints #-}
7{-# options_ghc -fno-warn-redundant-constraints #-}
8
8
9module Rel8.Expr.Ord
9module Rel8.Expr.Ord
10+ ( slt, sle, sgt, sge
10− ( (<.), (<=.), (>.), (>=.)
11+ , (<.), (<=.), (>.), (>=.)
11 , (<?), (<=?), (>?), (>=?)
12 , (<?), (<=?), (>?), (>=?)
12 , leastExpr, greatestExpr
13 , leastExpr, greatestExpr
13 )
14 )
@@ -22,9 +23,12 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
22-- rel8
23-- rel8
23import Rel8.Expr ( Expr( Expr ) )
24import Rel8.Expr ( Expr( Expr ) )
24import Rel8.Expr.Bool ( (&&.), (||.), coalesce )
25import Rel8.Expr.Bool ( (&&.), (||.), coalesce )
25−import Rel8.Expr.Null ( isNull, isNonNull, nullableExpr, unsafeLiftOpNull )
26+import Rel8.Expr.Null ( isNull, isNonNull, nullable, unsafeLiftOpNullable )
26−import Rel8.Expr.Opaleye ( toPrimExpr, zipPrimExprsWith )
27+import Rel8.Expr.Opaleye ( zipPrimExprsWith )
27−import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
28+import Rel8.Schema.Nullability
29+ ( Nullability( NonNullable, Nullable )
30+ , Nullabilizes, nullabilization
31+ )
28import Rel8.Type.Ord ( DBOrd )
32import Rel8.Type.Ord ( DBOrd )
29
33
30
34
@@ -44,94 +48,83 @@ ge :: DBOrd a => Expr a -> Expr a -> Expr Bool
44ge = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:>=))
48ge = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:>=))
45
49
46
50
47−-- | Corresponds to the SQL @<@ operator. Note that this differs from SQL @<@
48−-- as @null@ will sort below any other value. For a version of @<@ that exactly
49−-- matches SQL, see '(<?)'.
50−(<.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool
51+slt :: DBOrd db => Nullability db a -> Expr a -> Expr a -> Expr Bool
51−(<.) = case nullable @a of
52+slt = \case
52− Null -> \ma mb -> isNull ma &&. isNonNull mb ||. ma <? mb
53+ Nullable -> \ma mb -> isNull ma &&. isNonNull mb ||. ma <? mb
53− NotNull -> lt
54+ NonNullable -> lt
55+
56+
57+sle :: DBOrd db => Nullability db a -> Expr a -> Expr a -> Expr Bool
58+sle = \case
59+ Nullable -> \ma mb -> isNull ma ||. ma <=? mb
60+ NonNullable -> le
61+
62+
63+sgt :: DBOrd db => Nullability db a -> Expr a -> Expr a -> Expr Bool
64+sgt = \case
65+ Nullable -> \ma mb -> isNonNull ma &&. isNull mb ||. ma >? mb
66+ NonNullable -> gt
67+
68+
69+sge :: DBOrd db => Nullability db a -> Expr a -> Expr a -> Expr Bool
70+sge = \case
71+ Nullable -> \ma mb -> isNull mb ||. ma >=? mb
72+ NonNullable -> ge
73+
74+
75+(<.) :: (DBOrd db, Nullabilizes db a) => Expr a -> Expr a -> Expr Bool
76+(<.) = slt nullabilization
54infix 4 <.
77infix 4 <.
55
78
56
79
57−-- | Corresponds to the SQL @<=@ operator. Note that this differs from SQL @<=@
58−-- as @null@ will sort below any other value. For a version of @<=@ that exactly
59−-- matches SQL, see '(<=?)'.
60−(<=.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool
80+(<=.) :: (DBOrd db, Nullabilizes db a) => Expr a -> Expr a -> Expr Bool
61−(<=.) = case nullable @a of
81+(<=.) = sle nullabilization
62− Null -> \ma mb -> isNull ma ||. ma <=? mb
63− NotNull -> le
64infix 4 <=.
82infix 4 <=.
65
83
66
84
67−-- | Corresponds to the SQL @>@ operator. Note that this differs from SQL @>@
68−-- as @null@ will sort below any other value. For a version of @>@ that exactly
69−-- matches SQL, see '(>?)'.
70−(>.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool
85+(>.) :: (DBOrd db, Nullabilizes db a) => Expr a -> Expr a -> Expr Bool
71−(>.) = case nullable @a of
86+(>.) = sgt nullabilization
72− Null -> \ma mb -> isNonNull ma &&. isNull mb ||. ma >? mb
73− NotNull -> gt
74infix 4 >.
87infix 4 >.
75
88
76
89
77−-- | Corresponds to the SQL @>=@ operator. Note that this differs from SQL @>@
78−-- as @null@ will sort below any other value. For a version of @>=@ that
79−-- exactly matches SQL, see '(>=?)'.
80−(>=.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool
90+(>=.) :: (DBOrd db, Nullabilizes db a) => Expr a -> Expr a -> Expr Bool
81−(>=.) = case nullable @a of
91+(>=.) = sge nullabilization
82− Null -> \ma mb -> isNull mb ||. ma >=? mb
83− NotNull -> ge
84infix 4 >=.
92infix 4 >=.
85
93
86
94
87−-- | Corresponds to the SQL @<@ operator. Returns @null@ if either arguments
88−-- are @null@.
89(<?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
95(<?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
90−a <? b = coalesce $ unsafeLiftOpNull lt a b
96+a <? b = coalesce $ unsafeLiftOpNullable lt a b
91infix 4 <?
97infix 4 <?
92
98
93
99
94−-- | Corresponds to the SQL @<=@ operator. Returns @null@ if either arguments
95−-- are @null@.
96(<=?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
100(<=?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
97−a <=? b = coalesce $ unsafeLiftOpNull le a b
101+a <=? b = coalesce $ unsafeLiftOpNullable le a b
98infix 4 <=?
102infix 4 <=?
99
103
100
104
101−-- | Corresponds to the SQL @>@ operator. Returns @null@ if either arguments
102−-- are @null@.
103(>?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
105(>?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
104−a >? b = coalesce $ unsafeLiftOpNull gt a b
106+a >? b = coalesce $ unsafeLiftOpNullable gt a b
105infix 4 >?
107infix 4 >?
106
108
107
109
108−-- | Corresponds to the SQL @>=@ operator. Returns @null@ if either arguments
109−-- are @null@.
110(>=?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
110(>=?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
111−a >=? b = coalesce $ unsafeLiftOpNull ge a b
111+a >=? b = coalesce $ unsafeLiftOpNullable ge a b
112infix 4 >=?
112infix 4 >=?
113
113
114
114
115−-- | Given two expressions, return the expression that sorts less than the
115+leastExpr :: forall a db. (DBOrd db, Nullabilizes db a)
116−-- other.
117−--
118−-- Corresponds to the SQL @least()@ function.
119−leastExpr :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr a
116+ => Expr a -> Expr a -> Expr a
120−leastExpr ma mb = case nullable @a of
117+leastExpr ma mb = case nullabilization @a of
121− Null -> nullableExpr ma (\a -> nullableExpr mb (least_ a) mb) ma
118+ Nullable -> nullable ma (\a -> nullable mb (least_ a) mb) ma
122− NotNull -> least_ ma mb
119+ NonNullable -> least_ ma mb
123 where
120 where
124− least_ a b = Expr (Opaleye.FunExpr "LEAST" [toPrimExpr a, toPrimExpr b])
121+ least_ (Expr a) (Expr b) = Expr (Opaleye.FunExpr "LEAST" [a, b])
125
122
126
123
127−-- | Given two expressions, return the expression that sorts greater than the
128−-- other.
129−--
130−-- Corresponds to the SQL @greatest()@ function.
131−greatestExpr :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr a
124+greatestExpr :: forall a db. (DBOrd db, Nullabilizes db a)
125+ => Expr a -> Expr a -> Expr a
132−greatestExpr ma mb = case nullable @a of
126+greatestExpr ma mb = case nullabilization @a of
133− Null -> nullableExpr mb (\a -> nullableExpr ma (greatest_ a) mb) ma
127+ Nullable -> nullable mb (\a -> nullable ma (greatest_ a) mb) ma
134− NotNull -> greatest_ ma mb
128+ NonNullable -> greatest_ ma mb
135 where
129 where
136− greatest_ a b =
137− Expr (Opaleye.FunExpr "GREATEST" [toPrimExpr a, toPrimExpr b])
130+ greatest_ (Expr a) (Expr b) = Expr (Opaleye.FunExpr "GREATEST" [a, b])
src/Rel8/Expr/Order.hs−6
@@ -27,7 +27,6 @@ import Rel8.Order ( Order( Order ) )
27import Rel8.Type.Ord ( DBOrd )
27import Rel8.Type.Ord ( DBOrd )
28
28
29
29
30−-- | Sort a column in ascending order.
31asc :: DBOrd a => Order (Expr a)
30asc :: DBOrd a => Order (Expr a)
32asc = Order $ Opaleye.Order (\expr -> [(orderOp, toPrimExpr expr)])
31asc = Order $ Opaleye.Order (\expr -> [(orderOp, toPrimExpr expr)])
33 where
32 where
@@ -38,7 +37,6 @@ asc = Order $ Opaleye.Order (\expr -> [(orderOp, toPrimExpr expr)])
38 }
37 }
39
38
40
39
41−-- | Sort a column in descending order.
42desc :: DBOrd a => Order (Expr a)
40desc :: DBOrd a => Order (Expr a)
43desc = Order $ Opaleye.Order (\expr -> [(orderOp, toPrimExpr expr)])
41desc = Order $ Opaleye.Order (\expr -> [(orderOp, toPrimExpr expr)])
44 where
42 where
@@ -49,8 +47,6 @@ desc = Order $ Opaleye.Order (\expr -> [(orderOp, toPrimExpr expr)])
49 }
47 }
50
48
51
49
52−-- | Transform an ordering so that @null@ values appear first. This corresponds
53−-- to @NULLS FIRST@ in SQL.
54nullsFirst :: Order (Expr a) -> Order (Expr (Maybe a))
50nullsFirst :: Order (Expr a) -> Order (Expr (Maybe a))
55nullsFirst (Order (Opaleye.Order f)) =
51nullsFirst (Order (Opaleye.Order f)) =
56 Order $ Opaleye.Order $ fmap (first g) . f . unsafeUnnullify
52 Order $ Opaleye.Order $ fmap (first g) . f . unsafeUnnullify
@@ -59,8 +55,6 @@ nullsFirst (Order (Opaleye.Order f)) =
59 g orderOp = orderOp { Opaleye.orderNulls = Opaleye.NullsFirst }
55 g orderOp = orderOp { Opaleye.orderNulls = Opaleye.NullsFirst }
60
56
61
57
62−-- | Transform an ordering so that @null@ values appear first. This corresponds
63−-- to @NULLS LAST@ in SQL.
64nullsLast :: Order (Expr a) -> Order (Expr (Maybe a))
58nullsLast :: Order (Expr a) -> Order (Expr (Maybe a))
65nullsLast (Order (Opaleye.Order f)) =
59nullsLast (Order (Opaleye.Order f)) =
66 Order $ Opaleye.Order $ fmap (first g) . f . unsafeUnnullify
60 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+16−18
@@ -1,4 +1,3 @@
1−{-# language FlexibleContexts #-}
2{-# language NamedFieldPuns #-}
1{-# language NamedFieldPuns #-}
3{-# language TypeFamilies #-}
2{-# language TypeFamilies #-}
4
3
@@ -21,29 +20,28 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
21-- rel8
20-- rel8
22import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
21import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
23import Rel8.Expr.Opaleye ( scastExpr )
22import Rel8.Expr.Opaleye ( scastExpr )
24−import Rel8.Schema.Null ( Unnullify, Nullity( Null, NotNull ), Sql, nullable )
23+import Rel8.Schema.Nullability
24+ ( Nullability( Nullable, NonNullable )
25+ , Nullabilizes, nullabilization
26+ )
25import Rel8.Type ( DBType, typeInformation )
27import Rel8.Type ( DBType, typeInformation )
26import Rel8.Type.Information ( TypeInformation(..) )
28import Rel8.Type.Information ( TypeInformation(..) )
27
29
28
30
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.
33−litExpr :: Sql DBType a => a -> Expr a
31+litExpr :: (DBType db, Nullabilizes db a) => a -> Expr a
34−litExpr = slitExpr nullable typeInformation
32+litExpr = slitExpr nullabilization typeInformation
35
33
36
34
37−slitExpr :: Nullity a -> TypeInformation (Unnullify a) -> a -> Expr a
35+slitExpr :: Nullability db a -> TypeInformation db -> a -> Expr a
38−slitExpr nullity info@TypeInformation {encode} =
36+slitExpr nullable info@TypeInformation {encode} =
39− scastExpr info . Expr . encoder
37+ scastExpr nullable info . Expr . encoder
40 where
38 where
41− encoder = case nullity of
39+ encoder = case nullable of
42− Null -> maybe (Opaleye.ConstExpr Opaleye.NullLit) encode
40+ Nullable -> maybe (Opaleye.ConstExpr Opaleye.NullLit) encode
43− NotNull -> encode
41+ NonNullable -> encode
44
42
45
43
46−sparseValue :: Nullity a -> TypeInformation (Unnullify a) -> Hasql.Row a
44+sparseValue :: Nullability db a -> TypeInformation db -> Hasql.Row a
47−sparseValue nullity TypeInformation {decode} = case nullity of
45+sparseValue nullability TypeInformation {decode, out} = case nullability of
48− Null -> Hasql.column $ Hasql.nullable decode
46+ Nullable -> Hasql.column $ Hasql.nullable $ out <$> decode
49− NotNull -> Hasql.column $ Hasql.nonNullable decode
47+ NonNullable -> Hasql.column $ Hasql.nonNullable $ out <$> decode
src/Rel8/Expr/Text.hs+11−66
@@ -16,10 +16,7 @@ module Rel8.Expr.Text
16 , initcap, left, length, lengthEncoding, lpad, ltrim, md5
16 , initcap, left, length, lengthEncoding, lpad, ltrim, md5
17 , pgClientEncoding, quoteIdent, quoteLiteral, quoteNullable, regexpReplace
17 , pgClientEncoding, quoteIdent, quoteLiteral, quoteNullable, regexpReplace
18 , regexpSplitToArray, repeat, replace, reverse, right, rpad, rtrim
18 , regexpSplitToArray, repeat, replace, reverse, right, rpad, rtrim
19− , splitPart, strpos, substr, translate
19+ , splitPart, strpos, substr, toAscii, toHex, translate
20−
21− -- * @LIKE@ and @ILIKE@
22− , like, ilike
23 )
20 )
24where
21where
25
22
@@ -27,7 +24,7 @@ where
27import Data.Bool ( Bool )
24import Data.Bool ( Bool )
28import Data.Int ( Int32 )
25import Data.Int ( Int32 )
29import Data.Maybe ( Maybe( Nothing, Just ) )
26import Data.Maybe ( Maybe( Nothing, Just ) )
30−import Prelude ( flip )
27+import Prelude ()
31
28
32-- bytestring
29-- bytestring
33import Data.ByteString ( ByteString )
30import Data.ByteString ( ByteString )
@@ -35,6 +32,7 @@ import Data.ByteString ( ByteString )
35-- rel8
32-- rel8
36import Rel8.Expr ( Expr )
33import Rel8.Expr ( Expr )
37import Rel8.Expr.Function ( binaryOperator, function, nullaryFunction )
34import Rel8.Expr.Function ( binaryOperator, function, nullaryFunction )
35+import Rel8.Type.Array1D ( Array1D )
38
36
39-- text
37-- text
40import Data.Text (Text)
38import Data.Text (Text)
@@ -52,32 +50,24 @@ infixr 6 ++.
52
50
53
51
54-- | Matches regular expression, case sensitive
52-- | Matches regular expression, case sensitive
55−--
56−-- Corresponds to the @~.@ operator.
57(~.) :: Expr Text -> Expr Text -> Expr Bool
53(~.) :: Expr Text -> Expr Text -> Expr Bool
58(~.) = binaryOperator "~."
54(~.) = binaryOperator "~."
59infix 2 ~.
55infix 2 ~.
60
56
61
57
62-- | Matches regular expression, case insensitive
58-- | Matches regular expression, case insensitive
63−--
64−-- Corresponds to the @~*@ operator.
65(~*) :: Expr Text -> Expr Text -> Expr Bool
59(~*) :: Expr Text -> Expr Text -> Expr Bool
66(~*) = binaryOperator "~*"
60(~*) = binaryOperator "~*"
67infix 2 ~*
61infix 2 ~*
68
62
69
63
70-- | Does not match regular expression, case sensitive
64-- | Does not match regular expression, case sensitive
71−--
72−-- Corresponds to the @!~@ operator.
73(!~) :: Expr Text -> Expr Text -> Expr Bool
65(!~) :: Expr Text -> Expr Text -> Expr Bool
74(!~) = binaryOperator "!~"
66(!~) = binaryOperator "!~"
75infix 2 !~
67infix 2 !~
76
68
77
69
78-- | Does not match regular expression, case insensitive
70-- | Does not match regular expression, case insensitive
79−--
80−-- Corresponds to the @!~*@ operator.
81(!~*) :: Expr Text -> Expr Text -> Expr Bool
71(!~*) :: Expr Text -> Expr Text -> Expr Bool
82(!~*) = binaryOperator "!~*"
72(!~*) = binaryOperator "!~*"
83infix 2 !~*
73infix 2 !~*
@@ -88,209 +78,164 @@ infix 2 !~*
88-- * Standard SQL functions
78-- * Standard SQL functions
89
79
90
80
91−-- | Corresponds to the @bit_length@ function.
92bitLength :: Expr Text -> Expr Int32
81bitLength :: Expr Text -> Expr Int32
93bitLength = function "bit_length"
82bitLength = function "bit_length"
94
83
95
84
96−-- | Corresponds to the @char_length@ function.
97charLength :: Expr Text -> Expr Int32
85charLength :: Expr Text -> Expr Int32
98charLength = function "char_length"
86charLength = function "char_length"
99
87
100
88
101−-- | Corresponds to the @lower@ function.
102lower :: Expr Text -> Expr Text
89lower :: Expr Text -> Expr Text
103lower = function "lower"
90lower = function "lower"
104
91
105
92
106−-- | Corresponds to the @octet_length@ function.
107octetLength :: Expr Text -> Expr Int32
93octetLength :: Expr Text -> Expr Int32
108octetLength = function "octet_length"
94octetLength = function "octet_length"
109
95
110
96
111−-- | Corresponds to the @upper@ function.
112upper :: Expr Text -> Expr Text
97upper :: Expr Text -> Expr Text
113upper = function "upper"
98upper = function "upper"
114
99
115
100
116−-- | Corresponds to the @ascii@ function.
101+-- * PostgreSQL functions
117ascii :: Expr Text -> Expr Int32
102ascii :: Expr Text -> Expr Int32
118ascii = function "ascii"
103ascii = function "ascii"
119
104
120
105
121−-- | Corresponds to the @btrim@ function.
122btrim :: Expr Text -> Maybe (Expr Text) -> Expr Text
106btrim :: Expr Text -> Maybe (Expr Text) -> Expr Text
123btrim a (Just b) = function "btrim" a b
107btrim a (Just b) = function "btrim" a b
124btrim a Nothing = function "btrim" a
108btrim a Nothing = function "btrim" a
125
109
126
110
127−-- | Corresponds to the @chr@ function.
128chr :: Expr Int32 -> Expr Text
111chr :: Expr Int32 -> Expr Text
129chr = function "chr"
112chr = function "chr"
130
113
131
114
132−-- | Corresponds to the @convert@ function.
133convert :: Expr ByteString -> Expr Text -> Expr Text -> Expr ByteString
115convert :: Expr ByteString -> Expr Text -> Expr Text -> Expr ByteString
134convert = function "convert"
116convert = function "convert"
135
117
136
118
137−-- | Corresponds to the @convert_from@ function.
138convertFrom :: Expr ByteString -> Expr Text -> Expr Text
119convertFrom :: Expr ByteString -> Expr Text -> Expr Text
139convertFrom = function "convert_from"
120convertFrom = function "convert_from"
140
121
141
122
142−-- | Corresponds to the @convert_to@ function.
143convertTo :: Expr Text -> Expr Text -> Expr ByteString
123convertTo :: Expr Text -> Expr Text -> Expr ByteString
144convertTo = function "convert_to"
124convertTo = function "convert_to"
145
125
146
126
147−-- | Corresponds to the @decode@ function.
148decode :: Expr Text -> Expr Text -> Expr ByteString
127decode :: Expr Text -> Expr Text -> Expr ByteString
149decode = function "decode"
128decode = function "decode"
150
129
151
130
152−-- | Corresponds to the @encode@ function.
153encode :: Expr ByteString -> Expr Text -> Expr Text
131encode :: Expr ByteString -> Expr Text -> Expr Text
154encode = function "encode"
132encode = function "encode"
155
133
156
134
157−-- | Corresponds to the @initcap@ function.
158initcap :: Expr Text -> Expr Text
135initcap :: Expr Text -> Expr Text
159initcap = function "initcap"
136initcap = function "initcap"
160
137
161
138
162−-- | Corresponds to the @left@ function.
163left :: Expr Text -> Expr Int32 -> Expr Text
139left :: Expr Text -> Expr Int32 -> Expr Text
164left = function "left"
140left = function "left"
165
141
166
142
167−-- | Corresponds to the @length@ function.
168length :: Expr Text -> Expr Int32
143length :: Expr Text -> Expr Int32
169length = function "length"
144length = function "length"
170
145
171
146
172−-- | Corresponds to the @length@ function.
173lengthEncoding :: Expr ByteString -> Expr Text -> Expr Int32
147lengthEncoding :: Expr ByteString -> Expr Text -> Expr Int32
174lengthEncoding = function "length"
148lengthEncoding = function "length"
175
149
176
150
177−-- | Corresponds to the @lpad@ function.
178lpad :: Expr Text -> Expr Int32 -> Maybe (Expr Text) -> Expr Text
151lpad :: Expr Text -> Expr Int32 -> Maybe (Expr Text) -> Expr Text
179lpad a b (Just c) = function "lpad" a b c
152lpad a b (Just c) = function "lpad" a b c
180lpad a b Nothing = function "lpad" a b
153lpad a b Nothing = function "lpad" a b
181
154
182
155
183−-- | Corresponds to the @ltrim@ function.
184ltrim :: Expr Text -> Maybe (Expr Text) -> Expr Text
156ltrim :: Expr Text -> Maybe (Expr Text) -> Expr Text
185ltrim a (Just b) = function "ltrim" a b
157ltrim a (Just b) = function "ltrim" a b
186ltrim a Nothing = function "ltrim" a
158ltrim a Nothing = function "ltrim" a
187
159
188
160
189−-- | Corresponds to the @md5@ function.
190md5 :: Expr Text -> Expr Text
161md5 :: Expr Text -> Expr Text
191md5 = function "md5"
162md5 = function "md5"
192
163
193
164
194−-- | Corresponds to the @pg_client_encoding()@ expression.
195pgClientEncoding :: Expr Text
165pgClientEncoding :: Expr Text
196pgClientEncoding = nullaryFunction "pg_client_encoding"
166pgClientEncoding = nullaryFunction "pg_client_encoding"
197
167
198
168
199−-- | Corresponds to the @quote_ident@ function.
200quoteIdent :: Expr Text -> Expr Text
169quoteIdent :: Expr Text -> Expr Text
201quoteIdent = function "quote_ident"
170quoteIdent = function "quote_ident"
202
171
203
172
204−-- | Corresponds to the @quote_literal@ function.
205quoteLiteral :: Expr Text -> Expr Text
173quoteLiteral :: Expr Text -> Expr Text
206quoteLiteral = function "quote_literal"
174quoteLiteral = function "quote_literal"
207
175
208
176
209−-- | Corresponds to the @quote_nullable@ function.
210quoteNullable :: Expr Text -> Expr Text
177quoteNullable :: Expr Text -> Expr Text
211quoteNullable = function "quote_nullable"
178quoteNullable = function "quote_nullable"
212
179
213
180
214−-- | Corresponds to the @regexp_replace@ function.
215regexpReplace :: ()
181regexpReplace :: ()
216 => Expr Text -> Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr Text
182 => Expr Text -> Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr Text
217regexpReplace a b c (Just d) = function "regexp_replace" a b c d
183regexpReplace a b c (Just d) = function "regexp_replace" a b c d
218regexpReplace a b c Nothing = function "regexp_replace" a b c
184regexpReplace a b c Nothing = function "regexp_replace" a b c
219
185
220
186
221−-- | Corresponds to the @regexp_split_to_array@ function.
222regexpSplitToArray :: ()
187regexpSplitToArray :: ()
223− => Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr [Text]
188+ => Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr (Array1D Text)
224regexpSplitToArray a b (Just c) = function "regexp_split_to_array" a b c
189regexpSplitToArray a b (Just c) = function "regexp_split_to_array" a b c
225regexpSplitToArray a b Nothing = function "regexp_split_to_array" a b
190regexpSplitToArray a b Nothing = function "regexp_split_to_array" a b
226
191
227
192
228−-- | Corresponds to the @repeat@ function.
229repeat :: Expr Text -> Expr Int32 -> Expr Text
193repeat :: Expr Text -> Expr Int32 -> Expr Text
230repeat = function "repeat"
194repeat = function "repeat"
231
195
232
196
233−-- | Corresponds to the @replace@ function.
234replace :: Expr Text -> Expr Text -> Expr Text -> Expr Text
197replace :: Expr Text -> Expr Text -> Expr Text -> Expr Text
235replace = function "replace"
198replace = function "replace"
236
199
237
200
238−-- | Corresponds to the @reverse@ function.
239reverse :: Expr Text -> Expr Text
201reverse :: Expr Text -> Expr Text
240reverse = function "reverse"
202reverse = function "reverse"
241
203
242
204
243−-- | Corresponds to the @right@ function.
244right :: Expr Text -> Expr Int32 -> Expr Text
205right :: Expr Text -> Expr Int32 -> Expr Text
245right = function "right"
206right = function "right"
246
207
247
208
248−-- | Corresponds to the @rpad@ function.
249rpad :: Expr Text -> Expr Int32 -> Maybe (Expr Text) -> Expr Text
209rpad :: Expr Text -> Expr Int32 -> Maybe (Expr Text) -> Expr Text
250rpad a b (Just c) = function "rpad" a b c
210rpad a b (Just c) = function "rpad" a b c
251rpad a b Nothing = function "rpad" a b
211rpad a b Nothing = function "rpad" a b
252
212
253
213
254−-- | Corresponds to the @rtrim@ function.
255rtrim :: Expr Text -> Maybe (Expr Text) -> Expr Text
214rtrim :: Expr Text -> Maybe (Expr Text) -> Expr Text
256rtrim a (Just b) = function "rtrim" a b
215rtrim a (Just b) = function "rtrim" a b
257rtrim a Nothing = function "rtrim" a
216rtrim a Nothing = function "rtrim" a
258
217
259
218
260−-- | Corresponds to the @split_part@ function.
261splitPart :: Expr Text -> Expr Text -> Expr Int32 -> Expr Text
219splitPart :: Expr Text -> Expr Text -> Expr Int32 -> Expr Text
262splitPart = function "split_part"
220splitPart = function "split_part"
263
221
264
222
265−-- | Corresponds to the @strpos@ function.
266strpos :: Expr Text -> Expr Text -> Expr Int32
223strpos :: Expr Text -> Expr Text -> Expr Int32
267strpos = function "strpos"
224strpos = function "strpos"
268
225
269
226
270−-- | Corresponds to the @substr@ function.
271substr :: Expr Text -> Expr Int32 -> Maybe (Expr Int32) -> Expr Text
227substr :: Expr Text -> Expr Int32 -> Maybe (Expr Int32) -> Expr Text
272substr a b (Just c) = function "substr" a b c
228substr a b (Just c) = function "substr" a b c
273substr a b Nothing = function "substr" a b
229substr a b Nothing = function "substr" a b
274
230
275
231
276−-- | Corresponds to the @translate@ function.
277−translate :: Expr Text -> Expr Text -> Expr Text -> Expr Text
232+toAscii :: Expr Text -> Expr Text -> Expr Text
278−translate = function "translate"
233+toAscii = function "toAscii"
279
234
280
235
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
236+toHex :: Expr Int32 -> Expr Text
287−like = flip (binaryOperator "LIKE")
237+toHex = function "toHex"
288
238
289
239
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
240+translate :: Expr Text -> Expr Text -> Expr Text -> Expr Text
296−ilike = flip (binaryOperator "ILIKE")
241+translate = function "translate"
src/Rel8/Expr/Time.hs+24−36
@@ -13,13 +13,12 @@ module Rel8.Expr.Time
13 , diffTime
13 , diffTime
14 , subtractTime
14 , subtractTime
15
15
16− -- * Working with @CalendarDiffTime@
16+ -- Working with @DiffTime@
17 , scaleInterval
17 , scaleInterval
18 , second, seconds
18 , second, seconds
19 , minute, minutes
19 , minute, minutes
20 , hour, hours
20 , hour, hours
21 , day, days
21 , day, days
22− , week, weeks
23 , month, months
22 , month, months
24 , year, years
23 , year, years
25 ) where
24 ) where
@@ -31,12 +30,11 @@ import Prelude
31-- rel8
30-- rel8
32import Rel8.Expr ( Expr )
31import Rel8.Expr ( Expr )
33import Rel8.Expr.Function ( binaryOperator, nullaryFunction )
32import Rel8.Expr.Function ( binaryOperator, nullaryFunction )
34−import Rel8.Expr.Opaleye ( castExpr, unsafeCastExpr, unsafeLiteral )
33+import Rel8.Expr.Opaleye ( unsafeCastExpr, unsafeLiteral )
35
34
36-- time
35-- time
37import Data.Time.Calendar ( Day )
36import Data.Time.Calendar ( Day )
38−import Data.Time.Clock ( UTCTime )
37+import Data.Time.Clock ( DiffTime, UTCTime )
39−import Data.Time.LocalTime ( CalendarDiffTime )
40
38
41
39
42-- | Corresponds to @date(now())@.
40-- | Corresponds to @date(now())@.
@@ -75,93 +73,83 @@ now = nullaryFunction "now"
75
73
76
74
77-- | Add a time interval to a point in time, yielding a new point in time.
75-- | 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
79addTime = flip (binaryOperator "+")
77addTime = flip (binaryOperator "+")
80
78
81
79
82-- | Find the duration between two times.
80-- | Find the duration between two times.
83−diffTime :: Expr UTCTime -> Expr UTCTime -> Expr CalendarDiffTime
81+diffTime :: Expr UTCTime -> Expr UTCTime -> Expr DiffTime
84diffTime = binaryOperator "-"
82diffTime = binaryOperator "-"
85
83
86
84
87-- | Subtract a time interval from a point in time, yielding a new point in time.
85-- | 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
89subtractTime = flip (binaryOperator "-")
87subtractTime = flip (binaryOperator "-")
90
88
91
89
92−scaleInterval :: Expr Double -> Expr CalendarDiffTime -> Expr CalendarDiffTime
90+scaleInterval :: Expr Double -> Expr DiffTime -> Expr DiffTime
93scaleInterval = binaryOperator "*"
91scaleInterval = binaryOperator "*"
94
92
95
93
96-- | An interval of one second.
94-- | An interval of one second.
97−second :: Expr CalendarDiffTime
95+second :: Expr DiffTime
98second = singleton "second"
96second = singleton "second"
99
97
100
98
101−-- | Create a literal interval from a number of seconds.
99+-- | Create a literal interval from an integral number of seconds.
102−seconds :: Expr Double -> Expr CalendarDiffTime
100+seconds :: Expr Double -> Expr DiffTime
103seconds = (`scaleInterval` second)
101seconds = (`scaleInterval` second)
104
102
105
103
106-- | An interval of one minute.
104-- | An interval of one minute.
107−minute :: Expr CalendarDiffTime
105+minute :: Expr DiffTime
108minute = singleton "minute"
106minute = singleton "minute"
109
107
110
108
111−-- | Create a literal interval from a number of minutes.
109+-- | Create a literal interval from an integral number of minutes.
112−minutes :: Expr Double -> Expr CalendarDiffTime
110+minutes :: Expr Double -> Expr DiffTime
113minutes = (`scaleInterval` minute)
111minutes = (`scaleInterval` minute)
114
112
115
113
116-- | An interval of one hour.
114-- | An interval of one hour.
117−hour :: Expr CalendarDiffTime
115+hour :: Expr DiffTime
118hour = singleton "hour"
116hour = singleton "hour"
119
117
120
118
121−-- | Create a literal interval from a number of hours.
119+-- | Create a literal interval from an integral number of hours.
122−hours :: Expr Double -> Expr CalendarDiffTime
120+hours :: Expr Double -> Expr DiffTime
123hours = (`scaleInterval` hour)
121hours = (`scaleInterval` hour)
124
122
125
123
126-- | An interval of one day.
124-- | An interval of one day.
127−day :: Expr CalendarDiffTime
125+day :: Expr DiffTime
128day = singleton "day"
126day = singleton "day"
129
127
130
128
131-- | Create a literal interval from a number of days.
129-- | Create a literal interval from a number of days.
132−days :: Expr Double -> Expr CalendarDiffTime
130+days :: Expr Double -> Expr DiffTime
133days = (`scaleInterval` day)
131days = (`scaleInterval` day)
134
132
135
133
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−
146-- | An interval of one month.
134-- | An interval of one month.
147−month :: Expr CalendarDiffTime
135+month :: Expr DiffTime
148month = singleton "month"
136month = singleton "month"
149
137
150
138
151-- | Create a literal interval from a number of months.
139-- | Create a literal interval from a number of months.
152−months :: Expr Double -> Expr CalendarDiffTime
140+months :: Expr Double -> Expr DiffTime
153months = (`scaleInterval` month)
141months = (`scaleInterval` month)
154
142
155
143
156-- | An interval of one year.
144-- | An interval of one year.
157−year :: Expr CalendarDiffTime
145+year :: Expr DiffTime
158year = singleton "year"
146year = singleton "year"
159
147
160
148
161-- | Create a literal interval from a number of years.
149-- | Create a literal interval from a number of years.
162−years :: Expr Double -> Expr CalendarDiffTime
150+years :: Expr Double -> Expr DiffTime
163years = (`scaleInterval` year)
151years = (`scaleInterval` year)
164
152
165
153
166−singleton :: String -> Expr CalendarDiffTime
154+singleton :: String -> Expr DiffTime
167−singleton unit = castExpr $ unsafeLiteral $ "'1 " ++ unit ++ "'"
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.hsdeleted−26
@@ -1,26 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language PolyKinds #-}
3−{-# language StandaloneKindSignatures #-}
4−{-# language TypeFamilies #-}
5−
6−module Rel8.FCF
7− ( Exp, Eval
8− , Id
9− )
10−where
11−
12−-- base
13−import Data.Kind ( Type )
14−import Prelude ()
15−
16−
17−type Exp :: Type -> Type
18−type Exp e = e -> Type
19−
20−
21−type Eval :: Exp e -> e
22−type 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+1−7
@@ -16,15 +16,9 @@ import Prelude
16import Data.Functor.Contravariant.Divisible ( Decidable, Divisible )
16import Data.Functor.Contravariant.Divisible ( Decidable, Divisible )
17
17
18-- opaleye
18-- opaleye
19−import qualified Opaleye.Order as Opaleye
19+import qualified Opaleye.Internal.Order as Opaleye
20
20
21
21
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.
25−--
26−-- A common pattern is to use '<>' to combine multiple orderings in sequence,
27−-- and 'Data.Functor.Contravariant.>$<' to select individual columns.
28type Order :: Type -> Type
22type Order :: Type -> Type
29newtype Order a = Order (Opaleye.Order a)
23newtype Order a = Order (Opaleye.Order a)
30 deriving newtype (Contravariant, Divisible, Decidable, Semigroup, Monoid)
24 deriving newtype (Contravariant, Divisible, Decidable, Semigroup, Monoid)
src/Rel8/Query.hs+5−192
@@ -1,6 +1,6 @@
1−{-# language FlexibleContexts #-}
1+{-# language DerivingStrategies #-}
2+{-# language GeneralizedNewtypeDeriving #-}
2{-# language StandaloneKindSignatures #-}
3{-# language StandaloneKindSignatures #-}
3−{-# language UndecidableInstances #-}
4
4
5module Rel8.Query
5module Rel8.Query
6 ( Query( Query )
6 ( Query( Query )
@@ -8,216 +8,29 @@ module Rel8.Query
8where
8where
9
9
10-- base
10-- base
11−import Control.Applicative ( liftA2 )
12−import Control.Monad ( liftM2 )
13import Data.Kind ( Type )
11import Data.Kind ( Type )
14−import Data.Monoid ( Any( Any ) )
15import Prelude
12import Prelude
16
13
17-- opaleye
14-- opaleye
18−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
15+import qualified Opaleye.Select 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
23
16
24-- rel8
17-- rel8
25−import Rel8.Expr ( Expr )
26import Rel8.Query.Set ( unionAll )
18import Rel8.Query.Set ( unionAll )
27−import Rel8.Query.Opaleye ( fromOpaleye )
28import Rel8.Query.Values ( values )
19import Rel8.Query.Values ( values )
29−import Rel8.Table ( Table, fromColumns, toColumns )
30import Rel8.Table.Alternative
20import Rel8.Table.Alternative
31 ( AltTable, (<|>:)
21 ( AltTable, (<|>:)
32 , AlternativeTable, emptyTable
22 , AlternativeTable, emptyTable
33 )
23 )
34−import Rel8.Table.Projection ( Projectable, apply, project )
35
24
36−-- semigroupoids
37−import Data.Functor.Apply ( Apply, (<.>) )
38−import Data.Functor.Bind ( Bind, (>>-) )
39
25
40−
41−-- | The @Query@ monad allows you to compose a @SELECT@ query. This monad has
42−-- semantics similar to the list (@[]@) monad.
43type Query :: Type -> Type
26type Query :: Type -> Type
44−newtype Query a =
27+newtype Query a = Query (Opaleye.Select a)
45− Query (
28+ deriving newtype (Functor, Applicative, Monad)
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
29
171−instance Applicative Query where
172− pure = fromOpaleye . pure
173− liftA2 = liftM2
174
30
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''')
204−
205−
206−-- | '<|>:' = 'unionAll'.
207instance AltTable Query where
31instance AltTable Query where
208 (<|>:) = unionAll
32 (<|>:) = unionAll
209
33
210
34
211−-- | 'emptyTable' = 'values' @[]@.
212instance AlternativeTable Query where
35instance AlternativeTable Query where
213 emptyTable = values []
36 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
7
7
8-- base
8-- base
9import Data.Kind ( Type )
9import Data.Kind ( Type )
10−import Data.Monoid ( Any )
11import Prelude ()
10import Prelude ()
12
11
13-- opaleye
12-- opaleye
14−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
15import qualified Opaleye.Select as Opaleye
13import qualified Opaleye.Select as Opaleye
16
14
17
15
18type Query :: Type -> Type
16type 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−37
@@ -1,56 +1,22 @@
1{-# language FlexibleContexts #-}
1{-# language FlexibleContexts #-}
2−{-# language MonoLocalBinds #-}
3−{-# language ScopedTypeVariables #-}
4−{-# language TypeApplications #-}
5
2
6module Rel8.Query.Aggregate
3module Rel8.Query.Aggregate
7 ( aggregate
4 ( aggregate
8− , countRows
9− , mode
10 )
5 )
11where
6where
12
7
13-- base
8-- base
14−import Data.Functor.Contravariant ( (>$<) )
15−import Data.Int ( Int64 )
16−import Prelude
9+import Prelude ()
17
10
18-- opaleye
11-- opaleye
19import qualified Opaleye.Aggregate as Opaleye
12import qualified Opaleye.Aggregate as Opaleye
20
13
21-- rel8
14-- rel8
22−import Rel8.Aggregate ( Aggregates )
15+import Rel8.Aggregate ( Aggregate )
23−import Rel8.Expr ( Expr )
24−import Rel8.Expr.Aggregate ( countStar )
25−import Rel8.Expr.Order ( desc )
26import Rel8.Query ( Query )
16import Rel8.Query ( Query )
27−import Rel8.Query.Limit ( limit )
28−import Rel8.Query.Maybe ( optional )
29import Rel8.Query.Opaleye ( mapOpaleye )
17import 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 )
35import Rel8.Table.Opaleye ( aggregator )
18import Rel8.Table.Opaleye ( aggregator )
36−import Rel8.Table.Maybe ( maybeTable )
37
19
38
20
39−-- | Apply an aggregation to all rows returned by a 'Query'.
40−aggregate :: Aggregates aggregates exprs => Query aggregates -> Query exprs
21+aggregate :: Query (Aggregate exprs) -> Query exprs
41aggregate = mapOpaleye (Opaleye.aggregate aggregator)
22aggregate = 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+9−12
@@ -1,3 +1,5 @@
1+{-# options_ghc -fno-warn-redundant-constraints #-}
2+
1module Rel8.Query.Distinct
3module Rel8.Query.Distinct
2 ( distinct
4 ( distinct
3 , distinctOn
5 , distinctOn
@@ -6,11 +8,12 @@ module Rel8.Query.Distinct
6where
8where
7
9
8-- base
10-- base
9−import Prelude ()
11+import Prelude
10
12
11-- opaleye
13-- opaleye
12import qualified Opaleye.Distinct as Opaleye
14import 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
14
17
15-- rel8
18-- rel8
16import Rel8.Order ( Order( Order ) )
19import Rel8.Order ( Order( Order ) )
@@ -20,21 +23,15 @@ import Rel8.Table.Eq ( EqTable )
20import Rel8.Table.Opaleye ( distinctspec, unpackspec )
23import Rel8.Table.Opaleye ( distinctspec, unpackspec )
21
24
22
25
23−-- | Select all distinct rows from a query, removing duplicates. @distinct q@
24−-- is equivalent to the SQL statement @SELECT DISTINCT q@.
25distinct :: EqTable a => Query a -> Query a
26distinct :: EqTable a => Query a -> Query a
26distinct = mapOpaleye (Opaleye.distinctExplicit distinctspec)
27distinct = mapOpaleye (Opaleye.distinctExplicit distinctspec)
27
28
28
29
29−-- | Select all distinct rows from a query, where rows are equivalent according
30−-- to a projection. If multiple rows have the same projection, it is
31−-- unspecified which row will be returned. If this matters, use 'distinctOnBy'.
32distinctOn :: EqTable b => (a -> b) -> Query a -> Query a
30distinctOn :: EqTable b => (a -> b) -> Query a -> Query a
31+distinctOn proj =
33−distinctOn proj = mapOpaleye (Opaleye.distinctOnExplicit unpackspec proj)
32+ mapOpaleye (\q -> Opaleye.productQueryArr (Opaleye.distinctOn unpackspec proj . Opaleye.runSimpleQueryArr q))
34
33
35
34
36−-- | Select all distinct rows from a query, where rows are equivalent according
37−-- to a projection. If there are multiple rows with the same projection, the
38−-- first row according to the specified 'Order' will be returned.
39distinctOnBy :: EqTable b => (a -> b) -> Order a -> Query a -> Query a
35distinctOnBy :: EqTable b => (a -> b) -> Order a -> Query a -> Query a
40−distinctOnBy proj (Order order) = mapOpaleye (Opaleye.distinctOnByExplicit unpackspec proj order)
36+distinctOnBy proj (Order order) =
37+ mapOpaleye (\q -> Opaleye.productQueryArr (Opaleye.distinctOnBy unpackspec proj order . Opaleye.runSimpleQueryArr q))
src/Rel8/Query/Each.hs+4−7
@@ -1,5 +1,4 @@
1{-# language FlexibleContexts #-}
1{-# language FlexibleContexts #-}
2−{-# language MonoLocalBinds #-}
3
2
4module Rel8.Query.Each
3module Rel8.Query.Each
5 ( each
4 ( each
@@ -15,18 +14,16 @@ import qualified Opaleye.Table as Opaleye
15-- rel8
14-- rel8
16import Rel8.Query ( Query )
15import Rel8.Query ( Query )
17import Rel8.Query.Opaleye ( fromOpaleye )
16import Rel8.Query.Opaleye ( fromOpaleye )
18−import Rel8.Schema.Name ( Selects )
19import Rel8.Schema.Table ( TableSchema )
17import Rel8.Schema.Table ( TableSchema )
20−import Rel8.Table.Cols ( fromCols, toCols )
18+import Rel8.Table ( fromColumns, toColumns )
21import Rel8.Table.Opaleye ( table, unpackspec )
19import Rel8.Table.Opaleye ( table, unpackspec )
20+import Rel8.Table.Recontextualize ( Selects )
22
21
23
22
24−-- | Select each row from a table definition. This is equivalent to @FROM
25−-- table@.
26each :: Selects names exprs => TableSchema names -> Query exprs
23each :: Selects names exprs => TableSchema names -> Query exprs
27each =
24each =
28− fmap fromCols .
25+ fmap fromColumns .
29 fromOpaleye .
26 fromOpaleye .
30 Opaleye.selectTableExplicit unpackspec .
27 Opaleye.selectTableExplicit unpackspec .
31 table .
28 table .
32− fmap toCols
29+ fmap toColumns
src/Rel8/Query/Either.hs+30−35
@@ -3,6 +3,7 @@
3module Rel8.Query.Either
3module Rel8.Query.Either
4 ( keepLeftTable
4 ( keepLeftTable
5 , keepRightTable
5 , keepRightTable
6+ , bindEitherTable
6 , bitraverseEitherTable
7 , bitraverseEitherTable
7 )
8 )
8where
9where
@@ -10,60 +11,54 @@ where
10-- base
11-- base
11import Prelude
12import Prelude
12
13
13−-- comonad
14−import Control.Comonad ( extract )
15−
16-- rel8
14-- rel8
17−import Rel8.Expr ( Expr )
18import Rel8.Expr.Eq ( (==.) )
15import Rel8.Expr.Eq ( (==.) )
19import Rel8.Query ( Query )
16import Rel8.Query ( Query )
20import Rel8.Query.Filter ( where_ )
17import Rel8.Query.Filter ( where_ )
21import Rel8.Query.Maybe ( optional )
18import Rel8.Query.Maybe ( optional )
19+import Rel8.Query.Set ( unionAll )
20+import Rel8.Schema.Context ( DB )
21+import Rel8.Table ( Table )
22+import Rel8.Table.Bool ( bool )
22import Rel8.Table.Either
23import Rel8.Table.Either
23 ( EitherTable( EitherTable )
24 ( EitherTable( EitherTable )
25+ , leftTable, rightTable
24 , isLeftTable, isRightTable
26 , isLeftTable, isRightTable
25 )
27 )
26import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
28import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
27
29
28
30
29−-- | Filter 'EitherTable's, keeping only 'leftTable's.
30−keepLeftTable :: EitherTable Expr a b -> Query a
31+keepLeftTable :: EitherTable a b -> Query a
31keepLeftTable e@(EitherTable _ a _) = do
32keepLeftTable e@(EitherTable _ a _) = do
32 where_ $ isLeftTable e
33 where_ $ isLeftTable e
33− pure (extract a)
34+ pure a
34
35
35
36
36−-- | Filter 'EitherTable's, keeping only 'rightTable's.
37−keepRightTable :: EitherTable Expr a b -> Query b
37+keepRightTable :: EitherTable a b -> Query b
38keepRightTable e@(EitherTable _ _ b) = do
38keepRightTable e@(EitherTable _ _ b) = do
39 where_ $ isRightTable e
39 where_ $ isRightTable e
40− pure (extract b)
40+ pure b
41+
42+
43+bindEitherTable :: (Table DB a, Monad m)
44+ => (i -> m (EitherTable a b)) -> EitherTable a i -> m (EitherTable a b)
45+bindEitherTable query e@(EitherTable input a i) = do
46+ EitherTable output a' b <- query i
47+ pure $ EitherTable (input <> output) (bool a a' (isRightTable e)) b
41
48
42
49
43−-- | @bitraverseEitherTable f g x@ will pass all @leftTable@s through @f@ and
50+bitraverseEitherTable :: (Table DB c, Table DB d)
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 :: ()
60 => (a -> Query c)
51 => (a -> Query c)
61 -> (b -> Query d)
52 -> (b -> Query d)
62− -> EitherTable Expr a b
53+ -> EitherTable a b
63− -> Query (EitherTable Expr c d)
54+ -> Query (EitherTable c d)
64−bitraverseEitherTable f g e@(EitherTable tag _ _) = do
55+bitraverseEitherTable f g e = traverseLeftTable `unionAll` traverseRightTable
56+ where
57+ traverseLeftTable = do
65− mc@(MaybeTable _ c) <- optional (f =<< keepLeftTable e)
58+ mc@(MaybeTable _ c) <- optional (f =<< keepLeftTable e)
66− md@(MaybeTable _ d) <- optional (g =<< keepRightTable e)
67− where_ $ isJustTable mc ==. isLeftTable e
59+ where_ $ isJustTable mc ==. isLeftTable e
60+ pure $ leftTable c
61+ traverseRightTable = do
62+ md@(MaybeTable _ d) <- optional (g =<< keepRightTable e)
68− where_ $ isJustTable md ==. isRightTable e
63+ where_ $ isJustTable md ==. isRightTable e
69− pure $ EitherTable tag c d
64+ 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+25−21
@@ -2,8 +2,8 @@
2
2
3module Rel8.Query.Exists
3module Rel8.Query.Exists
4 ( exists, inQuery
4 ( exists, inQuery
5− , present, with, withBy
5+ , whereExists, with, withBy
6− , absent, without, withoutBy
6+ , whereNotExists, without, withoutBy
7 )
7 )
8where
8where
9
9
@@ -11,56 +11,60 @@ where
11import Prelude hiding ( filter )
11import Prelude hiding ( filter )
12
12
13-- opaleye
13-- opaleye
14−import qualified Opaleye.Exists as Opaleye
15import qualified Opaleye.Operators as Opaleye
14import qualified Opaleye.Operators as Opaleye
16
15
17-- rel8
16-- rel8
18import Rel8.Expr ( Expr )
17import Rel8.Expr ( Expr )
19−import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )
20import Rel8.Query ( Query )
18import Rel8.Query ( Query )
21import Rel8.Query.Filter ( filter )
19import Rel8.Query.Filter ( filter )
20+import Rel8.Query.Maybe ( optional )
22import Rel8.Query.Opaleye ( mapOpaleye )
21import Rel8.Query.Opaleye ( mapOpaleye )
23import Rel8.Table.Eq ( EqTable, (==:) )
22import Rel8.Table.Eq ( EqTable, (==:) )
23+import Rel8.Table.Maybe ( isJustTable )
24
24
25
25
26-- | Checks if a query returns at least one row.
26-- | 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)
27exists :: Query a -> Query (Expr Bool)
39exists :: 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
29
43
30
44
31inQuery :: EqTable a => a -> Query a -> Query (Expr Bool)
45inQuery :: EqTable a => a -> Query a -> Query (Expr Bool)
32inQuery a = exists . (>>= filter (a ==:))
46inQuery a = exists . (>>= filter (a ==:))
33
47
34
48
35−-- | Produce the empty query if the given query returns no rows. @present@
36−-- is equivalent to @WHERE EXISTS@ in SQL.
37−present :: Query a -> Query ()
49+whereExists :: Query a -> Query ()
38−present = mapOpaleye Opaleye.restrictExists
50+whereExists = mapOpaleye Opaleye.restrictExists
39
51
40
52
41−-- | Produce the empty query if the given query returns rows. @absent@
42−-- is equivalent to @WHERE NOT EXISTS@ in SQL.
43−absent :: Query a -> Query ()
53+whereNotExists :: Query a -> Query ()
44−absent = mapOpaleye Opaleye.restrictNotExists
54+whereNotExists = mapOpaleye Opaleye.restrictNotExists
45
55
46
56
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'.
50with :: (a -> Query b) -> a -> Query a
57with :: (a -> Query b) -> a -> Query a
51−with f a = a <$ present (f a)
58+with f a = a <$ whereExists (f a)
52
59
53
60
54−-- | Like @with@, but with a custom membership test.
55withBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a
61withBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a
56withBy predicate bs = with $ \a -> bs >>= filter (predicate a)
62withBy predicate bs = with $ \a -> bs >>= filter (predicate a)
57
63
58
64
59−-- | Filter rows where @a -> Query b@ yields no rows.
60without :: (a -> Query b) -> a -> Query a
65without :: (a -> Query b) -> a -> Query a
61−without f a = a <$ absent (f a)
66+without f a = a <$ whereNotExists (f a)
62
67
63
68
64−-- | Like @without@, but with a custom membership test.
65withoutBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a
69withoutBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a
66withoutBy predicate bs = without $ \a -> bs >>= filter (predicate a)
70withoutBy predicate bs = without $ \a -> bs >>= filter (predicate a)
src/Rel8/Query/Filter.hs−6
@@ -20,16 +20,10 @@ import Rel8.Query ( Query )
20import Rel8.Query.Opaleye ( fromOpaleye )
20import Rel8.Query.Opaleye ( fromOpaleye )
21
21
22
22
23−-- | @filter f x@ will be a zero-row query when @f x@ is @False@, and will
24−-- return @x@ unchanged when @f x@ is @True@. This is similar to
25−-- 'Control.Monad.guard', but as the predicate is separate from the argument,
26−-- it is easy to use in a pipeline of 'Query' transformations.
27filter :: (a -> Expr Bool) -> a -> Query a
23filter :: (a -> Expr Bool) -> a -> Query a
28filter f a = a <$ where_ (f a)
24filter f a = a <$ where_ (f a)
29
25
30
26
31−-- | Drop any rows that don't match a predicate. @where_ expr@ is equivalent
32−-- to the SQL @WHERE expr@.
33where_ :: Expr Bool -> Query ()
27where_ :: Expr Bool -> Query ()
34where_ condition =
28where_ condition =
35 fromOpaleye $ lmap (\_ -> toColumn $ toPrimExpr condition) Opaleye.restrict
29 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−4
@@ -15,13 +15,9 @@ import Rel8.Query ( Query )
15import Rel8.Query.Opaleye ( mapOpaleye )
15import Rel8.Query.Opaleye ( mapOpaleye )
16
16
17
17
18−-- | @limit n@ select at most @n@ rows from a query. @limit n@ is equivalent
19−-- to the SQL @LIMIT n@.
20limit :: Word -> Query a -> Query a
18limit :: Word -> Query a -> Query a
21limit = mapOpaleye . Opaleye.limit . fromIntegral
19limit = mapOpaleye . Opaleye.limit . fromIntegral
22
20
23
21
24−-- | @offset n@ drops the first @n@ rows from a query. @offset n@ is equivalent
25−-- to the SQL @OFFSET n@.
26offset :: Word -> Query a -> Query a
22offset :: Word -> Query a -> Query a
27offset = mapOpaleye . Opaleye.offset . fromIntegral
23offset = mapOpaleye . Opaleye.offset . fromIntegral
src/Rel8/Query/List.hs+8−102
@@ -1,122 +1,28 @@
1{-# language FlexibleContexts #-}
1{-# language FlexibleContexts #-}
2−{-# language GADTs #-}
3−{-# language NamedFieldPuns #-}
4
2
5module Rel8.Query.List
3module Rel8.Query.List
6 ( many, some
4 ( many, some
7− , manyExpr, someExpr
8− , catListTable, catNonEmptyTable
9− , catList, catNonEmpty
10 )
5 )
11where
6where
12
7
13-- base
8-- base
14−import Data.Functor.Identity ( runIdentity )
15−import Data.List.NonEmpty ( NonEmpty )
16import Prelude
9import Prelude
17
10
18−-- opaleye
19−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
20−
21-- rel8
11-- rel8
22−import Rel8.Expr ( Expr )
23−import Rel8.Expr.Aggregate ( listAggExpr, nonEmptyAggExpr )
24−import Rel8.Expr.Opaleye ( mapPrimExpr )
25import Rel8.Query ( Query )
12import Rel8.Query ( Query )
26import Rel8.Query.Aggregate ( aggregate )
13import Rel8.Query.Aggregate ( aggregate )
27import Rel8.Query.Maybe ( optional )
14import Rel8.Query.Maybe ( optional )
28−import Rel8.Query.Rebind ( rebind )
15+import Rel8.Schema.Context ( DB )
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 )
16+import Rel8.Table ( Table )
33−import Rel8.Table.Cols ( toCols )
34import Rel8.Table.Aggregate ( listAgg, nonEmptyAgg )
17import Rel8.Table.Aggregate ( listAgg, nonEmptyAgg )
35−import Rel8.Table.List ( ListTable( ListTable ) )
18+import Rel8.Table.List ( ListTable )
36import Rel8.Table.Maybe ( maybeTable )
19import Rel8.Table.Maybe ( maybeTable )
37−import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )
20+import Rel8.Table.NonEmpty ( 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)
56−
57−
58−-- | Aggregate a 'Query' into a 'NonEmptyTable'. If the supplied query returns
59−-- 0 rows, this function will produce a 'Query' that is empty - that is, will
60−-- produce zero @NonEmptyTable@s. If the supplied @Query@ does return rows,
61−-- @some@ will return exactly one row, with a @NonEmptyTable@ collecting all
62−-- returned rows.
63−--
64−-- @some@ is analogous to 'Control.Applicative.some' from
65−-- @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
21
110
22
111−-- | Expand an expression that contains a non-empty list into a 'Query', where
23+some :: Table DB a => Query a -> Query (NonEmptyTable a)
112−-- each row in the query is an element of the given list.
24+some = aggregate . fmap nonEmptyAgg
113−--
114−-- @catNonEmpty@ is an inverse to 'someExpr'.
115−catNonEmpty :: Sql DBType a => Expr (NonEmpty a) -> Query (Expr a)
116−catNonEmpty = rebind "unnest" . sunnest typeInformation
117
25
118
26
119−sunnest :: TypeInformation (Unnullify a) -> Expr (list a) -> Expr a
27+many :: Table DB a => Query a -> Query (ListTable a)
120−sunnest info = mapPrimExpr $
28+many = fmap (maybeTable mempty id) . optional . aggregate . fmap listAgg
121− extractArrayElement info .
122− Opaleye.UnExpr (Opaleye.UnOpOther "UNNEST")
src/Rel8/Query/Maybe.hs+73−38
@@ -1,10 +1,7 @@
1−{-# language GADTs #-}
2−{-# language LambdaCase #-}
3−{-# language NamedFieldPuns #-}
4−
5module Rel8.Query.Maybe
1module Rel8.Query.Maybe
6 ( optional
2 ( optional
7 , catMaybeTable
3 , catMaybeTable
4+ , bindMaybeTable
8 , traverseMaybeTable
5 , traverseMaybeTable
9 )
6 )
10where
7where
@@ -12,57 +9,95 @@ where
12-- base
9-- base
13import Prelude
10import Prelude
14
11
15−-- comonad
16−import Control.Comonad ( extract )
17−
18-- opaleye
12-- 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
20
18
21-- rel8
19-- rel8
22−import Rel8.Expr ( Expr )
20+import Rel8.Expr.Bool ( true )
23import Rel8.Expr.Eq ( (==.) )
21import Rel8.Expr.Eq ( (==.) )
24−import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )
22+import Rel8.Expr.Opaleye ( toPrimExpr )
25import Rel8.Query ( Query )
23import Rel8.Query ( Query )
26import Rel8.Query.Filter ( where_ )
24import Rel8.Query.Filter ( where_ )
27import Rel8.Query.Opaleye ( mapOpaleye )
25import 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 )
29
28
30
29
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)
30+optional :: Query a -> Query (MaybeTable a)
37−optional = mapOpaleye $ Opaleye.optionalInternal $ \tag a -> MaybeTable
31+optional = mapOpaleye $ Opaleye.QueryArr . go
38− { tag = fromPrimExpr $ fromColumn tag
32+ where
39− , just = pure a
33+ go query (i, left, tag) = (MaybeTable t' a, join, Opaleye.next tag')
40− }
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
41
41
42
42
43−-- | Filter out 'MaybeTable's, returning only the tables that are not-null.
44−--
45−-- This operation can be used to "undo" the effect of 'optional', which
46−-- operationally is like turning a @LEFT JOIN@ back into a full @JOIN@. You
47−-- can think of this as analogous to 'Data.Maybe.catMaybes'.
48−catMaybeTable :: MaybeTable Expr a -> Query a
43+catMaybeTable :: MaybeTable a -> Query a
49catMaybeTable ma@(MaybeTable _ a) = do
44catMaybeTable ma@(MaybeTable _ a) = do
50 where_ $ isJustTable ma
45 where_ $ isJustTable ma
51− pure (extract a)
46+ pure a
47+
48+
49+-- | @bindMaybeTable f x@ is similar to the monadic bind (@>>=@) operation. It
50+-- allows you to "extend" an optional query with another query. If either the
51+-- input or output are 'noTable', then the result is 'noTable'.
52+--
53+-- This is similar to 'traverseMaybeTable', followed by a @join@ on the
54+-- resulting @MaybeTable@s.
55+--
56+-- >>> select c $ bindMaybeTable (optional . values . pure . not_) =<< optional (values [lit True])
57+-- [Just False]
58+--
59+-- >>> select c $ bindMaybeTable (\_ -> return (noTable :: MaybeTable (Expr Bool))) =<< optional (values [lit True])
60+-- [Nothing]
61+--
62+-- >>> select c $ bindMaybeTable (optional . values . pure . not_) =<< return (noTable :: MaybeTable (Expr Bool))
63+-- [Nothing]
64+bindMaybeTable :: Monad m
65+ => (a -> m (MaybeTable b)) -> MaybeTable a -> m (MaybeTable b)
66+bindMaybeTable query (MaybeTable input a) = do
67+ MaybeTable output b <- query a
68+ pure $ MaybeTable (input <> output) b
52
69
53
70
54-- | Extend an optional query with another query. This is useful if you want
71-- | Extend an optional query with another query. This is useful if you want
55-- to step through multiple @LEFT JOINs@.
72-- to step through multiple @LEFT JOINs@.
56--
73--
57-- Note that @traverseMaybeTable@ takes a @a -> Query b@ function, which means
74-- 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
75+-- you also have the ability to "expand" one row into multiple rows.
76+--
77+-- >>> :{
78+-- duplicate :: Expr Bool -> Query (Expr Bool)
79+-- duplicate x = unionAll (return x) (return x)
80+-- :}
81+--
82+-- >>> select c $ traverseMaybeTable duplicate =<< optional (values [lit True])
83+-- [Just True,Just True]
84+--
59−-- @a -> Query b@ function returns no rows, then the resulting query will also
85+-- Note that if the @a -> Query b@ function returns no rows, then the resulting
86+-- query will also have no rows:
87+--
88+-- >>> select c $ traverseMaybeTable (limit 0 . pure) =<< optional (values [lit True])
89+-- []
90+--
60−-- have no rows. However, regardless of the given @a -> Query b@ function, if
91+-- However, regardless of the given @a -> Query b@ function, if the input is
61−-- the input is @nothingTable@, you will always get exactly one @nothingTable@
92+-- @noTable@, you will always get exactly one @noTable@ back:
62−-- back.
93+--
94+-- >>> select c $ traverseMaybeTable duplicate (noTable :: MaybeTable (Expr Bool))
95+-- [Nothing]
96+--
97+-- >>> select c $ traverseMaybeTable (limit 0 . pure) (noTable :: MaybeTable (Expr Bool))
98+-- [Nothing]
63−traverseMaybeTable :: (a -> Query b) -> MaybeTable Expr a -> Query (MaybeTable Expr b)
99+traverseMaybeTable :: (a -> Query b) -> MaybeTable a -> Query (MaybeTable b)
64traverseMaybeTable query ma@(MaybeTable input _) = do
100traverseMaybeTable query ma@(MaybeTable input _) = do
65− optional (query =<< catMaybeTable ma) >>= \case
101+ MaybeTable output b <- optional (query =<< catMaybeTable ma)
66− MaybeTable output b -> do
67− where_ $ output ==. input
102+ where_ $ output ==. input
68− pure $ MaybeTable input b
103+ pure $ MaybeTable input b
src/Rel8/Query/Null.hs+18−18
@@ -1,8 +1,5 @@
1−{-# language FlexibleContexts #-}
2−
3module Rel8.Query.Null
1module Rel8.Query.Null
4− ( catNull
2+ ( catNullable
5− , catNullTable
6 )
3 )
7where
4where
8
5
@@ -12,8 +9,6 @@ import Prelude
12-- rel8
9-- rel8
13import Rel8.Expr ( Expr )
10import Rel8.Expr ( Expr )
14import Rel8.Expr.Null ( isNonNull, unsafeUnnullify )
11import Rel8.Expr.Null ( isNonNull, unsafeUnnullify )
15−import Rel8.Table ( Table )
16−import Rel8.Table.Null ( NullTable, isNonNullTable, unsafeUnnullifyTable )
17import Rel8.Query ( Query )
12import Rel8.Query ( Query )
18import Rel8.Query.Filter ( where_ )
13import Rel8.Query.Filter ( where_ )
19
14
@@ -22,17 +17,22 @@ import Rel8.Query.Filter ( where_ )
22-- @null@s.
17-- @null@s.
23--
18--
24-- Corresponds to 'Data.Maybe.catMaybes'.
19-- Corresponds to 'Data.Maybe.catMaybes'.
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)
25−catNull :: Expr (Maybe a) -> Query (Expr a)
35+catNullable :: Expr (Maybe a) -> Query (Expr a)
26−catNull a = do
36+catNullable a = do
27 where_ $ isNonNull a
37 where_ $ isNonNull a
28 pure $ unsafeUnnullify a
38 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−
3module Rel8.Query.Opaleye
1module Rel8.Query.Opaleye
4 ( fromOpaleye
2 ( fromOpaleye
5 , toOpaleye
3 , toOpaleye
6 , mapOpaleye
4 , mapOpaleye
7 , zipOpaleyeWith
5 , zipOpaleyeWith
8− , unsafePeekQuery
9 )
6 )
10where
7where
11
8
12-- base
9-- base
13−import Control.Applicative ( liftA2 )
14import Prelude
10import Prelude
15
11
16-- opaleye
12-- opaleye
17−import qualified Opaleye.Internal.QueryArr as Opaleye
13+import qualified Opaleye.Select as Opaleye
18−import qualified Opaleye.Internal.Tag as Opaleye
19
14
20-- rel8
15-- rel8
21import {-# SOURCE #-} Rel8.Query ( Query( Query ) )
16import {-# SOURCE #-} Rel8.Query ( Query( Query ) )
22
17
23
18
24fromOpaleye :: Opaleye.Select a -> Query a
19fromOpaleye :: Opaleye.Select a -> Query a
25−fromOpaleye = Query . pure . fmap pure
20+fromOpaleye = Query
26
21
27
22
28toOpaleye :: Query a -> Opaleye.Select a
23toOpaleye :: Query a -> Opaleye.Select a
29−toOpaleye (Query a) = snd <$> a mempty
24+toOpaleye (Query a) = a
30
25
31
26
32mapOpaleye :: (Opaleye.Select a -> Opaleye.Select b) -> Query a -> Query b
27mapOpaleye :: (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
34
29
35
30
36zipOpaleyeWith :: ()
31zipOpaleyeWith :: ()
37 => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)
32 => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)
38 -> Query a -> Query b -> Query c
33 -> Query a -> Query b -> Query c
39−zipOpaleyeWith f (Query a) (Query b) = Query $ liftA2 (zipping f) a b
34+zipOpaleyeWith f a b = fromOpaleye $ f (toOpaleye a) (toOpaleye b)
40−
41−
42−unsafePeekQuery :: Query a -> a
43−unsafePeekQuery (Query q) = case q mempty of
44− f -> case Opaleye.runStateQueryArr f () Opaleye.start of
45− ((_, a), _, _) -> a
46−
47−
48−mapping :: ()
49− => (Opaleye.Select a -> Opaleye.Select b)
50− -> Opaleye.Select (m, a) -> Opaleye.Select (m, b)
51−mapping f q = Opaleye.stateQueryArr $ \_ tag ->
52− let
53− ((m, _), _, _) = Opaleye.runStateQueryArr q () tag
54− q' = (m,) <$> f (snd <$> q)
55− in
56− Opaleye.runStateQueryArr q' () tag
57−
58−
59−zipping :: Semigroup m
60− => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)
61− -> Opaleye.Select (m, a) -> Opaleye.Select (m, b) -> Opaleye.Select (m, c)
62−zipping f q q' =
63− Opaleye.stateQueryArr $ \_ tag ->
64− let
65− ((m, _), _, _) = Opaleye.runStateQueryArr q () tag
66− ((m', _), _, _) = Opaleye.runStateQueryArr q' () tag
67− m'' = m <> m'
68− q'' = (m'',) <$> f (snd <$> q) (snd <$> q')
69− in
70− Opaleye.runStateQueryArr q'' () tag
src/Rel8/Query/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/Order.hs−1
@@ -15,6 +15,5 @@ import Rel8.Query ( Query )
15import Rel8.Query.Opaleye ( mapOpaleye )
15import Rel8.Query.Opaleye ( mapOpaleye )
16
16
17
17
18−-- | Order the rows returned by a query.
19orderBy :: Order a -> Query a -> Query a
18orderBy :: Order a -> Query a -> Query a
20orderBy (Order o) = mapOpaleye (Opaleye.orderBy o)
19orderBy (Order o) = mapOpaleye (Opaleye.orderBy o)
src/Rel8/Query/Rebind.hsdeleted−27
@@ -1,27 +0,0 @@
1−{-# language FlexibleContexts #-}
2−
3−module Rel8.Query.Rebind
4− ( rebind
5− )
6−where
7−
8−-- base
9−import Prelude
10−import Control.Arrow ((<<<))
11−
12−-- opaleye
13−import qualified Opaleye.Internal.Rebind as Opaleye
14−
15−-- rel8
16−import Rel8.Expr ( Expr )
17−import Rel8.Query ( Query )
18−import Rel8.Table ( Table )
19−import Rel8.Table.Opaleye ( unpackspec )
20−import Rel8.Query.Opaleye (fromOpaleye)
21−
22−
23−-- | 'rebind' takes a variable name, some expressions, and binds each of them
24−-- to a new variable in the SQL. The @a@ returned consists only of these
25−-- variables. It's essentially a @let@ binding for Postgres expressions.
26−rebind :: Table Expr a => String -> a -> Query a
27−rebind prefix a = fromOpaleye (Opaleye.rebindExplicitPrefix prefix unpackspec <<< pure a)
src/Rel8/Query/SQL.hs+58−7
@@ -1,21 +1,72 @@
1{-# language FlexibleContexts #-}
1{-# language FlexibleContexts #-}
2−{-# language MonoLocalBinds #-}
2+{-# language TypeFamilies #-}
3+{-# language ViewPatterns #-}
3
4
4module Rel8.Query.SQL
5module Rel8.Query.SQL
5 ( showQuery
6 ( showQuery
7+ , sqlForQuery, sqlForQueryWithNames
6 )
8 )
7where
9where
8
10
9-- base
11-- base
12+import Data.Foldable ( fold )
13+import Data.Functor.Const ( Const( Const ), getConst )
14+import Data.Void ( Void )
10import Prelude
15import Prelude
11
16
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+
12-- rel8
25-- rel8
13−import Rel8.Expr ( Expr )
26+import Rel8.Expr.Opaleye ( toPrimExpr )
14import Rel8.Query ( Query )
27import Rel8.Query ( Query )
15−import Rel8.Statement.Select ( ppSelect )
28+import Rel8.Query.Opaleye ( toOpaleye )
29+import qualified Rel8.Query.Optimize as Rel8 ( optimize )
30+import Rel8.Schema.Context ( DB( DB ), Name( Name ) )
31+import Rel8.Schema.HTable ( htabulateA, hfield )
16−import Rel8.Table ( Table )
32+import Rel8.Table ( Table, toColumns )
33+import Rel8.Table.Name ( namesFromLabels )
34+import Rel8.Table.Recontextualize ( Selects )
35+
36+
37+showQuery :: Table DB a => Query a -> String
38+showQuery = fold . sqlForQuery
39+
40+
41+sqlForQuery :: Table DB a
42+ => Query a -> Maybe String
43+sqlForQuery = sqlForQueryWithNames namesFromLabels . fmap toColumns
44+
45+
46+sqlForQueryWithNames :: Selects names exprs
47+ => names -> Query exprs -> Maybe String
48+sqlForQueryWithNames names query =
49+ show . Opaleye.ppSql . selectFrom names exprs <$> optimize primQuery
50+ where
51+ (exprs, primQuery, _) =
52+ Opaleye.runSimpleQueryArrStart (toOpaleye query) ()
53+
54+
55+optimize :: Opaleye.PrimQuery' a -> Maybe (Opaleye.PrimQuery' Void)
56+optimize = Opaleye.removeEmpty . Rel8.optimize . Opaleye.optimize
17
57
18
58
19−-- | Convert a 'Query' to a 'String' containing a @SELECT@ statement.
59+selectFrom :: Selects names exprs
20−showQuery :: Table Expr a => Query a -> String
60+ => names -> exprs -> Opaleye.PrimQuery' Void -> Opaleye.Select
21−showQuery = show . ppSelect
61+selectFrom (toColumns -> names) (toColumns -> exprs) query =
62+ Opaleye.SelectFrom $ Opaleye.newSelect
63+ { Opaleye.attrs = Opaleye.SelectAttrs attributes
64+ , Opaleye.tables = Opaleye.oneTable select
65+ }
66+ where
67+ select = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator query
68+ attributes = getConst $ htabulateA $ \field -> case hfield names field of
69+ Name name -> case hfield exprs field of
70+ DB (toPrimExpr -> expr) -> Const (pure (makeAttr name expr))
71+ makeAttr label expr =
72+ (Opaleye.sqlExpr expr, Just (Opaleye.SqlColumn label))
src/Rel8/Query/Set.hs+4−16
@@ -14,45 +14,33 @@ import Prelude ()
14import qualified Opaleye.Binary as Opaleye
14import qualified Opaleye.Binary as Opaleye
15
15
16-- rel8
16-- rel8
17−import Rel8.Expr ( Expr )
18import {-# SOURCE #-} Rel8.Query ( Query )
17import {-# SOURCE #-} Rel8.Query ( Query )
19import Rel8.Query.Opaleye ( zipOpaleyeWith )
18import Rel8.Query.Opaleye ( zipOpaleyeWith )
20import Rel8.Table ( Table )
19import Rel8.Table ( Table )
21import Rel8.Table.Eq ( EqTable )
20import Rel8.Table.Eq ( EqTable )
22import Rel8.Table.Opaleye ( binaryspec )
21import Rel8.Table.Opaleye ( binaryspec )
22+import Rel8.Schema.Context ( DB )
23
23
24
24
25−-- | 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@.
27union :: EqTable a => Query a -> Query a -> Query a
25union :: EqTable a => Query a -> Query a -> Query a
28union = zipOpaleyeWith (Opaleye.unionExplicit binaryspec)
26union = zipOpaleyeWith (Opaleye.unionExplicit binaryspec)
29
27
30
28
31−-- | 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@.
33−unionAll :: Table Expr a => Query a -> Query a -> Query a
29+unionAll :: Table DB a => Query a -> Query a -> Query a
34unionAll = zipOpaleyeWith (Opaleye.unionAllExplicit binaryspec)
30unionAll = zipOpaleyeWith (Opaleye.unionAllExplicit binaryspec)
35
31
36
32
37−-- | Find the intersection of two queries, collapsing duplicates. @intersect a
38−-- b@ is the same as the SQL statement @a INTERSECT b@.
39intersect :: EqTable a => Query a -> Query a -> Query a
33intersect :: EqTable a => Query a -> Query a -> Query a
40intersect = zipOpaleyeWith (Opaleye.intersectExplicit binaryspec)
34intersect = zipOpaleyeWith (Opaleye.intersectExplicit binaryspec)
41
35
42
36
43−-- | 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
37+intersectAll :: Table DB a => Query a -> Query a -> Query a
46intersectAll = zipOpaleyeWith (Opaleye.intersectAllExplicit binaryspec)
38intersectAll = zipOpaleyeWith (Opaleye.intersectAllExplicit binaryspec)
47
39
48
40
49−-- | Find the difference of two queries, collapsing duplicates @except a b@ is
50−-- the same as the SQL statement @a EXCEPT b@.
51except :: EqTable a => Query a -> Query a -> Query a
41except :: EqTable a => Query a -> Query a -> Query a
52except = zipOpaleyeWith (Opaleye.exceptExplicit binaryspec)
42except = zipOpaleyeWith (Opaleye.exceptExplicit binaryspec)
53
43
54
44
55−-- | 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
45+exceptAll :: Table DB a => Query a -> Query a -> Query a
58exceptAll = zipOpaleyeWith (Opaleye.exceptAllExplicit binaryspec)
46exceptAll = zipOpaleyeWith (Opaleye.exceptAllExplicit binaryspec)
src/Rel8/Query/These.hs+54−63
@@ -1,5 +1,4 @@
1{-# language FlexibleContexts #-}
1{-# language FlexibleContexts #-}
2−{-# language GADTs #-}
3
2
4module Rel8.Query.These
3module Rel8.Query.These
5 ( alignBy
4 ( alignBy
@@ -8,116 +7,100 @@ module Rel8.Query.These
8 , keepThisTable, loseThisTable
7 , keepThisTable, loseThisTable
9 , keepThatTable, loseThatTable
8 , keepThatTable, loseThatTable
10 , keepThoseTable, loseThoseTable
9 , keepThoseTable, loseThoseTable
10+ , bindTheseTable
11 , bitraverseTheseTable
11 , bitraverseTheseTable
12 )
12 )
13where
13where
14
14
15-- base
15-- base
16+import Data.Bifunctor ( bimap )
16import Prelude
17import Prelude
17
18
18−-- comonad
19−import Control.Comonad ( extract )
20−
21-- opaleye
19-- opaleye
22−import qualified Opaleye.Internal.PackMap as Opaleye
20+import qualified Opaleye.Internal.Join as Opaleye
23import qualified Opaleye.Internal.PrimQuery as Opaleye
21import qualified Opaleye.Internal.PrimQuery as Opaleye
24−import qualified Opaleye.Internal.QueryArr as Opaleye
25−import qualified Opaleye.Internal.Tag as Opaleye
26
22
27-- rel8
23-- rel8
28import Rel8.Expr ( Expr )
24import Rel8.Expr ( Expr )
29−import Rel8.Expr.Bool ( boolExpr, not_ )
25+import Rel8.Expr.Bool ( (&&.), boolExpr, not_ )
30−import Rel8.Expr.Eq ( (==.) )
26+import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
31−import Rel8.Expr.Opaleye ( toPrimExpr, traversePrimExpr )
32import Rel8.Expr.Serialize ( litExpr )
27import Rel8.Expr.Serialize ( litExpr )
33import Rel8.Query ( Query )
28import Rel8.Query ( Query )
34import Rel8.Query.Filter ( where_ )
29import Rel8.Query.Filter ( where_ )
35−import Rel8.Query.Maybe ( optional )
30+import Rel8.Query.Maybe ( traverseMaybeTable )
36import Rel8.Query.Opaleye ( zipOpaleyeWith )
31import Rel8.Query.Opaleye ( zipOpaleyeWith )
32+import Rel8.Schema.Context ( DB )
33+import Rel8.Table ( Table )
37import Rel8.Table.Either ( EitherTable( EitherTable ) )
34import Rel8.Table.Either ( EitherTable( EitherTable ) )
38import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
35import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
36+import Rel8.Table.Opaleye ( unpackspec )
39import Rel8.Table.These
37import Rel8.Table.These
40− ( TheseTable( TheseTable, here, there )
38+ ( TheseTable( TheseTable )
41− , hasHereTable, hasThereTable
42 , isThisTable, isThatTable, isThoseTable
39 , isThisTable, isThatTable, isThoseTable
43 )
40 )
44import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) )
41import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) )
45
42
46
43
47−-- | Corresponds to a @FULL OUTER JOIN@ between two queries.
48−alignBy :: ()
44+alignBy :: (Table DB a, Table DB b)
49 => (a -> b -> Expr Bool)
45 => (a -> b -> Expr Bool)
50− -> Query a -> Query b -> Query (TheseTable Expr a b)
46+ -> Query a -> Query b -> Query (TheseTable a b)
51−alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.stateQueryArr $ \_ t -> case t of
47+alignBy condition as bs =
52− tag -> (tab, join', tag''')
48+ uncurry TheseTable <$> zipOpaleyeWith fullOuterJoin as bs
53− where
49+ where
54− (ma, left', tag') = Opaleye.runStateQueryArr (pure <$> left) () tag
50+ fullOuterJoin a b =
55− (mb, right', tag'') = Opaleye.runStateQueryArr (pure <$> right) () tag'
51+ Opaleye.joinExplicit unpackspec unpackspec pure pure full a b on
56− MaybeTable hasHere a = ma
52+ where
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''
53+ full = Opaleye.FullJoin
64− where
54+ on = toColumn . toPrimExpr . uncurry condition
65− on = toPrimExpr $ condition (extract a) (extract b)
55+
66− left'' = (Opaleye.NonLateral, Opaleye.toPrimQuery (left' <> Opaleye.aRebind lbindings))
56+
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)
57+keepHereTable :: TheseTable a b -> Query (a, MaybeTable b)
75keepHereTable = loseThatTable
58keepHereTable = loseThatTable
76
59
77
60
78−loseHereTable :: TheseTable Expr a b -> Query b
61+loseHereTable :: TheseTable a b -> Query b
79loseHereTable = keepThatTable
62loseHereTable = keepThatTable
80
63
81
64
82−keepThereTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)
65+keepThereTable :: TheseTable a b -> Query (MaybeTable a, b)
83keepThereTable = loseThisTable
66keepThereTable = loseThisTable
84
67
85
68
86−loseThereTable :: TheseTable Expr a b -> Query a
69+loseThereTable :: TheseTable a b -> Query a
87loseThereTable = keepThisTable
70loseThereTable = keepThisTable
88
71
89
72
90−keepThisTable :: TheseTable Expr a b -> Query a
73+keepThisTable :: TheseTable a b -> Query a
91keepThisTable t@(TheseTable (MaybeTable _ a) _) = do
74keepThisTable t@(TheseTable (MaybeTable _ a) _) = do
92 where_ $ isThisTable t
75 where_ $ isThisTable t
93− pure (extract a)
76+ pure a
94
77
95
78
96−loseThisTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)
79+loseThisTable :: TheseTable a b -> Query (MaybeTable a, b)
97loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do
80loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do
98 where_ $ not_ $ isThisTable t
81 where_ $ not_ $ isThisTable t
99− pure (ma, extract b)
82+ pure (ma, b)
100
83
101
84
102−keepThatTable :: TheseTable Expr a b -> Query b
85+keepThatTable :: TheseTable a b -> Query b
103keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do
86keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do
104 where_ $ isThatTable t
87 where_ $ isThatTable t
105− pure (extract b)
88+ pure b
106
89
107
90
108−loseThatTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)
91+loseThatTable :: TheseTable a b -> Query (a, MaybeTable b)
109loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do
92loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do
110 where_ $ not_ $ isThatTable t
93 where_ $ not_ $ isThatTable t
111− pure (extract a, mb)
94+ pure (a, mb)
112
95
113
96
114−keepThoseTable :: TheseTable Expr a b -> Query (a, b)
97+keepThoseTable :: TheseTable a b -> Query (a, b)
115keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
98keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
116 where_ $ isThoseTable t
99 where_ $ isThoseTable t
117− pure (extract a, extract b)
100+ pure (a, b)
118
101
119
102
120−loseThoseTable :: TheseTable Expr a b -> Query (EitherTable Expr a b)
103+loseThoseTable :: TheseTable a b -> Query (EitherTable a b)
121loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
104loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
122 where_ $ not_ $ isThoseTable t
105 where_ $ not_ $ isThoseTable t
123 pure $ EitherTable tag a b
106 pure $ EitherTable tag a b
@@ -125,14 +108,22 @@ loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
125 tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)
108 tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)
126
109
127
110
111+bindTheseTable :: (Table DB 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+
128−bitraverseTheseTable :: ()
118+bitraverseTheseTable :: (Table DB c, Table DB d)
129 => (a -> Query c)
119 => (a -> Query c)
130 -> (b -> Query d)
120 -> (b -> Query d)
131− -> TheseTable Expr a b
121+ -> TheseTable a b
132− -> Query (TheseTable Expr c d)
122+ -> Query (TheseTable c d)
133−bitraverseTheseTable f g t = do
123+bitraverseTheseTable f g (TheseTable here there) =
134− mc <- optional (f . fst =<< keepHereTable t)
124+ bimap fromJustTable fromJustTable <$>
135− md <- optional (g . snd =<< keepThereTable t)
125+ alignBy (\l r -> isJustTable l &&. isJustTable r)
136− where_ $ isJustTable mc ==. hasHereTable t
126+ (traverseMaybeTable f here)
137− where_ $ isJustTable md ==. hasThereTable t
127+ (traverseMaybeTable g there)
138− pure $ TheseTable mc md
128+ where
129+ fromJustTable (MaybeTable _ a) = a
src/Rel8/Query/Values.hs+2−5
@@ -13,15 +13,12 @@ import Prelude
13import qualified Opaleye.Values as Opaleye
13import qualified Opaleye.Values as Opaleye
14
14
15-- rel8
15-- rel8
16−import Rel8.Expr ( Expr )
17import {-# SOURCE #-} Rel8.Query ( Query )
16import {-# SOURCE #-} Rel8.Query ( Query )
18import Rel8.Query.Opaleye ( fromOpaleye )
17import Rel8.Query.Opaleye ( fromOpaleye )
19import Rel8.Table ( Table )
18import Rel8.Table ( Table )
20import Rel8.Table.Opaleye ( valuesspec )
19import Rel8.Table.Opaleye ( valuesspec )
20+import Rel8.Schema.Context ( DB )
21
21
22
22
23−-- | 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
25−-- @VALUES@ expression for efficiency.
26−values :: (Table Expr a, Foldable f) => f a -> Query a
23+values :: (Table DB a, Foldable f) => f a -> Query a
27values = fromOpaleye . Opaleye.valuesExplicit valuesspec . toList
24values = 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+141
@@ -0,0 +1,141 @@
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.Kind ( Type )
17+import Data.List.NonEmpty ( NonEmpty )
18+import GHC.TypeLits ( Symbol )
19+import Prelude
20+
21+-- rel8
22+import Rel8.Kind.Labels ( Labels )
23+import Rel8.Kind.Necessity ( Necessity( Required, Optional ) )
24+import Rel8.Schema.Context ( Result, IsSpecialContext )
25+import Rel8.Schema.Field ( Field )
26+import Rel8.Schema.Nullability ( Unnullify )
27+import Rel8.Schema.Spec ( Context )
28+import Rel8.Schema.Structure
29+ ( Structure
30+ , Shape( Either, List, Maybe, NonEmpty, These )
31+ , Shape1
32+ , Shape2
33+ )
34+import Rel8.Table.Either ( EitherTable )
35+import Rel8.Table.List ( ListTable )
36+import Rel8.Table.Maybe ( MaybeTable )
37+import Rel8.Table.NonEmpty ( NonEmptyTable )
38+import Rel8.Table.These ( TheseTable )
39+
40+-- these
41+import Data.These ( These )
42+
43+
44+type Label :: Symbol -> Type -> Type
45+data Label label a
46+
47+
48+type Default :: Type -> Type
49+data Default a
50+
51+
52+type GetLabel :: Type -> Labels
53+type family GetLabel a where
54+ GetLabel (Label label _) = '[label]
55+ GetLabel _ = '[]
56+
57+
58+type UnwrapLabel :: Type -> Type
59+type family UnwrapLabel a where
60+ UnwrapLabel (Label _ a) = a
61+ UnwrapLabel a = a
62+
63+
64+type GetNecessity :: Type -> Necessity
65+type family GetNecessity a where
66+ GetNecessity (Default _) = 'Optional
67+ GetNecessity _ = 'Required
68+
69+
70+type UnwrapDefault :: Type -> Type
71+type family UnwrapDefault a where
72+ UnwrapDefault (Default a) = a
73+ UnwrapDefault a = a
74+
75+
76+type Column :: Context -> Type -> Type
77+type Column context a =
78+ Field context (GetLabel a)
79+ (GetNecessity (UnwrapLabel a))
80+ (Unnullify (UnwrapDefault (UnwrapLabel a)))
81+ (UnwrapDefault (UnwrapLabel a))
82+
83+
84+type IHEither :: Bool -> Context -> Type -> Type -> Type
85+type family IHEither isSpecialContext context where
86+ IHEither 'False _ = EitherTable
87+ IHEither 'True Result = Either
88+ IHEither 'True Structure = Shape2 'Either
89+ IHEither 'True _ = EitherTable
90+
91+
92+type IHList :: Bool -> Context -> Type -> Type
93+type family IHList isSpecialContext context where
94+ IHList 'False _ = ListTable
95+ IHList 'True Result = []
96+ IHList 'True Structure = Shape1 'List
97+ IHList 'True _ = ListTable
98+
99+
100+type IHMaybe :: Bool -> Context -> Type -> Type
101+type family IHMaybe isSpecialContext context where
102+ IHMaybe 'False _ = MaybeTable
103+ IHMaybe 'True Result = Maybe
104+ IHMaybe 'True Structure = Shape1 'Maybe
105+ IHMaybe 'True _ = MaybeTable
106+
107+
108+type IHNonEmpty :: Bool -> Context -> Type -> Type
109+type family IHNonEmpty isSpecialContext context where
110+ IHNonEmpty 'False _ = NonEmptyTable
111+ IHNonEmpty 'True Result = NonEmpty
112+ IHNonEmpty 'True Structure = Shape1 'NonEmpty
113+ IHNonEmpty 'True _ = NonEmptyTable
114+
115+
116+type IHThese :: Bool -> Context -> Type -> Type -> Type
117+type family IHThese isSpecialContext context where
118+ IHThese 'False _ = TheseTable
119+ IHThese 'True Result = These
120+ IHThese 'True Structure = Shape2 'These
121+ IHThese 'True _ = TheseTable
122+
123+
124+type HEither :: Context -> Type -> Type -> Type
125+type HEither context = IHEither (IsSpecialContext context) context
126+
127+
128+type HList :: Context -> Type -> Type
129+type HList context = IHList (IsSpecialContext context) context
130+
131+
132+type HMaybe :: Context -> Type -> Type
133+type HMaybe context = IHMaybe (IsSpecialContext context) context
134+
135+
136+type HNonEmpty :: Context -> Type -> Type
137+type HNonEmpty context = IHNonEmpty (IsSpecialContext context) context
138+
139+
140+type HThese :: Context -> Type -> Type -> Type
141+type HThese context = IHThese (IsSpecialContext context) context
src/Rel8/Schema/Context.hsnew file+144
@@ -0,0 +1,144 @@
1+{-# language DataKinds #-}
2+{-# language DerivingStrategies #-}
3+{-# language FlexibleInstances #-}
4+{-# language GADTs #-}
5+{-# language GeneralizedNewtypeDeriving #-}
6+{-# language ScopedTypeVariables #-}
7+{-# language StandaloneDeriving #-}
8+{-# language StandaloneKindSignatures #-}
9+{-# language TypeApplications #-}
10+{-# language TypeFamilies #-}
11+{-# language UndecidableInstances #-}
12+
13+module Rel8.Schema.Context
14+ ( Aggregation( Aggregation )
15+ , DB( DB, unDB )
16+ , Insertion( RequiredInsert, OptionalInsert )
17+ , Name( Name )
18+ , Result( Result )
19+ , IsSpecialContext
20+ )
21+where
22+
23+-- base
24+import Control.Applicative ( liftA2 )
25+import Data.String ( IsString )
26+import Prelude
27+
28+-- rel8
29+import Rel8.Aggregate ( Aggregate )
30+import Rel8.Expr ( Expr )
31+import Rel8.Kind.Necessity
32+ ( Necessity( Optional, Required )
33+ , SNecessity( SOptional, SRequired )
34+ , KnownNecessity, necessitySing
35+ )
36+import Rel8.Schema.Nullability ( Nullabilizes )
37+import Rel8.Schema.Spec ( Context, Spec( Spec ) )
38+import Rel8.Schema.Structure ( Structure )
39+import Rel8.Type.Monoid ( DBMonoid )
40+import Rel8.Type.Semigroup ( DBSemigroup )
41+
42+
43+type Aggregation :: Context
44+data Aggregation spec where
45+ Aggregation :: ()
46+ => Aggregate (Expr a)
47+ -> Aggregation ('Spec labels necessity dbType a)
48+
49+
50+type DB :: Context
51+data DB spec where
52+ DB :: ()
53+ => { unDB :: Expr a }
54+ -> DB ('Spec labels necessity dbType a)
55+deriving stock instance Show (DB spec)
56+
57+
58+instance
59+ ( spec ~ 'Spec labels necessity dbType a
60+ , DBSemigroup dbType
61+ , Nullabilizes dbType a
62+ ) =>
63+ Semigroup (DB spec)
64+ where
65+ DB a <> DB b = DB (a <> b)
66+
67+
68+instance
69+ ( spec ~ 'Spec labels necessity dbType a
70+ , DBMonoid dbType
71+ , Nullabilizes dbType a
72+ ) =>
73+ Monoid (DB spec)
74+ where
75+ mempty = DB mempty
76+
77+
78+type Insertion :: Context
79+data Insertion spec where
80+ RequiredInsert :: ()
81+ => Expr a
82+ -> Insertion ('Spec labels 'Required dbType a)
83+ OptionalInsert :: ()
84+ => Maybe (Expr a)
85+ -> Insertion ('Spec labels 'Optional dbType a)
86+deriving stock instance Show (Insertion spec)
87+
88+
89+instance
90+ ( spec ~ 'Spec labels necessity dbType a
91+ , DBSemigroup dbType
92+ , Nullabilizes dbType a
93+ ) =>
94+ Semigroup (Insertion spec)
95+ where
96+ RequiredInsert a <> RequiredInsert b = RequiredInsert (a <> b)
97+ OptionalInsert ma <> OptionalInsert mb = OptionalInsert (liftA2 (<>) ma mb)
98+
99+
100+instance
101+ ( spec ~ 'Spec labels necessity dbType a
102+ , KnownNecessity necessity
103+ , DBMonoid dbType
104+ , Nullabilizes dbType a
105+ ) => Monoid (Insertion spec)
106+ where
107+ mempty = case necessitySing @necessity of
108+ SRequired -> RequiredInsert mempty
109+ SOptional -> OptionalInsert (Just mempty)
110+
111+
112+type Name :: Context
113+newtype Name spec = Name String
114+ deriving stock Show
115+ deriving newtype (IsString, Monoid, Semigroup)
116+
117+
118+type Result :: Context
119+data Result spec where
120+ Result :: a -> Result ('Spec labels necessity dbType a)
121+deriving stock instance Show a =>
122+ Show (Result ('Spec labels necessity dbType a))
123+
124+
125+instance (spec ~ 'Spec labels necessity dbType a, Semigroup a) =>
126+ Semigroup (Result spec)
127+ where
128+ Result a <> Result b = Result (a <> b)
129+
130+
131+instance (spec ~ 'Spec labels necessity dbType a, Monoid a) =>
132+ Monoid (Result spec)
133+ where
134+ mempty = Result mempty
135+
136+
137+type IsSpecialContext :: Context -> Bool
138+type family IsSpecialContext context where
139+ IsSpecialContext Aggregation = 'True
140+ IsSpecialContext DB = 'True
141+ IsSpecialContext Insertion = 'True
142+ IsSpecialContext Result = 'True
143+ IsSpecialContext Structure = 'True
144+ IsSpecialContext _ = 'False
src/Rel8/Schema/Context/Label.hsnew file+67
@@ -0,0 +1,67 @@
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+ )
12+where
13+
14+-- base
15+import Data.Kind ( Constraint )
16+import Prelude hiding ( null )
17+
18+-- rel8
19+import Rel8.Schema.Context
20+ ( Aggregation( Aggregation )
21+ , DB( DB )
22+ , Insertion( RequiredInsert, OptionalInsert )
23+ , Name( Name )
24+ , Result( Result )
25+ )
26+import Rel8.Schema.Spec ( Context, Spec( Spec ) )
27+
28+
29+type Labelable :: Context -> Constraint
30+class Labelable context where
31+ labeler :: ()
32+ => context ('Spec labels necessity db a)
33+ -> context ('Spec (label ': labels) necessity db a)
34+
35+ unlabeler :: ()
36+ => context ('Spec (label ': labels) necessity db a)
37+ -> context ('Spec labels necessity db a)
38+
39+
40+instance Labelable Aggregation where
41+ labeler (Aggregation aggregate) = Aggregation aggregate
42+ unlabeler (Aggregation aggregate) = Aggregation aggregate
43+
44+
45+instance Labelable DB where
46+ labeler (DB a) = DB a
47+ unlabeler (DB a) = DB a
48+
49+
50+instance Labelable Insertion where
51+ labeler = \case
52+ RequiredInsert a -> RequiredInsert a
53+ OptionalInsert ma -> OptionalInsert ma
54+
55+ unlabeler = \case
56+ RequiredInsert a -> RequiredInsert a
57+ OptionalInsert ma -> OptionalInsert ma
58+
59+
60+instance Labelable Name where
61+ labeler (Name name) = Name name
62+ unlabeler (Name name) = Name name
63+
64+
65+instance Labelable Result where
66+ labeler (Result a) = Result a
67+ unlabeler (Result a) = Result a
src/Rel8/Schema/Context/Nullify.hs+131−110
@@ -1,144 +1,165 @@
1{-# language DataKinds #-}
1{-# language DataKinds #-}
2−{-# language EmptyCase #-}
3−{-# language FlexibleContexts #-}
4−{-# language GADTs #-}
5{-# language LambdaCase #-}
2{-# language LambdaCase #-}
3+{-# language FlexibleContexts #-}
4+{-# language FlexibleInstances #-}
5+{-# language MultiParamTypeClasses #-}
6{-# language NamedFieldPuns #-}
6{-# language NamedFieldPuns #-}
7+{-# language ScopedTypeVariables #-}
7{-# language StandaloneKindSignatures #-}
8{-# language StandaloneKindSignatures #-}
9+{-# language TypeApplications #-}
10+{-# language TypeFamilies #-}
8
11
9module Rel8.Schema.Context.Nullify
12module Rel8.Schema.Context.Nullify
10− ( Nullifiability(..), NonNullifiability(..), nullifiableOrNot, absurd
11− , Nullifiable, nullifiability
12− , guarder, nullifier, unnullifier
13+ ( Nullifiable( encodeTag, decodeTag, nullifier, unnullifier )
13− , sguard, snullify
14+ , NullifiableEq
14 )
15 )
15where
16where
16
17
17-- base
18-- base
18−import Data.Bool ( bool )
19+import Control.Applicative ( empty )
19−import Data.Functor.Identity ( Identity( Identity ) )
20+import Data.Foldable ( fold )
20−import Data.Kind ( Constraint, Type )
21+import Data.Kind ( Constraint )
22+import qualified Data.List.NonEmpty as NonEmpty
23+import Data.Monoid ( First( First ), getFirst )
21import Prelude hiding ( null )
24import Prelude hiding ( null )
22
25
23-- opaleye
26-- opaleye
24import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
27import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
25
28
26-- rel8
29-- rel8
27−import Rel8.Aggregate ( Aggregate(..), zipOutputs )
30+import Rel8.Aggregate ( Aggregate, foldInputs, mapInputs )
28−import Rel8.Expr ( Expr )
31+import Rel8.Expr ( Expr( Expr ) )
32+import Rel8.Expr.Aggregate ( groupByExpr )
29import Rel8.Expr.Bool ( boolExpr )
33import Rel8.Expr.Bool ( boolExpr )
30import Rel8.Expr.Null ( nullify, unsafeUnnullify )
34import Rel8.Expr.Null ( nullify, unsafeUnnullify )
31−import Rel8.Expr.Opaleye ( fromPrimExpr )
35+import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
32−import Rel8.Kind.Context ( SContext(..) )
36+import Rel8.Kind.Labels ( KnownLabels, labelsSing, renderLabels )
37+import Rel8.Kind.Necessity ( Necessity( Required ) )
33−import Rel8.Schema.Field ( Field )
38+import Rel8.Schema.Context
34−import qualified Rel8.Schema.Kind as K
39+ ( Aggregation( Aggregation )
40+ , DB( DB )
41+ , Insertion( RequiredInsert, OptionalInsert )
42+ , Name( Name )
43+ )
35−import Rel8.Schema.Name ( Name( Name ) )
44+import Rel8.Schema.Nullability
36−import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )
45+ ( Nullability( Nullable, NonNullable )
46+ , Nullabilizes
47+ )
48+import Rel8.Schema.Spec ( Context, Spec( Spec ), SSpec(..) )
37−import Rel8.Schema.Result ( Result )
49+import Rel8.Type.Eq ( DBEq )
38−import Rel8.Schema.Spec ( Spec(..) )
50+import Rel8.Type.Monoid ( DBMonoid )
39
51
40
52
41−type Nullifiability :: K.Context -> Type
53+type Nullifiable :: Context -> Constraint
42−data Nullifiability context where
54+class Nullifiable context where
43− NAggregate :: Nullifiability Aggregate
55+ encodeTag :: (DBEq db, Nullabilizes db a, KnownLabels labels)
44− NExpr :: Nullifiability Expr
56+ => Expr a
45− NName :: Nullifiability Name
57+ -> context ('Spec labels 'Required db a)
46
58
59+ decodeTag :: (DBMonoid db, Nullabilizes db a)
60+ => context ('Spec labels 'Required db a)
61+ -> Expr a
47
62
48−type Nullifiable :: K.Context -> Constraint
63+ nullifier :: ()
49−class Nullifiable context where
64+ => Expr Bool
50− nullifiability :: Nullifiability context
65+ -> SSpec ('Spec labels necessity db a)
66+ -> context ('Spec labels necessity db a)
67+ -> context ('Spec labels necessity db (Maybe db))
68+
69+ unnullifier :: ()
70+ => Expr Bool
71+ -> SSpec ('Spec labels necessity db a)
72+ -> context ('Spec labels necessity db (Maybe db))
73+ -> context ('Spec labels necessity db a)
74+
75+
76+instance Nullifiable Aggregation where
77+ encodeTag = Aggregation . groupByExpr
78+ decodeTag (Aggregation aggregate) = fold $ undoGroupBy aggregate
79+
80+ nullifier tag SSpec {nullability} (Aggregation aggregate) = Aggregation $
81+ mapInputs (toPrimExpr . runTag nullability tag . fromPrimExpr) $
82+ runTag nullability tag <$> aggregate
83+
84+ unnullifier _ SSpec {nullability} (Aggregation aggregate) =
85+ Aggregation $ unnull nullability <$> aggregate
86+
87+ {-# INLINABLE encodeTag #-}
88+ {-# INLINABLE decodeTag #-}
89+ {-# INLINABLE nullifier #-}
90+ {-# INLINABLE unnullifier #-}
51
91
52
92
53−instance Nullifiable Aggregate where
93+instance Nullifiable DB where
54− nullifiability = NAggregate
94+ encodeTag = DB
95+ decodeTag (DB a) = a
96+ nullifier tag SSpec {nullability} (DB a) = DB $ runTag nullability tag a
97+ unnullifier _ SSpec {nullability} (DB a) = DB $ unnull nullability a
55
98
99+ {-# INLINABLE encodeTag #-}
100+ {-# INLINABLE decodeTag #-}
101+ {-# INLINABLE nullifier #-}
102+ {-# INLINABLE unnullifier #-}
56
103
104+
57−instance Nullifiable Expr where
105+instance Nullifiable Insertion where
58− nullifiability = NExpr
106+ encodeTag = RequiredInsert
107+ decodeTag (RequiredInsert a) = a
108+
109+ nullifier tag SSpec {nullability} = \case
110+ RequiredInsert a -> RequiredInsert $ runTag nullability tag a
111+ OptionalInsert ma -> OptionalInsert $ runTag nullability tag <$> ma
112+
113+ unnullifier _ SSpec {nullability} = \case
114+ RequiredInsert a -> RequiredInsert $ unnull nullability a
115+ OptionalInsert ma -> OptionalInsert $ unnull nullability <$> ma
116+
117+ {-# INLINABLE encodeTag #-}
118+ {-# INLINABLE decodeTag #-}
119+ {-# INLINABLE nullifier #-}
120+ {-# INLINABLE unnullifier #-}
59
121
60
122
61instance Nullifiable Name where
123instance Nullifiable Name where
62− nullifiability = NName
124+ encodeTag _ = nameFromLabel
63−
125+ decodeTag _ = mempty
64−
126+ nullifier _ _ (Name name) = Name name
65−type NonNullifiability :: K.Context -> Type
127+ unnullifier _ _ (Name name) = Name name
66−data NonNullifiability context where
128+
67− NField :: NonNullifiability (Field table)
129+ {-# INLINABLE encodeTag #-}
68− NResult :: NonNullifiability Result
130+ {-# INLINABLE decodeTag #-}
69−
131+ {-# INLINABLE nullifier #-}
70−
132+ {-# INLINABLE unnullifier #-}
71−nullifiableOrNot :: ()
133+
72− => SContext context
134+
73− -> Either (NonNullifiability context) (Nullifiability context)
135+type NullifiableEq :: Context -> Context -> Constraint
74−nullifiableOrNot = \case
136+class (a ~ b, Nullifiable b) => NullifiableEq a b
75− SAggregate -> Right NAggregate
137+instance (a ~ b, Nullifiable b) => NullifiableEq a b
76− SExpr -> Right NExpr
138+
77− SField -> Left NField
139+
78− SName -> Right NName
140+runTag :: Nullability db a -> Expr Bool -> Expr a -> Expr (Maybe db)
79− SResult -> Left NResult
141+runTag nullability tag a = case nullability of
80−
142+ Nullable -> boolExpr null a tag
81−
143+ NonNullable -> boolExpr null (nullify a) tag
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
131 where
144 where
132− null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit
145+ null = Expr (Opaleye.ConstExpr Opaleye.NullLit)
133
146
134
147
135−snullify :: Nullity a -> Expr a -> Expr (Nullify a)
148+unnull :: Nullability db a -> Expr (Maybe db) -> Expr a
136−snullify nullity a = case nullity of
149+unnull nullability a = case nullability of
137− Null -> a
150+ Nullable -> a
138− NotNull -> nullify a
151+ NonNullable -> unsafeUnnullify a
152+
153+
154+-- HACK
155+undoGroupBy :: Aggregate (Expr _a) -> Maybe (Expr a)
156+undoGroupBy = getFirst . foldInputs go
157+ where
158+ go Nothing a = pure (Expr a)
159+ go _ _ = First empty
139
160
140
161
141−sunnullify :: Nullity a -> Expr (Nullify a) -> Expr a
162+nameFromLabel :: forall labels necessity db a.
142−sunnullify nullity a = case nullity of
163+ KnownLabels labels => Name ('Spec labels necessity db a)
143− Null -> a
164+nameFromLabel = case labelsSing @labels of
144− NotNull -> unsafeUnnullify a
165+ labels -> Name (NonEmpty.last (renderLabels labels))
src/Rel8/Schema/Context/Result.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.Result
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.List.NonEmpty ( NonEmpty )
18+import Prelude hiding ( null )
19+
20+-- rel8
21+import Rel8.Schema.Context ( Result( Result ) )
22+import Rel8.Schema.HTable ( HTable )
23+import Rel8.Schema.HTable.Context ( H )
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 (H Result)) (u (H Result))
45+ -> HEitherTable t u (H Result)
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 (H Result)
63+ -> Either (t (H Result)) (u (H Result))
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 (H Result)] -> HListTable t (H Result)
74+toHListTable = hvectorize vectorizer
75+{-# INLINABLE toHListTable #-}
76+
77+
78+fromHListTable :: HTable t => HListTable t (H Result) -> [t (H Result)]
79+fromHListTable = hunvectorize unvectorizer
80+{-# INLINABLE fromHListTable #-}
81+
82+
83+toHMaybeTable :: HTable t => Maybe (t (H Result)) -> HMaybeTable t (H Result)
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 (H Result) -> Maybe (t (H Result))
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 (H Result)) -> HNonEmptyTable t (H Result)
107+toHNonEmptyTable = hvectorize vectorizer
108+{-# INLINABLE toHNonEmptyTable #-}
109+
110+
111+fromHNonEmptyTable :: HTable t => HNonEmptyTable t (H Result) -> NonEmpty (t (H Result))
112+fromHNonEmptyTable = hunvectorize unvectorizer
113+{-# INLINABLE fromHNonEmptyTable #-}
114+
115+
116+toHTheseTable :: (HTable t, HTable u)
117+ => These (t (H Result)) (u (H Result))
118+ -> HTheseTable t u (H Result)
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 (H Result)
139+ -> These (t (H Result)) (u (H Result))
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 :: Result ('Spec labels necessity db (Maybe db))
159+null = Result Nothing
160+
161+
162+nullifier :: ()
163+ => SSpec ('Spec labels necessity db a)
164+ -> Result ('Spec labels necessity db a)
165+ -> Result ('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+ -> Result ('Spec labels necessity db (Maybe db))
174+ -> Maybe (Result ('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 (Result ('Spec labels necessity db a))
184+ -> Result ('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+ -> Result ('Spec labels necessity (f a) (f a))
191+ -> f (Result ('Spec labels necessity db a))
192+unvectorizer _ (Result results) = Result <$> results
193+
194+
195+relabel :: ()
196+ => HIdentity ('Spec labels necessity db a) (H Result)
197+ -> HIdentity ('Spec relabels necessity db a) (H Result)
198+relabel (HIdentity (Result a)) = HIdentity (Result a)
src/Rel8/Schema/Field.hs+23−32
@@ -1,50 +1,41 @@
1{-# language DataKinds #-}
1{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
3−{-# language MultiParamTypeClasses #-}
4{-# language StandaloneKindSignatures #-}
2{-# language StandaloneKindSignatures #-}
5{-# language TypeFamilies #-}
3{-# language TypeFamilies #-}
4+{-# language UndecidableInstances #-}
6
5
7module Rel8.Schema.Field
6module Rel8.Schema.Field
8− ( Field(..)
7+ ( Field
9− , fields
10 )
8 )
11where
9where
12
10
13-- base
11-- base
14−import Data.Functor.Identity ( Identity( Identity ) )
15import Data.Kind ( Type )
12import Data.Kind ( Type )
16import Prelude
13import Prelude
17
14
18-- rel8
15-- rel8
19−import Rel8.Schema.HTable ( HField, htabulate )
16+import Rel8.Aggregate ( Aggregate )
20−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
17+import Rel8.Expr ( Expr )
21−import Rel8.Schema.Kind as K
18+import Rel8.Kind.Labels ( Labels )
22−import Rel8.Schema.Null ( Sql )
19+import Rel8.Kind.Necessity ( Necessity( Required, Optional ) )
23−import Rel8.Table
20+import Rel8.Schema.Context
24− ( Table, Columns, Context, fromColumns, toColumns
21+ ( Aggregation, DB, Insertion, Result
25− , FromExprs, fromResult, toResult
22+ , IsSpecialContext
26− , Transpose
27 )
23 )
28−import Rel8.Table.Transpose ( Transposes )
24+import Rel8.Schema.Spec ( Context, Spec( Spec ) )
29−import Rel8.Type ( DBType )
25+import Rel8.Schema.Structure ( Structure, Shape( Column ), Shape1 )
30
26
31
27
32−-- | A special context used in the construction of 'Rel8.Projection's.
28+type IField :: Bool -> Context -> Labels -> Necessity -> Type -> Type -> Type
33−type Field :: Type -> K.Context
29+type family IField isSpecialContext labels context necessity db a where
34−newtype Field table a = Field (HField (Columns table) a)
30+ IField 'False context labels necessity db a = context ('Spec labels necessity db a)
31+ IField 'True Result _labels _necessity _db a = a
32+ IField 'True DB _labels _necessity _db a = Expr a
33+ IField 'True Insertion _labels 'Required _db a = Expr a
34+ IField 'True Insertion _labels 'Optional _db a = Maybe (Expr a)
35+ IField 'True Aggregation _labels _necessity _db a = Aggregate (Expr a)
36+ IField 'True Structure labels necessity db a = Shape1 'Column ('Spec labels necessity db a)
35
37
36
38
37−instance Sql DBType a => Table (Field table) (Field table a) where
39+type Field :: Context -> Labels -> Necessity -> Type -> Type -> Type
38− type Columns (Field table a) = HIdentity a
40+type Field context labels necessity db a =
39− type Context (Field table a) = Field table
41+ IField (IsSpecialContext context) context labels necessity db a
40− type FromExprs (Field table a) = a
41− type Transpose to (Field table a) = to a
42−
43− toColumns = HIdentity
44− fromColumns (HIdentity a) = a
45− toResult a = HIdentity (Identity a)
46− fromResult (HIdentity (Identity a)) = a
47−
48−
49−fields :: Transposes context (Field table) table fields => fields
50−fields = fromColumns $ htabulate Field
src/Rel8/Schema/Generic.hsnew file+1021
@@ -0,0 +1,1021 @@
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.Kind ( Constraint, Type )
27+import Data.List.NonEmpty ( NonEmpty )
28+import GHC.Generics
29+ ( Generic, Rep, from, to
30+ , (:*:)( (:*:) ), K1( K1 ), M1( M1 )
31+ , D, C, S
32+ , Meta( MetaSel )
33+ )
34+import GHC.TypeLits ( Symbol )
35+import Prelude
36+
37+-- rel8
38+import Rel8.Kind.Necessity
39+ ( SNecessity( SRequired, SOptional )
40+ , KnownNecessity, necessitySing
41+ )
42+import Rel8.Schema.Context
43+ ( Aggregation( Aggregation )
44+ , DB( DB )
45+ , Insertion( RequiredInsert, OptionalInsert )
46+ , Result( Result )
47+ , IsSpecialContext
48+ )
49+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
50+import Rel8.Schema.Context.Nullify ( Nullifiable )
51+import Rel8.Schema.Context.Result
52+ ( fromHEitherTable, toHEitherTable
53+ , fromHListTable, toHListTable
54+ , fromHMaybeTable, toHMaybeTable
55+ , fromHNonEmptyTable, toHNonEmptyTable
56+ , fromHTheseTable, toHTheseTable
57+ )
58+import Rel8.Schema.Field ( Field )
59+import Rel8.Schema.HTable ( HTable )
60+import Rel8.Schema.HTable.Context ( H, HKTable )
61+import Rel8.Schema.HTable.Either ( HEitherTable )
62+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
63+import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
64+import Rel8.Schema.HTable.List ( HListTable )
65+import Rel8.Schema.HTable.Maybe ( HMaybeTable )
66+import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
67+import Rel8.Schema.HTable.Pair ( HPair(..) )
68+import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
69+import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
70+import Rel8.Schema.HTable.These ( HTheseTable )
71+import Rel8.Schema.HTable.Trio ( HTrio(..) )
72+import Rel8.Schema.HTable.Vectorize ( hrelabel )
73+import Rel8.Schema.Spec ( Spec( Spec ), KTable )
74+import qualified Rel8.Schema.Spec as Kind ( Context )
75+import Rel8.Schema.Structure
76+ ( IsStructure, Shape(..), Shape1, Shape2
77+ , Structure
78+ )
79+import Rel8.Table
80+ ( Table, Columns, Context, fromColumns, toColumns
81+ )
82+import Rel8.Table.Either ( EitherTable )
83+import Rel8.Table.Lifted
84+ ( fromColumns1, toColumns1
85+ , fromColumns2, toColumns2
86+ )
87+import Rel8.Table.List ( ListTable )
88+import Rel8.Table.Maybe ( MaybeTable(..) )
89+import Rel8.Table.NonEmpty ( NonEmptyTable )
90+import Rel8.Table.These ( TheseTable )
91+
92+-- these
93+import Data.These ( These )
94+
95+
96+instance (Rel8able t, TableHelper (IsSpecialContext context) context) =>
97+ Table context (t context)
98+ where
99+ type Columns (t context) = GRep t
100+ type Context (t context) = context
101+ fromColumns = gfromColumns
102+ toColumns = gtoColumns
103+
104+
105+type TableHelper :: Bool -> Kind.Context -> Constraint
106+class IsSpecialContext context ~ isSpecialContext =>
107+ TableHelper isSpecialContext context
108+ where
109+ gfromColumns :: Rel8able t => GRep t (H context) -> t context
110+ gtoColumns :: Rel8able t => t context -> GRep t (H context)
111+
112+
113+instance TableHelper 'True Aggregation where
114+ gfromColumns = fromAggregationColumns
115+ gtoColumns = toAggregationColumns
116+
117+
118+instance TableHelper 'True DB where
119+ gfromColumns = fromDBColumns
120+ gtoColumns = toDBColumns
121+
122+
123+instance TableHelper 'True Insertion where
124+ gfromColumns = fromInsertionColumns
125+ gtoColumns = toInsertionColumns
126+
127+
128+instance TableHelper 'True Result where
129+ gfromColumns = fromResultColumns
130+ gtoColumns = toResultColumns
131+
132+
133+instance (IsSpecialContext context ~ 'False, Labelable context, Nullifiable context) =>
134+ TableHelper 'False context
135+ where
136+ gfromColumns = fromUnspecialColumns
137+ gtoColumns = toUnspecialColumns
138+
139+
140+type Rel8able :: KTable -> Constraint
141+class HTable (GRep t) => Rel8able t where
142+ type GRep t :: HKTable
143+
144+ fromAggregationColumns :: GRep t (H Aggregation) -> t Aggregation
145+ toAggregationColumns :: t Aggregation -> GRep t (H Aggregation)
146+
147+ fromDBColumns :: GRep t (H DB) -> t DB
148+ toDBColumns :: t DB -> GRep t (H DB)
149+
150+ fromInsertionColumns :: GRep t (H Insertion) -> t Insertion
151+ toInsertionColumns :: t Insertion -> GRep t (H Insertion)
152+
153+ fromResultColumns :: GRep t (H Result) -> t Result
154+ toResultColumns :: t Result -> GRep t (H Result)
155+
156+ fromUnspecialColumns ::
157+ ( IsSpecialContext context ~ 'False
158+ , Labelable context, Nullifiable context
159+ )
160+ => GRep t (H context) -> t context
161+ toUnspecialColumns ::
162+ ( IsSpecialContext context ~ 'False
163+ , Labelable context, Nullifiable context
164+ )
165+ => t context -> GRep t (H context)
166+
167+ type GRep t = GColumns (Rep (t Structure))
168+
169+ default fromAggregationColumns ::
170+ ( Generic (t Aggregation)
171+ , GColumns (Rep (t Structure)) ~ GRep t
172+ , GRel8able Aggregation (Rep (t Structure)) (Rep (t Aggregation))
173+ ) => GRep t (H Aggregation) -> t Aggregation
174+ fromAggregationColumns = to . fromGColumns @_ @(Rep (t Structure))
175+
176+ default toAggregationColumns ::
177+ ( Generic (t Aggregation)
178+ , GColumns (Rep (t Structure)) ~ GRep t
179+ , GRel8able Aggregation (Rep (t Structure)) (Rep (t Aggregation))
180+ ) => t Aggregation -> GRep t (H Aggregation)
181+ toAggregationColumns = toGColumns @_ @(Rep (t Structure)) . from
182+
183+ default fromDBColumns ::
184+ ( Generic (t DB)
185+ , GColumns (Rep (t Structure)) ~ GRep t
186+ , GRel8able DB (Rep (t Structure)) (Rep (t DB))
187+ ) => GRep t (H DB) -> t DB
188+ fromDBColumns = to . fromGColumns @_ @(Rep (t Structure))
189+
190+ default toDBColumns ::
191+ ( Generic (t DB)
192+ , GColumns (Rep (t Structure)) ~ GRep t
193+ , GRel8able DB (Rep (t Structure)) (Rep (t DB))
194+ ) => t DB -> GRep t (H DB)
195+ toDBColumns = toGColumns @_ @(Rep (t Structure)) . from
196+
197+ default fromInsertionColumns ::
198+ ( Generic (t Insertion)
199+ , GColumns (Rep (t Structure)) ~ GRep t
200+ , GRel8able Insertion (Rep (t Structure)) (Rep (t Insertion))
201+ ) => GRep t (H Insertion) -> t Insertion
202+ fromInsertionColumns = to . fromGColumns @_ @(Rep (t Structure))
203+
204+ default toInsertionColumns ::
205+ ( Generic (t Insertion)
206+ , GColumns (Rep (t Structure)) ~ GRep t
207+ , GRel8able Insertion (Rep (t Structure)) (Rep (t Insertion))
208+ ) => t Insertion -> GRep t (H Insertion)
209+ toInsertionColumns = toGColumns @_ @(Rep (t Structure)) . from
210+
211+ default fromResultColumns ::
212+ ( Generic (t Result)
213+ , GColumns (Rep (t Structure)) ~ GRep t
214+ , GRel8able Result (Rep (t Structure)) (Rep (t Result))
215+ ) => GRep t (H Result) -> t Result
216+ fromResultColumns = to . fromGColumns @_ @(Rep (t Structure))
217+
218+ default toResultColumns ::
219+ ( Generic (t Result)
220+ , GColumns (Rep (t Structure)) ~ GRep t
221+ , GRel8able Result (Rep (t Structure)) (Rep (t Result))
222+ ) => t Result -> GRep t (H Result)
223+ toResultColumns = toGColumns @_ @(Rep (t Structure)) . from
224+
225+ default fromUnspecialColumns ::
226+ ( Generic (t context)
227+ , GColumns (Rep (t Structure)) ~ GRep t
228+ , GRel8able context (Rep (t Structure)) (Rep (t context))
229+ ) => GRep t (H context) -> t context
230+ fromUnspecialColumns = to . fromGColumns @_ @(Rep (t Structure))
231+
232+ default toUnspecialColumns ::
233+ ( Generic (t context)
234+ , GColumns (Rep (t Structure)) ~ GRep t
235+ , GRel8able context (Rep (t Structure)) (Rep (t context))
236+ ) => t context -> GRep t (H context)
237+ toUnspecialColumns = toGColumns @_ @(Rep (t Structure)) . from
238+
239+
240+type GColumns :: (Type -> Type) -> HKTable
241+type family GColumns structure where
242+ GColumns (M1 D _ structure) = GColumns structure
243+ GColumns (M1 C _ structure) = GColumns structure
244+ GColumns (a :*: b) = HPair (GColumns a) (GColumns b)
245+ GColumns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ structure)) =
246+ K1Columns label structure
247+
248+
249+type GRel8able :: Kind.Context -> (Type -> Type) -> (Type -> Type) -> Constraint
250+class GRel8able context structure rep where
251+ fromGColumns :: GColumns structure (H context) -> rep x
252+ toGColumns :: rep x -> GColumns structure (H context)
253+
254+
255+instance GRel8able context structure rep => GRel8able context (M1 D c structure) (M1 D c rep) where
256+ fromGColumns = M1 . fromGColumns @context @structure @rep
257+ toGColumns (M1 a) = toGColumns @context @structure @rep a
258+
259+
260+instance GRel8able context structure rep => GRel8able context (M1 C c structure) (M1 C c rep) where
261+ fromGColumns = M1 . fromGColumns @context @structure @rep
262+ toGColumns (M1 a) = toGColumns @context @structure @rep a
263+
264+
265+instance (GRel8able context structure1 rep1, GRel8able context structure2 rep2) =>
266+ GRel8able context (structure1 :*: structure2) (rep1 :*: rep2)
267+ where
268+ fromGColumns (HPair a b) =
269+ fromGColumns @context @structure1 @rep1 a :*:
270+ fromGColumns @context @structure2 @rep2 b
271+ toGColumns (a :*: b) =
272+ HPair
273+ (toGColumns @context @structure1 @rep1 a)
274+ (toGColumns @context @structure2 @rep2 b)
275+
276+
277+instance
278+ ( K1Table label isSpecialContext context isStructure structure a
279+ , meta ~ 'MetaSel ('Just label) _su _ss _ds
280+ , structureK1 ~ K1 i structure
281+ , k1 ~ K1 i a
282+ ) => GRel8able context (M1 S meta structureK1) (M1 S meta k1)
283+ where
284+ fromGColumns = M1 . K1 . fromK1Columns @label @_ @_ @_ @structure
285+ toGColumns (M1 (K1 a)) = toK1Columns @label @_ @_ @_ @structure a
286+
287+
288+type K1Columns :: Symbol -> Type -> HKTable
289+type family K1Columns label structure where
290+ K1Columns label (Shape1 'Column ('Spec '[] necessity nullability blueprint)) =
291+ HIdentity ('Spec '[label] necessity nullability blueprint)
292+ K1Columns _label (Shape1 'Column ('Spec (label ': labels) necessity nullability blueprint)) =
293+ HIdentity ('Spec (label ': labels) necessity nullability blueprint)
294+ K1Columns label (Shape2 'Either a b) =
295+ HLabel label (HEitherTable (K1Columns "Left" a) (K1Columns "Right" b))
296+ K1Columns label (Shape1 'List a) = HListTable (K1Columns label a)
297+ K1Columns label (Shape1 'Maybe a) = HLabel label (HMaybeTable (K1Columns "Just" a))
298+ K1Columns label (Shape1 'NonEmpty a) = HNonEmptyTable (K1Columns label a)
299+ K1Columns label (Shape2 'These a b) =
300+ HLabel label (HTheseTable (K1Columns "Here" a) (K1Columns "There" b))
301+ K1Columns label (a, b) =
302+ HLabel label
303+ (HPair
304+ (K1Columns "fst" a)
305+ (K1Columns "snd" b))
306+ K1Columns label (a, b, c) =
307+ HLabel label
308+ (HTrio
309+ (K1Columns "fst" a)
310+ (K1Columns "snd" b)
311+ (K1Columns "trd" c))
312+ K1Columns label (a, b, c, d) =
313+ HLabel label
314+ (HQuartet
315+ (K1Columns "fst" a)
316+ (K1Columns "snd" b)
317+ (K1Columns "trd" c)
318+ (K1Columns "frt" d))
319+ K1Columns label (a, b, c, d, e) =
320+ HLabel label
321+ (HQuintet
322+ (K1Columns "fst" a)
323+ (K1Columns "snd" b)
324+ (K1Columns "trd" c)
325+ (K1Columns "frt" d)
326+ (K1Columns "fft" e))
327+ K1Columns label a = HLabel label (Columns a)
328+
329+
330+type K1Table :: Symbol -> Bool -> Kind.Context -> Bool -> Type -> Type -> Constraint
331+class
332+ ( isSpecialContext ~ IsSpecialContext context
333+ , isStructure ~ IsStructure structure
334+ ) => K1Table label isSpecialContext context isStructure structure a
335+ where
336+ fromK1Columns :: K1Columns label structure (H context) -> a
337+ toK1Columns :: a -> K1Columns label structure (H context)
338+
339+
340+instance
341+ ( x ~ Field Aggregation '[] necessity db a
342+ ) => K1Table label 'True Aggregation 'True (Shape1 'Column ('Spec '[] necessity db a)) x
343+ where
344+ fromK1Columns (HIdentity (Aggregation a)) = a
345+ toK1Columns = HIdentity . Aggregation
346+ {-# INLINABLE fromK1Columns #-}
347+ {-# INLINABLE toK1Columns #-}
348+
349+
350+instance
351+ ( x ~ Field Aggregation (label ': labels) necessity db a
352+ ) => K1Table _label 'True Aggregation 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
353+ where
354+ fromK1Columns (HIdentity (Aggregation a)) = a
355+ toK1Columns = HIdentity . Aggregation
356+ {-# INLINABLE fromK1Columns #-}
357+ {-# INLINABLE toK1Columns #-}
358+
359+
360+instance
361+ ( x ~ Field DB '[] necessity db a
362+ ) => K1Table label 'True DB 'True (Shape1 'Column ('Spec '[] necessity db a)) x
363+ where
364+ fromK1Columns (HIdentity (DB a)) = a
365+ toK1Columns = HIdentity . DB
366+ {-# INLINABLE fromK1Columns #-}
367+ {-# INLINABLE toK1Columns #-}
368+
369+
370+instance
371+ ( x ~ Field DB (label ': labels) necessity db a
372+ ) => K1Table _label 'True DB 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
373+ where
374+ fromK1Columns (HIdentity (DB a)) = a
375+ toK1Columns = HIdentity . DB
376+ {-# INLINABLE fromK1Columns #-}
377+ {-# INLINABLE toK1Columns #-}
378+
379+
380+instance
381+ ( x ~ Field Insertion '[] necessity db a
382+ , KnownNecessity necessity
383+ ) => K1Table label 'True Insertion 'True (Shape1 'Column ('Spec '[] necessity db a)) x
384+ where
385+ fromK1Columns (HIdentity insert) = case insert of
386+ RequiredInsert a -> a
387+ OptionalInsert ma -> ma
388+ toK1Columns a = HIdentity $ case necessitySing @necessity of
389+ SRequired -> RequiredInsert a
390+ SOptional -> OptionalInsert a
391+ {-# INLINABLE fromK1Columns #-}
392+ {-# INLINABLE toK1Columns #-}
393+
394+
395+instance
396+ ( x ~ Field Insertion (label ': labels) necessity db a
397+ , KnownNecessity necessity
398+ ) => K1Table _label 'True Insertion 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
399+ where
400+ fromK1Columns (HIdentity insert) = case insert of
401+ RequiredInsert a -> a
402+ OptionalInsert ma -> ma
403+ toK1Columns a = HIdentity $ case necessitySing @necessity of
404+ SRequired -> RequiredInsert a
405+ SOptional -> OptionalInsert a
406+ {-# INLINABLE fromK1Columns #-}
407+ {-# INLINABLE toK1Columns #-}
408+
409+
410+instance
411+ ( x ~ Field Result '[] necessity db a
412+ ) => K1Table label 'True Result 'True (Shape1 'Column ('Spec '[] necessity db a)) x
413+ where
414+ fromK1Columns (HIdentity (Result a)) = a
415+ toK1Columns = HIdentity . Result
416+ {-# INLINABLE fromK1Columns #-}
417+ {-# INLINABLE toK1Columns #-}
418+
419+
420+instance
421+ ( x ~ Field Result (label ': labels) necessity db a
422+ ) => K1Table _label 'True Result 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
423+ where
424+ fromK1Columns (HIdentity (Result a)) = a
425+ toK1Columns = HIdentity . Result
426+ {-# INLINABLE fromK1Columns #-}
427+ {-# INLINABLE toK1Columns #-}
428+
429+
430+instance
431+ ( IsSpecialContext context ~ 'False
432+ , x ~ context ('Spec (label ': labels) necessity db a)
433+ ) => K1Table _label 'False context 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
434+ where
435+ fromK1Columns = unHIdentity
436+ toK1Columns = HIdentity
437+ {-# INLINABLE fromK1Columns #-}
438+ {-# INLINABLE toK1Columns #-}
439+
440+
441+instance
442+ ( IsSpecialContext context ~ 'False
443+ , x ~ context ('Spec '[] necessity db a)
444+ , Labelable context
445+ ) => K1Table label 'False context 'True (Shape1 'Column ('Spec '[] necessity db a)) x
446+ where
447+ fromK1Columns = unlabeler . unHIdentity
448+ toK1Columns = HIdentity . labeler
449+ {-# INLINABLE fromK1Columns #-}
450+ {-# INLINABLE toK1Columns #-}
451+
452+
453+instance
454+ ( HTable (K1Columns "Left" structure1)
455+ , HTable (K1Columns "Right" structure2)
456+ , K1Table "Left" 'True Aggregation (IsStructure structure1) structure1 a
457+ , K1Table "Right" 'True Aggregation (IsStructure structure2) structure2 b
458+ , e ~ EitherTable a b
459+ ) => K1Table label 'True Aggregation 'True (Shape2 'Either structure1 structure2) e
460+ where
461+ fromK1Columns =
462+ fromColumns2
463+ (fromK1Columns @"Left" @_ @_ @_ @structure1)
464+ (fromK1Columns @"Right" @_ @_ @_ @structure2) .
465+ hunlabel unlabeler
466+ toK1Columns =
467+ hlabel labeler .
468+ toColumns2
469+ (toK1Columns @"Left" @_ @_ @_ @structure1)
470+ (toK1Columns @"Right" @_ @_ @_ @structure2)
471+ {-# INLINABLE fromK1Columns #-}
472+ {-# INLINABLE toK1Columns #-}
473+
474+
475+instance
476+ ( HTable (K1Columns "Left" structure1)
477+ , HTable (K1Columns "Right" structure2)
478+ , K1Table "Left" 'True DB (IsStructure structure1) structure1 a
479+ , K1Table "Right" 'True DB (IsStructure structure2) structure2 b
480+ , e ~ EitherTable a b
481+ ) => K1Table label 'True DB '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" 'True Insertion (IsStructure structure1) structure1 a
501+ , K1Table "Right" 'True Insertion (IsStructure structure2) structure2 b
502+ , e ~ EitherTable a b
503+ ) => K1Table label 'True Insertion 'True (Shape2 'Either structure1 structure2) e
504+ where
505+ fromK1Columns =
506+ fromColumns2
507+ (fromK1Columns @"Left" @_ @_ @_ @structure1)
508+ (fromK1Columns @"Right" @_ @_ @_ @structure2) .
509+ hunlabel unlabeler
510+ toK1Columns =
511+ hlabel labeler .
512+ toColumns2
513+ (toK1Columns @"Left" @_ @_ @_ @structure1)
514+ (toK1Columns @"Right" @_ @_ @_ @structure2)
515+ {-# INLINABLE fromK1Columns #-}
516+ {-# INLINABLE toK1Columns #-}
517+
518+
519+instance
520+ ( HTable (K1Columns "Left" structure1)
521+ , HTable (K1Columns "Right" structure2)
522+ , K1Table "Left" 'True Result (IsStructure structure1) structure1 a
523+ , K1Table "Right" 'True Result (IsStructure structure2) structure2 b
524+ , e ~ Either a b
525+ ) => K1Table label 'True Result 'True (Shape2 'Either structure1 structure2) e
526+ where
527+ fromK1Columns
528+ = bimap
529+ (fromK1Columns @"Left" @_ @_ @_ @structure1)
530+ (fromK1Columns @"Right" @_ @_ @_ @structure2)
531+ . fromHEitherTable
532+ . hunlabel unlabeler
533+ toK1Columns
534+ = hlabel labeler
535+ . toHEitherTable
536+ . bimap
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" 'False context (IsStructure structure1) structure1 a
547+ , K1Table "Right" 'False context (IsStructure structure2) structure2 b
548+ , IsSpecialContext context ~ 'False
549+ , Labelable context
550+ , Nullifiable context
551+ , e ~ EitherTable a b
552+ ) => K1Table label 'False context 'True (Shape2 'Either structure1 structure2) e
553+ where
554+ fromK1Columns =
555+ fromColumns2
556+ (fromK1Columns @"Left" @_ @_ @_ @structure1)
557+ (fromK1Columns @"Right" @_ @_ @_ @structure2) .
558+ hunlabel unlabeler
559+ toK1Columns =
560+ hlabel labeler .
561+ toColumns2
562+ (toK1Columns @"Left" @_ @_ @_ @structure1)
563+ (toK1Columns @"Right" @_ @_ @_ @structure2)
564+ {-# INLINABLE fromK1Columns #-}
565+ {-# INLINABLE toK1Columns #-}
566+
567+
568+instance
569+ ( K1Table label 'True Aggregation (IsStructure structure) structure a
570+ , Table Aggregation a
571+ , K1Columns label structure ~ HLabel label (Columns a)
572+ , as ~ ListTable a
573+ ) => K1Table label 'True Aggregation 'True (Shape1 'List structure) as
574+ where
575+ fromK1Columns = fromColumns . hrelabel (hunlabel unlabeler)
576+ toK1Columns = hrelabel (hlabel labeler) . toColumns
577+ {-# INLINABLE fromK1Columns #-}
578+ {-# INLINABLE toK1Columns #-}
579+
580+
581+instance
582+ ( K1Table label 'True DB (IsStructure structure) structure a
583+ , Table DB a
584+ , K1Columns label structure ~ HLabel label (Columns a)
585+ , as ~ ListTable a
586+ ) => K1Table label 'True DB 'True (Shape1 'List structure) as
587+ where
588+ fromK1Columns = fromColumns . hrelabel (hunlabel unlabeler)
589+ toK1Columns = hrelabel (hlabel labeler) . toColumns
590+ {-# INLINABLE fromK1Columns #-}
591+ {-# INLINABLE toK1Columns #-}
592+
593+
594+instance
595+ ( K1Table label 'True Insertion (IsStructure structure) structure a
596+ , Table Insertion a
597+ , K1Columns label structure ~ HLabel label (Columns a)
598+ , as ~ ListTable a
599+ ) => K1Table label 'True Insertion 'True (Shape1 'List structure) as
600+ where
601+ fromK1Columns = fromColumns . hrelabel (hunlabel unlabeler)
602+ toK1Columns = hrelabel (hlabel labeler) . toColumns
603+ {-# INLINABLE fromK1Columns #-}
604+ {-# INLINABLE toK1Columns #-}
605+
606+
607+instance
608+ ( K1Table label 'True Result (IsStructure structure) structure a
609+ , HTable (K1Columns label structure)
610+ , as ~ [a]
611+ ) => K1Table label 'True Result 'True (Shape1 'List structure) as
612+ where
613+ fromK1Columns = fmap (fromK1Columns @label @'True @Result @_ @structure) . fromHListTable
614+ toK1Columns = toHListTable . fmap (toK1Columns @label @'True @Result @_ @structure)
615+ {-# INLINABLE fromK1Columns #-}
616+ {-# INLINABLE toK1Columns #-}
617+
618+
619+instance
620+ ( K1Table label 'False context (IsStructure structure) structure a
621+ , IsSpecialContext context ~ 'False
622+ , Table context a
623+ , K1Columns label structure ~ HLabel label (Columns a)
624+ , Labelable context
625+ , as ~ ListTable a
626+ ) => K1Table label 'False context 'True (Shape1 'List structure) as
627+ where
628+ fromK1Columns = fromColumns . hrelabel (hunlabel unlabeler)
629+ toK1Columns = hrelabel (hlabel labeler) . toColumns
630+ {-# INLINABLE fromK1Columns #-}
631+ {-# INLINABLE toK1Columns #-}
632+
633+
634+instance
635+ ( HTable (K1Columns "Just" structure)
636+ , K1Table "Just" 'True Aggregation (IsStructure structure) structure a
637+ , ma ~ MaybeTable a
638+ ) => K1Table label 'True Aggregation 'True (Shape1 'Maybe structure) ma
639+ where
640+ fromK1Columns =
641+ fromColumns1 (fromK1Columns @"Just" @_ @_ @_ @structure) .
642+ hunlabel unlabeler
643+ toK1Columns =
644+ hlabel labeler .
645+ toColumns1 (toK1Columns @"Just" @_ @_ @_ @structure)
646+ {-# INLINABLE fromK1Columns #-}
647+ {-# INLINABLE toK1Columns #-}
648+
649+
650+instance
651+ ( HTable (K1Columns "Just" structure)
652+ , K1Table "Just" 'True DB (IsStructure structure) structure a
653+ , ma ~ MaybeTable a
654+ ) => K1Table label 'True DB 'True (Shape1 'Maybe structure) ma
655+ where
656+ fromK1Columns =
657+ fromColumns1 (fromK1Columns @"Just" @_ @_ @_ @structure) .
658+ hunlabel unlabeler
659+ toK1Columns =
660+ hlabel labeler .
661+ toColumns1 (toK1Columns @"Just" @_ @_ @_ @structure)
662+ {-# INLINABLE fromK1Columns #-}
663+ {-# INLINABLE toK1Columns #-}
664+
665+
666+instance
667+ ( HTable (K1Columns "Just" structure)
668+ , K1Table "Just" 'True Insertion (IsStructure structure) structure a
669+ , ma ~ MaybeTable a
670+ ) => K1Table label 'True Insertion 'True (Shape1 'Maybe structure) ma
671+ where
672+ fromK1Columns =
673+ fromColumns1 (fromK1Columns @"Just" @_ @_ @_ @structure) .
674+ hunlabel unlabeler
675+ toK1Columns =
676+ hlabel labeler .
677+ toColumns1 (toK1Columns @"Just" @_ @_ @_ @structure)
678+ {-# INLINABLE fromK1Columns #-}
679+ {-# INLINABLE toK1Columns #-}
680+
681+
682+instance
683+ ( HTable (K1Columns "Just" structure)
684+ , K1Table "Just" 'True Result (IsStructure structure) structure a
685+ , ma ~ Maybe a
686+ ) => K1Table label 'True Result 'True (Shape1 'Maybe structure) ma
687+ where
688+ fromK1Columns
689+ = fmap (fromK1Columns @"Just" @_ @_ @_ @structure)
690+ . fromHMaybeTable
691+ . hunlabel unlabeler
692+ toK1Columns
693+ = hlabel labeler
694+ . toHMaybeTable
695+ . fmap (toK1Columns @"Just" @_ @_ @_ @structure)
696+ {-# INLINABLE fromK1Columns #-}
697+ {-# INLINABLE toK1Columns #-}
698+
699+
700+instance
701+ ( HTable (K1Columns "Just" structure)
702+ , K1Table "Just" 'False context (IsStructure structure) structure a
703+ , IsSpecialContext context ~ 'False
704+ , Labelable context
705+ , Nullifiable context
706+ , ma ~ MaybeTable a
707+ ) => K1Table label 'False context 'True (Shape1 'Maybe structure) ma
708+ where
709+ fromK1Columns =
710+ fromColumns1 (fromK1Columns @"Just" @_ @_ @_ @structure) .
711+ hunlabel unlabeler
712+ toK1Columns =
713+ hlabel labeler .
714+ toColumns1 (toK1Columns @"Just" @_ @_ @_ @structure)
715+ {-# INLINABLE fromK1Columns #-}
716+ {-# INLINABLE toK1Columns #-}
717+
718+
719+instance
720+ ( K1Table label 'True Aggregation (IsStructure structure) structure a
721+ , Table Aggregation a
722+ , K1Columns label structure ~ HLabel label (Columns a)
723+ , as ~ NonEmptyTable a
724+ ) => K1Table label 'True Aggregation 'True (Shape1 'NonEmpty structure) as
725+ where
726+ fromK1Columns = fromColumns . hrelabel (hunlabel unlabeler)
727+ toK1Columns = hrelabel (hlabel labeler) . toColumns
728+ {-# INLINABLE fromK1Columns #-}
729+ {-# INLINABLE toK1Columns #-}
730+
731+
732+instance
733+ ( K1Table label 'True DB (IsStructure structure) structure a
734+ , Table DB a
735+ , K1Columns label structure ~ HLabel label (Columns a)
736+ , as ~ NonEmptyTable a
737+ ) => K1Table label 'True DB 'True (Shape1 'NonEmpty structure) as
738+ where
739+ fromK1Columns = fromColumns . hrelabel (hunlabel unlabeler)
740+ toK1Columns = hrelabel (hlabel labeler) . toColumns
741+ {-# INLINABLE fromK1Columns #-}
742+ {-# INLINABLE toK1Columns #-}
743+
744+
745+instance
746+ ( K1Table label 'True Insertion (IsStructure structure) structure a
747+ , Table Insertion a
748+ , K1Columns label structure ~ HLabel label (Columns a)
749+ , as ~ NonEmptyTable a
750+ ) => K1Table label 'True Insertion 'True (Shape1 'NonEmpty structure) as
751+ where
752+ fromK1Columns = fromColumns . hrelabel (hunlabel unlabeler)
753+ toK1Columns = hrelabel (hlabel labeler) . toColumns
754+ {-# INLINABLE fromK1Columns #-}
755+ {-# INLINABLE toK1Columns #-}
756+
757+
758+instance
759+ ( K1Table label 'True Result (IsStructure structure) structure a
760+ , HTable (K1Columns label structure)
761+ , as ~ NonEmpty a
762+ ) => K1Table label 'True Result 'True (Shape1 'NonEmpty structure) as
763+ where
764+ fromK1Columns = fmap (fromK1Columns @label @'True @Result @_ @structure) . fromHNonEmptyTable
765+ toK1Columns = toHNonEmptyTable . fmap (toK1Columns @label @'True @Result @_ @structure)
766+ {-# INLINABLE fromK1Columns #-}
767+ {-# INLINABLE toK1Columns #-}
768+
769+
770+instance
771+ ( K1Table label 'False context (IsStructure structure) structure a
772+ , IsSpecialContext context ~ 'False
773+ , Table context a
774+ , K1Columns label structure ~ HLabel label (Columns a)
775+ , Labelable context
776+ , as ~ NonEmptyTable a
777+ ) => K1Table label 'False context 'True (Shape1 'NonEmpty structure) as
778+ where
779+ fromK1Columns = fromColumns . hrelabel (hunlabel unlabeler)
780+ toK1Columns = hrelabel (hlabel labeler) . toColumns
781+ {-# INLINABLE fromK1Columns #-}
782+ {-# INLINABLE toK1Columns #-}
783+
784+
785+instance
786+ ( HTable (K1Columns "Here" structure1)
787+ , HTable (K1Columns "There" structure2)
788+ , K1Table "Here" 'True Aggregation (IsStructure structure1) structure1 a
789+ , K1Table "There" 'True Aggregation (IsStructure structure2) structure2 b
790+ , e ~ TheseTable a b
791+ ) => K1Table label 'True Aggregation 'True (Shape2 'These structure1 structure2) e
792+ where
793+ fromK1Columns =
794+ fromColumns2
795+ (fromK1Columns @"Here" @_ @_ @_ @structure1)
796+ (fromK1Columns @"There" @_ @_ @_ @structure2) .
797+ hunlabel unlabeler
798+ toK1Columns =
799+ hlabel labeler .
800+ toColumns2
801+ (toK1Columns @"Here" @_ @_ @_ @structure1)
802+ (toK1Columns @"There" @_ @_ @_ @structure2)
803+ {-# INLINABLE fromK1Columns #-}
804+ {-# INLINABLE toK1Columns #-}
805+
806+
807+instance
808+ ( HTable (K1Columns "Here" structure1)
809+ , HTable (K1Columns "There" structure2)
810+ , K1Table "Here" 'True DB (IsStructure structure1) structure1 a
811+ , K1Table "There" 'True DB (IsStructure structure2) structure2 b
812+ , e ~ TheseTable a b
813+ ) => K1Table label 'True DB '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" 'True Insertion (IsStructure structure1) structure1 a
833+ , K1Table "There" 'True Insertion (IsStructure structure2) structure2 b
834+ , e ~ TheseTable a b
835+ ) => K1Table label 'True Insertion 'True (Shape2 'These structure1 structure2) e
836+ where
837+ fromK1Columns =
838+ fromColumns2
839+ (fromK1Columns @"Here" @_ @_ @_ @structure1)
840+ (fromK1Columns @"There" @_ @_ @_ @structure2) .
841+ hunlabel unlabeler
842+ toK1Columns =
843+ hlabel labeler .
844+ toColumns2
845+ (toK1Columns @"Here" @_ @_ @_ @structure1)
846+ (toK1Columns @"There" @_ @_ @_ @structure2)
847+ {-# INLINABLE fromK1Columns #-}
848+ {-# INLINABLE toK1Columns #-}
849+
850+
851+instance
852+ ( HTable (K1Columns "Here" structure1)
853+ , HTable (K1Columns "There" structure2)
854+ , K1Table "Here" 'True Result (IsStructure structure1) structure1 a
855+ , K1Table "There" 'True Result (IsStructure structure2) structure2 b
856+ , e ~ These a b
857+ ) => K1Table label 'True Result 'True (Shape2 'These structure1 structure2) e
858+ where
859+ fromK1Columns
860+ = bimap
861+ (fromK1Columns @"Here" @_ @_ @_ @structure1)
862+ (fromK1Columns @"There" @_ @_ @_ @structure2)
863+ . fromHTheseTable
864+ . hunlabel unlabeler
865+ toK1Columns
866+ = hlabel labeler
867+ . toHTheseTable
868+ . bimap
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" 'False context (IsStructure structure1) structure1 a
879+ , K1Table "There" 'False context (IsStructure structure2) structure2 b
880+ , IsSpecialContext context ~ 'False
881+ , Labelable context
882+ , Nullifiable context
883+ , e ~ TheseTable a b
884+ ) => K1Table label 'False context 'True (Shape2 'These structure1 structure2) e
885+ where
886+ fromK1Columns =
887+ fromColumns2
888+ (fromK1Columns @"Here" @_ @_ @_ @structure1)
889+ (fromK1Columns @"There" @_ @_ @_ @structure2) .
890+ hunlabel unlabeler
891+ toK1Columns =
892+ hlabel labeler .
893+ toColumns2
894+ (toK1Columns @"Here" @_ @_ @_ @structure1)
895+ (toK1Columns @"There" @_ @_ @_ @structure2)
896+ {-# INLINABLE fromK1Columns #-}
897+ {-# INLINABLE toK1Columns #-}
898+
899+
900+
901+instance
902+ ( K1Table "fst" isSpecialContext context (IsStructure structure1) structure1 a1
903+ , K1Table "snd" isSpecialContext context (IsStructure structure2) structure2 a2
904+ , HTable (K1Columns "fst" structure1)
905+ , HTable (K1Columns "snd" structure2)
906+ , Labelable context
907+ , a ~ (a1, a2)
908+ ) => K1Table label isSpecialContext context 'True (structure1, structure2) a
909+ where
910+ fromK1Columns (hunlabel unlabeler -> (HPair a b)) =
911+ ( fromK1Columns @"fst" @_ @_ @_ @structure1 a
912+ , fromK1Columns @"snd" @_ @_ @_ @structure2 b
913+ )
914+ toK1Columns (a, b) = hlabel labeler $ HPair
915+ { hfst = toK1Columns @"fst" @_ @_ @_ @structure1 a
916+ , hsnd = toK1Columns @"snd" @_ @_ @_ @structure2 b
917+ }
918+ {-# INLINABLE fromK1Columns #-}
919+ {-# INLINABLE toK1Columns #-}
920+
921+
922+instance
923+ ( K1Table "fst" isSpecialContext context (IsStructure structure1) structure1 a1
924+ , K1Table "snd" isSpecialContext context (IsStructure structure2) structure2 a2
925+ , K1Table "trd" isSpecialContext context (IsStructure structure3) structure3 a3
926+ , HTable (K1Columns "fst" structure1)
927+ , HTable (K1Columns "snd" structure2)
928+ , HTable (K1Columns "trd" structure3)
929+ , Labelable context
930+ , a ~ (a1, a2, a3)
931+ ) => K1Table label isSpecialContext context 'True (structure1, structure2, structure3) a
932+ where
933+ fromK1Columns (hunlabel unlabeler -> (HTrio a b c)) =
934+ ( fromK1Columns @"fst" @_ @_ @_ @structure1 a
935+ , fromK1Columns @"snd" @_ @_ @_ @structure2 b
936+ , fromK1Columns @"trd" @_ @_ @_ @structure3 c
937+ )
938+ toK1Columns (a, b, c) = hlabel labeler $ HTrio
939+ { hfst = toK1Columns @"fst" @_ @_ @_ @structure1 a
940+ , hsnd = toK1Columns @"snd" @_ @_ @_ @structure2 b
941+ , htrd = toK1Columns @"trd" @_ @_ @_ @structure3 c
942+ }
943+ {-# INLINABLE fromK1Columns #-}
944+ {-# INLINABLE toK1Columns #-}
945+
946+
947+instance
948+ ( K1Table "fst" isSpecialContext context (IsStructure structure1) structure1 a1
949+ , K1Table "snd" isSpecialContext context (IsStructure structure2) structure2 a2
950+ , K1Table "trd" isSpecialContext context (IsStructure structure3) structure3 a3
951+ , K1Table "frt" isSpecialContext context (IsStructure structure3) structure4 a4
952+ , HTable (K1Columns "fst" structure1)
953+ , HTable (K1Columns "snd" structure2)
954+ , HTable (K1Columns "trd" structure3)
955+ , HTable (K1Columns "frt" structure4)
956+ , Labelable context
957+ , a ~ (a1, a2, a3, a4)
958+ ) => K1Table label isSpecialContext context 'True (structure1, structure2, structure3, structure4) a
959+ where
960+ fromK1Columns (hunlabel unlabeler -> (HQuartet a b c d)) =
961+ ( fromK1Columns @"fst" @_ @_ @_ @structure1 a
962+ , fromK1Columns @"snd" @_ @_ @_ @structure2 b
963+ , fromK1Columns @"trd" @_ @_ @_ @structure3 c
964+ , fromK1Columns @"frt" @_ @_ @_ @structure4 d
965+ )
966+ toK1Columns (a, b, c, d) = hlabel labeler $ HQuartet
967+ { hfst = toK1Columns @"fst" @_ @_ @_ @structure1 a
968+ , hsnd = toK1Columns @"snd" @_ @_ @_ @structure2 b
969+ , htrd = toK1Columns @"trd" @_ @_ @_ @structure3 c
970+ , hfrt = toK1Columns @"frt" @_ @_ @_ @structure4 d
971+ }
972+ {-# INLINABLE fromK1Columns #-}
973+ {-# INLINABLE toK1Columns #-}
974+
975+
976+instance
977+ ( K1Table "fst" isSpecialContext context (IsStructure structure1) structure1 a1
978+ , K1Table "snd" isSpecialContext context (IsStructure structure2) structure2 a2
979+ , K1Table "trd" isSpecialContext context (IsStructure structure3) structure3 a3
980+ , K1Table "frt" isSpecialContext context (IsStructure structure3) structure4 a4
981+ , K1Table "fft" isSpecialContext context (IsStructure structure3) structure5 a5
982+ , HTable (K1Columns "fst" structure1)
983+ , HTable (K1Columns "snd" structure2)
984+ , HTable (K1Columns "trd" structure3)
985+ , HTable (K1Columns "frt" structure4)
986+ , HTable (K1Columns "fft" structure5)
987+ , Labelable context
988+ , a ~ (a1, a2, a3, a4, a5)
989+ ) => K1Table label isSpecialContext context 'True (structure1, structure2, structure3, structure4, structure5) a
990+ where
991+ fromK1Columns (hunlabel unlabeler -> (HQuintet a b c d e)) =
992+ ( fromK1Columns @"fst" @_ @_ @_ @structure1 a
993+ , fromK1Columns @"snd" @_ @_ @_ @structure2 b
994+ , fromK1Columns @"trd" @_ @_ @_ @structure3 c
995+ , fromK1Columns @"frt" @_ @_ @_ @structure4 d
996+ , fromK1Columns @"fft" @_ @_ @_ @structure5 e
997+ )
998+ toK1Columns (a, b, c, d, e) = hlabel labeler $ HQuintet
999+ { hfst = toK1Columns @"fst" @_ @_ @_ @structure1 a
1000+ , hsnd = toK1Columns @"snd" @_ @_ @_ @structure2 b
1001+ , htrd = toK1Columns @"trd" @_ @_ @_ @structure3 c
1002+ , hfrt = toK1Columns @"frt" @_ @_ @_ @structure4 d
1003+ , hfft = toK1Columns @"fft" @_ @_ @_ @structure5 e
1004+ }
1005+ {-# INLINABLE fromK1Columns #-}
1006+ {-# INLINABLE toK1Columns #-}
1007+
1008+
1009+instance
1010+ ( IsSpecialContext context ~ isSpecialContext
1011+ , IsStructure structure ~ 'False
1012+ , K1Columns label structure ~ HLabel label (Columns structure)
1013+ , Columns structure ~ Columns a
1014+ , Labelable context
1015+ , Table context a
1016+ ) => K1Table label isSpecialContext context 'False structure a
1017+ where
1018+ fromK1Columns = fromColumns . hunlabel unlabeler
1019+ toK1Columns = hlabel labeler . toColumns
1020+ {-# INLINABLE fromK1Columns #-}
1021+ {-# 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+63−98
@@ -16,12 +16,13 @@
16module Rel8.Schema.HTable
16module Rel8.Schema.HTable
17 ( HTable (HField, HConstrainTable)
17 ( HTable (HField, HConstrainTable)
18 , hfield, htabulate, htraverse, hdicts, hspecs
18 , hfield, htabulate, htraverse, hdicts, hspecs
19− , hfoldMap, hmap, htabulateA, htraverseP, htraversePWithField
19+ , htabulateA
20+
21+ , HPair(..)
20 )
22 )
21where
23where
22
24
23-- base
25-- base
24−import Data.Functor.Const ( Const( Const ), getConst )
25import Data.Kind ( Constraint, Type )
26import Data.Kind ( Constraint, Type )
26import Data.Functor.Compose ( Compose( Compose ), getCompose )
27import Data.Functor.Compose ( Compose( Compose ), getCompose )
27import Data.Proxy ( Proxy )
28import Data.Proxy ( Proxy )
@@ -33,84 +34,73 @@ import GHC.Generics
33 )
34 )
34import Prelude
35import Prelude
35
36
36−-- profunctors
37−import Data.Profunctor ( rmap, Profunctor (lmap) )
38−
39−-- product-profunctors
40−import Data.Profunctor.Product ( ProductProfunctor ((****)) )
41−
42-- rel8
37-- rel8
43import Rel8.Schema.Dict ( Dict )
38import Rel8.Schema.Dict ( Dict )
44−import Rel8.Schema.Spec ( Spec )
39+import Rel8.Schema.Spec ( Spec, SSpec, Context )
45−import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
40+import Rel8.Schema.HTable.Context ( HKTable, H )
46−import qualified Rel8.Schema.Kind as K
41+import Rel8.Schema.HTable.Pair ( HPair( HPair ) )
47
42
48-- semigroupoids
43-- semigroupoids
49import Data.Functor.Apply ( Apply, (<.>) )
44import Data.Functor.Apply ( Apply, (<.>) )
50
45
51−-- | A @HTable@ is a functor-indexed/higher-kinded data type that is
46+
52−-- representable ('htabulate'/'hfield'), constrainable ('hdicts'), and
53−-- specified ('hspecs').
54−--
55−-- This is an internal concept for Rel8, and you should not need to define
56−-- instances yourself or specify this constraint.
57−type HTable :: K.HTable -> Constraint
47+type HTable :: HKTable -> Constraint
58class HTable t where
48class HTable t where
59− type HField t = (field :: Type -> Type) | field -> t
49+ type HField t = (field :: Context) | field -> t
60− type HConstrainTable t (c :: Type -> Constraint) :: Constraint
50+ type HConstrainTable t (c :: Spec -> Constraint) :: Constraint
61
51
62− hfield :: t context -> HField t a -> context a
52+ hfield :: t (H context) -> HField t spec -> context spec
63− htabulate :: (forall a. HField t a -> context a) -> t context
53+ htabulate :: (forall spec. HField t spec -> context spec) -> t (H context)
64− htraverse :: Apply m => (forall a. f a -> m (g a)) -> t f -> m (t g)
54+ htraverse :: Apply m => (forall spec. f spec -> m (g spec)) -> t (H f) -> m (t (H g))
65− hdicts :: HConstrainTable t c => t (Dict c)
55+ hdicts :: HConstrainTable t c => t (H (Dict c))
66− hspecs :: t Spec
56+ hspecs :: t (H SSpec)
67
57
68 type HField t = GHField t
58 type HField t = GHField t
69− type HConstrainTable t c = HConstrainTable (GHColumns (Rep (t Proxy))) c
59+ type HConstrainTable t c = HConstrainTable (GHColumns (Rep (t (H Proxy)))) c
70
60
71 default hfield ::
61 default hfield ::
72− ( Generic (t context)
62+ ( Generic (t (H context))
73 , HField t ~ GHField t
63 , HField t ~ GHField t
74− , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))
64+ , HField (GHColumns (Rep (t (H Proxy)))) ~ HField (GHColumns (Rep (t (H context))))
75− , GHTable context (Rep (t context))
65+ , GHTable context (Rep (t (H context)))
76 )
66 )
77− => t context -> HField t a -> context a
67+ => t (H context) -> HField t spec -> context spec
78 hfield table (GHField field) = hfield (toGHColumns (from table)) field
68 hfield table (GHField field) = hfield (toGHColumns (from table)) field
79
69
80 default htabulate ::
70 default htabulate ::
81− ( Generic (t context)
71+ ( Generic (t (H context))
82 , HField t ~ GHField t
72 , HField t ~ GHField t
83− , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))
73+ , HField (GHColumns (Rep (t (H Proxy)))) ~ HField (GHColumns (Rep (t (H context))))
84− , GHTable context (Rep (t context))
74+ , GHTable context (Rep (t (H context)))
85 )
75 )
86− => (forall a. HField t a -> context a) -> t context
76+ => (forall spec. HField t spec -> context spec) -> t (H context)
87 htabulate f = to $ fromGHColumns $ htabulate (f . GHField)
77 htabulate f = to $ fromGHColumns $ htabulate (f . GHField)
88
78
89 default htraverse
79 default htraverse
90 :: forall f g m
80 :: forall f g m
91 . ( Apply m
81 . ( Apply m
92− , Generic (t f), GHTable f (Rep (t f))
82+ , Generic (t (H f)), GHTable f (Rep (t (H f)))
93− , Generic (t g), GHTable g (Rep (t g))
83+ , Generic (t (H g)), GHTable g (Rep (t (H g)))
94− , GHColumns (Rep (t f)) ~ GHColumns (Rep (t g))
84+ , GHColumns (Rep (t (H f))) ~ GHColumns (Rep (t (H g)))
95 )
85 )
96− => (forall a. f a -> m (g a)) -> t f -> m (t g)
86+ => (forall spec. f spec -> m (g spec)) -> t (H f) -> m (t (H g))
97 htraverse f = fmap (to . fromGHColumns) . htraverse f . toGHColumns . from
87 htraverse f = fmap (to . fromGHColumns) . htraverse f . toGHColumns . from
98
88
99 default hdicts
89 default hdicts
100 :: forall c
90 :: forall c
101− . ( Generic (t (Dict c))
91+ . ( Generic (t (H (Dict c)))
102− , GHTable (Dict c) (Rep (t (Dict c)))
92+ , GHTable (Dict c) (Rep (t (H (Dict c))))
103− , GHColumns (Rep (t Proxy)) ~ GHColumns (Rep (t (Dict c)))
93+ , GHColumns (Rep (t (H Proxy))) ~ GHColumns (Rep (t (H (Dict c))))
104− , HConstrainTable (GHColumns (Rep (t Proxy))) c
94+ , HConstrainTable (GHColumns (Rep (t (H Proxy)))) c
105 )
95 )
106− => t (Dict c)
96+ => t (H (Dict c))
107− hdicts = to $ fromGHColumns (hdicts @(GHColumns (Rep (t Proxy))) @c)
97+ hdicts = to $ fromGHColumns (hdicts @(GHColumns (Rep (t (H Proxy)))) @c)
108
98
109 default hspecs ::
99 default hspecs ::
110− ( Generic (t Spec)
100+ ( Generic (t (H SSpec))
111− , GHTable Spec (Rep (t Spec))
101+ , GHTable SSpec (Rep (t (H SSpec)))
112 )
102 )
113− => t Spec
103+ => t (H SSpec)
114 hspecs = to $ fromGHColumns hspecs
104 hspecs = to $ fromGHColumns hspecs
115
105
116 {-# INLINABLE hfield #-}
106 {-# INLINABLE hfield #-}
@@ -120,47 +110,22 @@ class HTable t where
120 {-# INLINABLE hspecs #-}
110 {-# INLINABLE hspecs #-}
121
111
122
112
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−
133htabulateA :: (HTable t, Apply m)
113htabulateA :: (HTable t, Apply m)
134− => (forall a. HField t a -> m (context a)) -> m (t context)
114+ => (forall spec. HField t spec -> m (context spec))
115+ -> m (t (H context))
135htabulateA f = htraverse getCompose $ htabulate $ Compose . f
116htabulateA f = htraverse getCompose $ htabulate $ Compose . f
136{-# INLINABLE htabulateA #-}
117{-# INLINABLE htabulateA #-}
137
118
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)
154
119
155−type GHField :: K.HTable -> Type -> Type
120+type GHField :: HKTable -> Context
156−newtype GHField t a = GHField (HField (GHColumns (Rep (t Proxy))) a)
121+newtype GHField t spec = GHField (HField (GHColumns (Rep (t (H Proxy)))) spec)
157
122
158
123
159−type GHTable :: K.Context -> (Type -> Type) -> Constraint
124+type GHTable :: Context -> (Type -> Type) -> Constraint
160class HTable (GHColumns rep) => GHTable context rep | rep -> context where
125class HTable (GHColumns rep) => GHTable context rep | rep -> context where
161− type GHColumns rep :: K.HTable
126+ type GHColumns rep :: HKTable
162− toGHColumns :: rep x -> GHColumns rep context
127+ toGHColumns :: rep x -> GHColumns rep (H context)
163− fromGHColumns :: GHColumns rep context -> rep x
128+ fromGHColumns :: GHColumns rep (H context) -> rep x
164
129
165
130
166instance GHTable context rep => GHTable context (M1 i c rep) where
131instance GHTable context rep => GHTable context (M1 i c rep) where
@@ -169,37 +134,37 @@ instance GHTable context rep => GHTable context (M1 i c rep) where
169 fromGHColumns = M1 . fromGHColumns
134 fromGHColumns = M1 . fromGHColumns
170
135
171
136
172−instance HTable table => GHTable context (K1 i (table context)) where
137+instance HTable table => GHTable context (K1 i (table (H context))) where
173− type GHColumns (K1 i (table context)) = table
138+ type GHColumns (K1 i (table (H context))) = table
174 toGHColumns (K1 a) = a
139 toGHColumns (K1 a) = a
175 fromGHColumns = K1
140 fromGHColumns = K1
176
141
177
142
178instance (GHTable context a, GHTable context b) => GHTable context (a :*: b) where
143instance (GHTable context a, GHTable context b) => GHTable context (a :*: b) where
179− type GHColumns (a :*: b) = HProduct (GHColumns a) (GHColumns b)
144+ type GHColumns (a :*: b) = HPair (GHColumns a) (GHColumns b)
180− toGHColumns (a :*: b) = HProduct (toGHColumns a) (toGHColumns b)
145+ toGHColumns (a :*: b) = HPair (toGHColumns a) (toGHColumns b)
181− fromGHColumns (HProduct a b) = fromGHColumns a :*: fromGHColumns b
146+ fromGHColumns (HPair a b) = fromGHColumns a :*: fromGHColumns b
182
147
183
148
184−-- | A HField type for indexing into HProduct.
149+-- | A HField type for indexing into HPair.
185−type HProductField :: K.HTable -> K.HTable -> Type -> Type
150+type HPairField :: HKTable -> HKTable -> Context
186−data HProductField x y a
151+data HPairField x y spec
187− = HFst (HField x a)
152+ = HFst (HField x spec)
188− | HSnd (HField y a)
153+ | HSnd (HField y spec)
189
154
190
155
191−instance (HTable x, HTable y) => HTable (HProduct x y) where
156+instance (HTable x, HTable y) => HTable (HPair x y) where
192− type HConstrainTable (HProduct x y) c = (HConstrainTable x c, HConstrainTable y c)
157+ type HConstrainTable (HPair x y) c = (HConstrainTable x c, HConstrainTable y c)
193− type HField (HProduct x y) = HProductField x y
158+ type HField (HPair x y) = HPairField x y
194
159
195− hfield (HProduct l r) = \case
160+ hfield (HPair l r) = \case
196 HFst i -> hfield l i
161 HFst i -> hfield l i
197 HSnd i -> hfield r i
162 HSnd i -> hfield r i
198
163
199− htabulate f = HProduct (htabulate (f . HFst)) (htabulate (f . HSnd))
164+ htabulate f = HPair (htabulate (f . HFst)) (htabulate (f . HSnd))
200− htraverse f (HProduct x y) = HProduct <$> htraverse f x <.> htraverse f y
165+ htraverse f (HPair x y) = HPair <$> htraverse f x <.> htraverse f y
201− hdicts = HProduct hdicts hdicts
166+ hdicts = HPair hdicts hdicts
202− hspecs = HProduct hspecs hspecs
167+ hspecs = HPair hspecs hspecs
203
168
204 {-# INLINABLE hfield #-}
169 {-# INLINABLE hfield #-}
205 {-# INLINABLE htabulate #-}
170 {-# INLINABLE htabulate #-}
src/Rel8/Schema/HTable/Context.hsnew file+26
@@ -0,0 +1,26 @@
1+{-# language DataKinds #-}
2+{-# language StandaloneKindSignatures #-}
3+
4+module Rel8.Schema.HTable.Context
5+ ( HContext, H, HKTable
6+ )
7+where
8+
9+-- base
10+import Data.Kind ( Type )
11+import Prelude ()
12+
13+-- rel8
14+import Rel8.Schema.Spec ( Context )
15+
16+
17+type HContext :: Type
18+newtype HContext = H Context
19+
20+
21+type H :: Context -> HContext
22+type H = 'H
23+
24+
25+type HKTable :: Type
26+type HKTable = HContext -> Type
src/Rel8/Schema/HTable/Either.hs+8−7
@@ -14,19 +14,20 @@ import GHC.Generics ( Generic )
14import Prelude ()
14import Prelude ()
15
15
16-- rel8
16-- rel8
17+import Rel8.Kind.Necessity ( Necessity( Required ) )
17import Rel8.Schema.HTable ( HTable )
18import Rel8.Schema.HTable ( HTable )
18−import Rel8.Schema.HTable.Identity ( HIdentity )
19+import Rel8.Schema.HTable.Context ( HKTable )
19−import Rel8.Schema.HTable.Label ( HLabel )
20+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
20import Rel8.Schema.HTable.Nullify ( HNullify )
21import Rel8.Schema.HTable.Nullify ( HNullify )
21−import qualified Rel8.Schema.Kind as K
22+import Rel8.Schema.Spec ( Spec( Spec ) )
22import Rel8.Type.Tag ( EitherTag )
23import Rel8.Type.Tag ( EitherTag )
23
24
24
25
25−type HEitherTable :: K.HTable -> K.HTable -> K.HTable
26+type HEitherTable :: HKTable -> HKTable -> HKTable
26data HEitherTable left right context = HEitherTable
27data HEitherTable left right context = HEitherTable
27− { htag :: HLabel "isRight" (HIdentity EitherTag) context
28+ { htag :: HIdentity ('Spec '["isRight"] 'Required EitherTag EitherTag) context
28− , hleft :: HLabel "Left" (HNullify left) context
29+ , hleft :: HNullify left context
29− , hright :: HLabel "Right" (HNullify right) context
30+ , hright :: HNullify right context
30 }
31 }
31 deriving stock Generic
32 deriving stock Generic
32 deriving anyclass HTable
33 deriving anyclass HTable
src/Rel8/Schema/HTable/Identity.hs+20−19
@@ -1,17 +1,14 @@
1{-# language DataKinds #-}
1{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
2+{-# language GADTs #-}
3{-# language StandaloneKindSignatures #-}
3{-# language StandaloneKindSignatures #-}
4{-# language TypeFamilies #-}
4{-# language TypeFamilies #-}
5−{-# language UndecidableInstances #-}
6
5
7module Rel8.Schema.HTable.Identity
6module Rel8.Schema.HTable.Identity
8− ( HIdentity( HIdentity, unHIdentity )
7+ ( HIdentity(..)
9 )
8 )
10where
9where
11
10
12-- base
11-- base
13−import Data.Kind ( Type )
14−import Data.Type.Equality ( (:~:)( Refl ) )
15import Prelude
12import Prelude
16
13
17-- rel8
14-- rel8
@@ -20,24 +17,28 @@ import Rel8.Schema.HTable
20 ( HTable, HConstrainTable, HField
17 ( HTable, HConstrainTable, HField
21 , hfield, htabulate, htraverse, hdicts, hspecs
18 , hfield, htabulate, htraverse, hdicts, hspecs
22 )
19 )
23−import qualified Rel8.Schema.Kind as K
20+import Rel8.Schema.HTable.Context ( H, HKTable )
24−import Rel8.Schema.Null ( Sql )
25−import Rel8.Schema.Spec ( specification )
21+import Rel8.Schema.Spec ( Context, Spec, KnownSpec, specSing )
26−import Rel8.Type ( DBType )
27
22
28
23
29−type HIdentity :: Type -> K.HTable
24+type HIdentity :: Spec -> HKTable
30−newtype HIdentity a context = HIdentity
25+data HIdentity spec context where
26+ HIdentity ::
31− { unHIdentity :: context a
27+ { unHIdentity :: context spec
32− }
28+ } -> HIdentity spec (H context)
33
29
34
30
35−instance Sql DBType a => HTable (HIdentity a) where
31+type HIdentityField :: Spec -> Context
36− type HConstrainTable (HIdentity a) constraint = constraint a
32+data HIdentityField _spec spec where
37− type HField (HIdentity a) = (:~:) a
33+ HIdentityField :: HIdentityField spec spec
38
34
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+
39− hfield (HIdentity a) Refl = a
40+ hfield (HIdentity a) HIdentityField = a
40− htabulate f = HIdentity $ f Refl
41+ htabulate f = HIdentity $ f HIdentityField
41 htraverse f (HIdentity a) = HIdentity <$> f a
42 htraverse f (HIdentity a) = HIdentity <$> f a
42 hdicts = HIdentity Dict
43 hdicts = HIdentity Dict
43− hspecs = HIdentity specification
44+ hspecs = HIdentity specSing
src/Rel8/Schema/HTable/Label.hs+94−33
@@ -1,70 +1,131 @@
1+{-# language ConstraintKinds #-}
1{-# language DataKinds #-}
2{-# language DataKinds #-}
3+{-# language FlexibleInstances #-}
4+{-# language GADTs #-}
5+{-# language InstanceSigs #-}
6+{-# language MultiParamTypeClasses #-}
7+{-# language QuantifiedConstraints #-}
2{-# language RankNTypes #-}
8{-# language RankNTypes #-}
3{-# language RecordWildCards #-}
9{-# language RecordWildCards #-}
4{-# language ScopedTypeVariables #-}
10{-# language ScopedTypeVariables #-}
5{-# language StandaloneKindSignatures #-}
11{-# language StandaloneKindSignatures #-}
6{-# language TypeApplications #-}
12{-# language TypeApplications #-}
7{-# language TypeFamilies #-}
13{-# language TypeFamilies #-}
14+{-# language TypeOperators #-}
15+{-# language UndecidableInstances #-}
8
16
9module Rel8.Schema.HTable.Label
17module Rel8.Schema.HTable.Label
18+ ( HLabel( HLabel )
10− ( HLabel, hlabel, hrelabel, hunlabel
19+ , hlabel, hunlabel
11− , hproject
12 )
20 )
13where
21where
14
22
15-- base
23-- base
16−import Data.Kind ( Type )
24+import Data.Kind ( Constraint, Type )
17import Data.Proxy ( Proxy( Proxy ) )
25import Data.Proxy ( Proxy( Proxy ) )
18−import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
26+import GHC.TypeLits ( KnownSymbol, Symbol )
19import Prelude
27import Prelude
20
28
21-- rel8
29-- rel8
30+import Rel8.Kind.Labels ( SLabels( SLabels ) )
31+import Rel8.Schema.Dict ( Dict( Dict ) )
22import Rel8.Schema.HTable
32import Rel8.Schema.HTable
23 ( HTable, HConstrainTable, HField
33 ( HTable, HConstrainTable, HField
24− , htabulate, hfield, htraverse, hdicts, hspecs
34+ , hfield, htabulate, htraverse, hdicts, hspecs
25 )
35 )
26−import qualified Rel8.Schema.Kind as K
36+import Rel8.Schema.HTable.Context ( H, HKTable )
27−import Rel8.Schema.Spec ( Spec(..) )
37+import Rel8.Schema.Spec ( Context, Spec( Spec ), SSpec(..) )
28
38
29
39
30−type HLabel :: Symbol -> K.HTable -> K.HTable
40+type HLabel :: Symbol -> HKTable -> HKTable
31−newtype HLabel label table context = HLabel (table context)
41+data HLabel label table context where
42+ HLabel :: table (H (LabelSpec label context)) -> HLabel label table (H context)
32
43
33
44
34−type HLabelField :: Symbol -> K.HTable -> Type -> Type
45+type HLabelField :: Symbol -> HKTable -> Context
35−newtype HLabelField label table a = HLabelField (HField table a)
46+data HLabelField label table spec where
47+ HLabelField
48+ :: HField table ('Spec labels necessity db a)
49+ -> HLabelField label table ('Spec (label ': labels) necessity db a)
36
50
37
51
38instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where
52instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where
39 type HField (HLabel label table) = HLabelField label table
53 type HField (HLabel label table) = HLabelField label table
40− type HConstrainTable (HLabel label table) constraint =
54+ type HConstrainTable (HLabel label table) c =
41− HConstrainTable table constraint
55+ HConstrainTable table (LabelSpecC label c)
42−
56+
43− hfield (HLabel a) (HLabelField field) = hfield a field
57+ hfield (HLabel table) (HLabelField field) =
58+ getLabelSpec (hfield table field)
59+
44− htabulate f = HLabel (htabulate (f . HLabelField))
60+ htabulate f = HLabel $ htabulate $ \field -> case hfield hspecs field of
61+ SSpec {} -> LabelSpec (f (HLabelField field))
45− htraverse f (HLabel a) = HLabel <$> htraverse f a
62+ htraverse f (HLabel t) = HLabel <$> htraverse (traverseLabelSpec f) t
46− hdicts = HLabel (hdicts @table)
63+
64+ hdicts :: forall c. HConstrainTable table (LabelSpecC label c)
65+ => HLabel label table (H (Dict c))
66+ hdicts = HLabel $ htabulate $ \field -> case hfield hspecs field of
67+ SSpec {} -> case hfield (hdicts @_ @(LabelSpecC label c)) field of
68+ Dict -> LabelSpec Dict
69+
47− hspecs = HLabel $ htabulate $ \field -> case hfield (hspecs @table) field of
70+ hspecs = HLabel $ htabulate $ \field -> case hfield hspecs field of
48− Spec {..} -> Spec {labels = symbolVal (Proxy @label) : labels, ..}
71+ SSpec {..} -> LabelSpec SSpec {labels = SLabels Proxy labels, ..}
72+
73+ {-# INLINABLE hfield #-}
74+ {-# INLINABLE htabulate #-}
75+ {-# INLINABLE htraverse #-}
76+ {-# INLINABLE hdicts #-}
49 {-# INLINABLE hspecs #-}
77 {-# INLINABLE hspecs #-}
50
78
51
79
52−hlabel :: forall label t context. t context -> HLabel label t context
80+type LabelingSpec :: Type -> Type
53−hlabel = HLabel
81+type LabelingSpec r = Symbol -> (Spec -> r) -> Spec -> r
54−{-# INLINABLE hlabel #-}
55
82
56
83
57−hrelabel :: forall label' label t context. HLabel label t context -> HLabel label' t context
84+type LabelSpec :: LabelingSpec Type
58−hrelabel = hlabel . hunlabel
85+data LabelSpec label context spec where
59−{-# INLINABLE hrelabel #-}
86+ LabelSpec
87+ :: { getLabelSpec :: context ('Spec (label ': labels) necessity db a) }
88+ -> LabelSpec label context ('Spec labels necessity db a)
60
89
61
90
62−hunlabel :: forall label t context. HLabel label t context -> t context
91+type LabelSpecC :: LabelingSpec Constraint
63−hunlabel (HLabel a) = a
92+class
64−{-# INLINABLE hunlabel #-}
93+ ( forall labels necessity db a.
94+ ( spec ~ 'Spec labels necessity db a =>
95+ constraint ('Spec (label ': labels) necessity db a)
96+ )
97+ ) => LabelSpecC label constraint spec
98+instance
99+ ( spec ~ 'Spec labels necessity db a
100+ , constraint ('Spec (label ': labels) necessity db a)
101+ ) => LabelSpecC label constraint spec
65
102
66
103
67−hproject :: ()
104+traverseLabelSpec :: forall context context' label spec m. Functor m
68− => (forall ctx. t ctx -> t' ctx)
105+ => (forall x. context x -> m (context' x))
106+ -> LabelSpec label context spec -> m (LabelSpec label context' spec)
107+traverseLabelSpec f (LabelSpec a) = LabelSpec <$> f a
108+
109+
110+hlabel :: HTable t
111+ => (forall labels necessity db a. ()
112+ => context ('Spec labels necessity db a)
113+ -> context ('Spec (label ': labels) necessity db a))
114+ -> t (H context)
115+ -> HLabel label t (H context)
116+hlabel labeler a = HLabel $ htabulate $ \field ->
117+ case hfield hspecs field of
118+ SSpec {} -> LabelSpec (labeler (hfield a field))
119+{-# INLINABLE hlabel #-}
120+
121+
122+hunlabel :: HTable t
123+ => (forall labels necessity db a. ()
124+ => context ('Spec (label ': labels) necessity db a)
125+ -> context ('Spec labels necessity db a))
69− -> HLabel label t context -> HLabel label t' context
126+ -> HLabel label t (H context)
70−hproject f (HLabel a) = HLabel (f a)
127+ -> t (H context)
128+hunlabel unlabler (HLabel as) =
129+ htabulate $ \field -> case hfield as field of
130+ LabelSpec a -> unlabler a
131+{-# INLINABLE hunlabel #-}
src/Rel8/Schema/HTable/List.hs+2−2
@@ -10,9 +10,9 @@ where
10import Prelude ()
10import Prelude ()
11
11
12-- rel8
12-- rel8
13−import qualified Rel8.Schema.Kind as K
13+import Rel8.Schema.HTable.Context ( HKTable )
14import Rel8.Schema.HTable.Vectorize ( HVectorize )
14import Rel8.Schema.HTable.Vectorize ( HVectorize )
15
15
16
16
17−type HListTable :: K.HTable -> K.HTable
17+type HListTable :: HKTable -> HKTable
18type HListTable = HVectorize []
18type HListTable = HVectorize []
src/Rel8/Schema/HTable/MapTable.hsdeleted−99
@@ -1,99 +0,0 @@
1−{-# language AllowAmbiguousTypes #-}
2−{-# language BlockArguments #-}
3−{-# language ConstraintKinds #-}
4−{-# language DataKinds #-}
5−{-# language FlexibleInstances #-}
6−{-# language GADTs #-}
7−{-# language InstanceSigs #-}
8−{-# language MultiParamTypeClasses #-}
9−{-# language RankNTypes #-}
10−{-# language ScopedTypeVariables #-}
11−{-# language StandaloneKindSignatures #-}
12−{-# language TypeApplications #-}
13−{-# language TypeFamilies #-}
14−{-# language UndecidableInstances #-}
15−{-# language UndecidableSuperClasses #-}
16−
17−module Rel8.Schema.HTable.MapTable
18− ( HMapTable(..)
19− , MapSpec(..)
20− , Precompose(..)
21− , HMapTableField(..)
22− , hproject
23− )
24−where
25−
26−-- base
27−import Data.Kind ( Constraint, Type )
28−import Prelude
29−
30−-- rel8
31−import Rel8.FCF ( Exp, Eval )
32−import Rel8.Schema.HTable
33− ( HTable, HConstrainTable, HField
34− , hfield, htabulate, htraverse, hdicts, hspecs
35− )
36−import Rel8.Schema.Spec ( Spec )
37−import qualified Rel8.Schema.Kind as K
38−import Rel8.Schema.Dict ( Dict( Dict ) )
39−
40−
41−type HMapTable :: (Type -> Exp Type) -> K.HTable -> K.HTable
42−newtype HMapTable f t context = HMapTable
43− { unHMapTable :: t (Precompose f context)
44− }
45−
46−
47−type Precompose :: (Type -> Exp Type) -> K.Context -> K.Context
48−newtype Precompose f g x = Precompose
49− { precomposed :: g (Eval (f x))
50− }
51−
52−
53−type HMapTableField :: (Type -> Exp Type) -> K.HTable -> K.Context
54−data HMapTableField f t x where
55− HMapTableField :: HField t a -> HMapTableField f t (Eval (f a))
56−
57−
58−instance (HTable t, MapSpec f) => HTable (HMapTable f t) where
59− type HField (HMapTable f t) =
60− HMapTableField f t
61−
62− type HConstrainTable (HMapTable f t) c =
63− HConstrainTable t (ComposeConstraint f c)
64−
65− hfield (HMapTable x) (HMapTableField i) =
66− precomposed (hfield x i)
67−
68− htabulate f =
69− HMapTable $ htabulate (Precompose . f . HMapTableField)
70−
71− htraverse f (HMapTable x) =
72− HMapTable <$> htraverse (fmap Precompose . f . precomposed) x
73− {-# INLINABLE htraverse #-}
74−
75− hdicts :: forall c. HConstrainTable (HMapTable f t) c => HMapTable f t (Dict c)
76− hdicts =
77− htabulate \(HMapTableField j) ->
78− case hfield (hdicts @_ @(ComposeConstraint f c)) j of
79− Dict -> Dict
80−
81− hspecs =
82− HMapTable $ htabulate $ Precompose . mapInfo @f . hfield hspecs
83− {-# INLINABLE hspecs #-}
84−
85−
86−type MapSpec :: (Type -> Exp Type) -> Constraint
87−class MapSpec f where
88− mapInfo :: Spec x -> Spec (Eval (f x))
89−
90−
91−type ComposeConstraint :: (Type -> Exp Type) -> (Type -> Constraint) -> Type -> Constraint
92−class 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+7−6
@@ -14,18 +14,19 @@ import GHC.Generics ( Generic )
14import Prelude
14import Prelude
15
15
16-- rel8
16-- rel8
17+import Rel8.Kind.Necessity ( Necessity( Required ) )
17import Rel8.Schema.HTable ( HTable )
18import Rel8.Schema.HTable ( HTable )
18−import Rel8.Schema.HTable.Identity ( HIdentity )
19+import Rel8.Schema.HTable.Context ( HKTable )
19−import Rel8.Schema.HTable.Label ( HLabel )
20+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
20import Rel8.Schema.HTable.Nullify ( HNullify )
21import Rel8.Schema.HTable.Nullify ( HNullify )
21−import qualified Rel8.Schema.Kind as K
22+import Rel8.Schema.Spec ( Spec( Spec ) )
22import Rel8.Type.Tag ( MaybeTag )
23import Rel8.Type.Tag ( MaybeTag )
23
24
24
25
25−type HMaybeTable :: K.HTable -> K.HTable
26+type HMaybeTable :: HKTable -> HKTable
26data HMaybeTable table context = HMaybeTable
27data HMaybeTable table context = HMaybeTable
27− { htag :: HLabel "isJust" (HIdentity (Maybe MaybeTag)) context
28+ { htag :: HIdentity ('Spec '["isJust"] 'Required MaybeTag (Maybe MaybeTag)) context
28− , hjust :: HLabel "Just" (HNullify table) context
29+ , hjust :: HNullify table context
29 }
30 }
30 deriving stock Generic
31 deriving stock Generic
31 deriving anyclass HTable
32 deriving anyclass HTable
src/Rel8/Schema/HTable/NonEmpty.hs+2−2
@@ -11,9 +11,9 @@ import Data.List.NonEmpty ( NonEmpty )
11import Prelude ()
11import Prelude ()
12
12
13-- rel8
13-- rel8
14+import Rel8.Schema.HTable.Context ( HKTable )
14import Rel8.Schema.HTable.Vectorize ( HVectorize )
15import Rel8.Schema.HTable.Vectorize ( HVectorize )
15−import qualified Rel8.Schema.Kind as K
16
16
17
17
18−type HNonEmptyTable :: K.HTable -> K.HTable
18+type HNonEmptyTable :: HKTable -> HKTable
19type HNonEmptyTable = HVectorize NonEmpty
19type HNonEmptyTable = HVectorize NonEmpty
src/Rel8/Schema/HTable/Nullify.hs+97−68
@@ -1,117 +1,146 @@
1{-# language ConstraintKinds #-}
1{-# language ConstraintKinds #-}
2{-# language DataKinds #-}
2{-# language DataKinds #-}
3−{-# language DeriveAnyClass #-}
4−{-# language DerivingStrategies #-}
5−{-# language DeriveGeneric #-}
6{-# language FlexibleInstances #-}
3{-# language FlexibleInstances #-}
7{-# language GADTs #-}
4{-# language GADTs #-}
8−{-# language LambdaCase #-}
5+{-# language InstanceSigs #-}
9{-# language MultiParamTypeClasses #-}
6{-# language MultiParamTypeClasses #-}
10−{-# language NamedFieldPuns #-}
11{-# language QuantifiedConstraints #-}
7{-# language QuantifiedConstraints #-}
12{-# language RankNTypes #-}
8{-# language RankNTypes #-}
13{-# language RecordWildCards #-}
9{-# language RecordWildCards #-}
14{-# language ScopedTypeVariables #-}
10{-# language ScopedTypeVariables #-}
15{-# language StandaloneKindSignatures #-}
11{-# language StandaloneKindSignatures #-}
12+{-# language TypeApplications #-}
16{-# language TypeFamilies #-}
13{-# language TypeFamilies #-}
17{-# language UndecidableInstances #-}
14{-# language UndecidableInstances #-}
18
15
19module Rel8.Schema.HTable.Nullify
16module Rel8.Schema.HTable.Nullify
20 ( HNullify( HNullify )
17 ( HNullify( HNullify )
21− , Nullify
22− , hguard
23− , hnulls
24− , hnullify
25− , hunnullify
18+ , hnulls, hnullify, hunnullify
26− , hproject
27 )
19 )
28where
20where
29
21
30-- base
22-- base
31−import Data.Kind ( Type )
23+import Data.Kind ( Constraint, Type )
32−import GHC.Generics ( Generic )
33import Prelude hiding ( null )
24import Prelude hiding ( null )
34
25
35-- rel8
26-- rel8
36−import Rel8.FCF ( Eval, Exp )
27+import Rel8.Schema.Dict ( Dict( Dict ) )
28+import Rel8.Schema.HTable
29+ ( HTable, HConstrainTable, HField
37−import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )
30+ , hfield, htabulate, htabulateA, htraverse, hdicts, hspecs
38−import Rel8.Schema.HTable.MapTable
39− ( HMapTable, HMapTableField( HMapTableField )
40− , MapSpec, mapInfo
41 )
31 )
42−import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )
32+import Rel8.Schema.HTable.Context ( H, HKTable )
43−import qualified Rel8.Schema.Kind as K
33+import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
44−import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
34+import Rel8.Schema.Spec ( Context, Spec( Spec ), SSpec(..) )
45−import qualified Rel8.Schema.Null as Type ( Nullify )
46−import Rel8.Schema.Spec ( Spec(..) )
47
35
48-- semigroupoids
36-- semigroupoids
49import Data.Functor.Apply ( Apply )
37import Data.Functor.Apply ( Apply )
50
38
51
39
52−type HNullify :: K.HTable -> K.HTable
40+type HNullify :: HKTable -> HKTable
53−newtype HNullify table context = HNullify (HMapTable Nullify table context)
41+data HNullify table context where
54− deriving stock Generic
42+ HNullify :: table (H (NullifySpec context)) -> HNullify table (H context)
55− deriving anyclass HTable
56
43
57
44
58−-- | Transform a 'Type' by allowing it to be @null@.
45+type HNullifyField :: HKTable -> Context
59−data Nullify :: Type -> Exp Type
46+data HNullifyField table spec where
60−type instance Eval (Nullify a) = Type.Nullify a
47+ HNullifyField
48+ :: HField table ('Spec labels necessity dbType a)
49+ -> HNullifyField table ('Spec labels necessity dbType (Maybe dbType))
61
50
62
51
63−instance MapSpec Nullify where
52+instance HTable table => HTable (HNullify table) where
64− mapInfo = \case
53+ type HField (HNullify table) = HNullifyField table
65− Spec {nullity, ..} -> Spec
54+ type HConstrainTable (HNullify table) c =
66− { nullity = case nullity of
55+ HConstrainTable table (NullifySpecC c)
67− Null -> Null
68− NotNull -> Null
69− , ..
70− }
71
56
57+ hfield (HNullify table) (HNullifyField field) =
58+ getNullifySpec (hfield table field)
59+
60+ htabulate f = HNullify $ htabulate $ \field -> case hfield hspecs field of
61+ SSpec {} -> NullifySpec (f (HNullifyField field))
62+
63+ htraverse f (HNullify t) = HNullify <$> htraverse (traverseNullifySpec f) t
64+
65+ hdicts :: forall c. HConstrainTable table (NullifySpecC c)
66+ => HNullify table (H (Dict c))
67+ hdicts = HNullify $ htabulate $ \field -> case hfield hspecs field of
68+ SSpec {} -> case hfield (hdicts @_ @(NullifySpecC c)) field of
69+ Dict -> NullifySpec Dict
70+
71+ hspecs = HNullify $ htabulate $ \field -> case hfield hspecs field of
72+ SSpec {..} -> case nullability of
73+ Nullable -> NullifySpec SSpec {nullability = Nullable, ..}
74+ NonNullable -> NullifySpec SSpec {nullability = Nullable, ..}
75+
76+ {-# INLINABLE hfield #-}
77+ {-# INLINABLE htabulate #-}
78+ {-# INLINABLE htraverse #-}
79+ {-# INLINABLE hdicts #-}
80+ {-# INLINABLE hspecs #-}
81+
82+
83+type NullifyingSpec :: Type -> Type
84+type NullifyingSpec r = (Spec -> r) -> Spec -> r
72
85
73−hguard :: HTable t
86+
74− => (forall a. context (Maybe a) -> context (Maybe a))
87+type NullifySpec :: NullifyingSpec Type
75− -> HNullify t context -> HNullify t context
88+data NullifySpec context spec where
76−hguard guarder (HNullify as) = HNullify $ htabulate $ \(HMapTableField field) ->
89+ NullifySpec
77− case hfield hspecs field of
90+ :: { getNullifySpec :: context ('Spec labels necessity dbType (Maybe dbType)) }
78− Spec {nullity} -> case hfield as (HMapTableField field) of
91+ -> NullifySpec context ('Spec labels necessity dbType a)
79− a -> case nullity of
92+
80− Null -> guarder a
93+
81− NotNull -> guarder a
94+type NullifySpecC :: NullifyingSpec Constraint
95+class
96+ ( forall labels necessity dbType a.
97+ ( spec ~ 'Spec labels necessity dbType a =>
98+ constraint ('Spec labels necessity dbType (Maybe dbType))
99+ )
100+ ) => NullifySpecC constraint spec
101+instance
102+ ( spec ~ 'Spec labels necessity dbType a
103+ , constraint ('Spec labels necessity dbType (Maybe dbType))
104+ ) => NullifySpecC constraint spec
105+
106+
107+traverseNullifySpec :: forall context context' spec m. Functor m
108+ => (forall x. context x -> m (context' x))
109+ -> NullifySpec context spec -> m (NullifySpec context' spec)
110+traverseNullifySpec f (NullifySpec a) = NullifySpec <$> f a
82
111
83
112
84hnulls :: HTable t
113hnulls :: HTable t
85− => (forall a. Spec a -> context (Type.Nullify a))
114+ => (forall labels necessity dbType. ()
115+ => context ('Spec labels necessity dbType (Maybe dbType)))
86− -> HNullify t context
116+ -> HNullify t (H context)
87−hnulls null = HNullify $ htabulate $ \(HMapTableField field) ->
117+hnulls null = HNullify $ htabulate $ \field -> case hfield hspecs field of
88− case hfield hspecs field of
118+ SSpec {} -> NullifySpec null
89− spec@Spec {} -> null spec
90{-# INLINABLE hnulls #-}
119{-# INLINABLE hnulls #-}
91
120
92
121
93hnullify :: HTable t
122hnullify :: HTable t
94− => (forall a. Spec a -> context a -> context (Type.Nullify a))
123+ => (forall labels necessity dbType a. ()
124+ => SSpec ('Spec labels necessity dbType a)
125+ -> context ('Spec labels necessity dbType a)
126+ -> context ('Spec labels necessity dbType (Maybe dbType)))
95− -> t context
127+ -> t (H context)
96− -> HNullify t context
128+ -> HNullify t (H context)
97−hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->
129+hnullify nullifier a = HNullify $ htabulate $ \field ->
98 case hfield hspecs field of
130 case hfield hspecs field of
99− spec@Spec {} -> nullifier spec (hfield a field)
131+ spec@SSpec {} -> NullifySpec (nullifier spec (hfield a field))
100{-# INLINABLE hnullify #-}
132{-# INLINABLE hnullify #-}
101
133
102
134
103hunnullify :: (HTable t, Apply m)
135hunnullify :: (HTable t, Apply m)
104− => (forall a. Spec a -> context (Type.Nullify a) -> m (context a))
136+ => (forall labels necessity dbType a. ()
137+ => SSpec ('Spec labels necessity dbType a)
138+ -> context ('Spec labels necessity dbType (Maybe dbType))
139+ -> m (context ('Spec labels necessity dbType a)))
105− -> HNullify t context
140+ -> HNullify t (H context)
106− -> m (t context)
141+ -> m (t (H context))
107hunnullify unnullifier (HNullify as) =
142hunnullify unnullifier (HNullify as) =
108 htabulateA $ \field -> case hfield hspecs field of
143 htabulateA $ \field -> case hfield hspecs field of
109− spec@Spec {} -> case hfield as (HMapTableField field) of
144+ spec@SSpec {} -> case hfield as field of
110− a -> unnullifier spec a
145+ NullifySpec a -> unnullifier spec a
111{-# INLINABLE hunnullify #-}
146{-# 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 Rel8.Schema.HTable.Context ( HKTable )
14+
15+
16+type HPair :: HKTable -> HKTable -> HKTable
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 Rel8.Schema.HTable.Context ( HKTable )
19+
20+
21+type HQuartet :: HKTable -> HKTable -> HKTable -> HKTable -> HKTable
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 Rel8.Schema.HTable.Context ( HKTable )
19+
20+
21+type HQuintet :: HKTable -> HKTable -> HKTable -> HKTable -> HKTable -> HKTable
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+8−7
@@ -14,20 +14,21 @@ import GHC.Generics ( Generic )
14import Prelude
14import Prelude
15
15
16-- rel8
16-- rel8
17+import Rel8.Kind.Necessity ( Necessity( Required ) )
17import Rel8.Schema.HTable ( HTable )
18import Rel8.Schema.HTable ( HTable )
19+import Rel8.Schema.HTable.Context ( HKTable )
18import Rel8.Schema.HTable.Identity ( HIdentity )
20import Rel8.Schema.HTable.Identity ( HIdentity )
19−import Rel8.Schema.HTable.Label ( HLabel )
20import Rel8.Schema.HTable.Nullify ( HNullify )
21import Rel8.Schema.HTable.Nullify ( HNullify )
21−import qualified Rel8.Schema.Kind as K
22+import Rel8.Schema.Spec ( Spec( Spec ) )
22import Rel8.Type.Tag ( MaybeTag )
23import Rel8.Type.Tag ( MaybeTag )
23
24
24
25
25−type HTheseTable :: K.HTable -> K.HTable -> K.HTable
26+type HTheseTable :: HKTable -> HKTable -> HKTable
26data HTheseTable here there context = HTheseTable
27data HTheseTable here there context = HTheseTable
27− { hhereTag :: HLabel "hereTag" (HIdentity (Maybe MaybeTag)) context
28+ { hhereTag :: HIdentity ('Spec '["hasHere"] 'Required MaybeTag (Maybe MaybeTag)) context
28− , hhere :: HLabel "Here" (HNullify here) context
29+ , hhere :: HNullify here context
29− , hthereTag :: HLabel "thereTag" (HIdentity (Maybe MaybeTag)) context
30+ , hthereTag :: HIdentity ('Spec '["hasThere"] 'Required MaybeTag (Maybe MaybeTag)) context
30− , hthere :: HLabel "There" (HNullify there) context
31+ , hthere :: HNullify there context
31 }
32 }
32 deriving stock Generic
33 deriving stock Generic
33 deriving anyclass HTable
34 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 Rel8.Schema.HTable.Context ( HKTable )
19+
20+
21+type HTrio :: HKTable -> HKTable -> HKTable -> HKTable
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+56
@@ -0,0 +1,56 @@
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 Rel8.Schema.HTable.Context ( H, HKTable )
26+import Rel8.Schema.Nullability ( Unnullify, Nullabilizes, nullabilization )
27+import Rel8.Schema.Spec ( Context, Spec( Spec ), SSpec(..) )
28+import Rel8.Type ( DBType, typeInformation )
29+
30+
31+type HType :: Type -> HKTable
32+data HType a context where
33+ HType ::
34+ { unHType :: context ('Spec '[""] 'Required (Unnullify a) a)
35+ } -> HType a (H context)
36+
37+
38+type HTypeField :: Type -> Context
39+data HTypeField a spec where
40+ HTypeField :: HTypeField a ('Spec '[""] 'Required (Unnullify a) a)
41+
42+
43+instance (DBType db, Nullabilizes db a) => HTable (HType a) where
44+ type HConstrainTable (HType a) c = c ('Spec '[""] 'Required (Unnullify a) a)
45+ type HField (HType a) = HTypeField a
46+
47+ hfield (HType a) HTypeField = a
48+ htabulate f = HType $ f HTypeField
49+ htraverse f (HType a) = HType <$> f a
50+ hdicts = HType Dict
51+ hspecs = HType SSpec
52+ { labels = SLabel Proxy
53+ , necessity = SRequired
54+ , info = typeInformation
55+ , nullability = nullabilization
56+ }
src/Rel8/Schema/HTable/Vectorize.hs+143−72
@@ -1,143 +1,214 @@
1{-# language AllowAmbiguousTypes #-}
1{-# language AllowAmbiguousTypes #-}
2{-# language ConstraintKinds #-}
2{-# language ConstraintKinds #-}
3{-# language DataKinds #-}
3{-# language DataKinds #-}
4−{-# language DeriveAnyClass #-}
5−{-# language DeriveGeneric #-}
6−{-# language DerivingStrategies #-}
7{-# language FlexibleContexts #-}
4{-# language FlexibleContexts #-}
8{-# language FlexibleInstances #-}
5{-# language FlexibleInstances #-}
9{-# language GADTs #-}
6{-# language GADTs #-}
10−{-# language LambdaCase #-}
7+{-# language InstanceSigs #-}
11{-# language MultiParamTypeClasses #-}
8{-# language MultiParamTypeClasses #-}
9+{-# language NamedFieldPuns #-}
10+{-# language QuantifiedConstraints #-}
12{-# language RankNTypes #-}
11{-# language RankNTypes #-}
13{-# language RecordWildCards #-}
12{-# language RecordWildCards #-}
14{-# language ScopedTypeVariables #-}
13{-# language ScopedTypeVariables #-}
15{-# language StandaloneKindSignatures #-}
14{-# language StandaloneKindSignatures #-}
16{-# language TypeApplications #-}
15{-# language TypeApplications #-}
17{-# language TypeFamilies #-}
16{-# language TypeFamilies #-}
17+{-# language TypeOperators #-}
18{-# language UndecidableInstances #-}
18{-# language UndecidableInstances #-}
19
19
20module Rel8.Schema.HTable.Vectorize
20module Rel8.Schema.HTable.Vectorize
21− ( HVectorize
21+ ( HVectorize( HVectorize )
22 , hvectorize, hunvectorize
22 , hvectorize, hunvectorize
23 , happend, hempty
23 , happend, hempty
24− , hproject
24+ , hrelabel
25− , hcolumn
26 )
25 )
27where
26where
28
27
29-- base
28-- base
30import Data.Kind ( Constraint, Type )
29import Data.Kind ( Constraint, Type )
31import Data.List.NonEmpty ( NonEmpty )
30import Data.List.NonEmpty ( NonEmpty )
32−import GHC.Generics (Generic)
31+import Data.Type.Equality ( (:~:)( Refl ) )
33import Prelude
32import Prelude
34
33
35-- rel8
34-- rel8
36−import Rel8.FCF ( Eval, Exp )
35+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
37import Rel8.Schema.Dict ( Dict( Dict ) )
36import Rel8.Schema.Dict ( Dict( Dict ) )
38−import qualified Rel8.Schema.Kind as K
37+import Rel8.Schema.HTable
38+ ( HTable, HConstrainTable, HField
39−import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )
39+ , hfield, htabulate, htabulateA, htraverse, hdicts, 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 )
45 )
40 )
46−import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )
41+import Rel8.Schema.HTable.Context ( H, HKTable )
47−import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )
42+import Rel8.Schema.Nullability ( IsMaybe, Nullability( NonNullable ) )
48−import Rel8.Schema.Spec ( Spec(..) )
43+import Rel8.Schema.Spec ( Context, Spec( Spec ), SSpec(..) )
49import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
44import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
50import Rel8.Type.Information ( TypeInformation )
45import Rel8.Type.Information ( TypeInformation )
51
46
52-- semialign
47-- semialign
53−import Data.Zip ( Unzip, Zip, Zippy(..) )
48+import Data.Zip ( Unzip, Repeat, Zippy(..) )
54
49
55
50
56−type Vector :: (Type -> Type) -> Constraint
57class Vector list where
51class Vector list where
58− listNotNull :: proxy a -> Dict NotNull (list a)
52+ listIsn'tMaybe :: proxy a -> IsMaybe (list a) :~: 'False
59 vectorTypeInformation :: ()
53 vectorTypeInformation :: ()
60− => Nullity a
54+ => Nullability a ma
61− -> TypeInformation (Unnullify a)
55+ -> TypeInformation a
62− -> TypeInformation (list a)
56+ -> TypeInformation (list ma)
63
57
64
58
65instance Vector [] where
59instance Vector [] where
66− listNotNull _ = Dict
60+ listIsn'tMaybe _ = Refl
67 vectorTypeInformation = listTypeInformation
61 vectorTypeInformation = listTypeInformation
68
62
69
63
70instance Vector NonEmpty where
64instance Vector NonEmpty where
71− listNotNull _ = Dict
65+ listIsn'tMaybe _ = Refl
72 vectorTypeInformation = nonEmptyTypeInformation
66 vectorTypeInformation = nonEmptyTypeInformation
73
67
74
68
75−type HVectorize :: (Type -> Type) -> K.HTable -> K.HTable
69+type HVectorize :: (Type -> Type) -> HKTable -> HKTable
76−newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) table context)
70+data HVectorize list table context where
77− deriving stock Generic
71+ HVectorize :: table (H (VectorizeSpec list context)) -> HVectorize list table (H context)
78− deriving anyclass HTable
79
72
80
73
81−data Vectorize :: (Type -> Type) -> Type -> Exp Type
74+type HVectorizeField :: (Type -> Type) -> HKTable -> Context
75+data HVectorizeField list table spec where
76+ HVectorizeField
77+ :: HField table ('Spec labels necessity db a)
78+ -> HVectorizeField list table
79+ ('Spec labels necessity (list a) (list a)
80+ )
82
81
83
82
84−type instance Eval (Vectorize list a) = list a
83+instance (HTable table, Vector list) => HTable (HVectorize list table) where
85
84
85+ type HField (HVectorize list table) = HVectorizeField list table
86+ type HConstrainTable (HVectorize list table) c =
87+ HConstrainTable table (VectorizeSpecC list c)
86
88
87−instance Vector list => MapSpec (Vectorize list) where
89+ hfield (HVectorize table) (HVectorizeField field) =
88− mapInfo = \case
90+ getVectorizeSpec (hfield table field)
89− Spec {..} -> case listNotNull @list nullity of
91+
90− Dict -> Spec
92+ htabulate f = HVectorize $ htabulate $ \field -> case hfield hspecs field of
91− { nullity = NotNull
93+ SSpec {} -> VectorizeSpec (f (HVectorizeField field))
94+ htraverse f (HVectorize t) = HVectorize <$> htraverse (traverseVectorizeSpec f) t
95+
96+ hdicts :: forall c. HConstrainTable table (VectorizeSpecC list c) =>
97+ HVectorize list table (H (Dict c))
98+ hdicts = HVectorize $ htabulate $ \field -> case hfield hspecs field of
99+ SSpec {} -> case hfield (hdicts @_ @(VectorizeSpecC list c)) field of
100+ Dict -> VectorizeSpec Dict
101+
102+ hspecs = HVectorize $ htabulate $ \field -> case hfield hspecs field of
103+ SSpec {..} -> case listIsn'tMaybe @list nullability of
104+ Refl -> VectorizeSpec SSpec
105+ { nullability = NonNullable
92− , info = vectorTypeInformation nullity info
106+ , info = vectorTypeInformation nullability info
93 , ..
107 , ..
94 }
108 }
95
109
110+ {-# INLINABLE hfield #-}
111+ {-# INLINABLE htabulate #-}
112+ {-# INLINABLE htraverse #-}
113+ {-# INLINABLE hdicts #-}
114+ {-# INLINABLE hspecs #-}
115+
116+
117+type VectorizingSpec :: Type -> Type
118+type VectorizingSpec r = (Type -> Type) -> (Spec -> r) -> Spec -> r
119+
120+
121+type VectorizeSpec :: VectorizingSpec Type
122+data VectorizeSpec list context spec where
123+ VectorizeSpec ::
124+ { getVectorizeSpec :: context ('Spec labels necessity (list a) (list a))
125+ } -> VectorizeSpec list context ('Spec labels necessity db a)
126+
127+
128+instance Labelable context => Labelable (VectorizeSpec list context) where
129+ labeler (VectorizeSpec a) = VectorizeSpec (labeler a)
130+ unlabeler (VectorizeSpec a) = VectorizeSpec (unlabeler a)
131+
96
132
97−hvectorize :: (HTable t, Unzip f, Vector list)
133+type VectorizeSpecC :: VectorizingSpec Constraint
98− => (forall a. Spec a -> f (context a) -> context' (list a))
134+class
99− -> f (t context)
135+ ( forall labels necessity db a.
100− -> HVectorize list t context'
136+ ( spec ~ 'Spec labels necessity db a
101−hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->
137+ => constraint ('Spec labels necessity (list a) (list a))
138+ )
139+ )
140+ => VectorizeSpecC list constraint spec
141+instance
142+ ( spec ~ 'Spec labels necessity db a
143+ , constraint ('Spec labels necessity (list a) (list a))
144+ )
145+ => VectorizeSpecC list constraint spec
146+
147+
148+traverseVectorizeSpec :: forall context context' list spec m. Functor m
149+ => (forall x. context x -> m (context' x))
150+ -> VectorizeSpec list context spec
151+ -> m (VectorizeSpec list context' spec)
152+traverseVectorizeSpec f (VectorizeSpec a) = VectorizeSpec <$> f a
153+
154+
155+hvectorize :: (HTable t, Unzip f)
156+ => (forall labels necessity db a. ()
157+ => SSpec ('Spec labels necessity db a)
158+ -> f (context ('Spec labels necessity db a))
159+ -> context' ('Spec labels necessity (list a) (list a)))
160+ -> f (t (H context))
161+ -> HVectorize list t (H context')
162+hvectorize vectorizer as = HVectorize $ htabulate $ \field ->
102 case hfield hspecs field of
163 case hfield hspecs field of
103− spec -> vectorizer spec (fmap (`hfield` field) as)
164+ spec@SSpec {} -> VectorizeSpec (vectorizer spec (fmap (`hfield` field) as))
104{-# INLINABLE hvectorize #-}
165{-# INLINABLE hvectorize #-}
105
166
106
167
107−hunvectorize :: (HTable t, Zip f, Vector list)
168+hunvectorize :: (HTable t, Repeat f)
108− => (forall a. Spec a -> context (list a) -> f (context' a))
169+ => (forall labels necessity db a. ()
109− -> HVectorize list t context
170+ => SSpec ('Spec labels necessity db a)
110− -> f (t context')
171+ -> context ('Spec labels necessity (list a) (list a))
172+ -> f (context' ('Spec labels necessity db a)))
173+ -> HVectorize list t (H context)
174+ -> f (t (H context'))
111hunvectorize unvectorizer (HVectorize table) =
175hunvectorize unvectorizer (HVectorize table) =
112 getZippy $ htabulateA $ \field -> case hfield hspecs field of
176 getZippy $ htabulateA $ \field -> case hfield hspecs field of
113− spec -> case hfield table (HMapTableField field) of
177+ spec -> case hfield table field of
114− a -> Zippy (unvectorizer spec a)
178+ VectorizeSpec a -> Zippy (unvectorizer spec a)
115{-# INLINABLE hunvectorize #-}
179{-# INLINABLE hunvectorize #-}
116
180
117
181
118−happend :: (HTable t, Vector list)
182+happend :: HTable t =>
119− => (forall a. Spec a -> context (list a) -> context (list a) -> context (list a))
183+ ( forall labels necessity db a. ()
120− -> HVectorize list t context
184+ => Nullability db a
121− -> HVectorize list t context
185+ -> TypeInformation db
122− -> HVectorize list t context
186+ -> context ('Spec labels necessity (list a) (list a))
187+ -> context ('Spec labels necessity (list a) (list a))
188+ -> context ('Spec labels necessity (list a) (list a))
189+ )
190+ -> HVectorize list t (H context)
191+ -> HVectorize list t (H context)
192+ -> HVectorize list t (H context)
123happend append (HVectorize as) (HVectorize bs) = HVectorize $
193happend append (HVectorize as) (HVectorize bs) = HVectorize $
124− htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of
194+ htabulate $ \field -> case (hfield as field, hfield bs field) of
125− (a, b) -> case hfield hspecs j of
195+ (VectorizeSpec a, VectorizeSpec b) -> case hfield hspecs field of
126− spec -> append spec a b
196+ SSpec {nullability, info} -> VectorizeSpec $ append nullability info a b
127−
128
197
129−hempty :: HTable t
130− => (forall a. Spec a -> context [a])
131− -> HVectorize [] t context
132−hempty empty = HVectorize $ htabulate $ \(HMapTableField field) ->
133− empty (hfield hspecs field)
134
198
135−
199+hempty :: HTable t =>
136−hproject :: ()
200+ ( forall labels necessity db a. ()
137− => (forall ctx. t ctx -> t' ctx)
201+ => Nullability db a
138− -> HVectorize list t context -> HVectorize list t' context
202+ -> TypeInformation db
139−hproject f (HVectorize a) = HVectorize (HMapTable.hproject f a)
203+ -> context ('Spec labels necessity [a] [a])
204+ )
205+ -> HVectorize [] t (H context)
206+hempty empty = HVectorize $ htabulate $ \field -> case hfield hspecs field of
207+ SSpec {nullability, info} -> VectorizeSpec (empty nullability info)
140
208
141
209
142−hcolumn :: HVectorize list (HIdentity a) context -> context (list a)
210+hrelabel :: Labelable context
143−hcolumn (HVectorize (HMapTable (HIdentity (Precompose a)))) = a
211+ => (forall ctx. Labelable ctx => t (H ctx) -> u (H ctx))
212+ -> HVectorize list t (H context)
213+ -> HVectorize list u (H context)
214+hrelabel f (HVectorize table) = HVectorize (f table)
src/Rel8/Schema/Kind.hsdeleted−24
@@ -1,24 +0,0 @@
1−{-# language StandaloneKindSignatures #-}
2−
3−module Rel8.Schema.Kind
4− ( Rel8able
5− , Context
6− , HTable
7− )
8−where
9−
10−-- base
11−import Data.Kind ( Type )
12−import Prelude ()
13−
14−
15−type Context :: Type
16−type Context = Type -> Type
17−
18−
19−type HTable :: Type
20−type HTable = Context -> Type
21−
22−
23−type Rel8able :: Type
24−type Rel8able = 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+86
@@ -0,0 +1,86 @@
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+
13+module Rel8.Schema.Nullability
14+ ( IsMaybe, Nullify, Unnullify
15+ , Nullability( Nullable, NonNullable )
16+ , Nullabilizes, nullabilization
17+ )
18+where
19+
20+-- base
21+import Data.Kind ( Constraint, Type )
22+import Prelude
23+
24+-- rel8
25+import Rel8.Opaque ( Opaque )
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+type Nullability :: Type -> Type -> Type
55+data Nullability a ma where
56+ NonNullable :: IsMaybe a ~ 'False => Nullability a a
57+ Nullable :: IsMaybe a ~ 'False => Nullability a (Maybe a)
58+
59+
60+type Nullabilizes' :: Bool -> Type -> Type -> Constraint
61+class
62+ ( IsMaybe ma ~ isMaybe
63+ , IsMaybe a ~ 'False
64+ , Unnullify ma ~ a
65+ , Nullify' isMaybe a ~ ma
66+ ) => Nullabilizes' isMaybe a ma | isMaybe ma -> a, isMaybe a -> ma
67+ where
68+ nullabilization' :: Nullability a ma
69+
70+
71+instance IsMaybe a ~ 'False => Nullabilizes' 'False a a where
72+ nullabilization' = NonNullable
73+
74+
75+instance IsMaybe a ~ 'False => Nullabilizes' 'True a (Maybe a) where
76+ nullabilization' = Nullable
77+
78+
79+type Nullabilizes :: Type -> Type -> Constraint
80+class Nullabilizes' (IsMaybe ma) a ma => Nullabilizes a ma
81+instance Nullabilizes' (IsMaybe ma) a ma => Nullabilizes a ma
82+instance {-# OVERLAPPING #-} Nullabilizes Opaque Opaque
83+
84+
85+nullabilization :: forall a db. Nullabilizes db a => Nullability db a
86+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+55−18
@@ -1,34 +1,71 @@
1+{-# language DataKinds #-}
1{-# language FlexibleContexts #-}
2{-# language FlexibleContexts #-}
2−{-# language MonoLocalBinds #-}
3+{-# language GADTs #-}
3{-# language StandaloneKindSignatures #-}
4{-# language StandaloneKindSignatures #-}
5+{-# language UndecidableInstances #-}
4
6
5module Rel8.Schema.Spec
7module Rel8.Schema.Spec
6− ( Spec( Spec, labels, info, nullity )
8+ ( Spec( Spec )
7− , specification
9+ , SSpec( SSpec, labels, necessity, info, nullability )
10+ , KnownSpec( specSing )
11+ , Context, KTable
8 )
12 )
9where
13where
10
14
11-- base
15-- base
12−import Data.Kind ( Type )
16+import Data.Kind ( Constraint, Type )
13−import Prelude
17+import Prelude ()
14
18
15-- rel8
19-- rel8
16−import Rel8.Schema.Null ( Nullity, Sql, Unnullify, nullable )
20+import Rel8.Kind.Labels ( Labels, SLabels, KnownLabels, labelsSing )
21+import Rel8.Kind.Necessity
22+ ( Necessity
23+ , SNecessity
24+ , KnownNecessity, necessitySing
25+ )
26+import Rel8.Schema.Nullability ( Nullability, Nullabilizes, nullabilization )
17import Rel8.Type ( DBType, typeInformation )
27import Rel8.Type ( DBType, typeInformation )
18import Rel8.Type.Information ( TypeInformation )
28import Rel8.Type.Information ( TypeInformation )
19
29
20
30
21−type Spec :: Type -> Type
31+type Spec :: Type
22−data Spec a = Spec
32+data Spec = Spec Labels Necessity Type Type
23− { labels :: [String]
33+
24− , info :: TypeInformation (Unnullify a)
34+
25− , nullity :: Nullity a
35+type SSpec :: Spec -> Type
26− }
36+data SSpec spec where
37+ SSpec ::
38+ { labels :: SLabels labels
39+ , necessity :: SNecessity necessity
40+ , info :: TypeInformation db
41+ , nullability :: Nullability db a
42+ }
43+ -> SSpec ('Spec labels necessity db a)
44+
45+
46+type KnownSpec :: Spec -> Constraint
47+class KnownSpec spec where
48+ specSing :: SSpec spec
49+
50+
51+instance
52+ ( KnownLabels labels
53+ , KnownNecessity necessity
54+ , DBType db
55+ , Nullabilizes db a
56+ ) => KnownSpec ('Spec labels necessity db a)
57+ where
58+ specSing = SSpec
59+ { labels = labelsSing
60+ , necessity = necessitySing
61+ , info = typeInformation
62+ , nullability = nullabilization
63+ }
64+
65+
66+type Context :: Type
67+type Context = Spec -> Type
27
68
28
69
29−specification :: Sql DBType a => Spec a
70+type KTable :: Type
30−specification = Spec
71+type KTable = Context -> Type
31− { labels = []
32− , info = typeInformation
33− , nullity = nullable
34− }
src/Rel8/Schema/Spec/ConstrainContext.hsnew file+23
@@ -0,0 +1,23 @@
1+{-# language ConstraintKinds #-}
2+{-# language DataKinds #-}
3+{-# language FlexibleInstances #-}
4+{-# language MultiParamTypeClasses #-}
5+{-# language StandaloneKindSignatures #-}
6+{-# language UndecidableSuperClasses #-}
7+
8+module Rel8.Schema.Spec.ConstrainContext
9+ ( ConstrainContext
10+ )
11+where
12+
13+-- base
14+import Data.Kind ( Constraint, Type )
15+import Prelude ()
16+
17+-- rel8
18+import Rel8.Schema.Spec ( Context, Spec )
19+
20+
21+type ConstrainContext :: (Type -> Constraint) -> Context -> Spec -> Constraint
22+class constraint (context spec) => ConstrainContext constraint context spec
23+instance constraint (context spec) => ConstrainContext constraint context spec
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+53
@@ -0,0 +1,53 @@
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 Rel8.Schema.Spec ( Context, Spec )
21+
22+
23+type Structure :: Context
24+data Structure spec
25+
26+
27+type Shape :: Type
28+data Shape
29+ = Column Spec
30+ | Either Type Type
31+ | List Type
32+ | Maybe Type
33+ | NonEmpty Type
34+ | These Type Type
35+
36+
37+type Shape1 :: (a -> Shape) -> a -> Type
38+data Shape1 shape a
39+
40+
41+type Shape2 :: (a -> b -> Shape) -> a -> b -> Type
42+data Shape2 shape a b
43+
44+
45+type IsStructure :: Type -> Bool
46+type family IsStructure a where
47+ IsStructure (Shape1 _ _) = 'True
48+ IsStructure (Shape2 _ _ _) = 'True
49+ IsStructure (_, _) = 'True
50+ IsStructure (_, _, _) = 'True
51+ IsStructure (_, _, _, _) = 'True
52+ IsStructure (_, _, _, _, _) = 'True
53+ IsStructure _ = 'False
src/Rel8/Schema/Table.hs+14−21
@@ -1,34 +1,34 @@
1{-# language DeriveFunctor #-}
1{-# language DeriveFunctor #-}
2{-# language DerivingStrategies #-}
2{-# language DerivingStrategies #-}
3−{-# language DisambiguateRecordFields #-}
4−{-# language NamedFieldPuns #-}
5−{-# language StandaloneKindSignatures #-}
6
3
7module Rel8.Schema.Table
4module Rel8.Schema.Table
8 ( TableSchema(..)
5 ( TableSchema(..)
9− , ppTable
10 )
6 )
11where
7where
12
8
13-- base
9-- base
14−import Data.Kind ( Type )
15import Prelude
10import Prelude
16
11
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−
24
12
25-- | The schema for a table. This is used to specify the name and schema that a
13-- | The schema for a table. This is used to specify the name and schema that a
26-- table belongs to (the @FROM@ part of a SQL query), along with the schema of
14-- table belongs to (the @FROM@ part of a SQL query), along with the schema of
27-- the columns within this table.
15-- the columns within this table.
28--
16--
29-- For each selectable table in your database, you should provide a
17-- For each selectable table in your database, you should provide a
30−-- @TableSchema@ in order to interact with the table via Rel8.
18+-- @TableSchema@ in order to interact with the table via Rel8. For a table
31−type TableSchema :: Type -> Type
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+-- :}
32data TableSchema names = TableSchema
32data TableSchema names = TableSchema
33 { name :: String
33 { name :: String
34 -- ^ The name of the table.
34 -- ^ The name of the table.
@@ -40,10 +40,3 @@ data TableSchema names = TableSchema
40 -- data type here, parameterized by the 'Rel8.ColumnSchema.ColumnSchema' functor.
40 -- data type here, parameterized by the 'Rel8.ColumnSchema.ColumnSchema' functor.
41 }
41 }
42 deriving stock Functor
42 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+68−36
@@ -1,37 +1,41 @@
1{-# language DuplicateRecordFields #-}
1{-# language DuplicateRecordFields #-}
2{-# language GADTs #-}
2{-# language GADTs #-}
3{-# language NamedFieldPuns #-}
3{-# language NamedFieldPuns #-}
4−{-# language RankNTypes #-}
4+{-# language ScopedTypeVariables #-}
5−{-# language RecordWildCards #-}
6{-# language StandaloneKindSignatures #-}
5{-# language StandaloneKindSignatures #-}
7−{-# language StrictData #-}
6+{-# language TypeApplications #-}
8
7
9module Rel8.Statement.Delete
8module Rel8.Statement.Delete
10 ( Delete(..)
9 ( Delete(..)
11 , delete
10 , delete
12− , ppDelete
13 )
11 )
14where
12where
15
13
16-- base
14-- base
15+import Control.Exception ( throwIO )
16+import Control.Monad ( (>=>) )
17import Data.Kind ( Type )
17import Data.Kind ( Type )
18import Prelude
18import Prelude
19
19
20-- hasql
20-- hasql
21+import Hasql.Connection ( Connection )
22+import qualified Hasql.Decoders as Hasql
21import qualified Hasql.Encoders as Hasql
23import qualified Hasql.Encoders as Hasql
24+import qualified Hasql.Session as Hasql
22import qualified Hasql.Statement as Hasql
25import qualified Hasql.Statement as Hasql
23
26
24−-- pretty
27+-- opaleye
25−import Text.PrettyPrint ( Doc, (<+>), ($$), text )
28+import qualified Opaleye.Internal.Manipulation as Opaleye
26
29
27-- rel8
30-- rel8
28import Rel8.Expr ( Expr )
31import Rel8.Expr ( Expr )
29−import Rel8.Query ( Query )
32+import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
30−import Rel8.Schema.Name ( Selects )
33+import Rel8.Schema.Table ( TableSchema )
31−import Rel8.Schema.Table ( TableSchema, ppTable )
34+import Rel8.Statement.Returning ( Returning( NumberOfRowsAffected, Projection ) )
32−import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )
35+import Rel8.Table ( fromColumns, toColumns )
33−import Rel8.Statement.Using ( ppUsing )
36+import Rel8.Table.Opaleye ( table, unpackspec )
34−import Rel8.Statement.Where ( ppWhere )
37+import Rel8.Table.Recontextualize ( Selects )
38+import Rel8.Table.Serialize ( Serializable, parse )
35
39
36-- text
40-- text
37import qualified Data.Text as Text
41import qualified Data.Text as Text
@@ -44,10 +48,7 @@ data Delete a where
44 Delete :: Selects names exprs =>
48 Delete :: Selects names exprs =>
45 { from :: TableSchema names
49 { from :: TableSchema names
46 -- ^ Which table to delete from.
50 -- ^ Which table to delete from.
47− , using :: Query using
51+ , deleteWhere :: exprs -> Expr Bool
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
51 -- ^ Which rows should be selected for deletion.
52 -- ^ Which rows should be selected for deletion.
52 , returning :: Returning names a
53 , returning :: Returning names a
53 -- ^ What to return from the @DELETE@ statement.
54 -- ^ What to return from the @DELETE@ statement.
@@ -55,25 +56,56 @@ data Delete a where
55 -> Delete a
56 -> Delete a
56
57
57
58
58−ppDelete :: Delete a -> Doc
59+-- | Run a @DELETE@ statement.
59−ppDelete Delete {..} = case ppUsing using of
60+--
60− Nothing ->
61+-- >>> mapM_ print =<< select c (each projectSchema)
61− text "DELETE FROM" <+> ppTable from $$
62+-- Project {projectAuthorId = 1, projectName = "rel8"}
62− text "WHERE false"
63+-- Project {projectAuthorId = 2, projectName = "aeson"}
63− Just (usingDoc, i) ->
64+-- Project {projectAuthorId = 2, projectName = "text"}
64− text "DELETE FROM" <+> ppTable from $$
65+--
65− usingDoc $$
66+-- >>> :{
66− ppWhere from (deleteWhere i) $$
67+-- delete c Delete
67− ppReturning from returning
68+-- { from = projectSchema
69+-- , deleteWhere = \p -> projectName p ==. lit "rel8"
70+-- , returning = Projection projectName
71+-- }
72+-- :}
73+-- ["rel8"]
74+--
75+-- >>> mapM_ print =<< select c (each projectSchema)
76+-- Project {projectAuthorId = 2, projectName = "aeson"}
77+-- Project {projectAuthorId = 2, projectName = "text"}
78+delete :: Delete a -> Connection -> IO a
79+delete Delete {from, deleteWhere, returning} =
80+ case returning of
81+ NumberOfRowsAffected -> Hasql.run session >=> either throwIO pure
82+ where
83+ session = Hasql.statement () statement
84+ statement = Hasql.Statement bytes params decode prepare
85+ bytes = encodeUtf8 $ Text.pack sql
86+ params = Hasql.noParams
87+ decode = Hasql.rowsAffected
88+ prepare = False
89+ sql = Opaleye.arrangeDeleteSql from' where'
90+ where
91+ from' = table $ toColumns <$> from
92+ where' = toColumn . toPrimExpr . deleteWhere . fromColumns
68
93
69−
94+ Projection project -> Hasql.run session >=> either throwIO pure
70−-- | Run a 'Delete' statement.
95+ where
71−delete :: Delete a -> Hasql.Statement () a
96+ session = Hasql.statement () statement
72−delete d@Delete {returning} = Hasql.Statement bytes params decode prepare
97+ statement = Hasql.Statement bytes params decode prepare
98+ bytes = encodeUtf8 $ Text.pack sql
99+ params = Hasql.noParams
100+ decode = decoder project
101+ prepare = False
102+ sql =
103+ Opaleye.arrangeDeleteReturningSql unpackspec from' where' project'
104+ where
105+ from' = table $ toColumns <$> from
106+ where' = toColumn . toPrimExpr . deleteWhere . fromColumns
107+ project' = toColumns . project . fromColumns
73 where
108 where
74− bytes = encodeUtf8 $ Text.pack sql
109+ decoder :: forall exprs projection a. Serializable projection a
75− params = Hasql.noParams
110+ => (exprs -> projection) -> Hasql.Result [a]
76− decode = decodeReturning returning
111+ decoder _ = Hasql.rowList (parse @projection @a)
77− prepare = False
78− sql = show doc
79− doc = ppDelete d
src/Rel8/Statement/Insert.hs+82−44
@@ -2,42 +2,40 @@
2{-# language FlexibleContexts #-}
2{-# language FlexibleContexts #-}
3{-# language GADTs #-}
3{-# language GADTs #-}
4{-# language NamedFieldPuns #-}
4{-# language NamedFieldPuns #-}
5−{-# language RecordWildCards #-}
5+{-# language ScopedTypeVariables #-}
6{-# language StandaloneKindSignatures #-}
6{-# language StandaloneKindSignatures #-}
7−{-# language StrictData #-}
7+{-# language TypeApplications #-}
8
8
9module Rel8.Statement.Insert
9module Rel8.Statement.Insert
10 ( Insert(..)
10 ( Insert(..)
11+ , OnConflict(..)
11 , insert
12 , insert
12− , ppInsert
13− , ppInto
14 )
13 )
15where
14where
16
15
17-- base
16-- base
18−import Data.Foldable ( toList )
17+import Control.Exception ( throwIO )
18+import Control.Monad ( (>=>) )
19import Data.Kind ( Type )
19import Data.Kind ( Type )
20+import Data.List.NonEmpty ( NonEmpty( (:|) ) )
20import Prelude
21import Prelude
21
22
22-- hasql
23-- hasql
24+import Hasql.Connection ( Connection )
25+import qualified Hasql.Decoders as Hasql
23import qualified Hasql.Encoders as Hasql
26import qualified Hasql.Encoders as Hasql
27+import qualified Hasql.Session as Hasql
24import qualified Hasql.Statement as Hasql
28import qualified Hasql.Statement as Hasql
25
29
26−-- opaleye
27−import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye
28−
29−-- pretty
30−import Text.PrettyPrint ( Doc, (<+>), ($$), parens, text )
31−
32-- rel8
30-- rel8
33−import Rel8.Query ( Query )
31+import qualified Opaleye.Internal.Manipulation as Opaleye
34−import Rel8.Schema.Name ( Name, Selects, ppColumn )
32+import qualified Opaleye.Manipulation as Opaleye
35−import Rel8.Schema.Table ( TableSchema(..), ppTable )
33+import Rel8.Schema.Table ( TableSchema )
36−import Rel8.Statement.OnConflict ( OnConflict, ppOnConflict )
34+import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) )
37−import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )
35+import Rel8.Table ( fromColumns, toColumns )
38−import Rel8.Statement.Select ( ppRows )
36+import Rel8.Table.Opaleye ( table, unpackspec )
39−import Rel8.Table ( Table )
37+import Rel8.Table.Recontextualize ( Inserts, Selects )
40−import Rel8.Table.Name ( showNames )
38+import Rel8.Table.Serialize ( Serializable, parse )
41
39
42-- text
40-- text
43import qualified Data.Text as Text ( pack )
41import qualified Data.Text as Text ( pack )
@@ -47,13 +45,12 @@ import Data.Text.Encoding ( encodeUtf8 )
47-- | The constituent parts of a SQL @INSERT@ statement.
45-- | The constituent parts of a SQL @INSERT@ statement.
48type Insert :: Type -> Type
46type Insert :: Type -> Type
49data Insert a where
47data Insert a where
50− Insert :: Selects names exprs =>
48+ Insert :: (Selects names exprs, Inserts exprs inserts) =>
51 { into :: TableSchema names
49 { into :: TableSchema names
52 -- ^ Which table to insert into.
50 -- ^ Which table to insert into.
53− , rows :: Query exprs
51+ , rows :: [inserts]
54− -- ^ The rows to insert. This can be an arbitrary query — use
52+ -- ^ The rows to insert.
55− -- 'Rel8.values' insert a static list of rows.
53+ , onConflict :: OnConflict
56− , onConflict :: OnConflict names
57 -- ^ What to do if the inserted rows conflict with data already in the
54 -- ^ What to do if the inserted rows conflict with data already in the
58 -- table.
55 -- table.
59 , returning :: Returning names a
56 , returning :: Returning names a
@@ -62,28 +59,69 @@ data Insert a where
62 -> Insert a
59 -> Insert a
63
60
64
61
65−ppInsert :: Insert a -> Doc
62+-- | @OnConflict@ allows you to add an @ON CONFLICT@ clause to an @INSERT@
66−ppInsert Insert {..} =
63+-- statement.
67− text "INSERT INTO" <+>
64+data OnConflict
68− ppInto into $$
65+ = Abort -- ^ @ON CONFLICT ABORT@
69− ppRows rows $$
66+ | DoNothing -- ^ @ON CONFLICT DO NOTHING@
70− ppOnConflict into onConflict $$
71− ppReturning into returning
72
67
73
68
74−ppInto :: Table Name a => TableSchema a -> Doc
69+-- | Run an @INSERT@ statement
75−ppInto table@TableSchema {columns} =
70+--
76− ppTable table <+>
71+-- >>> :{
77− parens (Opaleye.commaV ppColumn (toList (showNames columns)))
72+-- insert c Insert
73+-- { into = authorSchema
74+-- , rows = [ lit Author{ authorName = "Gabriel Gonzales", authorId = AuthorId 4, authorUrl = Just "https://haskellforall.com" } ]
75+-- , onConflict = Abort
76+-- , returning = NumberOfRowsAffected
77+-- }
78+-- :}
79+-- 1
80+insert :: Insert a -> Connection -> IO a
81+insert Insert {into, rows, onConflict, returning} =
82+ case (rows, returning) of
83+ ([], NumberOfRowsAffected) -> const $ pure 0
84+ ([], Projection _) -> const $ pure []
78
85
86+ (x:xs, NumberOfRowsAffected) -> Hasql.run session >=> either throwIO pure
87+ where
88+ session = Hasql.statement () statement
89+ statement = Hasql.Statement bytes params decode prepare
90+ bytes = encodeUtf8 $ Text.pack sql
91+ params = Hasql.noParams
92+ decode = Hasql.rowsAffected
93+ prepare = False
94+ sql = Opaleye.arrangeInsertManySql into' rows' onConflict'
95+ where
96+ into' = table $ toColumns <$> into
97+ rows' = toColumns <$> x :| xs
98+
99+ (x:xs, Projection project) -> Hasql.run session >=> either throwIO pure
100+ where
101+ session = Hasql.statement () statement
102+ statement = Hasql.Statement bytes params decode prepare
103+ bytes = encodeUtf8 $ Text.pack sql
104+ params = Hasql.noParams
105+ decode = decoder project
106+ prepare = False
107+ sql =
108+ Opaleye.arrangeInsertManyReturningSql
109+ unpackspec
110+ into'
111+ rows'
112+ project'
113+ onConflict'
114+ where
115+ into' = table $ toColumns <$> into
116+ rows' = toColumns <$> x :| xs
117+ project' = toColumns . project . fromColumns
79
118
80−-- | Run an 'Insert' statement.
81−insert :: Insert a -> Hasql.Statement () a
82−insert i@Insert {returning} = Hasql.Statement bytes params decode prepare
83 where
119 where
84− bytes = encodeUtf8 $ Text.pack sql
120+ onConflict' =
85− params = Hasql.noParams
121+ case onConflict of
86− decode = decodeReturning returning
122+ DoNothing -> Just Opaleye.DoNothing
87− prepare = False
123+ Abort -> Nothing
88− sql = show doc
124+
89− doc = ppInsert i
125+ decoder :: forall exprs projection a. Serializable projection a
126+ => (exprs -> projection) -> Hasql.Result [a]
127+ 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+6−115
@@ -1,133 +1,24 @@
1{-# language GADTs #-}
1{-# language GADTs #-}
2−{-# language LambdaCase #-}
3−{-# language NamedFieldPuns #-}
4−{-# language RankNTypes #-}
5−{-# language ScopedTypeVariables #-}
6{-# language StandaloneKindSignatures #-}
2{-# language StandaloneKindSignatures #-}
7−{-# language StrictData #-}
8−{-# language TypeApplications #-}
9
3
10module Rel8.Statement.Returning
4module Rel8.Statement.Returning
11− ( Returning( NumberOfRowsAffected, Projection )
5+ ( Returning(..)
12− , decodeReturning
13− , ppReturning
14 )
6 )
15where
7where
16
8
17-- base
9-- base
18−import Control.Applicative ( liftA2 )
19−import Data.Foldable ( toList )
20import Data.Int ( Int64 )
10import Data.Int ( Int64 )
21import Data.Kind ( Type )
11import Data.Kind ( Type )
22−import Data.List.NonEmpty ( NonEmpty )
12+import Prelude ()
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 )
35
13
36-- rel8
14-- rel8
37−import Rel8.Schema.Name ( Selects )
15+import Rel8.Table.Recontextualize ( Selects )
38−import Rel8.Schema.Table ( TableSchema(..) )
16+import Rel8.Table.Serialize ( Serializable )
39−import Rel8.Table.Opaleye ( castTable, exprs, view )
40−import Rel8.Table.Serialize ( Serializable, parse )
41
17
42−-- semigropuoids
43−import Data.Functor.Apply ( Apply, (<.>) )
44
18
45−
46−-- | 'Rel8.Insert', 'Rel8.Update' and 'Rel8.Delete' all support returning either
47−-- the number of rows affected, or the actual rows modified.
48type Returning :: Type -> Type -> Type
19type Returning :: Type -> Type -> Type
49data Returning names a where
20data 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.
54 NumberOfRowsAffected :: Returning names Int64
21 NumberOfRowsAffected :: Returning names Int64
55−
22+ Projection :: (Selects names exprs, Serializable projection a)
56− -- | 'Projection' allows you to project out of the affected rows, which can
23+ => (exprs -> projection)
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)
62 -> Returning names [a]
24 -> 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+37−122
@@ -1,147 +1,62 @@
1−{-# language DeriveTraversable #-}
2−{-# language DerivingStrategies #-}
3−{-# language FlexibleContexts #-}
4−{-# language MonoLocalBinds #-}
5{-# language ScopedTypeVariables #-}
1{-# language ScopedTypeVariables #-}
6−{-# language StandaloneKindSignatures #-}
7{-# language TypeApplications #-}
2{-# language TypeApplications #-}
8
3
9module Rel8.Statement.Select
4module Rel8.Statement.Select
10 ( select
5 ( select
11− , ppSelect
6+ , selectWithNames
12−
13− , Optimized(..)
14− , ppPrimSelect
15− , ppRows
16 )
7 )
17where
8where
18
9
19-- base
10-- base
20−import Data.Foldable ( toList )
11+import Control.Exception ( throwIO )
21−import Data.Kind ( Type )
12+import Control.Monad ( (>=>) )
22−import Data.Void ( Void )
13+import Prelude
23−import Prelude hiding ( undefined )
24
14
25-- hasql
15-- hasql
16+import Hasql.Connection ( Connection )
26import qualified Hasql.Decoders as Hasql
17import qualified Hasql.Decoders as Hasql
27import qualified Hasql.Encoders as Hasql
18import qualified Hasql.Encoders as Hasql
19+import qualified Hasql.Session as Hasql
28import qualified Hasql.Statement as Hasql
20import qualified Hasql.Statement as Hasql
29
21
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−
44-- rel8
22-- rel8
45−import Rel8.Expr ( Expr )
46−import Rel8.Expr.Bool ( false )
47−import Rel8.Expr.Opaleye ( toPrimExpr )
48import Rel8.Query ( Query )
23import Rel8.Query ( Query )
49−import Rel8.Query.Opaleye ( toOpaleye )
24+import Rel8.Query.SQL ( sqlForQuery, sqlForQueryWithNames )
50−import Rel8.Schema.Name ( Selects )
25+import Rel8.Table.Recontextualize ( 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
56import Rel8.Table.Serialize ( Serializable, parse )
26import Rel8.Table.Serialize ( Serializable, parse )
57−import Rel8.Table.Undefined ( undefined )
58
27
59-- text
28-- text
60import qualified Data.Text as Text
29import qualified Data.Text as Text
61import Data.Text.Encoding ( encodeUtf8 )
30import Data.Text.Encoding ( encodeUtf8 )
62
31
63
32
64−-- | Run a @SELECT@ statement, returning all rows.
33+-- | Run a @SELECT@ query, returning all rows.
65select :: forall exprs a. Serializable exprs a
34select :: forall exprs a. Serializable exprs a
66− => Query exprs -> Hasql.Statement () [a]
35+ => Query exprs -> Connection -> IO [a]
67−select query = Hasql.Statement bytes params decode prepare
36+select query = case sqlForQuery query of
68− where
37+ Nothing -> const $ pure []
69− bytes = encodeUtf8 (Text.pack sql)
38+ Just sql -> Hasql.run session >=> either throwIO pure
70− params = Hasql.noParams
39+ where
71− decode = Hasql.rowList (parse @exprs @a)
40+ session = Hasql.statement () statement
72− prepare = False
41+ statement = Hasql.Statement bytes params decode prepare
73− sql = show doc
42+ bytes = encodeUtf8 (Text.pack sql)
74− doc = ppSelect query
43+ params = Hasql.noParams
75−
44+ decode = Hasql.rowList (parse @exprs @a)
76−
45+ prepare = False
77−ppSelect :: Table Expr a => Query a -> Doc
46+
78−ppSelect query =
47+
79− Opaleye.ppSql $ primSelectWith names (toCols exprs') primQuery'
48+selectWithNames :: forall exprs a names.
80− where
49+ ( Selects names exprs
81− names = namesFromLabels
50+ , Serializable exprs a
82− (exprs, primQuery, _) =
51+ )
83− Opaleye.runSimpleQueryArrStart (toOpaleye query) ()
52+ => names -> Query exprs -> Connection -> IO [a]
84− (exprs', primQuery') = case optimize primQuery of
53+selectWithNames names query = case sqlForQueryWithNames names query of
85− Empty -> (undefined, Opaleye.Product (pure (pure Opaleye.Unit)) never)
54+ Nothing -> const $ pure []
86− Unit -> (exprs, Opaleye.Unit)
55+ Just sql -> Hasql.run session >=> either throwIO pure
87− Optimized pq -> (exprs, pq)
56+ where
88− never = pure (toPrimExpr false)
57+ session = Hasql.statement () statement
89−
58+ statement = Hasql.Statement bytes params decode prepare
90−
59+ bytes = encodeUtf8 (Text.pack sql)
91−ppRows :: Table Expr a => Query a -> Doc
60+ params = Hasql.noParams
92−ppRows query = case optimize primQuery of
61+ decode = Hasql.rowList (parse @exprs @a)
93− -- Special case VALUES because we can't use DEFAULT inside a SELECT
62+ prepare = False
94− Optimized (Opaleye.Values symbols rows)
95− | eqSymbols symbols (toList (T.exprs a)) ->
96− Opaleye.ppValues_ (map Opaleye.sqlExpr <$> toList rows)
97− _ -> ppSelect query
98− where
99− (a, primQuery, _) = Opaleye.runSimpleQueryArrStart (toOpaleye query) ()
100−
101− eqSymbols (symbol : symbols) (Opaleye.AttrExpr symbol' : exprs)
102− | eqSymbol symbol symbol' = eqSymbols symbols exprs
103− | otherwise = False
104− eqSymbols [] [] = True
105− eqSymbols _ _ = False
106−
107− eqSymbol
108− (Opaleye.Symbol name (Opaleye.UnsafeTag tag))
109− (Opaleye.Symbol name' (Opaleye.UnsafeTag tag'))
110− = name == name' && tag == tag'
111−
112−
113−ppPrimSelect :: Query a -> (Optimized Doc, a)
114−ppPrimSelect query =
115− (Opaleye.ppSql . primSelect <$> optimize primQuery, a)
116− where
117− (a, primQuery, _) = Opaleye.runSimpleQueryArrStart (toOpaleye query) ()
118−
119−
120−type Optimized :: Type -> Type
121−data Optimized a = Empty | Unit | Optimized a
122− deriving stock (Functor, Foldable, Traversable, Show)
123−
124−
125−optimize :: Opaleye.PrimQuery' a -> Optimized (Opaleye.PrimQuery' Void)
126−optimize query = case Opaleye.removeEmpty (Opaleye.optimize query) of
127− Nothing -> Empty
128− Just Opaleye.Unit -> Unit
129− Just query' -> Optimized query'
130−
131−
132−primSelect :: Opaleye.PrimQuery' Void -> Opaleye.Select
133−primSelect = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator
134−
135−
136−primSelectWith :: Selects names exprs
137− => names -> exprs -> Opaleye.PrimQuery' Void -> Opaleye.Select
138−primSelectWith names exprs query =
139− Opaleye.SelectFrom $ Opaleye.newSelect
140− { Opaleye.attrs = Opaleye.SelectAttrs attrs
141− , Opaleye.tables = Opaleye.oneTable (primSelect query)
142− }
143− where
144− attrs = makeAttr <$> exprsWithNames names (castTable exprs)
145− where
146− makeAttr (label, expr) =
147− (Opaleye.sqlExpr expr, Just (Opaleye.SqlColumn label))
src/Rel8/Statement/Set.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+82−39
@@ -1,37 +1,44 @@
1−{-# language DuplicateRecordFields #-}
2{-# language GADTs #-}
1{-# language GADTs #-}
3{-# language NamedFieldPuns #-}
2{-# language NamedFieldPuns #-}
4−{-# language RecordWildCards #-}
3+{-# language ScopedTypeVariables #-}
5{-# language StandaloneKindSignatures #-}
4{-# language StandaloneKindSignatures #-}
6−{-# language StrictData #-}
5+{-# language TypeApplications #-}
7
6
8module Rel8.Statement.Update
7module Rel8.Statement.Update
9 ( Update(..)
8 ( Update(..)
10 , update
9 , update
11− , ppUpdate
12 )
10 )
13where
11where
14
12
15-- base
13-- base
14+import Control.Exception ( throwIO )
15+import Control.Monad ( (>=>) )
16import Data.Kind ( Type )
16import Data.Kind ( Type )
17import Prelude
17import Prelude
18
18
19-- hasql
19-- hasql
20+import Hasql.Connection ( Connection )
21+import qualified Hasql.Decoders as Hasql
20import qualified Hasql.Encoders as Hasql
22import qualified Hasql.Encoders as Hasql
23+import qualified Hasql.Session as Hasql
21import qualified Hasql.Statement as Hasql
24import qualified Hasql.Statement as Hasql
22
25
23−-- pretty
26+-- opaleye
24−import Text.PrettyPrint ( Doc, (<+>), ($$), text )
27+import qualified Opaleye.Internal.Manipulation as Opaleye
28+
29+-- profunctors
30+import Data.Profunctor ( lmap )
25
31
26-- rel8
32-- rel8
27import Rel8.Expr ( Expr )
33import Rel8.Expr ( Expr )
28−import Rel8.Query ( Query )
34+import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
29−import Rel8.Schema.Name ( Selects )
35+import Rel8.Schema.Table ( TableSchema )
30−import Rel8.Schema.Table ( TableSchema(..), ppTable )
36+import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) )
31−import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )
37+import Rel8.Table ( fromColumns, toColumns )
32−import Rel8.Statement.Set ( ppSet )
38+import Rel8.Table.Insert ( toInsert )
33−import Rel8.Statement.Using ( ppFrom )
39+import Rel8.Table.Opaleye ( table, unpackspec )
34−import Rel8.Statement.Where ( ppWhere )
40+import Rel8.Table.Recontextualize ( Selects )
41+import Rel8.Table.Serialize ( Serializable, parse )
35
42
36-- text
43-- text
37import qualified Data.Text as Text
44import qualified Data.Text as Text
@@ -44,12 +51,9 @@ data Update a where
44 Update :: Selects names exprs =>
51 Update :: Selects names exprs =>
45 { target :: TableSchema names
52 { target :: TableSchema names
46 -- ^ Which table to update.
53 -- ^ Which table to update.
47− , from :: Query from
54+ , set :: exprs -> exprs
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
51 -- ^ How to update each selected row.
55 -- ^ How to update each selected row.
52− , updateWhere :: from -> exprs -> Expr Bool
56+ , updateWhere :: exprs -> Expr Bool
53 -- ^ Which rows to select for update.
57 -- ^ Which rows to select for update.
54 , returning :: Returning names a
58 , returning :: Returning names a
55 -- ^ What to return from the @UPDATE@ statement.
59 -- ^ What to return from the @UPDATE@ statement.
@@ -57,27 +61,66 @@ data Update a where
57 -> Update a
61 -> Update a
58
62
59
63
60−ppUpdate :: Update a -> Doc
64+-- | Run an @UPDATE@ statement.
61−ppUpdate Update {..} = case ppFrom from of
65+--
62− Nothing ->
66+-- >>> mapM_ print =<< select c (each projectSchema)
63− text "UPDATE" <+> ppTable target $$
67+-- Project {projectAuthorId = 1, projectName = "rel8"}
64− ppSet target id $$
68+-- Project {projectAuthorId = 2, projectName = "aeson"}
65− text "WHERE false"
69+-- Project {projectAuthorId = 2, projectName = "text"}
66− Just (fromDoc, i) ->
70+--
67− text "UPDATE" <+> ppTable target $$
71+-- >>> :{
68− ppSet target (set i) $$
72+-- update c Update
69− fromDoc $$
73+-- { target = projectSchema
70− ppWhere target (updateWhere i) $$
74+-- , set = \p -> p { projectName = "Rel8!" }
71− ppReturning target returning
75+-- , updateWhere = \p -> projectName p ==. lit "rel8"
76+-- , returning = NumberOfRowsAffected
77+-- }
78+-- :}
79+-- 1
80+--
81+-- >>> mapM_ print =<< select c (each projectSchema)
82+-- Project {projectAuthorId = 2, projectName = "aeson"}
83+-- Project {projectAuthorId = 2, projectName = "text"}
84+-- Project {projectAuthorId = 1, projectName = "Rel8!"}
85+update :: Update a -> Connection -> IO a
86+update Update {target, set, updateWhere, returning} =
87+ case returning of
88+ NumberOfRowsAffected -> Hasql.run session >=> either throwIO pure
89+ where
90+ session = Hasql.statement () statement
91+ statement = Hasql.Statement bytes params decode prepare
92+ bytes = encodeUtf8 $ Text.pack sql
93+ params = Hasql.noParams
94+ decode = Hasql.rowsAffected
95+ prepare = False
96+ sql = Opaleye.arrangeUpdateSql target' set' where'
97+ where
98+ target' = lmap toInsert $ table $ toColumns <$> target
99+ set' = toColumns . set . fromColumns
100+ where' = toColumn . toPrimExpr . updateWhere . fromColumns
72
101
102+ Projection project -> Hasql.run session >=> either throwIO pure
103+ where
104+ session = Hasql.statement () statement
105+ statement = Hasql.Statement bytes params decode prepare
106+ bytes = encodeUtf8 $ Text.pack sql
107+ params = Hasql.noParams
108+ decode = decoder project
109+ prepare = False
110+ sql =
111+ Opaleye.arrangeUpdateReturningSql
112+ unpackspec
113+ target'
114+ set'
115+ where'
116+ project'
117+ where
118+ target' = lmap toInsert $ table $ toColumns <$> target
119+ set' = toColumns . set . fromColumns
120+ where' = toColumn . toPrimExpr . updateWhere . fromColumns
121+ project' = toColumns . project . fromColumns
73
122
74−-- | Run an @UPDATE@ statement.
75−update :: Update a -> Hasql.Statement () a
76−update u@Update {returning} = Hasql.Statement bytes params decode prepare
77 where
123 where
78− bytes = encodeUtf8 $ Text.pack sql
124+ decoder :: forall exprs projection a. Serializable projection a
79− params = Hasql.noParams
125+ => (exprs -> projection) -> Hasql.Result [a]
80− decode = decodeReturning returning
126+ decoder _ = Hasql.rowList (parse @projection @a)
81− prepare = False
82− sql = show doc
83− doc = ppUpdate u
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 @@
1{-# language FlexibleContexts #-}
1{-# language FlexibleContexts #-}
2−{-# language MonoLocalBinds #-}
3
2
4module Rel8.Statement.View
3module Rel8.Statement.View
5 ( createView
4 ( createView
6− , createOrReplaceView
7 )
5 )
8where
6where
9
7
10-- base
8-- base
9+import Control.Exception ( throwIO )
10+import Control.Monad ( (>=>) )
11+import Data.Foldable ( fold )
12+import Data.Maybe ( fromMaybe )
11import Prelude
13import Prelude
12
14
13-- hasql
15-- hasql
16+import Hasql.Connection ( Connection )
14import qualified Hasql.Decoders as Hasql
17import qualified Hasql.Decoders as Hasql
15import qualified Hasql.Encoders as Hasql
18import qualified Hasql.Encoders as Hasql
19+import qualified Hasql.Session as Hasql
16import qualified Hasql.Statement as Hasql
20import qualified Hasql.Statement as Hasql
17
21
18-- rel8
22-- rel8
19import Rel8.Query ( Query )
23import Rel8.Query ( Query )
20−import Rel8.Schema.Name ( Selects )
24+import Rel8.Query.SQL ( sqlForQueryWithNames )
21−import Rel8.Schema.Table ( TableSchema )
25+import Rel8.Schema.Table ( TableSchema( TableSchema ) )
22−import Rel8.Statement.Insert ( ppInto )
26+import Rel8.Table.Alternative ( emptyTable )
23−import Rel8.Statement.Select ( ppSelect )
27+import Rel8.Table.Recontextualize ( Selects )
24−
25−-- pretty
26−import Text.PrettyPrint ( Doc, (<+>), ($$), text )
27
28
28-- text
29-- text
29import qualified Data.Text as Text
30import qualified Data.Text as Text
30import Data.Text.Encoding ( encodeUtf8 )
31import Data.Text.Encoding ( encodeUtf8 )
31
32
32
33
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.
39createView :: Selects names exprs
34createView :: Selects names exprs
40− => TableSchema names -> Query exprs -> Hasql.Statement () ()
35+ => TableSchema names -> Query exprs -> Connection -> IO ()
41−createView =
36+createView (TableSchema name mschema names) query =
42− createViewGeneric Create
37+ Hasql.run session >=> either throwIO pure
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
60 where
38 where
39+ session = Hasql.statement () statement
40+ statement = Hasql.Statement bytes params decode prepare
61 bytes = encodeUtf8 (Text.pack sql)
41 bytes = encodeUtf8 (Text.pack sql)
62 params = Hasql.noParams
42 params = Hasql.noParams
63 decode = Hasql.noResult
43 decode = Hasql.noResult
64 prepare = False
44 prepare = False
65− sql = show doc
45+ sql = "CREATE VIEW " <> title <> " WITH " <> select
66− doc = ppCreateView schema query replace
46+ where
67−
47+ title = case mschema of
68−
48+ Nothing -> quote name
69−ppCreateView :: Selects names exprs
49+ Just schema -> quote schema <> "." <> quote name
70− => TableSchema names -> Query exprs -> CreateView -> Doc
50+ select = fromMaybe fallback $ sqlForQueryWithNames names query
71−ppCreateView schema query replace =
51+ where
72− createOrReplace replace <+>
52+ fallback = fold $ sqlForQueryWithNames names emptyTable
73− ppInto schema $$
53+
74− text "AS" <+>
54+
75− ppSelect query
55+quote :: String -> String
56+quote string = "\"" <> concatMap go string <> "\""
76 where
57 where
77− createOrReplace Create = text "CREATE VIEW"
58+ go '"' = "\"\""
78− createOrReplace CreateOrReplace = text "CREATE OR REPLACE VIEW"
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+160−159
@@ -1,220 +1,221 @@
1−{-# language AllowAmbiguousTypes #-}
2{-# language DataKinds #-}
1{-# language DataKinds #-}
3−{-# language DefaultSignatures #-}
2+{-# language DisambiguateRecordFields #-}
4{-# language FlexibleContexts #-}
3{-# language FlexibleContexts #-}
5{-# language FlexibleInstances #-}
4{-# language FlexibleInstances #-}
6{-# language FunctionalDependencies #-}
5{-# language FunctionalDependencies #-}
7−{-# language ScopedTypeVariables #-}
8{-# language StandaloneKindSignatures #-}
6{-# language StandaloneKindSignatures #-}
9−{-# language TypeApplications #-}
10{-# language TypeFamilies #-}
7{-# language TypeFamilies #-}
11{-# language UndecidableInstances #-}
8{-# language UndecidableInstances #-}
12
9
13module Rel8.Table
10module Rel8.Table
14− ( Table
11+ ( Table (Columns, Context)
15− ( Columns, Context, fromColumns, toColumns
12+ , toColumns, fromColumns
16− , FromExprs, fromResult, toResult
17− , Transpose
18− )
19 , Congruent
13 , Congruent
20− , TTable, TColumns, TContext, TFromExprs, TTranspose
21− , TSerialize
22 )
14 )
23where
15where
24
16
25-- base
17-- base
26import Data.Functor.Identity ( Identity( Identity ) )
18import Data.Functor.Identity ( Identity( Identity ) )
27import Data.Kind ( Constraint, Type )
19import Data.Kind ( Constraint, Type )
28−import GHC.Generics ( Generic, Rep, from, to )
20+import Prelude
29−import Prelude hiding ( null )
30
21
31-- rel8
22-- rel8
32−import Rel8.FCF ( Eval, Exp )
23+import Rel8.Aggregate ( Aggregate )
33−import Rel8.Generic.Map ( Map )
24+import Rel8.Expr ( Expr )
34−import Rel8.Generic.Table.Record
25+import Rel8.Opaque ( Opaque, Opaque1 )
35− ( GTable, GColumns, GContext, gfromColumns, gtoColumns
26+import Rel8.Schema.Context
36− , GSerialize, gfromResult, gtoResult
27+ ( Aggregation( Aggregation )
28+ , DB( DB ), unDB
29+ , Result( Result )
37 )
30 )
38−import Rel8.Generic.Record ( Record(..) )
31+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
39−import Rel8.Schema.HTable ( HTable )
32+import Rel8.Schema.HTable ( HTable, hfield, hspecs, htabulate, htabulateA )
40−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
33+import Rel8.Schema.HTable.Context ( H, HKTable )
41−import qualified Rel8.Schema.Kind as K
34+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
42−import Rel8.Schema.Null ( Sql )
35+import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
43−import Rel8.Schema.Result ( Result )
36+import Rel8.Schema.HTable.Pair ( HPair(..) )
37+import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
38+import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
39+import Rel8.Schema.HTable.Trio ( HTrio(..) )
40+import Rel8.Schema.HTable.Type ( HType( HType ) )
41+import Rel8.Schema.Nullability ( Nullabilizes )
42+import Rel8.Schema.Spec ( SSpec( SSpec ), KnownSpec )
43+import qualified Rel8.Schema.Spec as Kind ( Context )
44import Rel8.Type ( DBType )
44import Rel8.Type ( DBType )
45
45
46
46
47−-- | @Table@s are one of the foundational elements of Rel8, and describe data
47+type Table :: Kind.Context -> Type -> Constraint
48−-- types that have a finite number of columns. Each of these columns contains
48+class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where
49−-- data under a shared context, and contexts describe how to interpret the
49+ type Columns a :: HKTable
50−-- metadata about a column to a particular Haskell type. In Rel8, we have
50+ type Context a :: Kind.Context
51−-- contexts for expressions (the 'Rel8.Expr' context), aggregations (the
52−-- 'Rel8.Aggregate' context), insert values (the 'Rel8.Insert' contex), among
53−-- others.
54−--
55−-- 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'.
58−type 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
66− -- | The 'HTable' functor that describes the schema of this table.
67− type Columns a :: K.HTable
68−
69− -- | The common context that all columns use as an interpretation.
70− type Context a :: K.Context
71
51
72− -- | The @FromExprs@ type family maps a type in the @Expr@ context to the
52+ toColumns :: a -> Columns a (H (Context a))
73− -- corresponding Haskell type.
53+ fromColumns :: Columns a (H (Context a)) -> a
74− type FromExprs a :: Type
75
54
76− type Transpose (context' :: K.Context) a :: Type
77
55
56+-- | Any 'HTable' is also a 'Table'.
57+instance HTable t => Table context (t (H context)) where
58+ type Columns (t (H context)) = t
59+ type Context (t (H context)) = context
78
60
79− toColumns :: a -> Columns a context
61+ toColumns = id
80− fromColumns :: Columns a context -> a
62+ fromColumns = id
81
63
82− fromResult :: Columns a Result -> FromExprs a
83− toResult :: FromExprs a -> Columns a Result
84
64
85− type Columns a = GColumns TColumns (Rep (Record a))
65+-- | Any context is trivially a table.
86− type Context a = GContext TContext (Rep (Record a))
66+instance KnownSpec spec => Table context (context spec) where
87− type FromExprs a = Map TFromExprs a
67+ type Columns (context spec) = HIdentity spec
88− type Transpose context a = Map (TTranspose context) a
68+ type Context (context spec) = context
89−
90− default toColumns ::
91− ( Generic (Record a)
92− , GTable (TTable context) TColumns (Rep (Record a))
93− , Columns a ~ GColumns TColumns (Rep (Record a))
94− )
95− => a -> Columns a context
96− toColumns =
97− gtoColumns @(TTable context) @TColumns toColumns .
98− from .
99− Record
100−
101− default fromColumns ::
102− ( Generic (Record a)
103− , GTable (TTable context) TColumns (Rep (Record a))
104− , Columns a ~ GColumns TColumns (Rep (Record a))
105− )
106− => Columns a context -> a
107− fromColumns =
108− unrecord .
109− to .
110− gfromColumns @(TTable context) @TColumns fromColumns
111−
112− default toResult ::
113− ( Generic (Record (FromExprs a))
114− , GSerialize TSerialize TColumns (Rep (Record a)) (Rep (Record (FromExprs a)))
115− , Columns a ~ GColumns TColumns (Rep (Record a))
116− )
117− => FromExprs a -> Columns a Result
118− toResult =
119− gtoResult
120− @TSerialize
121− @TColumns
122− @(Rep (Record a))
123− @(Rep (Record (FromExprs a)))
124− (\(_ :: proxy x) -> toResult @(Context x) @x) .
125− from .
126− Record
127−
128− default fromResult ::
129− ( Generic (Record (FromExprs a))
130− , GSerialize TSerialize TColumns (Rep (Record a)) (Rep (Record (FromExprs a)))
131− , Columns a ~ GColumns TColumns (Rep (Record a))
132− )
133− => Columns a Result -> FromExprs a
134− fromResult =
135− unrecord .
136− to .
137− gfromResult
138− @TSerialize
139− @TColumns
140− @(Rep (Record a))
141− @(Rep (Record (FromExprs a)))
142− (\(_ :: proxy x) -> fromResult @(Context x) @x)
143−
144−
145−instance Sql DBType a => Table Result (Identity a) where
146− type Columns (Identity a) = HIdentity a
147− type Context (Identity a) = Result
148− type FromExprs (Identity a) = a
149− type Transpose to (Identity a) = to a
150
69
151 toColumns = HIdentity
70 toColumns = HIdentity
152− fromColumns (HIdentity a) = a
71+ fromColumns = unHIdentity
153− toResult a = HIdentity (Identity a)
154− fromResult (HIdentity (Identity a)) = a
155
72
156
73
157−data TTable :: K.Context -> Type -> Exp Constraint
74+instance Table DB a => Table Aggregation (Aggregate a) where
158−type instance Eval (TTable context a) = Table context a
75+ type Columns (Aggregate a) = Columns a
76+ type Context (Aggregate a) = Aggregation
159
77
78+ toColumns a = htabulate $ \field -> case hfield hspecs field of
79+ SSpec {} -> Aggregation $ unDB . (`hfield` field) . toColumns <$> a
80+ fromColumns as = fmap fromColumns $ htabulateA $ \field ->
81+ case hfield as field of
82+ Aggregation a -> DB <$> a
160
83
161−data TColumns :: Type -> Exp K.HTable
162−type instance Eval (TColumns a) = Columns a
163
84
85+instance (DBType db, Nullabilizes db a) => Table DB (Expr a) where
86+ type Columns (Expr a) = HType a
87+ type Context (Expr a) = DB
164
88
165−data TContext :: Type -> Exp K.Context
89+ toColumns a = HType (DB a)
166−type instance Eval (TContext a) = Context a
90+ fromColumns (HType (DB a)) = a
167
91
168
92
169−data TFromExprs :: Type -> Exp Type
93+instance (DBType db, Nullabilizes db a) => Table Result (Identity a) where
170−type instance Eval (TFromExprs a) = FromExprs a
94+ type Columns (Identity a) = HType a
171−
95+ type Context (Identity a) = Result
172−
173−data TTranspose :: K.Context -> Type -> Exp Type
174−type instance Eval (TTranspose context a) = Transpose context a
175−
176
96
177−data TSerialize :: Type -> Type -> Exp Constraint
97+ toColumns (Identity a) = HType (Result a)
178−type instance Eval (TSerialize expr a) =
98+ fromColumns (HType (Result a)) = Identity a
179− ( Table (Context expr) expr
180− , a ~ FromExprs expr
181− )
182
99
183
100
184−instance (Table context a, Table context b) => Table context (a, b)
101+instance
102+ ( Table context a, Table context b
103+ , Labelable context
104+ ) =>
105+ Table context (a, b)
106+ where
107+ type Columns (a, b) =
108+ HPair
109+ (HLabel "fst" (Columns a))
110+ (HLabel "snd" (Columns b))
111+ type Context (a, b) = Context a
112+
113+ toColumns (a, b) = HPair
114+ { hfst = hlabel labeler $ toColumns a
115+ , hsnd = hlabel labeler $ toColumns b
116+ }
117+ fromColumns (HPair a b) =
118+ ( fromColumns $ hunlabel unlabeler a
119+ , fromColumns $ hunlabel unlabeler b
120+ )
185
121
186
122
187instance
123instance
188 ( Table context a, Table context b, Table context c
124 ( Table context a, Table context b, Table context c
189− )
125+ , Labelable context
190− => Table context (a, b, c)
126+ ) => Table context (a, b, c)
127+ where
128+ type Columns (a, b, c) =
129+ HTrio
130+ (HLabel "fst" (Columns a))
131+ (HLabel "snd" (Columns b))
132+ (HLabel "trd" (Columns c))
133+ type Context (a, b, c) = Context a
134+
135+ toColumns (a, b, c) = HTrio
136+ { hfst = hlabel labeler $ toColumns a
137+ , hsnd = hlabel labeler $ toColumns b
138+ , htrd = hlabel labeler $ toColumns c
139+ }
140+ fromColumns (HTrio a b c) =
141+ ( fromColumns $ hunlabel unlabeler a
142+ , fromColumns $ hunlabel unlabeler b
143+ , fromColumns $ hunlabel unlabeler c
144+ )
191
145
192
146
193instance
147instance
194 ( Table context a, Table context b, Table context c, Table context d
148 ( Table context a, Table context b, Table context c, Table context d
195− )
149+ , Labelable context
196− => Table context (a, b, c, d)
150+ ) => Table context (a, b, c, d)
151+ where
152+ type Columns (a, b, c, d) =
153+ HQuartet
154+ (HLabel "fst" (Columns a))
155+ (HLabel "snd" (Columns b))
156+ (HLabel "trd" (Columns c))
157+ (HLabel "frt" (Columns d))
158+ type Context (a, b, c, d) = Context a
159+
160+ toColumns (a, b, c, d) = HQuartet
161+ { hfst = hlabel labeler $ toColumns a
162+ , hsnd = hlabel labeler $ toColumns b
163+ , htrd = hlabel labeler $ toColumns c
164+ , hfrt = hlabel labeler $ toColumns d
165+ }
166+ fromColumns (HQuartet a b c d) =
167+ ( fromColumns $ hunlabel unlabeler a
168+ , fromColumns $ hunlabel unlabeler b
169+ , fromColumns $ hunlabel unlabeler c
170+ , fromColumns $ hunlabel unlabeler d
171+ )
197
172
198
173
199instance
174instance
200 ( Table context a, Table context b, Table context c, Table context d
175 ( Table context a, Table context b, Table context c, Table context d
201 , Table context e
176 , Table context e
202− )
177+ , Labelable context
203− => Table context (a, b, c, d, e)
178+ ) => Table context (a, b, c, d, e)
179+ where
180+ type Columns (a, b, c, d, e) =
181+ HQuintet
182+ (HLabel "fst" (Columns a))
183+ (HLabel "snd" (Columns b))
184+ (HLabel "trd" (Columns c))
185+ (HLabel "frt" (Columns d))
186+ (HLabel "fft" (Columns e))
187+ type Context (a, b, c, d, e) = Context a
188+
189+ toColumns (a, b, c, d, e) = HQuintet
190+ { hfst = hlabel labeler $ toColumns a
191+ , hsnd = hlabel labeler $ toColumns b
192+ , htrd = hlabel labeler $ toColumns c
193+ , hfrt = hlabel labeler $ toColumns d
194+ , hfft = hlabel labeler $ toColumns e
195+ }
196+ fromColumns (HQuintet a b c d e) =
197+ ( fromColumns $ hunlabel unlabeler a
198+ , fromColumns $ hunlabel unlabeler b
199+ , fromColumns $ hunlabel unlabeler c
200+ , fromColumns $ hunlabel unlabeler d
201+ , fromColumns $ hunlabel unlabeler e
202+ )
204
203
205
204
206−instance
205+instance Table DB Opaque where
207− ( Table context a, Table context b, Table context c, Table context d
206+ type Columns Opaque = HType Opaque
208− , Table context e, Table context f
207+ type Context Opaque = DB
209− )
210− => Table context (a, b, c, d, e, f)
211
208
209+ fromColumns = error "opaque"
210+ toColumns = error "opaque"
212
211
213−instance
212+
214− ( Table context a, Table context b, Table context c, Table context d
213+instance Table context (Opaque1 context a) where
215− , Table context e, Table context f, Table context g
214+ type Columns (Opaque1 context a) = HType Opaque
216− )
215+ type Context (Opaque1 context a) = context
217− => Table context (a, b, c, d, e, f, g)
216+
217+ fromColumns = error "opaque"
218+ toColumns = error "opaque"
218
219
219
220
220type Congruent :: Type -> Type -> Constraint
221type 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+29−59
@@ -6,8 +6,10 @@
6{-# language ViewPatterns #-}
6{-# language ViewPatterns #-}
7
7
8module Rel8.Table.Aggregate
8module Rel8.Table.Aggregate
9− ( groupBy, hgroupBy
9+ ( groupBy
10− , listAgg, nonEmptyAgg
10+ , listAgg
11+ , nonEmptyAgg
12+ , runAggregation
11 )
13 )
12where
14where
13
15
@@ -16,77 +18,45 @@ import Data.Functor.Identity ( Identity( Identity ) )
16import Prelude
18import Prelude
17
19
18-- rel8
20-- rel8
19−import Rel8.Aggregate ( Aggregate, Aggregates )
21+import Rel8.Aggregate ( Aggregate )
20−import Rel8.Expr ( Expr )
22+import Rel8.Expr.Aggregate ( listAggExpr, nonEmptyAggExpr, sgroupByExpr )
21−import Rel8.Expr.Aggregate
23+import Rel8.Schema.Context ( Aggregation( Aggregation ), DB( DB ) )
22− ( groupByExpr
23− , slistAggExpr
24− , snonEmptyAggExpr
25− )
26import Rel8.Schema.Dict ( Dict( Dict ) )
24import Rel8.Schema.Dict ( Dict( Dict ) )
27−import Rel8.Schema.HTable ( HTable, hfield, htabulate )
25+import Rel8.Schema.HTable ( htabulate, hfield, hdicts, hspecs )
28import Rel8.Schema.HTable.Vectorize ( hvectorize )
26import Rel8.Schema.HTable.Vectorize ( hvectorize )
29−import Rel8.Schema.Null ( Sql )
27+import Rel8.Schema.Spec ( SSpec(..) )
30−import Rel8.Schema.Spec ( Spec( Spec, info ) )
28+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
31−import Rel8.Table ( toColumns, fromColumns )
29+import Rel8.Table ( Table, Columns, toColumns, fromColumns )
32−import Rel8.Table.Eq ( EqTable, eqTable )
30+import Rel8.Table.Eq ( EqTable )
33import Rel8.Table.List ( ListTable )
31import Rel8.Table.List ( ListTable )
34import Rel8.Table.NonEmpty ( NonEmptyTable )
32import Rel8.Table.NonEmpty ( NonEmptyTable )
33+import Rel8.Table.Recontextualize ( Aggregates )
35import Rel8.Type.Eq ( DBEq )
34import Rel8.Type.Eq ( DBEq )
36
35
37
36
38−-- | Group equal tables together. This works by aggregating each column in the
37+groupBy :: forall exprs. EqTable exprs => exprs -> Aggregate exprs
39−-- given table with 'groupByExpr'.
38+groupBy (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
40−--
39+ case hfield dicts field of
41−-- For example, if we have a table of items, we could group the items by the
40+ Dict -> case hfield hspecs field of
42−-- order they belong to:
41+ SSpec {nullability} -> case hfield exprs field of
43−--
42+ DB expr -> Aggregation $ sgroupByExpr nullability expr
44−-- @
43+ where
45−-- itemsByOrder :: Query (OrderId Expr, ListTable Expr (Item Expr))
44+ dicts = hdicts @(Columns exprs) @(ConstrainDBType DBEq)
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
62
45
63
46
64−-- | Aggregate rows into a single row containing an array of all aggregated
47+listAgg :: Table DB exprs => exprs -> Aggregate (ListTable exprs)
65−-- rows. This can be used to associate multiple rows with a single row, without
66−-- changing the over cardinality of the query. This allows you to essentially
67−-- return a tree-like structure from queries.
68−--
69−-- For example, if we have a table of orders and each orders contains multiple
70−-- items, we could aggregate the table of orders, pairing each order with its
71−-- items:
72−--
73−-- @
74−-- ordersWithItems :: Query (Order Expr, ListTable Expr (Item Expr))
75−-- ordersWithItems = do
76−-- order <- each orderSchema
77−-- items <- aggregate $ listAgg <$> itemsFromOrder order
78−-- return (order, items)
79−-- @
80−listAgg :: Aggregates aggregates exprs => exprs -> ListTable Aggregate aggregates
81listAgg (toColumns -> exprs) = fromColumns $
48listAgg (toColumns -> exprs) = fromColumns $
82 hvectorize
49 hvectorize
83− (\Spec {info} (Identity a) -> slistAggExpr info a)
50+ (\_ (Identity (DB a)) -> Aggregation $ listAggExpr a)
84 (pure exprs)
51 (pure exprs)
85
52
86
53
87−-- | Like 'listAgg', but the result is guaranteed to be a non-empty list.
54+nonEmptyAgg :: Table DB exprs => exprs -> Aggregate (NonEmptyTable exprs)
88−nonEmptyAgg :: Aggregates aggregates exprs => exprs -> NonEmptyTable Aggregate aggregates
89nonEmptyAgg (toColumns -> exprs) = fromColumns $
55nonEmptyAgg (toColumns -> exprs) = fromColumns $
90 hvectorize
56 hvectorize
91− (\Spec {info} (Identity a) -> snonEmptyAggExpr info a)
57+ (\_ (Identity (DB a)) -> Aggregation $ nonEmptyAggExpr a)
92 (pure exprs)
58 (pure exprs)
59+
60+
61+runAggregation :: Aggregates aggregates exprs => aggregates -> Aggregate exprs
62+runAggregation = fromColumns . toColumns
src/Rel8/Table/Alternative.hs+3−12
@@ -13,25 +13,16 @@ import Data.Kind ( Constraint, Type )
13import Prelude ()
13import Prelude ()
14
14
15-- rel8
15-- rel8
16−import Rel8.Expr ( Expr )
16+import Rel8.Schema.Context ( DB )
17import Rel8.Table ( Table )
17import Rel8.Table ( Table )
18
18
19
19
20−-- | Like 'Alt' in Haskell. This class is purely a Rel8 concept, and allows you
21−-- to take a choice between two tables. See also 'AlternativeTable'.
22−--
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.
25type AltTable :: (Type -> Type) -> Constraint
20type AltTable :: (Type -> Type) -> Constraint
26class AltTable f where
21class AltTable f where
27− -- | An associative binary operation on 'Table's.
22+ (<|>:) :: Table DB a => f a -> f a -> f a
28− (<|>:) :: Table Expr a => f a -> f a -> f a
29 infixl 3 <|>:
23 infixl 3 <|>:
30
24
31
25
32−-- | Like 'Alternative' in Haskell, some 'Table's form a monoid on applicative
33−-- functors.
34type AlternativeTable :: (Type -> Type) -> Constraint
26type AlternativeTable :: (Type -> Type) -> Constraint
35class AltTable f => AlternativeTable f where
27class AltTable f => AlternativeTable f where
36− -- | The identity of '<|>:'.
28+ emptyTable :: Table DB a => f a
37− emptyTable :: Table Expr a => f a
src/Rel8/Table/Bool.hs+8−21
@@ -5,7 +5,6 @@
5module Rel8.Table.Bool
5module Rel8.Table.Bool
6 ( bool
6 ( bool
7 , case_
7 , case_
8− , nullable
9 )
8 )
10where
9where
11
10
@@ -15,34 +14,22 @@ import Prelude
15-- rel8
14-- rel8
16import Rel8.Expr ( Expr )
15import Rel8.Expr ( Expr )
17import Rel8.Expr.Bool ( boolExpr, caseExpr )
16import Rel8.Expr.Bool ( boolExpr, caseExpr )
18−import Rel8.Expr.Null ( isNull, unsafeUnnullify )
17+import Rel8.Schema.Context ( DB( DB ), unDB )
19import Rel8.Schema.HTable ( htabulate, hfield )
18import Rel8.Schema.HTable ( htabulate, hfield )
20import Rel8.Table ( Table, fromColumns, toColumns )
19import Rel8.Table ( Table, fromColumns, toColumns )
21
20
22
21
23−-- | An if-then-else expression on tables.
22+bool :: Table DB a => a -> a -> Expr Bool -> a
24−--
25−-- @bool x y p@ returns @x@ if @p@ is @False@, and returns @y@ if @p@ is
26−-- @True@.
27−bool :: Table Expr a => a -> a -> Expr Bool -> a
28bool (toColumns -> false) (toColumns -> true) condition =
23bool (toColumns -> false) (toColumns -> true) condition =
29 fromColumns $ htabulate $ \field ->
24 fromColumns $ htabulate $ \field ->
30 case (hfield false field, hfield true field) of
25 case (hfield false field, hfield true field) of
31− (falseExpr, trueExpr) -> boolExpr falseExpr trueExpr condition
26+ (DB falseExpr, DB trueExpr) ->
32−{-# INLINABLE bool #-}
27+ DB (boolExpr falseExpr trueExpr condition)
33
28
34
29
35−-- | Produce a table expression from a list of alternatives. Returns the first
30+case_ :: Table DB a => [(Expr Bool, a)] -> a -> a
36−-- table where the @Expr Bool@ expression is @True@. If no alternatives are
37−-- true, the given default is returned.
38−case_ :: Table Expr a => [(Expr Bool, a)] -> a -> a
39case_ (map (fmap toColumns) -> branches) (toColumns -> fallback) =
31case_ (map (fmap toColumns) -> branches) (toColumns -> fallback) =
40 fromColumns $ htabulate $ \field -> case hfield fallback field of
32 fromColumns $ htabulate $ \field -> case hfield fallback field of
41− fallbackExpr ->
33+ DB fallbackExpr ->
42− case map (fmap (`hfield` field)) branches of
34+ case map (fmap (unDB . (`hfield` field))) branches of
43− branchExprs -> caseExpr branchExprs fallbackExpr
35+ branchExprs -> DB (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)
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+92−161
@@ -3,59 +3,46 @@
3{-# language DerivingStrategies #-}
3{-# language DerivingStrategies #-}
4{-# language FlexibleContexts #-}
4{-# language FlexibleContexts #-}
5{-# language FlexibleInstances #-}
5{-# language FlexibleInstances #-}
6−{-# language LambdaCase #-}
7{-# language MultiParamTypeClasses #-}
6{-# language MultiParamTypeClasses #-}
8{-# language NamedFieldPuns #-}
7{-# language NamedFieldPuns #-}
9−{-# language ScopedTypeVariables #-}
10{-# language StandaloneKindSignatures #-}
8{-# language StandaloneKindSignatures #-}
11−{-# language TypeApplications #-}
12{-# language TypeFamilies #-}
9{-# language TypeFamilies #-}
13{-# language UndecidableInstances #-}
10{-# language UndecidableInstances #-}
14
11
15−{-# options_ghc -fno-warn-orphans #-}
16−
17module Rel8.Table.Either
12module Rel8.Table.Either
18 ( EitherTable(..)
13 ( EitherTable(..)
19 , eitherTable, leftTable, rightTable
14 , eitherTable, leftTable, rightTable
20 , isLeftTable, isRightTable
15 , isLeftTable, isRightTable
21− , aggregateEitherTable
22− , nameEitherTable
23 )
16 )
24where
17where
25
18
26-- base
19-- base
27import Data.Bifunctor ( Bifunctor, bimap )
20import Data.Bifunctor ( Bifunctor, bimap )
28−import Data.Functor.Identity ( Identity( Identity ) )
21+import Data.Functor.Identity ( runIdentity )
29import Data.Kind ( Type )
22import Data.Kind ( Type )
30import Prelude hiding ( undefined )
23import Prelude hiding ( undefined )
31
24
32−-- comonad
33−import Control.Comonad ( extract )
34−
35-- rel8
25-- rel8
36−import Rel8.Aggregate ( Aggregate )
37import Rel8.Expr ( Expr )
26import Rel8.Expr ( Expr )
38−import Rel8.Expr.Aggregate ( groupByExpr )
39import Rel8.Expr.Serialize ( litExpr )
27import Rel8.Expr.Serialize ( litExpr )
40−import Rel8.Kind.Context ( Reifiable )
28+import Rel8.Schema.Context ( DB )
41−import Rel8.Schema.Context.Nullify ( Nullifiable )
29+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
42−import Rel8.Schema.Dict ( Dict( Dict ) )
30+import Rel8.Schema.Context.Nullify
31+ ( Nullifiable, NullifiableEq
32+ , encodeTag, decodeTag
33+ , nullifier, unnullifier
34+ )
43import Rel8.Schema.HTable.Either ( HEitherTable(..) )
35import Rel8.Schema.HTable.Either ( HEitherTable(..) )
44import Rel8.Schema.HTable.Identity ( HIdentity(..) )
36import Rel8.Schema.HTable.Identity ( HIdentity(..) )
45−import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
37+import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
46−import qualified Rel8.Schema.Kind as K
38+import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
47−import Rel8.Schema.Name ( Name )
39+import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
48−import Rel8.Table
49− ( Table, Columns, Context, fromColumns, toColumns
50− , FromExprs, fromResult, toResult
51− , Transpose
52− )
53import Rel8.Table.Bool ( bool )
40import Rel8.Table.Bool ( bool )
54−import Rel8.Table.Eq ( EqTable, eqTable )
41+import Rel8.Table.Lifted
55−import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )
42+ ( Table1, Columns1, ConstrainContext1, fromColumns1, toColumns1
56−import Rel8.Table.Ord ( OrdTable, ordTable )
43+ , Table2, Columns2, ConstrainContext2, fromColumns2, toColumns2
57−import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )
44+ )
58−import Rel8.Table.Serialize ( ToExprs )
45+import Rel8.Table.Recontextualize ( Recontextualize )
59import Rel8.Table.Undefined ( undefined )
46import Rel8.Table.Undefined ( undefined )
60import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
47import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
61
48
@@ -64,180 +51,124 @@ import Data.Functor.Apply ( Apply, (<.>) )
64import Data.Functor.Bind ( Bind, (>>-) )
51import Data.Functor.Bind ( Bind, (>>-) )
65
52
66
53
67−-- | An @EitherTable a b@ is a Rel8 table that contains either the table @a@ or
54+type EitherTable :: Type -> Type -> Type
68−-- the table @b@. You can construct an @EitherTable@ using 'leftTable' and
55+data EitherTable a b = EitherTable
69−-- 'rightTable', and eliminate/pattern match using 'eitherTable'.
56+ { tag :: Expr EitherTag
70−--
57+ , left :: a
71−-- An @EitherTable@ is operationally the same as Haskell's 'Either' type, but
58+ , right :: b
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
78 }
59 }
79− deriving stock Functor
60+ deriving stock (Show, 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
61
87−instance Nullifiable context => Bifunctor (EitherTable context) where
88− bimap f g (EitherTable tag a b) = EitherTable tag (fmap f a) (fmap g b)
89
62
63+instance Bifunctor EitherTable where
64+ bimap f g (EitherTable tag a b) = EitherTable tag (f a) (g b)
90
65
91−instance Projectable (EitherTable context a) where
92− project f (EitherTable tag a b) = EitherTable tag a (project f b)
93
66
94−
67+instance Table DB a => Apply (EitherTable a) where
95−instance (context ~ Expr, Table Expr a) => Apply (EitherTable context a) where
96 EitherTable tag l1 f <.> EitherTable tag' l2 a =
68 EitherTable tag l1 f <.> EitherTable tag' l2 a =
97− EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f <.> a)
69+ EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f a)
98
70
99
71
100−instance (context ~ Expr, Table Expr a) => Applicative (EitherTable context a) where
72+instance Table DB a => Applicative (EitherTable a) where
101 pure = rightTable
73 pure = rightTable
102 (<*>) = (<.>)
74 (<*>) = (<.>)
103
75
104
76
105−instance (context ~ Expr, Table Expr a) => Bind (EitherTable context a) where
77+instance Table DB a => Bind (EitherTable a) where
106− EitherTable tag l1 a >>- f = case f (extract a) of
78+ EitherTable tag l1 a >>- f = case f a of
107 EitherTable tag' l2 b ->
79 EitherTable tag' l2 b ->
108 EitherTable (tag <> tag') (bool l1 l2 (isRight tag)) b
80 EitherTable (tag <> tag') (bool l1 l2 (isRight tag)) b
109
81
110
82
111−instance (context ~ Expr, Table Expr a) => Monad (EitherTable context a) where
83+instance Table DB a => Monad (EitherTable a) where
112 (>>=) = (>>-)
84 (>>=) = (>>-)
113
85
114
86
115−instance (context ~ Expr, Table Expr a, Table Expr b) =>
87+instance (Table DB a, Table DB b) => Semigroup (EitherTable a b) where
116− Semigroup (EitherTable context a b)
117− where
118 a <> b = bool a b (isRightTable a)
88 a <> b = bool a b (isRightTable a)
119
89
120
90
121−instance
91+instance Table2 EitherTable where
122− ( Table context a, Table context b
92+ type Columns2 EitherTable = HEitherTable
123− , Reifiable context, context ~ context'
93+ type ConstrainContext2 EitherTable = Nullifiable
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− }
138
94
139− fromColumns HEitherTable {htag, hleft, hright} = EitherTable
95+ toColumns2 f g EitherTable {tag, left, right} = HEitherTable
140− { tag = unHIdentity $ hunlabel htag
96+ { htag
141− , left = fromColumns $ hunlabel hleft
97+ , hleft = hnullify (nullifier (isLeft tag)) $ f left
142− , right = fromColumns $ hunlabel hright
98+ , hright = hnullify (nullifier (isRight tag)) $ g right
143 }
99 }
144−
100+ where
145− toResult = \case
101+ htag = HIdentity (encodeTag tag)
146− Left table -> HEitherTable
102+
147− { htag = hlabel (HIdentity (Identity IsLeft))
103+ fromColumns2 f g HEitherTable {htag = htag, hleft, hright} =
148− , hleft = hlabel (toResult @_ @(Nullify context a) (Just table))
104+ EitherTable
149− , hright = hlabel (toResult @_ @(Nullify context b) Nothing)
105+ { tag
150− }
106+ , left = f $ runIdentity $
151− Right table -> HEitherTable
107+ hunnullify (\a -> pure . unnullifier (isLeft tag) a) hleft
152− { htag = hlabel (HIdentity (Identity IsRight))
108+ , right = g $ runIdentity $
153− , hleft = hlabel (toResult @_ @(Nullify context a) Nothing)
109+ hunnullify (\a -> pure . unnullifier (isRight tag) a) hright
154− , hright = hlabel (toResult @_ @(Nullify context b) (Just table))
155 }
110 }
156−
157− fromResult HEitherTable {htag, hleft, hright} = case hunlabel htag of
158− HIdentity (Identity tag) -> case tag of
159− IsLeft -> maybe err Left $ fromResult @_ @(Nullify context a) (hunlabel hleft)
160− IsRight -> maybe err Right $ fromResult @_ @(Nullify context b) (hunlabel hright)
161 where
111 where
162− err = error "Either.fromColumns: mismatch between tag and data"
112+ tag = decodeTag $ unHIdentity htag
163−
164
113
165−instance (EqTable a, EqTable b, context ~ Expr) =>
114+ {-# INLINABLE fromColumns2 #-}
166− EqTable (EitherTable context a b)
115+ {-# INLINABLE toColumns2 #-}
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− }
173
116
174
117
175−instance (OrdTable a, OrdTable b, context ~ Expr) =>
118+instance Table context a => Table1 (EitherTable a) where
176− OrdTable (EitherTable context a b)
119+ type Columns1 (EitherTable a) = HEitherTable (Columns a)
177− where
120+ type ConstrainContext1 (EitherTable a) = NullifiableEq (Context a)
178− ordTable = HEitherTable
179− { htag = hlabel (HIdentity Dict)
180− , hleft = hlabel (ordTable @(Nullify context a))
181− , hright = hlabel (ordTable @(Nullify context b))
182− }
183
121
122+ toColumns1 = toColumns2 toColumns
123+ fromColumns1 = fromColumns2 fromColumns
184
124
185−instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable Expr exprs1 exprs2) =>
186− ToExprs x (Either a b)
187
125
126+instance
127+ ( Table context a, Table context b
128+ , Labelable context, Nullifiable context
129+ ) =>
130+ Table context (EitherTable a b)
131+ where
132+ type Columns (EitherTable a b) =
133+ HEitherTable (HLabel "Left" (Columns a)) (HLabel "Right" (Columns b))
134+ type Context (EitherTable a b) = Context a
188
135
189−-- | Test if an 'EitherTable' is a 'leftTable'.
136+ toColumns =
190−isLeftTable :: EitherTable Expr a b -> Expr Bool
137+ toColumns2
191−isLeftTable EitherTable {tag} = isLeft tag
138+ (hlabel labeler . toColumns)
139+ (hlabel labeler . toColumns)
140+ fromColumns =
141+ fromColumns2
142+ (fromColumns . hunlabel unlabeler)
143+ (fromColumns . hunlabel unlabeler)
192
144
193
145
194−-- | Test if an 'EitherTable' is a 'rightTable'.
146+instance
195−isRightTable :: EitherTable Expr a b -> Expr Bool
147+ ( Nullifiable from, Labelable from
196−isRightTable EitherTable {tag} = isRight tag
148+ , Nullifiable to, Labelable to
149+ , Recontextualize from to a1 b1
150+ , Recontextualize from to a2 b2
151+ ) =>
152+ Recontextualize from to (EitherTable a1 a2) (EitherTable b1 b2)
197
153
198
154
199−-- | Pattern match/eliminate an 'EitherTable', by providing mappings from a
155+isLeftTable :: EitherTable a b -> Expr Bool
200−-- 'leftTable' and 'rightTable'.
156+isLeftTable = isLeft . tag
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)
205
157
206
158
207−-- | Construct a left 'EitherTable'. Like 'Left'.
159+isRightTable :: EitherTable a b -> Expr Bool
208−leftTable :: Table Expr b => a -> EitherTable Expr a b
160+isRightTable = isRight . tag
209−leftTable a = EitherTable (litExpr IsLeft) (pure a) undefined
210
161
211
162
212−-- | Construct a right 'EitherTable'. Like 'Right'.
163+eitherTable :: Table DB c
213−rightTable :: Table Expr a => b -> EitherTable Expr a b
164+ => (a -> c) -> (b -> c) -> EitherTable a b -> c
214−rightTable = EitherTable (litExpr IsRight) undefined . pure
165+eitherTable f g EitherTable {tag, left, right} =
166+ bool (f left) (g right) (isRight tag)
215
167
216
168
217−-- | Lift a pair of aggregating functions to operate on an 'EitherTable'.
169+leftTable :: Table DB b => a -> EitherTable a b
218−-- @leftTable@s and @rightTable@s are grouped separately.
170+leftTable a = EitherTable (litExpr IsLeft) a undefined
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− }
229
171
230
172
231−-- | Construct a 'EitherTable' in the 'Name' context. This can be useful if you
173+rightTable :: Table DB a => b -> EitherTable a b
232−-- have a 'EitherTable' that you are storing in a table and need to construct a
174+rightTable = EitherTable (litExpr IsRight) undefined
233−-- 'TableSchema'.
234−nameEitherTable
235− :: Name EitherTag
236− -- ^ The name of the column to track whether a row is a 'leftTable' or
237− -- 'rightTable'.
238− -> a
239− -- ^ Names of the columns in the @a@ table.
240− -> b
241− -- ^ Names of the columns in the @b@ table.
242− -> EitherTable Name a b
243−nameEitherTable tag left right = EitherTable tag (pure left) (pure right)
src/Rel8/Table/Eq.hs+35−71
@@ -1,20 +1,17 @@
1−{-# language AllowAmbiguousTypes #-}
2−{-# language BlockArguments #-}
3{-# language DataKinds #-}
1{-# language DataKinds #-}
4−{-# language DefaultSignatures #-}
5−{-# language DisambiguateRecordFields #-}
6{-# language FlexibleContexts #-}
2{-# language FlexibleContexts #-}
7{-# language FlexibleInstances #-}
3{-# language FlexibleInstances #-}
4+{-# language NamedFieldPuns #-}
8{-# language ScopedTypeVariables #-}
5{-# language ScopedTypeVariables #-}
9{-# language StandaloneKindSignatures #-}
6{-# language StandaloneKindSignatures #-}
10{-# language TypeApplications #-}
7{-# language TypeApplications #-}
11{-# language TypeFamilies #-}
8{-# language TypeFamilies #-}
12−{-# language TypeOperators #-}
13{-# language UndecidableInstances #-}
9{-# language UndecidableInstances #-}
10+{-# language UndecidableSuperClasses #-}
14{-# language ViewPatterns #-}
11{-# language ViewPatterns #-}
15
12
16module Rel8.Table.Eq
13module Rel8.Table.Eq
17− ( EqTable( eqTable ), (==:), (/=:)
14+ ( EqTable, (==:), (/=:)
18 )
15 )
19where
16where
20
17
@@ -23,94 +20,61 @@ import Data.Foldable ( foldl' )
23import Data.Functor.Const ( Const( Const ), getConst )
20import Data.Functor.Const ( Const( Const ), getConst )
24import Data.Kind ( Constraint, Type )
21import Data.Kind ( Constraint, Type )
25import Data.List.NonEmpty ( NonEmpty( (:|) ) )
22import Data.List.NonEmpty ( NonEmpty( (:|) ) )
26−import GHC.Generics ( Rep )
23+import Prelude hiding ( seq )
27−import Prelude
28
24
29-- rel8
25-- rel8
30import Rel8.Expr ( Expr )
26import Rel8.Expr ( Expr )
31import Rel8.Expr.Bool ( (||.), (&&.) )
27import Rel8.Expr.Bool ( (||.), (&&.) )
32−import Rel8.Expr.Eq ( (==.), (/=.) )
28+import Rel8.Expr.Eq ( seq, sne )
33−import Rel8.FCF ( Eval, Exp )
29+import Rel8.Opaque ( Opaque )
34−import Rel8.Generic.Record ( Record )
30+import Rel8.Schema.Context ( DB( DB ) )
35−import Rel8.Generic.Table.Record ( GTable, GColumns, gtable )
36import Rel8.Schema.Dict ( Dict( Dict ) )
31import Rel8.Schema.Dict ( Dict( Dict ) )
37−import Rel8.Schema.HTable ( htabulateA, hfield )
32+import Rel8.Schema.HTable
38−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
33+ ( HConstrainTable
39−import Rel8.Schema.Null ( Sql )
34+ , htabulateA, hfield
40−import Rel8.Table ( Table, Columns, toColumns, TColumns )
35+ , hdicts, hspecs
36+ )
37+import Rel8.Schema.Spec ( SSpec(..) )
38+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
39+import Rel8.Table ( Table, Columns, toColumns )
41import Rel8.Type.Eq ( DBEq )
40import Rel8.Type.Eq ( DBEq )
42
41
43
42
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'".
47type EqTable :: Type -> Constraint
43type EqTable :: Type -> Constraint
48−class Table Expr a => EqTable a where
44+class
49− eqTable :: Columns a (Dict (Sql DBEq))
45+ ( Table DB a
50−
46+ , HConstrainTable (Columns a) (ConstrainDBType DBEq)
51− default eqTable ::
47+ ) => EqTable a
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−
86instance
48instance
87− ( EqTable a, EqTable b, EqTable c, EqTable d, EqTable e, EqTable f
49+ ( Table DB a
88− , EqTable g
50+ , HConstrainTable (Columns a) (ConstrainDBType DBEq)
89− )
51+ ) => EqTable a
90− => EqTable (a, b, c, d, e, f, g)
52+instance {-# OVERLAPPING #-} EqTable Opaque
91
53
92
54
93−-- | Compare two 'Table's for equality. This corresponds to comparing all
94−-- columns inside each table for equality, and combining all comparisons with
95−-- @AND@.
96(==:) :: forall a. EqTable a => a -> a -> Expr Bool
55(==:) :: forall a. EqTable a => a -> a -> Expr Bool
97(toColumns -> as) ==: (toColumns -> bs) =
56(toColumns -> as) ==: (toColumns -> bs) =
98 foldl1' (&&.) $ getConst $ htabulateA $ \field ->
57 foldl1' (&&.) $ getConst $ htabulateA $ \field ->
99 case (hfield as field, hfield bs field) of
58 case (hfield as field, hfield bs field) of
100− (a, b) -> case hfield (eqTable @a) field of
59+ (DB a, DB b) -> case hfield dicts field of
101− Dict -> Const (pure (a ==. b))
60+ Dict -> case hfield specs field of
61+ SSpec {nullability} -> Const (pure (seq nullability a b))
62+ where
63+ dicts = hdicts @(Columns a) @(ConstrainDBType DBEq)
64+ specs = hspecs @(Columns a)
102infix 4 ==:
65infix 4 ==:
103
66
104
67
105−-- | Test if two 'Table's are different. This corresponds to comparing all
106−-- columns inside each table for inequality, and combining all comparisons with
107−-- @OR@.
108(/=:) :: forall a. EqTable a => a -> a -> Expr Bool
68(/=:) :: forall a. EqTable a => a -> a -> Expr Bool
109(toColumns -> as) /=: (toColumns -> bs) =
69(toColumns -> as) /=: (toColumns -> bs) =
110 foldl1' (||.) $ getConst $ htabulateA $ \field ->
70 foldl1' (||.) $ getConst $ htabulateA $ \field ->
111 case (hfield as field, hfield bs field) of
71 case (hfield as field, hfield bs field) of
112− (a, b) -> case hfield (eqTable @a) field of
72+ (DB a, DB b) -> case hfield dicts field of
113− Dict -> Const (pure (a /=. b))
73+ Dict -> case hfield specs field of
74+ SSpec {nullability} -> Const (pure (sne nullability a b))
75+ where
76+ dicts = hdicts @(Columns a) @(ConstrainDBType DBEq)
77+ specs = hspecs @(Columns a)
114infix 4 /=:
78infix 4 /=:
115
79
116
80
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+39
@@ -0,0 +1,39 @@
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 ( DB(..), Insertion(..) )
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 :: Inserts exprs inserts => exprs -> inserts
25+toInsert (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
26+ case hfield hspecs field of
27+ SSpec {necessity} -> case hfield exprs field of
28+ DB expr -> case necessity of
29+ SRequired -> RequiredInsert expr
30+ SOptional -> OptionalInsert (Just expr)
31+
32+
33+toInsertDefaults :: Inserts exprs inserts => exprs -> inserts
34+toInsertDefaults (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
35+ case hfield hspecs field of
36+ SSpec {necessity} -> case hfield exprs field of
37+ DB expr -> case necessity of
38+ SRequired -> RequiredInsert expr
39+ SOptional -> OptionalInsert Nothing
src/Rel8/Table/Lifted.hsnew file+62
@@ -0,0 +1,62 @@
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.HTable ( HTable )
20+import Rel8.Schema.HTable.Context ( H, HKTable )
21+import Rel8.Schema.Spec ( Context )
22+
23+
24+type Table1 :: (Type -> Type) -> Constraint
25+class Table1 f where
26+ type Columns1 f :: HKTable -> HKTable
27+ type ConstrainContext1 f :: Context -> Constraint
28+ type ConstrainContext1 _ = DefaultConstrainContext
29+
30+ toColumns1 :: (ConstrainContext1 f context, HTable t)
31+ => (a -> t (H context))
32+ -> f a
33+ -> Columns1 f t (H context)
34+
35+ fromColumns1 :: (ConstrainContext1 f context, HTable t)
36+ => (t (H context) -> a)
37+ -> Columns1 f t (H context)
38+ -> f a
39+
40+
41+type Table2 :: (Type -> Type -> Type) -> Constraint
42+class Table2 p where
43+ type Columns2 p :: HKTable -> HKTable -> HKTable
44+ type ConstrainContext2 p :: Context -> Constraint
45+ type ConstrainContext2 _ = DefaultConstrainContext
46+
47+ toColumns2 :: (ConstrainContext2 p context, HTable t, HTable u)
48+ => (a -> t (H context))
49+ -> (b -> u (H context))
50+ -> p a b
51+ -> Columns2 p t u (H context)
52+
53+ fromColumns2 :: (ConstrainContext2 p context, HTable t, HTable u)
54+ => (t (H context) -> a)
55+ -> (u (H context) -> b)
56+ -> Columns2 p t u (H context)
57+ -> p a b
58+
59+
60+type DefaultConstrainContext :: Context -> Constraint
61+class DefaultConstrainContext context
62+instance DefaultConstrainContext context
src/Rel8/Table/List.hs+21−108
@@ -1,149 +1,62 @@
1−{-# language DataKinds #-}
2{-# language FlexibleContexts #-}
1{-# language FlexibleContexts #-}
3{-# language FlexibleInstances #-}
2{-# language FlexibleInstances #-}
4{-# language MultiParamTypeClasses #-}
3{-# language MultiParamTypeClasses #-}
5−{-# language NamedFieldPuns #-}
6−{-# language ScopedTypeVariables #-}
7{-# language StandaloneKindSignatures #-}
4{-# language StandaloneKindSignatures #-}
8−{-# language TypeApplications #-}
9{-# language TypeFamilies #-}
5{-# language TypeFamilies #-}
10{-# language UndecidableInstances #-}
6{-# language UndecidableInstances #-}
11
7
12module Rel8.Table.List
8module Rel8.Table.List
13 ( ListTable(..)
9 ( ListTable(..)
14− , ($*)
15− , listTable
16− , nameListTable
17 )
10 )
18where
11where
19
12
20-- base
13-- base
21−import Data.Functor.Identity ( Identity( Identity ) )
22import Data.Kind ( Type )
14import Data.Kind ( Type )
23import Prelude
15import Prelude
24
16
25-- rel8
17-- rel8
26−import Rel8.Expr ( Expr )
18+import Rel8.Expr.Array ( sappend, sempty )
27−import Rel8.Expr.Array ( sappend, sempty, slistOf )
19+import Rel8.Schema.Context ( DB( DB ) )
28−import Rel8.Schema.Dict ( Dict( Dict ) )
20+import Rel8.Schema.HTable.Context ( H )
29import Rel8.Schema.HTable.List ( HListTable )
21import Rel8.Schema.HTable.List ( HListTable )
30−import Rel8.Schema.HTable.Vectorize
22+import Rel8.Schema.HTable.Vectorize ( happend, hempty )
31− ( hvectorize, hunvectorize
23+import Rel8.Table ( Table, Context, Columns, fromColumns, toColumns )
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− )
45import Rel8.Table.Alternative
24import Rel8.Table.Alternative
46 ( AltTable, (<|>:)
25 ( AltTable, (<|>:)
47 , AlternativeTable, emptyTable
26 , AlternativeTable, emptyTable
48 )
27 )
49−import Rel8.Table.Eq ( EqTable, eqTable )
28+import Rel8.Table.Recontextualize ( Recontextualize )
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 )
55−
56
29
57−-- | 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
30
31+type ListTable :: Type -> Type
32+newtype ListTable a = ListTable (HListTable (Columns a) (H (Context a)))
63
33
64−instance Projectable (ListTable context) where
65− project f (ListTable a) = ListTable (hproject (apply f) a)
66
34
67−
35+instance Table context a => Table context (ListTable a) where
68−instance (Table context a, context ~ context') =>
36+ type Columns (ListTable a) = HListTable (Columns a)
69− Table context' (ListTable context a)
37+ type Context (ListTable a) = 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)
75
38
76 fromColumns = ListTable
39 fromColumns = ListTable
77 toColumns (ListTable a) = a
40 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−
90
41
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))
98
42
43+instance Recontextualize from to a b =>
44+ Recontextualize from to (ListTable a) (ListTable b)
99
45
100−instance (ToExprs exprs a, context ~ Expr) =>
101− ToExprs (ListTable context exprs) [a]
102
46
103−
47+instance AltTable ListTable where
104−instance context ~ Expr => AltTable (ListTable context) where
105 (<|>:) = (<>)
48 (<|>:) = (<>)
106
49
107
50
108−instance context ~ Expr => AlternativeTable (ListTable context) where
51+instance AlternativeTable ListTable where
109 emptyTable = mempty
52 emptyTable = mempty
110
53
111
54
112−instance (context ~ Expr, Table Expr a) => Semigroup (ListTable context a)
55+instance Table DB a => Semigroup (ListTable a) where
113− where
56+ ListTable as <> ListTable bs = ListTable $
114− ListTable as <> ListTable bs = ListTable $ happend (const sappend) as bs
57+ happend (\_ _ (DB a) (DB b) -> DB (sappend a b)) 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
136
58
137
59
138−-- | Construct a 'ListTable' in the 'Name' context. This can be useful if you
60+instance Table DB a => Monoid (ListTable a) where
139−-- have a 'ListTable' that you are storing in a table and need to construct a
61+ mempty = ListTable $ hempty $ \nullability info ->
140−-- 'TableSchema'.
62+ DB (sempty nullability info)
141−nameListTable
142− :: Table Name a
143− => a -- ^ The names of the columns of elements of the list.
144− -> ListTable Name a
145−nameListTable =
146− ListTable .
147− hvectorize (\_ (Identity (Name a)) -> Name a) .
148− pure .
149− toColumns
src/Rel8/Table/Maybe.hs+91−133
@@ -15,53 +15,45 @@ module Rel8.Table.Maybe
15 ( MaybeTable(..)
15 ( MaybeTable(..)
16 , maybeTable, nothingTable, justTable
16 , maybeTable, nothingTable, justTable
17 , isNothingTable, isJustTable
17 , isNothingTable, isJustTable
18− , fromMaybeTable
19 , ($?)
18 , ($?)
20− , aggregateMaybeTable
21− , nameMaybeTable
22 )
19 )
23where
20where
24
21
25-- base
22-- base
26−import Data.Functor ( ($>) )
23+import Data.Functor.Identity ( runIdentity )
27−import Data.Functor.Identity ( Identity( Identity ) )
28import Data.Kind ( Type )
24import Data.Kind ( Type )
29−import Data.Maybe ( fromMaybe, isJust )
25+import Prelude hiding ( null, repeat, undefined, zipWith )
30−import Prelude hiding ( null, undefined )
31−
32−-- comonad
33−import Control.Comonad ( extract )
34
26
35-- rel8
27-- rel8
36−import Rel8.Aggregate ( Aggregate )
37import Rel8.Expr ( Expr )
28import Rel8.Expr ( Expr )
38−import Rel8.Expr.Aggregate ( groupByExpr )
39import Rel8.Expr.Bool ( boolExpr )
29import Rel8.Expr.Bool ( boolExpr )
40import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )
30import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )
41−import Rel8.Kind.Context ( Reifiable )
31+import Rel8.Expr.Serialize ( litExpr )
42−import Rel8.Schema.Dict ( Dict( Dict ) )
32+import Rel8.Schema.Context ( DB )
43−import qualified Rel8.Schema.Kind as K
33+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
34+import Rel8.Schema.Context.Nullify
35+ ( Nullifiable
36+ , encodeTag, decodeTag
37+ , nullifier, unnullifier
38+ )
44import Rel8.Schema.HTable.Identity ( HIdentity(..) )
39import Rel8.Schema.HTable.Identity ( HIdentity(..) )
45−import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
40+import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
46import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
41import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
47−import Rel8.Schema.Name ( Name )
42+import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
48−import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
43+import Rel8.Schema.Nullability
49−import qualified Rel8.Schema.Null as N
44+ ( Nullability( Nullable, NonNullable )
50−import Rel8.Table
45+ , Nullabilizes, nullabilization
51− ( Table, Columns, Context, fromColumns, toColumns
52− , FromExprs, fromResult, toResult
53− , Transpose
54 )
46 )
47+import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
55import Rel8.Table.Alternative
48import Rel8.Table.Alternative
56 ( AltTable, (<|>:)
49 ( AltTable, (<|>:)
57 , AlternativeTable, emptyTable
50 , AlternativeTable, emptyTable
58 )
51 )
59import Rel8.Table.Bool ( bool )
52import Rel8.Table.Bool ( bool )
60−import Rel8.Table.Eq ( EqTable, eqTable )
53+import Rel8.Table.Lifted
61−import Rel8.Table.Ord ( OrdTable, ordTable )
54+ ( Table1, Columns1, ConstrainContext1, fromColumns1, toColumns1
62−import Rel8.Table.Projection ( Projectable, project )
55+ )
63−import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )
56+import Rel8.Table.Recontextualize ( Recontextualize )
64−import Rel8.Table.Serialize ( ToExprs )
65import Rel8.Table.Undefined ( undefined )
57import Rel8.Table.Undefined ( undefined )
66import Rel8.Type ( DBType )
58import Rel8.Type ( DBType )
67import Rel8.Type.Tag ( MaybeTag( IsJust ) )
59import Rel8.Type.Tag ( MaybeTag( IsJust ) )
@@ -79,168 +71,134 @@ import Data.Functor.Bind ( Bind, (>>-) )
79-- entirely of nulls, you can't distinguish if you matched an all null row, or
71-- entirely of nulls, you can't distinguish if you matched an all null row, or
80-- if the match failed. For this reason @MaybeTable@ contains an extra field -
72-- if the match failed. For this reason @MaybeTable@ contains an extra field -
81-- a "nullTag" - to track whether or not the outer join produced any rows.
73-- a "nullTag" - to track whether or not the outer join produced any rows.
82−type MaybeTable :: K.Context -> Type -> Type
74+type MaybeTable :: Type -> Type
83−data MaybeTable context a = MaybeTable
75+data MaybeTable a = MaybeTable
84− { tag :: context (Maybe MaybeTag)
76+ { tag :: Expr (Maybe MaybeTag)
85− , just :: Nullify context a
77+ , just :: a
86 }
78 }
87− deriving stock Functor
79+ deriving stock (Show, Functor)
88−
89−
90−instance Projectable (MaybeTable context) where
91− project f (MaybeTable tag a) = MaybeTable tag (project f a)
92
80
93
81
94−instance context ~ Expr => Apply (MaybeTable context) where
82+instance Apply MaybeTable where
95− MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f <.> a)
83+ MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f a)
96
84
97
85
98-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:
86-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:
99−-- 'Rel8.traverseMaybeTable'.
87+-- 'traverseMaybeTable'.
100−instance context ~ Expr => Applicative (MaybeTable context) where
88+instance Applicative MaybeTable where
101 (<*>) = (<.>)
89 (<*>) = (<.>)
102 pure = justTable
90 pure = justTable
103
91
104
92
105−instance context ~ Expr => Bind (MaybeTable context) where
93+instance Bind MaybeTable where
106− MaybeTable tag a >>- f = case f (extract a) of
94+ MaybeTable tag a >>- f = case f a of
107 MaybeTable tag' b -> MaybeTable (tag <> tag') b
95 MaybeTable tag' b -> MaybeTable (tag <> tag') b
108
96
109
97
110−-- | Has the same behavior as the @Monad@ instance for @Maybe@.
98+-- | Has the same behavior as the @Monad@ instance for @Maybe@. See also:
111−instance context ~ Expr => Monad (MaybeTable context) where
99+-- 'bindMaybeTable'.
100+instance Monad MaybeTable where
112 (>>=) = (>>-)
101 (>>=) = (>>-)
113
102
114
103
115−instance context ~ Expr => AltTable (MaybeTable context) where
104+instance AltTable MaybeTable where
116− ma <|>: mb = bool ma mb (isNothingTable ma)
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
117
111
118
112
119−instance context ~ Expr => AlternativeTable (MaybeTable context) where
113+instance AlternativeTable MaybeTable where
120 emptyTable = nothingTable
114 emptyTable = nothingTable
121
115
122
116
123−instance (context ~ Expr, Table Expr a, Semigroup a) =>
117+instance (Table DB a, Semigroup a) => Semigroup (MaybeTable a) where
124− Semigroup (MaybeTable context a)
125− where
126 ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma
118 ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma
127
119
128
120
129−instance (context ~ Expr, Table Expr a, Semigroup a) =>
121+instance (Table DB a, Semigroup a) => Monoid (MaybeTable a) where
130− Monoid (MaybeTable context a)
131− where
132 mempty = nothingTable
122 mempty = nothingTable
133
123
134
124
135−instance (Table context a, Reifiable context, context ~ context') =>
125+instance Table1 MaybeTable where
136− Table context' (MaybeTable context a)
126+ type Columns1 MaybeTable = HMaybeTable
137− where
127+ type ConstrainContext1 MaybeTable = Nullifiable
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− }
147
128
148− fromColumns HMaybeTable {htag, hjust} = MaybeTable
129+ toColumns1 f MaybeTable {tag, just} = HMaybeTable
149− { tag = unHIdentity $ hunlabel htag
130+ { htag
150− , just = fromColumns $ hunlabel hjust
131+ , hjust = hnullify (nullifier (isNonNull tag)) $ f just
151 }
132 }
133+ where
134+ htag = HIdentity (encodeTag tag)
152
135
153− toResult ma = HMaybeTable
136+ fromColumns1 f HMaybeTable {htag = HIdentity htag, hjust} = MaybeTable
154− { htag = hlabel (HIdentity (Identity (IsJust <$ ma)))
137+ { tag
155− , hjust = hlabel (toResult @_ @(Nullify context a) ma)
138+ , just = f $ runIdentity $
139+ hunnullify (\a -> pure . unnullifier (isNonNull tag) a) hjust
156 }
140 }
157−
158− fromResult HMaybeTable {htag, hjust} = case hunlabel htag of
159− HIdentity (Identity tag) -> tag $>
160− fromMaybe err (fromResult @_ @(Nullify context a) (hunlabel hjust))
161 where
141 where
162− err = error "Maybe.fromColumns: mismatch between tag and data"
142+ tag = decodeTag htag
163
143
144+ {-# INLINABLE fromColumns1 #-}
145+ {-# INLINABLE toColumns1 #-}
164
146
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− }
170
147
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
171
155
172−instance (OrdTable a, context ~ Expr) => OrdTable (MaybeTable context a) where
156+ toColumns = toColumns1 (hlabel labeler . toColumns)
173− ordTable = HMaybeTable
157+ fromColumns = fromColumns1 (fromColumns . hunlabel unlabeler)
174− { htag = hlabel (HIdentity Dict)
175− , hjust = hlabel (ordTable @(Nullify context a))
176− }
177
158
178
159
179−instance (ToExprs exprs a, context ~ Expr) =>
160+instance
180− ToExprs (MaybeTable context exprs) (Maybe a)
161+ ( Labelable from, Nullifiable from
162+ , Labelable to, Nullifiable to
163+ , Recontextualize from to a b
164+ ) => Recontextualize from to (MaybeTable a) (MaybeTable b)
181
165
182
166
183−-- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.
167+-- | Check if a @MaybeTable@ is absent of any row.. Like 'isNothing'.
184−isNothingTable :: MaybeTable Expr a -> Expr Bool
168+isNothingTable :: MaybeTable a -> Expr Bool
185isNothingTable (MaybeTable tag _) = isNull tag
169isNothingTable (MaybeTable tag _) = isNull tag
186
170
187
171
188−-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.
172+-- | Check if a @MaybeTable@ contains a row. Like 'isJust'.
189−isJustTable :: MaybeTable Expr a -> Expr Bool
173+isJustTable :: MaybeTable a -> Expr Bool
190isJustTable (MaybeTable tag _) = isNonNull tag
174isJustTable (MaybeTable tag _) = isNonNull tag
191
175
192
176
193-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.
177-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.
194−maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable Expr a -> b
178+maybeTable :: Table DB b => b -> (a -> b) -> MaybeTable a -> b
195−maybeTable b f ma@(MaybeTable _ a) = bool (f (extract a)) b (isNothingTable ma)
179+maybeTable b f ma@(MaybeTable _ a) = bool (f a) b (isNothingTable ma)
196−{-# INLINABLE maybeTable #-}
197
180
198
181
199-- | The null table. Like 'Nothing'.
182-- | The null table. Like 'Nothing'.
200−nothingTable :: Table Expr a => MaybeTable Expr a
183+nothingTable :: Table DB a => MaybeTable a
201−nothingTable = MaybeTable null (pure undefined)
184+nothingTable = MaybeTable null undefined
202
185
203
186
204-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use
187-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use
205-- 'pure'.
188-- 'pure'.
206−justTable :: a -> MaybeTable Expr a
189+justTable :: a -> MaybeTable a
207−justTable = MaybeTable mempty . pure
190+justTable = MaybeTable (nullify (litExpr IsJust))
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
213
191
214
192
215-- | Project a single expression out of a 'MaybeTable'. You can think of this
193-- | Project a single expression out of a 'MaybeTable'. You can think of this
216-- operator like the '$' operator, but it also has the ability to return
194-- operator like the '$' operator, but it also has the ability to return
217-- @null@.
195-- @null@.
218−($?) :: forall a b. Sql DBType b
196+--
219− => (a -> Expr b) -> MaybeTable Expr a -> Expr (N.Nullify b)
197+-- >>> select c $ fmap (fst $?) (optional (values [lit (True, False)]))
220−f $? ma@(MaybeTable _ a) = case nullable @b of
198+-- [Just True]
221− Null -> boolExpr (f (extract a)) null (isNothingTable ma)
199+($?) :: forall a b db. (DBType db, Nullabilizes db b)
222− NotNull -> boolExpr (nullify (f (extract a))) null (isNothingTable ma)
200+ => (a -> Expr b) -> MaybeTable a -> Expr (Maybe db)
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)
223infixl 4 $?
204infixl 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+13−37
@@ -1,12 +1,8 @@
1−{-# language DataKinds #-}
2{-# language FlexibleContexts #-}
1{-# language FlexibleContexts #-}
3−{-# language FlexibleInstances #-}
4−{-# language MultiParamTypeClasses #-}
5{-# language NamedFieldPuns #-}
2{-# language NamedFieldPuns #-}
6{-# language ScopedTypeVariables #-}
3{-# language ScopedTypeVariables #-}
7{-# language TypeApplications #-}
4{-# language TypeApplications #-}
8{-# language TypeFamilies #-}
5{-# language TypeFamilies #-}
9−{-# language UndecidableInstances #-}
10{-# language ViewPatterns #-}
6{-# language ViewPatterns #-}
11
7
12module Rel8.Table.Name
8module Rel8.Table.Name
@@ -20,60 +16,40 @@ where
20-- base
16-- base
21import Data.Foldable ( fold )
17import Data.Foldable ( fold )
22import Data.Functor.Const ( Const( Const ), getConst )
18import Data.Functor.Const ( Const( Const ), getConst )
23−import Data.List.NonEmpty ( NonEmpty, intersperse, nonEmpty )
19+import Data.List.NonEmpty ( NonEmpty, intersperse )
24−import Data.Maybe ( fromMaybe )
25import Prelude
20import Prelude
26
21
22+-- casing
23+import Text.Casing ( quietSnake )
24+
27-- rel8
25-- rel8
26+import Rel8.Kind.Labels ( renderLabels )
27+import Rel8.Schema.Context ( Name( Name ) )
28import Rel8.Schema.HTable ( htabulate, htabulateA, hfield, hspecs )
28import Rel8.Schema.HTable ( htabulate, htabulateA, hfield, hspecs )
29−import Rel8.Schema.Name ( Name( Name ) )
29+import Rel8.Schema.Spec ( SSpec(..) )
30−import Rel8.Schema.Spec ( Spec(..) )
30+import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
31−import Rel8.Table ( Table(..) )
32
31
33
32
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'.
38namesFromLabels :: Table Name a => a
33namesFromLabels :: Table Name a => a
39namesFromLabels = namesFromLabelsWith go
34namesFromLabels = namesFromLabelsWith go
40 where
35 where
41− go = fold . intersperse "/"
36+ go = fold . intersperse "/" . fmap quietSnake
42
37
43
38
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.
59namesFromLabelsWith :: Table Name a
39namesFromLabelsWith :: Table Name a
60 => (NonEmpty String -> String) -> a
40 => (NonEmpty String -> String) -> a
61namesFromLabelsWith f = fromColumns $ htabulate $ \field ->
41namesFromLabelsWith f = fromColumns $ htabulate $ \field ->
62 case hfield hspecs field of
42 case hfield hspecs field of
63− Spec {labels} -> Name (f (renderLabels labels))
43+ SSpec {labels} -> Name (f (renderLabels labels))
64
44
65
45
66showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]
46showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]
67showLabels _ = getConst $
47showLabels _ = getConst $
68 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
48 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
69− Spec {labels} -> Const (pure (renderLabels labels))
49+ SSpec {labels} -> Const [renderLabels labels]
70
50
71
51
72−showNames :: forall a. Table Name a => a -> NonEmpty String
52+showNames :: forall a. Table Name a => a -> [String]
73showNames (toColumns -> names) = getConst $
53showNames (toColumns -> names) = getConst $
74 htabulateA @(Columns a) $ \field -> case hfield names field of
54 htabulateA @(Columns a) $ \field -> case hfield names field of
75− Name name -> Const (pure name)
55+ Name name -> Const [name]
76−
77−
78−renderLabels :: [String] -> NonEmpty String
79−renderLabels labels = fromMaybe (pure "anon") (nonEmpty labels )
src/Rel8/Table/NonEmpty.hs+19−111
@@ -1,143 +1,51 @@
1−{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
3{-# language FlexibleInstances #-}
1{-# language FlexibleInstances #-}
4{-# language MultiParamTypeClasses #-}
2{-# language MultiParamTypeClasses #-}
5−{-# language NamedFieldPuns #-}
6−{-# language ScopedTypeVariables #-}
7{-# language StandaloneKindSignatures #-}
3{-# language StandaloneKindSignatures #-}
8−{-# language TypeApplications #-}
9{-# language TypeFamilies #-}
4{-# language TypeFamilies #-}
10{-# language UndecidableInstances #-}
5{-# language UndecidableInstances #-}
11
6
12module Rel8.Table.NonEmpty
7module Rel8.Table.NonEmpty
13 ( NonEmptyTable(..)
8 ( NonEmptyTable(..)
14− , ($+)
9+ , HNonEmptyTable
15− , nonEmptyTable
16− , nameNonEmptyTable
17 )
10 )
18where
11where
19
12
20-- base
13-- base
21−import Data.Functor.Identity ( Identity( Identity ) )
22import Data.Kind ( Type )
14import Data.Kind ( Type )
23−import Data.List.NonEmpty ( NonEmpty )
15+import Prelude
24−import Prelude hiding ( id )
25
16
26-- rel8
17-- rel8
27−import Rel8.Expr ( Expr )
18+import Rel8.Expr.Array ( sappend1 )
28−import Rel8.Expr.Array ( sappend1, snonEmptyOf )
19+import Rel8.Schema.Context ( DB( DB ) )
29−import Rel8.Schema.Dict ( Dict( Dict ) )
20+import Rel8.Schema.HTable.Context ( H )
30import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
21import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
31−import Rel8.Schema.HTable.Vectorize
22+import Rel8.Schema.HTable.Vectorize ( happend )
32− ( hvectorize, hunvectorize
23+import Rel8.Table ( Table, Context, Columns, fromColumns, toColumns )
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− )
46import Rel8.Table.Alternative ( AltTable, (<|>:) )
24import Rel8.Table.Alternative ( AltTable, (<|>:) )
47−import Rel8.Table.Eq ( EqTable, eqTable )
25+import Rel8.Table.Recontextualize ( Recontextualize )
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 )
53−
54
26
55−-- | 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
27
28+type NonEmptyTable :: Type -> Type
29+newtype NonEmptyTable a =
30+ NonEmptyTable (HNonEmptyTable (Columns a) (H (Context a)))
61
31
62−instance Projectable (NonEmptyTable context) where
63− project f (NonEmptyTable a) = NonEmptyTable (hproject (apply f) a)
64
32
65−
33+instance Table context a => Table context (NonEmptyTable a) where
66−instance (Table context a, context ~ context') =>
34+ type Columns (NonEmptyTable a) = HNonEmptyTable (Columns a)
67− Table context' (NonEmptyTable context a)
35+ type Context (NonEmptyTable a) = 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)
74
36
75 fromColumns = NonEmptyTable
37 fromColumns = NonEmptyTable
76 toColumns (NonEmptyTable a) = a
38 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−
91
39
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))
101
40
41+instance Recontextualize from to a b =>
42+ Recontextualize from to (NonEmptyTable a) (NonEmptyTable b)
102
43
103−instance (ToExprs exprs a, context ~ Expr) =>
104− ToExprs (NonEmptyTable context exprs) (NonEmpty a)
105
44
106−
45+instance AltTable NonEmptyTable where
107−instance context ~ Expr => AltTable (NonEmptyTable context) where
108 (<|>:) = (<>)
46 (<|>:) = (<>)
109
47
110
48
111−instance (Table Expr a, context ~ Expr) => Semigroup (NonEmptyTable context a)
49+instance Table DB a => Semigroup (NonEmptyTable a) where
112− where
113 NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $
50 NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $
114− happend (const sappend1) as bs
51+ happend (\_ _ (DB a) (DB b) -> DB (sappend1 a b)) 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
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+76−97
@@ -1,150 +1,129 @@
1−{-# language BlockArguments #-}
2−{-# language DataKinds #-}
3{-# language DisambiguateRecordFields #-}
1{-# language DisambiguateRecordFields #-}
4{-# language FlexibleContexts #-}
2{-# language FlexibleContexts #-}
5{-# language NamedFieldPuns #-}
3{-# language NamedFieldPuns #-}
6−{-# language RankNTypes #-}
7{-# language TypeFamilies #-}
4{-# language TypeFamilies #-}
8{-# language ViewPatterns #-}
5{-# language ViewPatterns #-}
9
6
10−{-# options_ghc -Wno-deprecations #-}
11−
12module Rel8.Table.Opaleye
7module Rel8.Table.Opaleye
13 ( aggregator
8 ( aggregator
14− , attributes
15 , binaryspec
9 , binaryspec
16 , distinctspec
10 , distinctspec
17− , exprs
18− , exprsWithNames
19 , table
11 , table
20 , tableFields
12 , tableFields
21 , unpackspec
13 , unpackspec
22 , valuesspec
14 , valuesspec
23− , view
24− , castTable
25 )
15 )
26where
16where
27
17
28-- base
18-- base
29−import Data.Functor.Const ( Const( Const ), getConst )
19+import Prelude hiding ( undefined )
30−import Data.List.NonEmpty ( NonEmpty )
31−import Prelude
32
20
33-- opaleye
21-- opaleye
34−import qualified Opaleye.Adaptors as Opaleye
35−import qualified Opaleye.Field as Opaleye ( Field_ )
36import qualified Opaleye.Internal.Aggregate as Opaleye
22import qualified Opaleye.Internal.Aggregate as Opaleye
23+import qualified Opaleye.Internal.Binary as Opaleye
24+import qualified Opaleye.Internal.Distinct as Opaleye
37import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
25import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
26+import qualified Opaleye.Internal.PackMap as Opaleye
27+import qualified Opaleye.Internal.Unpackspec as Opaleye
38import qualified Opaleye.Internal.Values as Opaleye
28import qualified Opaleye.Internal.Values as Opaleye
39−import qualified Opaleye.Table as Opaleye
29+import qualified Opaleye.Internal.Table as Opaleye
40
30
41-- profunctors
31-- profunctors
42import Data.Profunctor ( dimap, lmap )
32import Data.Profunctor ( dimap, lmap )
43
33
44-- rel8
34-- rel8
45−import Rel8.Aggregate ( Aggregate( Aggregate ), Aggregates )
35+import Rel8.Aggregate ( Aggregate( Aggregate ) )
46−import Rel8.Expr ( Expr )
47import Rel8.Expr.Opaleye
36import Rel8.Expr.Opaleye
48− ( fromPrimExpr, toPrimExpr
37+ ( scastExpr
49− , scastExpr, traverseFieldP
38+ , fromPrimExpr, toPrimExpr
39+ , traversePrimExpr
40+ , fromColumn, toColumn
50 )
41 )
51−import Rel8.Schema.HTable ( htabulateA, hfield, hspecs, htabulate,
42+import Rel8.Kind.Necessity ( SNecessity( SRequired, SOptional ) )
52− htraverseP, htraversePWithField )
43+import Rel8.Schema.Context ( DB(..), Insertion(..), Name(..) )
53−import Rel8.Schema.Name ( Name( Name ), Selects, ppColumn )
44+import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs )
54−import Rel8.Schema.Spec ( Spec(..) )
45+import Rel8.Schema.Spec ( SSpec(..) )
55−import Rel8.Schema.Table ( TableSchema(..), ppTable )
46+import Rel8.Schema.Table ( TableSchema(..) )
56import Rel8.Table ( Table, fromColumns, toColumns )
47import Rel8.Table ( Table, fromColumns, toColumns )
57−import Rel8.Type.Information ( typeName )
48+import Rel8.Table.Recontextualize ( Selects, Inserts )
49+import Rel8.Table.Undefined ( undefined )
58
50
59-- semigroupoids
51-- semigroupoids
60import Data.Functor.Apply ( WrappedApplicative(..) )
52import 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−
69−
70−attributes :: Selects names exprs => TableSchema names -> exprs
71−attributes schema@TableSchema {columns} = fromColumns $ htabulate $ \field ->
72− case hfield (toColumns columns) field of
73− Name column -> fromPrimExpr $ Opaleye.ConstExpr $
74− Opaleye.OtherLit $
75− show (ppTable schema) <> "." <> show (ppColumn column)
76−
77−
78−fromOpaleyespec :: (ProductProfunctor p, Table Expr a)
79− => p (Opaleye.Field_ n x) (Opaleye.Field_ n x)
80− -> p a a
81−fromOpaleyespec x =
82− dimap toColumns fromColumns (htraverseP (traverseFieldP x))
83
53
84
54
85−binaryspec :: Table Expr a => Opaleye.Binaryspec a a
55+aggregator :: Opaleye.Aggregator (Aggregate exprs) exprs
86−binaryspec = fromOpaleyespec Opaleye.binaryspecField
56+aggregator = Opaleye.Aggregator $ Opaleye.PackMap $
57+ \f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner))) -> inner f ()
87
58
88
59
89−distinctspec :: Table Expr a => Opaleye.Distinctspec a a
60+binaryspec :: Table DB a => Opaleye.Binaryspec a a
90−distinctspec = fromOpaleyespec Opaleye.distinctspecField
61+binaryspec = Opaleye.Binaryspec $ Opaleye.PackMap $ \f (as, bs) ->
62+ fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->
63+ WrapApplicative $
64+ case (hfield (toColumns as) field, hfield (toColumns bs) field) of
65+ (DB a, DB b) -> DB . fromPrimExpr <$> f (toPrimExpr a, toPrimExpr b)
91
66
92
67
93−exprs :: Table Expr a => a -> NonEmpty Opaleye.PrimExpr
68+distinctspec :: Table DB a => Opaleye.Distinctspec a a
94−exprs (toColumns -> as) = getConst $ htabulateA $ \field ->
69+distinctspec =
95− case hfield as field of
70+ Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap $ \f ->
96− expr -> Const (pure (toPrimExpr expr))
71+ fmap fromColumns .
72+ unwrapApplicative .
73+ htraverse
74+ (\(DB a) ->
75+ WrapApplicative $ DB . fromPrimExpr <$> f (Nothing, toPrimExpr a)) .
76+ toColumns
97
77
98
78
99−exprsWithNames :: Selects names exprs
79+table ::(Selects names exprs, Inserts exprs inserts)
100− => names -> exprs -> NonEmpty (String, Opaleye.PrimExpr)
80+ => TableSchema names -> Opaleye.Table inserts exprs
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
107table (TableSchema name schema columns) =
81table (TableSchema name schema columns) =
108− case schema of
82+ Opaleye.Table qualified (tableFields columns)
109− Nothing -> Opaleye.table name (tableFields columns)
83+ where
110− Just schemaName -> Opaleye.tableWithSchema schemaName name (tableFields columns)
84+ qualified = case schema of
85+ Nothing -> name
86+ Just qualifier -> qualifier <> "." <> name
111
87
112
88
113−tableFields :: Selects names exprs
89+tableFields :: (Selects names exprs, Inserts exprs inserts)
114− => names -> Opaleye.TableFields exprs exprs
90+ => names -> Opaleye.TableFields inserts exprs
115tableFields (toColumns -> names) = dimap toColumns fromColumns $
91tableFields (toColumns -> names) = dimap toColumns fromColumns $
116 unwrapApplicative $ htabulateA $ \field -> WrapApplicative $
92 unwrapApplicative $ htabulateA $ \field -> WrapApplicative $
117− case hfield names field of
93+ case hfield hspecs field of
118− name -> lmap (`hfield` field) (go name)
94+ specs -> case hfield names field of
95+ name -> lmap (`hfield` field) (go specs name)
119 where
96 where
120− go :: Name a -> Opaleye.TableFields (Expr a) (Expr a)
97+ go :: SSpec spec -> Name spec -> Opaleye.TableFields (Insertion spec) (DB spec)
121− go (Name name) =
98+ go SSpec {necessity, info, nullability} (Name name) =
122− traverseFieldP $
99+ case necessity of
123− Opaleye.requiredTableField name
100+ SRequired ->
124−
101+ lmap (\(RequiredInsert a) -> toColumn $ toPrimExpr a) $
125−
102+ DB . scastExpr nullability info . fromPrimExpr . fromColumn <$>
126−unpackspec :: Table Expr a => Opaleye.Unpackspec a a
103+ Opaleye.requiredTableField name
127−unpackspec = fromOpaleyespec Opaleye.unpackspecField
104+ SOptional ->
105+ lmap (\(OptionalInsert ma) -> toColumn . toPrimExpr <$> ma) $
106+ DB . scastExpr nullability info . fromPrimExpr . fromColumn <$>
107+ Opaleye.optionalTableField name
108+
109+
110+unpackspec :: Table DB a => Opaleye.Unpackspec a a
111+unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->
112+ fmap fromColumns .
113+ unwrapApplicative .
114+ htraverse (\(DB a) -> WrapApplicative $ DB <$> traversePrimExpr f a) .
115+ toColumns
128{-# INLINABLE unpackspec #-}
116{-# INLINABLE unpackspec #-}
129
117
130
118
131−valuesspec :: Table Expr a => Opaleye.Valuesspec a a
119+valuesspec :: Table DB a => Opaleye.ValuesspecSafe a a
132−valuesspec = dimap toColumns fromColumns $
120+valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec
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
141
121
142
122
143−-- | Transform a table by adding 'CAST' to all columns. This is most useful for
123+toPackMap :: Table DB a
144−-- finalising a SELECT or RETURNING statement, guaranteed that the output
124+ => a -> Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () a
145−-- matches what is encoded in each columns TypeInformation.
125+toPackMap as = Opaleye.PackMap $ \f () ->
146−castTable :: Table Expr a => a -> a
126+ fmap fromColumns $
147−castTable (toColumns -> as) = fromColumns $ htabulate \field ->
127+ unwrapApplicative .
148− case hfield hspecs field of
128+ htraverse (\(DB a) -> WrapApplicative $ DB <$> traversePrimExpr f a) $
149− Spec {info} -> case hfield as field of
129+ toColumns as
150− expr -> scastExpr info expr
src/Rel8/Table/Ord.hs+49−83
@@ -1,154 +1,120 @@
1−{-# language AllowAmbiguousTypes #-}
2{-# language DataKinds #-}
1{-# language DataKinds #-}
3−{-# language DefaultSignatures #-}
4−{-# language DisambiguateRecordFields #-}
5−{-# language FlexibleContexts #-}
6{-# language FlexibleInstances #-}
2{-# language FlexibleInstances #-}
3+{-# language NamedFieldPuns #-}
7{-# language ScopedTypeVariables #-}
4{-# language ScopedTypeVariables #-}
8{-# language StandaloneKindSignatures #-}
5{-# language StandaloneKindSignatures #-}
9{-# language TypeApplications #-}
6{-# language TypeApplications #-}
10{-# language TypeFamilies #-}
7{-# language TypeFamilies #-}
11−{-# language TypeOperators #-}
12{-# language UndecidableInstances #-}
8{-# language UndecidableInstances #-}
9+{-# language UndecidableSuperClasses #-}
13{-# language ViewPatterns #-}
10{-# language ViewPatterns #-}
14
11
15module Rel8.Table.Ord
12module Rel8.Table.Ord
16− ( OrdTable( ordTable ), (<:), (<=:), (>:), (>=:), least, greatest
13+ ( OrdTable, (<:), (<=:), (>:), (>=:), least, greatest
17 )
14 )
18where
15where
19
16
20-- base
17-- base
21import Data.Functor.Const ( Const( Const ), getConst )
18import Data.Functor.Const ( Const( Const ), getConst )
22import Data.Kind ( Constraint, Type )
19import Data.Kind ( Constraint, Type )
23−import GHC.Generics ( Rep )
24import Prelude hiding ( seq )
20import Prelude hiding ( seq )
25
21
26-- rel8
22-- rel8
27import Rel8.Expr ( Expr )
23import Rel8.Expr ( Expr )
28import Rel8.Expr.Bool ( (||.), (&&.), false, true )
24import Rel8.Expr.Bool ( (||.), (&&.), false, true )
29−import Rel8.Expr.Eq ( (==.) )
25+import Rel8.Expr.Eq ( seq )
30−import Rel8.Expr.Ord ( (<.), (>.) )
26+import Rel8.Expr.Ord ( slt, sgt)
31−import Rel8.FCF ( Eval, Exp )
27+import Rel8.Opaque ( Opaque )
32−import Rel8.Generic.Record ( Record )
28+import Rel8.Schema.Context ( DB( DB ) )
33−import Rel8.Generic.Table.Record ( GTable, GColumns, gtable )
34import Rel8.Schema.Dict ( Dict( Dict ) )
29import Rel8.Schema.Dict ( Dict( Dict ) )
35−import Rel8.Schema.HTable ( htabulateA, hfield )
30+import Rel8.Schema.HTable
36−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
31+ ( HConstrainTable
37−import Rel8.Schema.Null (Sql)
32+ , htabulateA, hfield
38−import Rel8.Table ( Columns, toColumns, TColumns )
33+ , hdicts, hspecs
34+ )
35+import Rel8.Schema.Spec ( SSpec(..) )
36+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
37+import Rel8.Table ( Columns, toColumns )
39import Rel8.Table.Bool ( bool )
38import Rel8.Table.Bool ( bool )
40import Rel8.Table.Eq ( EqTable )
39import Rel8.Table.Eq ( EqTable )
41import Rel8.Type.Ord ( DBOrd )
40import Rel8.Type.Ord ( DBOrd )
42
41
43
42
44−-- | The class of 'Table's that can be ordered. Ordering on tables is defined
45−-- by their lexicographic ordering of all columns, so this class means "all
46−-- columns in a 'Table' have an instance of 'DBOrd'".
47type OrdTable :: Type -> Constraint
43type OrdTable :: Type -> Constraint
48−class EqTable a => OrdTable a where
44+class
49− ordTable :: Columns a (Dict (Sql DBOrd))
45+ ( EqTable a
50−
46+ , HConstrainTable (Columns a) (ConstrainDBType DBOrd)
51− default ordTable ::
47+ ) => OrdTable a
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−
82instance
48instance
83− ( OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e, OrdTable f
49+ ( EqTable a
84− )
50+ , HConstrainTable (Columns a) (ConstrainDBType DBOrd)
85− => OrdTable (a, b, c, d, e, f)
51+ ) => OrdTable a
86−
52+instance {-# OVERLAPPING #-} OrdTable Opaque
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)
93
53
94
54
95−-- | Test if one 'Table' sorts before another. Corresponds to comparing all
96−-- columns with '<'.
97(<:) :: forall a. OrdTable a => a -> a -> Expr Bool
55(<:) :: forall a. OrdTable a => a -> a -> Expr Bool
98(toColumns -> as) <: (toColumns -> bs) =
56(toColumns -> as) <: (toColumns -> bs) =
99 foldr @[] go false $ getConst $ htabulateA $ \field ->
57 foldr @[] go false $ getConst $ htabulateA $ \field ->
100 case (hfield as field, hfield bs field) of
58 case (hfield as field, hfield bs field) of
101− (a, b) -> case hfield (ordTable @a) field of
59+ (DB a, DB b) -> case hfield dicts field of
102− Dict -> Const [(a <. b, a ==. b)]
60+ Dict -> case hfield specs field of
61+ SSpec {nullability} ->
62+ Const [(slt nullability a b, seq nullability a b)]
103 where
63 where
64+ dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
65+ specs = hspecs @(Columns a)
104 go (lt, eq) a = lt ||. (eq &&. a)
66 go (lt, eq) a = lt ||. (eq &&. a)
105infix 4 <:
67infix 4 <:
106
68
107
69
108−-- | Test if one 'Table' sorts before, or is equal to, another. Corresponds to
109−-- comparing all columns with '<='.
110(<=:) :: forall a. OrdTable a => a -> a -> Expr Bool
70(<=:) :: forall a. OrdTable a => a -> a -> Expr Bool
111(toColumns -> as) <=: (toColumns -> bs) =
71(toColumns -> as) <=: (toColumns -> bs) =
112 foldr @[] go true $ getConst $ htabulateA $ \field ->
72 foldr @[] go true $ getConst $ htabulateA $ \field ->
113 case (hfield as field, hfield bs field) of
73 case (hfield as field, hfield bs field) of
114− (a, b) -> case hfield (ordTable @a) field of
74+ (DB a, DB b) -> case hfield dicts field of
115− Dict -> Const [(a <. b, a ==. b)]
75+ Dict -> case hfield specs field of
76+ SSpec {nullability} ->
77+ Const [(slt nullability a b, seq nullability a b)]
116 where
78 where
79+ dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
80+ specs = hspecs @(Columns a)
117 go (lt, eq) a = lt ||. (eq &&. a)
81 go (lt, eq) a = lt ||. (eq &&. a)
118infix 4 <=:
82infix 4 <=:
119
83
120
84
121−-- | Test if one 'Table' sorts after another. Corresponds to comparing all
122−-- columns with '>'.
123(>:) :: forall a. OrdTable a => a -> a -> Expr Bool
85(>:) :: forall a. OrdTable a => a -> a -> Expr Bool
124(toColumns -> as) >: (toColumns -> bs) =
86(toColumns -> as) >: (toColumns -> bs) =
125 foldr @[] go false $ getConst $ htabulateA $ \field ->
87 foldr @[] go false $ getConst $ htabulateA $ \field ->
126 case (hfield as field, hfield bs field) of
88 case (hfield as field, hfield bs field) of
127− (a, b) -> case hfield (ordTable @a) field of
89+ (DB a, DB b) -> case hfield dicts field of
128− Dict -> Const [(a >. b, a ==. b)]
90+ Dict -> case hfield specs field of
91+ SSpec {nullability} ->
92+ Const [(slt nullability a b, seq nullability a b)]
129 where
93 where
94+ dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
95+ specs = hspecs @(Columns a)
130 go (gt, eq) a = gt ||. (eq &&. a)
96 go (gt, eq) a = gt ||. (eq &&. a)
131infix 4 >:
97infix 4 >:
132
98
133
99
134−-- | Test if one 'Table' sorts after another. Corresponds to comparing all
135−-- columns with '>='.
136(>=:) :: forall a. OrdTable a => a -> a -> Expr Bool
100(>=:) :: forall a. OrdTable a => a -> a -> Expr Bool
137(toColumns -> as) >=: (toColumns -> bs) =
101(toColumns -> as) >=: (toColumns -> bs) =
138 foldr @[] go true $ getConst $ htabulateA $ \field ->
102 foldr @[] go true $ getConst $ htabulateA $ \field ->
139 case (hfield as field, hfield bs field) of
103 case (hfield as field, hfield bs field) of
140− (a, b) -> case hfield (ordTable @a) field of
104+ (DB a, DB b) -> case hfield dicts field of
141− Dict -> Const [(a >. b, a ==. b)]
105+ Dict -> case hfield specs field of
106+ SSpec {nullability} ->
107+ Const [(sgt nullability a b, seq nullability a b)]
142 where
108 where
109+ dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
110+ specs = hspecs @(Columns a)
143 go (gt, eq) a = gt ||. (eq &&. a)
111 go (gt, eq) a = gt ||. (eq &&. a)
144infix 4 >=:
112infix 4 >=:
145
113
146
114
147−-- | Given two 'Table's, return the table that sorts before the other.
148least :: OrdTable a => a -> a -> a
115least :: OrdTable a => a -> a -> a
149−least a b = bool b a (a <: b)
116+least a b = bool a b (a <: b)
150
117
151
118
152−-- | Given two 'Table's, return the table that sorts after the other.
153greatest :: OrdTable a => a -> a -> a
119greatest :: OrdTable a => a -> a -> a
154−greatest a b = bool b a (a >: b)
120+greatest a b = bool a b (a >: b)
src/Rel8/Table/Order.hs+20−20
@@ -1,4 +1,3 @@
1−{-# language DataKinds #-}
2{-# language NamedFieldPuns #-}
1{-# language NamedFieldPuns #-}
3{-# language ScopedTypeVariables #-}
2{-# language ScopedTypeVariables #-}
4{-# language TypeApplications #-}
3{-# language TypeApplications #-}
@@ -18,33 +17,34 @@ import Prelude
18-- rel8
17-- rel8
19import Rel8.Expr.Order ( asc, desc, nullsFirst, nullsLast )
18import Rel8.Expr.Order ( asc, desc, nullsFirst, nullsLast )
20import Rel8.Order ( Order )
19import Rel8.Order ( Order )
20+import Rel8.Schema.Context ( unDB )
21import Rel8.Schema.Dict ( Dict( Dict ) )
21import Rel8.Schema.Dict ( Dict( Dict ) )
22−import Rel8.Schema.HTable (htabulateA, hfield, hspecs)
22+import Rel8.Schema.HTable (htabulateA, hfield, hdicts, hspecs)
23−import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
23+import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
24−import Rel8.Schema.Spec ( Spec( Spec, nullity ) )
24+import Rel8.Schema.Spec ( SSpec(..) )
25−import Rel8.Table ( Columns, toColumns )
25+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
26−import Rel8.Table.Ord ( OrdTable, ordTable )
26+import Rel8.Table
27+import Rel8.Table.Ord
28+import Rel8.Type.Ord
27
29
28
30
29−-- | Construct an 'Order' for a 'Table' by sorting all columns into ascending
30−-- orders (any nullable columns will be sorted with @NULLS FIRST@).
31ascTable :: forall a. OrdTable a => Order a
31ascTable :: forall a. OrdTable a => Order a
32ascTable = contramap toColumns $ getConst $
32ascTable = contramap toColumns $ getConst $
33 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
33 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
34− Spec {nullity} -> case hfield (ordTable @a) field of
34+ SSpec {nullability} -> case hfield ords field of
35− Dict -> Const $ (`hfield` field) >$<
35+ Dict -> Const $ unDB . (`hfield` field) >$< case nullability of
36− case nullity of
36+ Nullable -> nullsFirst asc
37− Null -> nullsFirst asc
37+ NonNullable -> asc
38− NotNull -> asc
38+ where
39+ ords = hdicts @(Columns a) @(ConstrainDBType DBOrd)
39
40
40
41
41−-- | Construct an 'Order' for a 'Table' by sorting all columns into descending
42−-- orders (any nullable columns will be sorted with @NULLS LAST@).
43descTable :: forall a. OrdTable a => Order a
42descTable :: forall a. OrdTable a => Order a
44descTable = contramap toColumns $ getConst $
43descTable = contramap toColumns $ getConst $
45 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
44 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
46− Spec {nullity} -> case hfield (ordTable @a) field of
45+ SSpec {nullability} -> case hfield ords field of
47− Dict -> Const $ (`hfield` field) >$<
46+ Dict -> Const $ unDB . (`hfield` field) >$< case nullability of
48− case nullity of
47+ Nullable -> nullsLast desc
49− Null -> nullsLast desc
48+ NonNullable -> desc
50− NotNull -> desc
49+ where
50+ 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+162
@@ -0,0 +1,162 @@
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 ( Aggregation, DB, Insertion, Name, Result )
29+import Rel8.Schema.Context.Label ( Labelable )
30+import Rel8.Schema.HTable ( HTable )
31+import Rel8.Schema.HTable.Context ( H )
32+import Rel8.Schema.Nullability ( Nullabilizes )
33+import Rel8.Schema.Spec ( KnownSpec )
34+import qualified Rel8.Schema.Spec as Kind ( Context )
35+import Rel8.Table ( Table, Congruent )
36+import Rel8.Type ( DBType )
37+
38+
39+type Recontextualize :: Kind.Context -> Kind.Context -> Type -> Type -> Constraint
40+class
41+ ( Table from a
42+ , Table to b
43+ , Congruent a b
44+ , Recontextualize from from a a
45+ , Recontextualize to to b b
46+ , Recontextualize to from b a
47+ ) => Recontextualize from to a b
48+ | a -> from
49+ , b -> to
50+ , a to -> b
51+ , b from -> a
52+
53+
54+instance (DBType db, Nullabilizes db a) =>
55+ Recontextualize Aggregation Aggregation (Aggregate (Expr a)) (Aggregate (Expr a))
56+
57+
58+instance (DBType db, Nullabilizes db a) =>
59+ Recontextualize Aggregation DB (Aggregate (Expr a)) (Expr a)
60+
61+
62+instance (DBType db, Nullabilizes db a) =>
63+ Recontextualize Aggregation Result (Aggregate (Expr a)) (Identity a)
64+
65+
66+instance (DBType db, Nullabilizes db a) =>
67+ Recontextualize DB Aggregation (Expr a) (Aggregate (Expr a))
68+
69+
70+instance (DBType db, Nullabilizes db a) =>
71+ Recontextualize DB DB (Expr a) (Expr a)
72+
73+
74+instance (DBType db, Nullabilizes db a) =>
75+ Recontextualize DB Result (Expr a) (Identity a)
76+
77+
78+instance (DBType db, Nullabilizes db a) =>
79+ Recontextualize Result Aggregation (Identity a) (Aggregate (Expr a))
80+
81+
82+instance (DBType db, Nullabilizes db a) =>
83+ Recontextualize Result DB (Identity a) (Expr a)
84+
85+
86+instance (DBType db, Nullabilizes db a) =>
87+ Recontextualize Result Result (Identity a) (Identity a)
88+
89+
90+instance KnownSpec spec => Recontextualize from to (from spec) (to spec)
91+
92+
93+instance Recontextualize from to (Opaque1 from a) (Opaque1 to a)
94+
95+
96+instance HTable t => Recontextualize from to (t (H from)) (t (H to))
97+
98+
99+instance
100+ ( Table from (t from)
101+ , Table to (t to)
102+ , Congruent (t from) (t to)
103+ ) => Recontextualize from to (t from) (t to)
104+
105+
106+instance
107+ ( Recontextualize from to a1 b1
108+ , Recontextualize from to a2 b2
109+ , Labelable from
110+ , Labelable to
111+ ) => Recontextualize from to (a1, a2) (b1, b2)
112+
113+
114+instance
115+ ( Recontextualize from to a1 b1
116+ , Recontextualize from to a2 b2
117+ , Recontextualize from to a3 b3
118+ , Labelable from, Labelable to
119+ ) => Recontextualize from to (a1, a2, a3) (b1, b2, b3)
120+
121+
122+instance
123+ ( Recontextualize from to a1 b1
124+ , Recontextualize from to a2 b2
125+ , Recontextualize from to a3 b3
126+ , Recontextualize from to a4 b4
127+ , Labelable from, Labelable to
128+ ) => Recontextualize from to (a1, a2, a3, a4) (b1, b2, b3, b4)
129+
130+
131+instance
132+ ( Recontextualize from to a1 b1
133+ , Recontextualize from to a2 b2
134+ , Recontextualize from to a3 b3
135+ , Recontextualize from to a4 b4
136+ , Recontextualize from to a5 b5
137+ , Labelable from, Labelable to
138+ ) => Recontextualize from to (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5)
139+
140+
141+type Aggregates :: Type -> Type -> Constraint
142+class Recontextualize Aggregation DB aggregates exprs => Aggregates aggregates exprs
143+instance Recontextualize Aggregation DB aggregates exprs => Aggregates aggregates exprs
144+instance {-# OVERLAPPING #-} Aggregates (Opaque1 Aggregation Opaque) (Opaque1 DB Opaque)
145+
146+
147+type Encodes :: Type -> Type -> Constraint
148+class Recontextualize Result DB a exprs => Encodes a exprs
149+instance Recontextualize Result DB a exprs => Encodes a exprs
150+instance {-# OVERLAPPING #-} Encodes (Opaque1 Result Opaque) (Opaque1 DB Opaque)
151+
152+
153+type Inserts :: Type -> Type -> Constraint
154+class Recontextualize DB Insertion exprs inserts => Inserts exprs inserts
155+instance Recontextualize DB Insertion exprs inserts => Inserts exprs inserts
156+instance {-# OVERLAPPING #-} Inserts (Opaque1 DB Opaque) (Opaque1 Insertion Opaque)
157+
158+
159+type Selects :: Type -> Type -> Constraint
160+class Recontextualize Name DB names exprs => Selects names exprs
161+instance Recontextualize Name DB names exprs => Selects names exprs
162+instance {-# OVERLAPPING #-} Selects (Opaque1 Name Opaque) (Opaque1 DB 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+374−69
@@ -1,4 +1,6 @@
1{-# language AllowAmbiguousTypes #-}
1{-# language AllowAmbiguousTypes #-}
2+{-# language DataKinds #-}
3+{-# language DisambiguateRecordFields #-}
2{-# language FlexibleContexts #-}
4{-# language FlexibleContexts #-}
3{-# language FlexibleInstances #-}
5{-# language FlexibleInstances #-}
4{-# language FunctionalDependencies #-}
6{-# language FunctionalDependencies #-}
@@ -7,16 +9,16 @@
7{-# language StandaloneKindSignatures #-}
9{-# language StandaloneKindSignatures #-}
8{-# language TypeApplications #-}
10{-# language TypeApplications #-}
9{-# language TypeFamilies #-}
11{-# language TypeFamilies #-}
12+{-# language ViewPatterns #-}
10{-# language UndecidableInstances #-}
13{-# language UndecidableInstances #-}
11
14
12module Rel8.Table.Serialize
15module Rel8.Table.Serialize
13− ( Serializable, lit, litHTable, parse
16+ ( Serializable, lit, parse
14− , ToExprs
15 )
17 )
16where
18where
17
19
18-- base
20-- base
19−import Data.Functor.Identity ( Identity( Identity ) )
21+import Data.Bifunctor ( bimap )
20import Data.Kind ( Constraint, Type )
22import Data.Kind ( Constraint, Type )
21import Data.List.NonEmpty ( NonEmpty )
23import Data.List.NonEmpty ( NonEmpty )
22import Prelude
24import Prelude
@@ -27,122 +29,425 @@ import qualified Hasql.Decoders as Hasql
27-- rel8
29-- rel8
28import Rel8.Expr ( Expr )
30import Rel8.Expr ( Expr )
29import Rel8.Expr.Serialize ( slitExpr, sparseValue )
31import Rel8.Expr.Serialize ( slitExpr, sparseValue )
32+import Rel8.Opaque ( Opaque )
33+import Rel8.Schema.Context ( DB(..), Result(..) )
34+import Rel8.Schema.Context.Label ( labeler, unlabeler )
35+import Rel8.Schema.Context.Result
36+ ( fromHEitherTable, toHEitherTable
37+ , fromHListTable, toHListTable
38+ , fromHMaybeTable, toHMaybeTable
39+ , fromHNonEmptyTable, toHNonEmptyTable
40+ , fromHTheseTable, toHTheseTable
41+ )
30import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )
42import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )
31−import Rel8.Schema.Null ( NotNull, Sql )
43+import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
32−import Rel8.Schema.Result ( Result )
44+import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
33−import Rel8.Schema.Spec ( Spec(..) )
45+import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
34−import Rel8.Table ( Table, fromColumns, FromExprs, fromResult, toResult )
46+import Rel8.Schema.HTable.Pair ( HPair(..) )
47+import Rel8.Schema.HTable.Trio ( HTrio(..) )
48+import Rel8.Schema.HTable.Type ( HType(..) )
49+import Rel8.Schema.HTable.Context ( H )
50+import Rel8.Schema.Nullability ( IsMaybe, Nullabilizes )
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 )
35import Rel8.Type ( DBType )
59import Rel8.Type ( DBType )
36
60
37-- semigroupoids
61-- semigroupoids
38import Data.Functor.Apply ( WrappedApplicative(..) )
62import Data.Functor.Apply ( WrappedApplicative(..) )
39
63
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 (_ (H Result)) = 'False
80+ IsPlainColumn (_ Result) = 'False
81+ IsPlainColumn (Result _) = '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 (_ (H Result)) = 'True
97+ IsTabular (_ Result) = 'True
98+ IsTabular (Result _) = '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+
40
120
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.
44type ToExprs :: Type -> Type -> Constraint
121type 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+fromResults' :: forall exprs a. ToExprs a exprs => Columns exprs (H Result) -> a
127+fromResults' = fromResults @(IsPlainColumn a) @_ @_ @exprs
128+
129+
130+toResults' :: forall exprs a. ToExprs a exprs => a -> Columns exprs (H Result)
131+toResults' = toResults @(IsPlainColumn a) @_ @_ @exprs
132+
133+
134+type ExprsFor :: Bool -> Bool -> Type -> Type -> Constraint
135+class (Table DB exprs, isTabular ~ IsTabular a) =>
136+ ExprsFor isPlainColumn isTabular a exprs where
137+ fromResults :: Columns exprs (H Result) -> a
138+ toResults :: a -> Columns exprs (H Result)
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+ fromResults (HType (Result a)) = a
150+ toResults = HType . Result
151+
152+
153+instance
154+ ( DBType db
155+ , Nullabilizes db a
156+ , IsListTabular a ~ 'False
157+ , x ~ [a]
158+ ) => ExprsFor 'False 'False [a] (Expr x)
159+ where
160+ fromResults (HType (Result a)) = a
161+ toResults = HType . Result
162+
163+
164+instance
165+ ( DBType a
166+ , Nullabilizes a (Maybe a)
167+ , isTabular ~ 'False
168+ , IsMaybeTabular a ~ 'False
169+ , x ~ Maybe a
170+ ) => ExprsFor 'False 'False (Maybe a) (Expr x)
171+ where
172+ fromResults (HType (Result a)) = a
173+ toResults = HType . Result
174+
175+
176+instance
177+ ( DBType db
178+ , Nullabilizes db a
179+ , IsListTabular a ~ 'False
180+ , x ~ NonEmpty a
181+ ) => ExprsFor 'False 'False (NonEmpty a) (Expr x)
182+ where
183+ fromResults (HType (Result a)) = a
184+ toResults = HType . Result
185+
186+
187+instance
188+ ( ToExprs a exprs
189+ , IsListTabular a ~ 'False
190+ ) => ExprsFor 'False 'False [a] (ListTable exprs)
191+ where
192+ fromResults = fmap (fromResults' @exprs) . fromHListTable
193+ toResults = toHListTable . fmap (toResults' @exprs)
194+
195+
196+instance
197+ ( ToExprs a exprs
198+ , IsMaybeTabular a ~ 'False
199+ ) => ExprsFor 'False 'False (Maybe a) (MaybeTable exprs)
200+ where
201+ fromResults =
202+ fmap (fromResults' @exprs . hunlabel unlabeler) .
203+ fromHMaybeTable
204+ toResults =
205+ toHMaybeTable .
206+ fmap (hlabel labeler . toResults' @exprs)
207+
208+
209+instance
210+ ( ToExprs a exprs
211+ , IsListTabular a ~ 'False
212+ ) => ExprsFor 'False 'False (NonEmpty a) (NonEmptyTable exprs)
213+ where
214+ fromResults = fmap (fromResults' @exprs) . fromHNonEmptyTable
215+ toResults = toHNonEmptyTable . fmap (toResults' @exprs)
46
216
47
217
48−instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a
218+instance
219+ ( ToExprs a exprs1
220+ , ToExprs b exprs2
221+ , isTabular ~ 'True
222+ , x ~ EitherTable exprs1 exprs2
223+ ) => ExprsFor 'False isTabular (Either a b) x
224+ where
225+ fromResults =
226+ bimap
227+ (fromResults' @exprs1 . hunlabel unlabeler)
228+ (fromResults' @exprs2 . hunlabel unlabeler) .
229+ fromHEitherTable
230+ toResults =
231+ toHEitherTable .
232+ bimap
233+ (hlabel labeler . toResults' @exprs1)
234+ (hlabel labeler . toResults' @exprs2)
49
235
50
236
51−instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a]
237+instance
238+ ( ToExprs a exprs
239+ , IsListTabular a ~ 'True
240+ , x ~ ListTable exprs
241+ ) => ExprsFor 'False 'True [a] x
242+ where
243+ fromResults = fmap (fromResults' @exprs) . fromHListTable
244+ toResults = toHListTable . fmap (toResults' @exprs)
52
245
53
246
54−instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a)
247+instance
248+ ( ToExprs a exprs
249+ , IsMaybeTabular a ~ 'True
250+ , x ~ MaybeTable exprs
251+ ) => ExprsFor 'False 'True (Maybe a) x
252+ where
253+ fromResults =
254+ fmap (fromResults' @exprs . hunlabel unlabeler) .
255+ fromHMaybeTable
256+ toResults =
257+ toHMaybeTable .
258+ fmap (hlabel labeler . toResults' @exprs)
55
259
56
260
57−instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a)
261+instance
262+ ( ToExprs a exprs
263+ , IsListTabular a ~ 'True
264+ , x ~ NonEmptyTable exprs
265+ ) => ExprsFor 'False 'True (NonEmpty a) x
266+ where
267+ fromResults = fmap (fromResults' @exprs) . fromHNonEmptyTable
268+ toResults = toHNonEmptyTable . fmap (toResults' @exprs)
58
269
59
270
60−instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>
271+instance
61− ToExprs x (a, b)
272+ ( ToExprs a exprs1
273+ , ToExprs b exprs2
274+ , isTabular ~ 'True
275+ , x ~ TheseTable exprs1 exprs2
276+ ) => ExprsFor 'False isTabular (These a b) x
277+ where
278+ fromResults =
279+ bimap
280+ (fromResults' @exprs1 . hunlabel unlabeler)
281+ (fromResults' @exprs2 . hunlabel unlabeler) .
282+ fromHTheseTable
283+ toResults =
284+ toHTheseTable .
285+ bimap
286+ (hlabel labeler . toResults' @exprs1)
287+ (hlabel labeler . toResults' @exprs2)
62
288
63
289
64instance
290instance
65− ( ToExprs exprs1 a
291+ ( ToExprs a exprs1
66− , ToExprs exprs2 b
292+ , ToExprs b exprs2
67− , ToExprs exprs3 c
293+ , isTabular ~ 'True
294+ , x ~ (exprs1, exprs2)
295+ ) => ExprsFor 'False isTabular (a, b) x
296+ where
297+ fromResults (HPair a b) =
298+ ( fromResults' @exprs1 $ hunlabel unlabeler a
299+ , fromResults' @exprs2 $ hunlabel unlabeler b
300+ )
301+ toResults (a, b) = HPair
302+ { hfst = hlabel labeler $ toResults' @exprs1 a
303+ , hsnd = hlabel labeler $ toResults' @exprs2 b
304+ }
305+
306+
307+instance
308+ ( ToExprs a exprs1
309+ , ToExprs b exprs2
310+ , ToExprs c exprs3
311+ , isTabular ~ 'True
68 , x ~ (exprs1, exprs2, exprs3)
312 , x ~ (exprs1, exprs2, exprs3)
69− )
313+ ) => ExprsFor 'False isTabular (a, b, c) x
70− => ToExprs x (a, b, c)
314+ where
315+ fromResults (HTrio a b c) =
316+ ( fromResults' @exprs1 $ hunlabel unlabeler a
317+ , fromResults' @exprs2 $ hunlabel unlabeler b
318+ , fromResults' @exprs3 $ hunlabel unlabeler c
319+ )
320+ toResults (a, b, c) = HTrio
321+ { hfst = hlabel labeler $ toResults' @exprs1 a
322+ , hsnd = hlabel labeler $ toResults' @exprs2 b
323+ , htrd = hlabel labeler $ toResults' @exprs3 c
324+ }
71
325
72
326
73instance
327instance
74− ( ToExprs exprs1 a
328+ ( ToExprs a exprs1
75− , ToExprs exprs2 b
329+ , ToExprs b exprs2
76− , ToExprs exprs3 c
330+ , ToExprs c exprs3
77− , ToExprs exprs4 d
331+ , ToExprs d exprs4
332+ , isTabular ~ 'True
78 , x ~ (exprs1, exprs2, exprs3, exprs4)
333 , x ~ (exprs1, exprs2, exprs3, exprs4)
79− )
334+ ) => ExprsFor 'False isTabular (a, b, c, d) x
80− => ToExprs x (a, b, c, d)
335+ where
336+ fromResults (HQuartet a b c d) =
337+ ( fromResults' @exprs1 $ hunlabel unlabeler a
338+ , fromResults' @exprs2 $ hunlabel unlabeler b
339+ , fromResults' @exprs3 $ hunlabel unlabeler c
340+ , fromResults' @exprs4 $ hunlabel unlabeler d
341+ )
342+ toResults (a, b, c, d) = HQuartet
343+ { hfst = hlabel labeler $ toResults' @exprs1 a
344+ , hsnd = hlabel labeler $ toResults' @exprs2 b
345+ , htrd = hlabel labeler $ toResults' @exprs3 c
346+ , hfrt = hlabel labeler $ toResults' @exprs4 d
347+ }
81
348
82
349
83instance
350instance
84− ( ToExprs exprs1 a
351+ ( ToExprs a exprs1
85− , ToExprs exprs2 b
352+ , ToExprs b exprs2
86− , ToExprs exprs3 c
353+ , ToExprs c exprs3
87− , ToExprs exprs4 d
354+ , ToExprs d exprs4
88− , ToExprs exprs5 e
355+ , ToExprs e exprs5
356+ , isTabular ~ 'True
89 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
357 , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
90− )
358+ ) => ExprsFor 'False isTabular (a, b, c, d, e) x
91− => ToExprs x (a, b, c, d, e)
359+ where
360+ fromResults (HQuintet a b c d e) =
361+ ( fromResults' @exprs1 $ hunlabel unlabeler a
362+ , fromResults' @exprs2 $ hunlabel unlabeler b
363+ , fromResults' @exprs3 $ hunlabel unlabeler c
364+ , fromResults' @exprs4 $ hunlabel unlabeler d
365+ , fromResults' @exprs5 $ hunlabel unlabeler e
366+ )
367+ toResults (a, b, c, d, e) = HQuintet
368+ { hfst = hlabel labeler $ toResults' @exprs1 a
369+ , hsnd = hlabel labeler $ toResults' @exprs2 b
370+ , htrd = hlabel labeler $ toResults' @exprs3 c
371+ , hfrt = hlabel labeler $ toResults' @exprs4 d
372+ , hfft = hlabel labeler $ toResults' @exprs5 e
373+ }
92
374
93
375
94instance
376instance
95− ( ToExprs exprs1 a
377+ ( HTable t
96− , ToExprs exprs2 b
378+ , isTabular ~ 'True
97− , ToExprs exprs3 c
379+ , result ~ H Result
98− , ToExprs exprs4 d
380+ , x ~ t (H DB)
99− , ToExprs exprs5 e
381+ ) => ExprsFor 'False isTabular (t result) x
100− , ToExprs exprs6 f
382+ where
101− , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6)
383+ fromResults = id
102− )
384+ toResults = id
103− => ToExprs x (a, b, c, d, e, f)
104
385
105
386
106instance
387instance
107− ( ToExprs exprs1 a
388+ ( Encodes (t Result) (t DB)
108− , ToExprs exprs2 b
389+ , isTabular ~ 'True
109− , ToExprs exprs3 c
390+ , result ~ Result
110− , ToExprs exprs4 d
391+ , x ~ t DB
111− , ToExprs exprs5 e
392+ ) => ExprsFor 'False isTabular (t result) x
112− , ToExprs exprs6 f
393+ where
113− , ToExprs exprs7 g
394+ fromResults = fromColumns
114− , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6, exprs7)
395+ toResults = toColumns
115− )
396+
116− => ToExprs x (a, b, c, d, e, f, g)
397+
398+instance
399+ ( KnownSpec spec
400+ , isTabular ~ 'True
401+ , x ~ DB spec
402+ ) => ExprsFor 'False isTabular (Result spec) x
403+ where
404+ fromResults = fromColumns
405+ toResults = toColumns
406+
407+
408+type FromExprs :: Type -> Type
409+type family FromExprs a where
410+ FromExprs (Expr a) = a
411+ FromExprs (DB spec) = Result spec
412+ FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
413+ FromExprs (ListTable a) = [FromExprs a]
414+ FromExprs (MaybeTable a) = Maybe (FromExprs a)
415+ FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)
416+ FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
417+ FromExprs (a, b) = (FromExprs a, FromExprs b)
418+ FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)
419+ FromExprs (a, b, c, d) =
420+ (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
421+ FromExprs (a, b, c, d, e) =
422+ (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
423+ FromExprs (t DB) = t Result
424+ FromExprs (t (H DB)) = t (H Result)
117
425
118
426
119-- | @Serializable@ witnesses the one-to-one correspondence between the type
427-- | @Serializable@ witnesses the one-to-one correspondence between the type
120-- @sql@, which contains SQL expressions, and the type @haskell@, which
428-- @sql@, which contains SQL expressions, and the type @haskell@, which
121-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
429-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
122−type Serializable :: Type -> Type -> Constraint
430+class (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
123−class (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
431+instance (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a
124−instance (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a
432+instance Serializable (Expr Opaque) Opaque
125−instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a
126
433
127
434
128−-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is
129−-- capable of lifting single @Expr@s to full tables.
130lit :: forall exprs a. Serializable exprs a => a -> exprs
435lit :: forall exprs a. Serializable exprs a => a -> exprs
131−lit = fromColumns . litHTable . toResult @_ @exprs
436+lit = fromColumns . litTable . toResults' @exprs
132
437
133
438
134parse :: forall exprs a. Serializable exprs a => Hasql.Row a
439parse :: forall exprs a. Serializable exprs a => Hasql.Row a
135−parse = fromResult @_ @exprs <$> parseHTable
440+parse = fromResults' @exprs <$> parseTable
136
441
137
442
138−litHTable :: HTable t => t Result -> t Expr
443+litTable :: Encodes a b => a -> b
139−litHTable as = htabulate $ \field ->
444+litTable (toColumns -> as) = fromColumns $ htabulate $ \field ->
140 case hfield hspecs field of
445 case hfield hspecs field of
141− Spec {nullity, info} -> case hfield as field of
446+ SSpec {nullability, info} -> case hfield as field of
142− Identity value -> slitExpr nullity info value
447+ Result value -> DB (slitExpr nullability info value)
143
448
144
449
145−parseHTable :: HTable t => Hasql.Row (t Result)
450+parseTable :: Table Result a => Hasql.Row a
146−parseHTable = unwrapApplicative $ htabulateA $ \field ->
451+parseTable = fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->
147 WrapApplicative $ case hfield hspecs field of
452 WrapApplicative $ case hfield hspecs field of
148− Spec {nullity, info} -> Identity <$> sparseValue nullity info
453+ SSpec {nullability, info} -> Result <$> sparseValue nullability info
src/Rel8/Table/These.hs+110−234
@@ -5,122 +5,85 @@
5{-# language FlexibleInstances #-}
5{-# language FlexibleInstances #-}
6{-# language MultiParamTypeClasses #-}
6{-# language MultiParamTypeClasses #-}
7{-# language NamedFieldPuns #-}
7{-# language NamedFieldPuns #-}
8−{-# language ScopedTypeVariables #-}
9{-# language StandaloneKindSignatures #-}
8{-# language StandaloneKindSignatures #-}
10{-# language TupleSections #-}
9{-# language TupleSections #-}
11−{-# language TypeApplications #-}
12{-# language TypeFamilies #-}
10{-# language TypeFamilies #-}
13{-# language UndecidableInstances #-}
11{-# language UndecidableInstances #-}
14
12
15−{-# options_ghc -fno-warn-orphans #-}
16−
17module Rel8.Table.These
13module Rel8.Table.These
18 ( TheseTable(..)
14 ( TheseTable(..)
19 , theseTable, thisTable, thatTable, thoseTable
15 , theseTable, thisTable, thatTable, thoseTable
20 , isThisTable, isThatTable, isThoseTable
16 , isThisTable, isThatTable, isThoseTable
21 , hasHereTable, hasThereTable
17 , hasHereTable, hasThereTable
22 , justHereTable, justThereTable
18 , justHereTable, justThereTable
23− , alignMaybeTable
24− , aggregateTheseTable
25− , nameTheseTable
26 )
19 )
27where
20where
28
21
29-- base
22-- base
30import Data.Bifunctor ( Bifunctor, bimap )
23import Data.Bifunctor ( Bifunctor, bimap )
24+import Data.Functor.Identity ( runIdentity )
31import Data.Kind ( Type )
25import Data.Kind ( Type )
32−import Data.Maybe ( isJust )
26+import Prelude hiding ( undefined )
33−import Prelude hiding ( null, undefined )
34
27
35-- rel8
28-- rel8
36−import Rel8.Aggregate ( Aggregate )
37import Rel8.Expr ( Expr )
29import Rel8.Expr ( Expr )
38−import Rel8.Expr.Bool ( (&&.), (||.), boolExpr, not_ )
30+import Rel8.Expr.Bool ( (&&.), not_ )
39−import Rel8.Expr.Null ( null, isNonNull )
31+import Rel8.Expr.Null ( isNonNull )
40−import Rel8.Kind.Context ( Reifiable )
32+import Rel8.Schema.Context ( DB )
41−import Rel8.Schema.Context.Nullify ( Nullifiable )
33+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
42−import Rel8.Schema.Dict ( Dict( Dict ) )
34+import Rel8.Schema.Context.Nullify
43−import Rel8.Schema.HTable.Label ( hlabel, hrelabel, hunlabel )
35+ ( Nullifiable, NullifiableEq
36+ , encodeTag, decodeTag
37+ , nullifier, unnullifier
38+ )
39+import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
44import Rel8.Schema.HTable.Identity ( HIdentity(..) )
40import Rel8.Schema.HTable.Identity ( HIdentity(..) )
45−import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
41+import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
46import Rel8.Schema.HTable.These ( HTheseTable(..) )
42import Rel8.Schema.HTable.These ( HTheseTable(..) )
47−import qualified Rel8.Schema.Kind as K
43+import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
48−import Rel8.Schema.Name ( Name )
44+import Rel8.Table.Lifted
49−import Rel8.Table
45+ ( Table1, Columns1, ConstrainContext1, fromColumns1, toColumns1
50− ( Table, Columns, Context, fromColumns, toColumns
46+ , Table2, Columns2, ConstrainContext2, fromColumns2, toColumns2
51− , FromExprs, fromResult, toResult
52− , Transpose
53 )
47 )
54−import Rel8.Table.Eq ( EqTable, eqTable )
55import Rel8.Table.Maybe
48import Rel8.Table.Maybe
56 ( MaybeTable(..)
49 ( MaybeTable(..)
57 , maybeTable, justTable, nothingTable
50 , maybeTable, justTable, nothingTable
58 , isJustTable
51 , isJustTable
59− , aggregateMaybeTable
60− , nameMaybeTable
61 )
52 )
62−import Rel8.Table.Nullify ( Nullify, guard )
53+import Rel8.Table.Recontextualize ( Recontextualize )
63−import Rel8.Table.Ord ( OrdTable, ordTable )
64−import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )
65−import Rel8.Table.Serialize ( ToExprs )
66import Rel8.Table.Undefined ( undefined )
54import Rel8.Table.Undefined ( undefined )
67−import Rel8.Type.Tag ( MaybeTag )
68
55
69-- semigroupoids
56-- semigroupoids
70import Data.Functor.Apply ( Apply, (<.>) )
57import Data.Functor.Apply ( Apply, (<.>) )
71import Data.Functor.Bind ( Bind, (>>-) )
58import Data.Functor.Bind ( Bind, (>>-) )
72
59
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
91
60
92−
61+type TheseTable :: Type -> Type -> Type
93−instance Biprojectable (TheseTable context) where
62+data TheseTable a b = TheseTable
94− biproject f g (TheseTable a b) = TheseTable (project f a) (project g b)
63+ { here :: MaybeTable a
64+ , there :: MaybeTable b
65+ }
66+ deriving stock (Show, Functor)
95
67
96
68
97−instance Nullifiable context => Bifunctor (TheseTable context) where
69+instance Bifunctor TheseTable where
98 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
70 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
99
71
100
72
101−instance Projectable (TheseTable context a) where
73+instance (Table DB a, Semigroup a) => Apply (TheseTable 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
108 fs <.> as = TheseTable
74 fs <.> as = TheseTable
109 { here = here fs <> here as
75 { here = here fs <> here as
110 , there = there fs <.> there as
76 , there = there fs <.> there as
111 }
77 }
112
78
113
79
114−instance (context ~ Expr, Table Expr a, Semigroup a) =>
80+instance (Table DB a, Semigroup a) => Applicative (TheseTable a)
115− Applicative (TheseTable context a)
116 where
81 where
117 pure = thatTable
82 pure = thatTable
118 (<*>) = (<.>)
83 (<*>) = (<.>)
119
84
120
85
121−instance (context ~ Expr, Table Expr a, Semigroup a) =>
86+instance (Table DB a, Semigroup a) => Bind (TheseTable a) where
122− Bind (TheseTable context a)
123− where
124 TheseTable here1 ma >>- f = case ma >>- f' of
87 TheseTable here1 ma >>- f = case ma >>- f' of
125 mtb -> TheseTable
88 mtb -> TheseTable
126 { here = maybeTable here1 ((here1 <>) . fst) mtb
89 { here = maybeTable here1 ((here1 <>) . fst) mtb
@@ -131,14 +94,12 @@ instance (context ~ Expr, Table Expr a, Semigroup a) =>
131 TheseTable here2 mb -> (here2,) <$> mb
94 TheseTable here2 mb -> (here2,) <$> mb
132
95
133
96
134−instance (context ~ Expr, Table Expr a, Semigroup a) =>
97+instance (Table DB a, Semigroup a) => Monad (TheseTable a) where
135− Monad (TheseTable context a)
136− where
137 (>>=) = (>>-)
98 (>>=) = (>>-)
138
99
139
100
140−instance (context ~ Expr, Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
101+instance (Table DB a, Table DB b, Semigroup a, Semigroup b) =>
141− Semigroup (TheseTable context a b)
102+ Semigroup (TheseTable a b)
142 where
103 where
143 a <> b = TheseTable
104 a <> b = TheseTable
144 { here = here a <> here b
105 { here = here a <> here b
@@ -146,212 +107,127 @@ instance (context ~ Expr, Table Expr a, Table Expr b, Semigroup a, Semigroup b)
146 }
107 }
147
108
148
109
149−instance
110+instance Table2 TheseTable where
150− ( Table context a, Table context b
111+ type Columns2 TheseTable = HTheseTable
151− , Reifiable context, context ~ context'
112+ type ConstrainContext2 TheseTable = Nullifiable
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− }
170
113
171− fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable
114+ toColumns2 f g TheseTable {here, there} = HTheseTable
172− { here = MaybeTable
115+ { hhereTag = HIdentity $ encodeTag (tag here)
173− { tag = unHIdentity $ hunlabel hhereTag
116+ , hhere = hnullify (nullifier (isNonNull (tag here))) $ f (just here)
174− , just = fromColumns $ hunlabel hhere
117+ , hthereTag = HIdentity $ encodeTag (tag there)
175− }
118+ , hthere = hnullify (nullifier (isNonNull (tag there))) $ g (just there)
176− , there = MaybeTable
177− { tag = unHIdentity $ hunlabel hthereTag
178− , just = fromColumns $ hunlabel hthere
179− }
180 }
119 }
181
120
182− toResult tables = HTheseTable
121+ fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} =
183− { hhereTag = hrelabel hhereTag
122+ TheseTable
184− , hhere = hrelabel hhere
123+ { here =
185− , hthereTag = hrelabel hthereTag
124+ let
186− , hthere = hrelabel hthere
125+ tag = decodeTag $ unHIdentity hhereTag
187− }
126+ in
188− where
127+ MaybeTable
189− HMaybeTable
128+ { tag
190− { htag = hhereTag
129+ , just = f $
191− , hjust = hhere
130+ runIdentity $
192− } = toResult @_ @(MaybeTable context a) (justHere tables)
131+ hunnullify (\a -> pure . unnullifier (isNonNull tag) a)
193− HMaybeTable
132+ hhere
194− { htag = hthereTag
133+ }
195− , hjust = hthere
134+ , there =
196− } = toResult @_ @(MaybeTable context b) (justThere tables)
135+ let
197−
136+ tag = decodeTag $ unHIdentity hthereTag
198− fromResult HTheseTable {hhereTag, hhere, hthereTag, hthere} =
137+ in
199− case (here, there) of
138+ MaybeTable
200− (Just a, Nothing) -> This a
139+ { tag
201− (Nothing, Just b) -> That b
140+ , just = g $
202− (Just a, Just b) -> These a b
141+ runIdentity $
203− _ -> error "These.fromColumns: mismatch between tags and data"
142+ hunnullify (\a -> pure . unnullifier (isNonNull tag) a)
204− where
143+ hthere
205− here = fromResult @_ @(MaybeTable context a) mhere
144+ }
206− there = fromResult @_ @(MaybeTable context b) mthere
145+ }
207− mhere = HMaybeTable
146+
208− { htag = hrelabel hhereTag
147+ {-# INLINABLE fromColumns2 #-}
209− , hjust = hrelabel hhere
148+ {-# INLINABLE toColumns2 #-}
210− }
149+
211− mthere = HMaybeTable
150+
212− { htag = hrelabel hthereTag
151+instance Table context a => Table1 (TheseTable a) where
213− , hjust = hrelabel hthere
152+ type Columns1 (TheseTable a) = HTheseTable (Columns a)
214− }
153+ type ConstrainContext1 (TheseTable a) = NullifiableEq (Context a)
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− }
226
154
155+ toColumns1 = toColumns2 toColumns
156+ fromColumns1 = fromColumns2 fromColumns
227
157
228−instance (OrdTable a, OrdTable b, context ~ Expr) =>
158+
229− OrdTable (TheseTable context a b)
159+instance
160+ ( Table context a, Table context b
161+ , Labelable context, Nullifiable context
162+ ) => Table context (TheseTable a b)
230 where
163 where
231− ordTable = HTheseTable
164+ type Columns (TheseTable a b) =
232− { hhereTag = hlabel (HIdentity Dict)
165+ HTheseTable (HLabel "Here" (Columns a)) (HLabel "There" (Columns b))
233− , hhere = hlabel (ordTable @(Nullify context a))
166+ type Context (TheseTable a b) = Context a
234− , hthereTag = hlabel (HIdentity Dict)
235− , hthere = hlabel (ordTable @(Nullify context b))
236− }
237
167
168+ toColumns =
169+ toColumns2
170+ (hlabel labeler . toColumns)
171+ (hlabel labeler . toColumns)
172+ fromColumns =
173+ fromColumns2
174+ (fromColumns . hunlabel unlabeler)
175+ (fromColumns . hunlabel unlabeler)
238
176
239−instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable Expr exprs1 exprs2) =>
240− ToExprs x (These a b)
241
177
178+instance
179+ ( Labelable from, Nullifiable from
180+ , Labelable to, Nullifiable to
181+ , Recontextualize from to a1 b1
182+ , Recontextualize from to a2 b2
183+ ) =>
184+ Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2)
242
185
243−-- | Test if a 'TheseTable' was constructed with 'thisTable'.
186+
244−--
187+isThisTable :: TheseTable a b -> Expr Bool
245−-- Corresponds to 'Data.These.Combinators.isThis'.
246−isThisTable :: TheseTable Expr a b -> Expr Bool
247isThisTable a = hasHereTable a &&. not_ (hasThereTable a)
188isThisTable a = hasHereTable a &&. not_ (hasThereTable a)
248
189
249
190
250−-- | Test if a 'TheseTable' was constructed with 'thatTable'.
191+isThatTable :: TheseTable a b -> Expr Bool
251−--
252−-- Corresponds to 'Data.These.Combinators.isThat'.
253−isThatTable :: TheseTable Expr a b -> Expr Bool
254isThatTable a = not_ (hasHereTable a) &&. hasThereTable a
192isThatTable a = not_ (hasHereTable a) &&. hasThereTable a
255
193
256
194
257−-- | Test if a 'TheseTable' was constructed with 'thoseTable'.
195+isThoseTable :: TheseTable a b -> Expr Bool
258−--
259−-- Corresponds to 'Data.These.Combinators.isThese'.
260−isThoseTable :: TheseTable Expr a b -> Expr Bool
261isThoseTable a = hasHereTable a &&. hasThereTable a
196isThoseTable a = hasHereTable a &&. hasThereTable a
262
197
263
198
264−-- | Test if the @a@ side of @TheseTable a b@ is present.
199+hasHereTable :: TheseTable a b -> Expr Bool
265−--
266−-- Corresponds to 'Data.These.Combinators.hasHere'.
267−hasHereTable :: TheseTable Expr a b -> Expr Bool
268hasHereTable TheseTable {here} = isJustTable here
200hasHereTable TheseTable {here} = isJustTable here
269
201
270
202
271−-- | Test if the @b@ table of @TheseTable a b@ is present.
203+hasThereTable :: TheseTable a b -> Expr Bool
272−--
273−-- Corresponds to 'Data.These.Combinators.hasThere'.
274−hasThereTable :: TheseTable Expr a b -> Expr Bool
275hasThereTable TheseTable {there} = isJustTable there
204hasThereTable TheseTable {there} = isJustTable there
276
205
277
206
278−-- | Attempt to project out the @a@ table of a @TheseTable a b@.
207+justHereTable :: TheseTable a b -> MaybeTable a
279−--
280−-- Corresponds to 'Data.These.Combinators.justHere'.
281−justHereTable :: TheseTable context a b -> MaybeTable context a
282justHereTable = here
208justHereTable = here
283
209
284
210
285−-- | Attempt to project out the @b@ table of a @TheseTable a b@.
211+justThereTable :: TheseTable a b -> MaybeTable b
286−--
287−-- Corresponds to 'Data.These.Combinators.justThere'.
288−justThereTable :: TheseTable context a b -> MaybeTable context b
289justThereTable = there
212justThereTable = there
290
213
291
214
292−-- | Construct a @TheseTable@ from two 'MaybeTable's.
215+thisTable :: Table DB b => a -> TheseTable a b
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
304thisTable a = TheseTable (justTable a) nothingTable
216thisTable a = TheseTable (justTable a) nothingTable
305
217
306
218
307−-- | Construct a @TheseTable@. Corresponds to 'That'.
219+thatTable :: Table DB a => b -> TheseTable a b
308−thatTable :: Table Expr a => b -> TheseTable Expr a b
309thatTable b = TheseTable nothingTable (justTable b)
220thatTable b = TheseTable nothingTable (justTable b)
310
221
311
222
312−-- | Construct a @TheseTable@. Corresponds to 'These'.
223+thoseTable :: a -> b -> TheseTable a b
313−thoseTable :: a -> b -> TheseTable Expr a b
314thoseTable a b = TheseTable (justTable a) (justTable b)
224thoseTable a b = TheseTable (justTable a) (justTable b)
315
225
316
226
317−-- | Pattern match on a 'TheseTable'. Corresponds to 'these'.
227+theseTable :: Table DB c
318−theseTable :: Table Expr c
228+ => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable a b -> c
319− => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable Expr a b -> c
320theseTable f g h TheseTable {here, there} =
229theseTable f g h TheseTable {here, there} =
321 maybeTable
230 maybeTable
322 (maybeTable undefined f here)
231 (maybeTable undefined f here)
323 (\b -> maybeTable (g b) (`h` b) here)
232 (\b -> maybeTable (g b) (`h` b) here)
324 there
233 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+7−7
@@ -11,16 +11,16 @@ where
11import Prelude hiding ( undefined )
11import Prelude hiding ( undefined )
12
12
13-- rel8
13-- rel8
14−import Rel8.Expr ( Expr )
15import Rel8.Expr.Null ( snull, unsafeUnnullify )
14import Rel8.Expr.Null ( snull, unsafeUnnullify )
15+import Rel8.Schema.Context ( DB( DB ) )
16import Rel8.Schema.HTable ( htabulate, hfield, hspecs )
16import Rel8.Schema.HTable ( htabulate, hfield, hspecs )
17−import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
17+import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
18−import Rel8.Schema.Spec ( Spec(..) )
18+import Rel8.Schema.Spec ( SSpec(..) )
19import Rel8.Table ( Table, fromColumns )
19import Rel8.Table ( Table, fromColumns )
20
20
21
21
22−undefined :: Table Expr a => a
22+undefined :: Table DB a => a
23undefined = fromColumns $ htabulate $ \field -> case hfield hspecs field of
23undefined = fromColumns $ htabulate $ \field -> case hfield hspecs field of
24− Spec {nullity, info} -> case nullity of
24+ SSpec {nullability, info} -> case nullability of
25− Null -> snull info
25+ Nullable -> DB (snull Nullable info)
26− NotNull -> unsafeUnnullify (snull info)
26+ 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+141−549

This diff is too big to show here.

src/Rel8/Type.hs+53−28

This diff is too big to show here.

src/Rel8/Type/Array.hs+36−56

This diff is too big to show here.

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

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+39−8

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+10−10

This diff is too big to show here.

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

This diff is too big to show here.

src/Rel8/Type/Ord.hs+19−18

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−13

This diff is too big to show here.

src/Rel8/Type/String.hs−5

This diff is too big to show here.

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

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+237−340

This diff is too big to show here.

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

This diff is too big to show here.