on master help sign in
.github/workflows/build.yaml+7−2
since splitsnapshots
unifiedsplit
@@ -9,13 +9,18 @@ jobs:
9 persist-credentials: false
9 persist-credentials: false
10 submodules: true
10 submodules: true
11
11
12− - uses: cachix/install-nix-action@v12
12+ - uses: cachix/install-nix-action@v14.1
13 with:
13 with:
14 nix_path: nixpkgs=channel:nixos-unstable
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
15
18
16− - uses: cachix/cachix-action@v8
19+ - uses: cachix/cachix-action@v10
17 with:
20 with:
18 name: rel8
21 name: rel8
19 authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}'
22 authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}'
20
23
21 - run: nix-build -A hsPkgs.rel8.components.library
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.mdnew file+159
@@ -0,0 +1,159 @@
1+# 1.4.0.0 (2002-08-17)
2+
3+## Breaking changes
4+
5+* The behavior of `greatest`/`least` has been corrected, and was previously flipped. ([#183](https://github.com/circuithub/rel8/pull/183))
6+
7+## New features
8+
9+* `NullTable`/`HNull` have been added. This is an alternative to `MaybeTable` that doesn't use a tag columns. It's less flexible (no `Functor` or `Applicative` instance) and is meaningless when used with a table that has no non-nullable columns (so nesting `NullTable` is redundant). But in situations where the underlying `Table` does have non-nullable columns, it can losslessly converted to and from `MaybeTable`. It is useful for embedding into a base table when you don't want to store the extra tag column in your schema. ([#173](https://github.com/circuithub/rel8/pull/173))
10+* Add `fromMaybeTable`. ([#179](https://github.com/circuithub/rel8/pull/179))
11+* Add `alignMaybeTable`. ([#196](https://github.com/circuithub/rel8/pull/196))
12+
13+## Improvements
14+
15+* Optimize implementation of `AltTable` for `Tabulation` ([#178](https://github.com/circuithub/rel8/pull/178))
16+
17+## Other
18+
19+* Documentation improvements for `HADT`. ([#177](https://github.com/circuithub/rel8/pull/177))
20+* Document example usage of `groupBy`. ([#184](https://github.com/circuithub/rel8/pull/184))
21+* Build with and require Opaleye >= 0.9.3.3. ([#190](https://github.com/circuithub/rel8/pull/190))
22+* Build with `hasql` 1.6. ([#195](https://github.com/circuithub/rel8/pull/195))
23+
24+# 1.3.1.0 (2022-01-20)
25+
26+## Other
27+
28+* Rel8 now requires Opaleye >= 0.9.1. ([#165](https://github.com/circuithub/rel8/pull/165))
29+
30+# 1.3.0.0 (2022-01-31)
31+
32+## Breaking changes
33+
34+* `div` and `mod` have been changed to match Haskell semantics. If you need the PostgreSQL `div()` and `mod()` functions, use `quot` and `rem`. While this is not an API change, we feel this is a breaking change in semantics and have bumped the major version number. ([#155](https://github.com/circuithub/rel8/pull/155))
35+
36+## New features
37+
38+* `divMod` and `quotRem` functions have been added, matching Haskell's `Prelude` functions. ([#155](https://github.com/circuithub/rel8/pull/155))
39+* `avg` and `mode` aggregation functions to find the mean value of an expression, or the most common row in a query, respectively. ([#152](https://github.com/circuithub/rel8/pull/152))
40+* The full `EqTable` and `OrdTable` classes have been exported, allowing for instances to be manually created. ([#157](https://github.com/circuithub/rel8/pull/157))
41+* Added `like` and `ilike` (for the `LIKE` and `ILIKE` operators). ([#146](https://github.com/circuithub/rel8/pull/146))
42+
43+## Other
44+
45+* Rel8 now requires Opaleye 0.9. ([#158](https://github.com/circuithub/rel8/pull/158))
46+* Rel8's test suite supports Hedgehog 1.1. ([#160](https://github.com/circuithub/rel8/pull/160))
47+* The documentation for binary operations has been corrected. ([#162](https://github.com/circuithub/rel8/pull/162))
48+
49+# 1.2.2.0 (2021-11-21)
50+
51+## Other
52+
53+* Support GHC 9.2 ([#145](https://github.com/circuithub/rel8/pull/145))
54+* Correct the documentation for `except` ([#147](https://github.com/circuithub/rel8/pull/147))
55+* Support `hasql` 1.5 ([#149](https://github.com/circuithub/rel8/pull/149))
56+
57+# 1.2.1.0 (2021-11-21)
58+
59+## New features
60+
61+* `castTable` has been added, which casts all columns selected from in `Query` according to the types of columns. This can occasionally be useful when using `many`/`some` on older PostgreSQL versions. ([#137](https://github.com/circuithub/rel8/pull/137))
62+
63+* Added `<:`, `<=:`, `>:`, `>=:`, `greatest` and `least`, which sort all columns in a table lexicographically. These operators are like the `<.` operators which operate on `Expr`s, but the `<:` operate on entire tables. ([#139](https://github.com/circuithub/rel8/pull/139))
64+
65+## Other
66+
67+* Support opaleye-0.8 ([#142](https://github.com/circuithub/rel8/pull/142))
68+
69+# 1.2.0.0 (2021-10-22)
70+
71+## New features
72+
73+* New `$*` and `$+` operators for projecting out of `ListTable` and `NonEmptyTable` respectively (analogous to the existing `$?` for `MaybeTable`). ([#125](https://github.com/circuithub/rel8/pull/125))
74+
75+## Bug fixes
76+
77+* Fix `UPSERT` support (and add tests), which was broken due to a typo inside Rel8 that made it impossible to construct `Projection`s which are needed by `UPSERT`. ([#134](https://github.com/circuithub/rel8/pull/134))
78+
79+* Remove `DBMin` and `DBMax` instances for `Bool`, which are invalid as far as Postgres is concerned. `and` and `or` can be used to achieve the same thing. ([#126](https://github.com/circuithub/rel8/pull/126))
80+
81+* Fix `aggregateMaybeTable`, `aggregateEitherTable` and `aggregateTheseTable`, which generated invalid SQL previously. ([#127](https://github.com/circuithub/rel8/pull/127))
82+
83+## Breaking changes
84+
85+* `rebind` now takes an additional argument for the "name" of the binding. ([#128](https://github.com/circuithub/rel8/pull/128))
86+
87+# 1.1.0.0 (2021-07-16)
88+
89+## New features
90+
91+* You can derive `Rel8able` for "vanilla" higher-kinded data types - data types that don't use the `Column` type family. For example, the following is now possible:
92+
93+ ```haskell
94+ data MyTable f = MyTable
95+ { myTableX :: f Int32
96+ , myTableY :: f Text
97+ } deriving (Generic, Rel8able)
98+ ```
99+
100+* The `Projectable` and `Biprojectable` type classes have been introduced. These classes model a type of functors and bifunctors (respectively) on tables, where the mapping function is only able to rearrange columns. For example, the following is now possible:
101+
102+ ```haskell
103+ x <- project myTableX <$> many ...
104+ ```
105+
106+* `Insert`'s `onConflict` field now has a new option - `DoUpdate`. This maps to PostgreSQL's `ON CONFLICT DO UPDATE` syntax, which provides upsert support. ([#85](https://github.com/circuithub/rel8/pull/85))
107+
108+* `Insert`, `Update` and `Delete` has all been expanded to work with `Query`s. In particular:
109+
110+ * `Delete` now supports a `USING` sub-query
111+ * `Update` now supports a `FROM` sub-query
112+ * `Insert` can delete the result of any arbitrary `Query` (providing the types match)
113+
114+* The new `Rel8.Tabulate` module has been added, which gives a `Map`-esque interface to writing and composing queries. ([#70](https://github.com/circuithub/rel8/pull/70))
115+
116+* The new `indexed` `Query -> Query` function was added. This function augments each row in a query with it's 0-based index. ([#117](https://github.com/circuithub/rel8/pull/117))
117+
118+## Breaking changes
119+
120+* `Insert`, `Delete` and `Update` have all changed. In particular, for `Insert` users should now replace `rows = xs` with `rows = values xs`. ([#85](https://github.com/circuithub/rel8/pull/85))
121+
122+* Rename `whereExists` and `whereNotExists` to `present` and `absent` respectively. ([#57](https://github.com/circuithub/rel8/pull/57))
123+
124+* Simplify `evaluate` to run directly inside the `Query` monad, rendering the `Evaluate` monad unnecessary. ([#56](https://github.com/circuithub/rel8/pull/56))
125+
126+* The `Labelable` type class has been removed as it's no longer necessary. This class was mostly internal, though was visible in some public API functions. ([#76](https://github.com/circuithub/rel8/pull/76))
127+
128+* `EitherTable`, `ListTable`, `MaybeTable`, `NonEmptyTable` and `TheseTable` now all have an extra parameter which tracks the context of the table. If you manually specified any types before, you need to provide this parameter - usually `Expr` will be the correct choice. ([#101](https://github.com/circuithub/rel8/pull/101))
129+
130+* We've done a lot of work to simplify the internals of Rel8, but some of these are breaking changes. However, most of these API changes shouldn't affect users as they are mostly types used in type inference, or affect classes where users don't need to define their own instances.
131+
132+ * The kind of a `Rel8able` is now `(Type -> Type) -> Type`. Previously it was `(X -> Type) -> Type`.
133+ * `Table` has a new associated type - `FromExprs`. This was previously an open type family.
134+ * `Table` has a new associated type - `Transpose` - and `Recontextualise` has been renamed to `Transposes`. This `Transposes` class now operates in terms of `Transpose`.
135+
136+* `select`, `insert`, `update` and `delete` now produce Hasql `Statement`s, rather than actually running the statement as IO. This allows Rel8 to be used with transaction/connection-managing monads like [`hasql-transaction`](https://hackage.haskell.org/package/hasql-transaction). ([#94](https://github.com/circuithub/rel8/pull/94))
137+
138+## Bug fixes
139+
140+* Fixes a bug where cartesian products of queries using `catListTable`, `catNonEmptyTable`, `catList` and `catNonEmpty` would incorrectly be zipped instead. ([#61](https://github.com/circuithub/rel8/pull/61))
141+
142+* Require Opaleye 0.7.3.0. This version has better support for lateral queries, which can improve query plans, especially in `optional`/`LEFT JOIN` ([#72](https://github.com/circuithub/rel8/pull/72))
143+
144+* Rel8 now compiles with GHC 9. ([#97](https://github.com/circuithub/rel8/pull/97))
145+
146+## Other changes
147+
148+* `exists` is now implemented in terms of the SQL `EXISTS` keyword. ([#69](https://github.com/circuithub/rel8/pull/69))
149+
150+* `alignBy` no longer requires `Table`s. ([#67](https://github.com/circuithub/rel8/pull/67))
151+
152+
153+# 1.0.0.1 (2021-06-21)
154+
155+This release contains various fixes for documentation.
156+
157+# 1.0.0.0 (2021-06-18)
158+
159+* Initial release.
Doctest.hsdeleted−53
@@ -1,53 +0,0 @@
1−{-# language BlockArguments #-}
2−{-# language OverloadedStrings #-}
3−
4−module Main where
5−
6−-- base
7−import Control.Exception ( bracket, throwIO )
8−import Data.Foldable ( traverse_ )
9−import System.Environment ( lookupEnv, setEnv )
10−
11−-- base-compat
12−import System.Environment.Compat ( unsetEnv )
13−
14−-- bytestring
15−import Data.ByteString.Char8 ( unpack )
16−
17−-- doctest
18−import Test.DocTest ( doctest )
19−
20−-- hasql
21−import Hasql.Connection ( acquire, release )
22−import Hasql.Session ( run, sql )
23−
24−-- rel8
25−import Build_doctests ( flags, module_sources, pkgs )
26−
27−-- tmp-postgres
28−import Database.Postgres.Temp ( toConnectionString, verboseConfig, with, withConfig )
29−
30−
31−main :: IO ()
32−main = do
33− nixGhcLibdir <- lookupEnv "NIX_GHC_LIBDIR"
34− unsetEnv "GHC_ENVIRONMENT"
35− either throwIO return =<< with \db -> do
36− setEnv "TEST_DATABASE_URL" (unpack (toConnectionString db))
37− bracket (either (error . show) return =<< acquire (toConnectionString db)) release \conn -> do
38− flip run conn do
39− sql "create table author ( author_id serial primary key, name text not null, url text )"
40− sql "create table project ( author_id int not null references author (author_id), name text not null )"
41−
42− sql "insert into author ( name, url ) values ( 'Ollie', 'https://ocharles.org.uk' )"
43− sql "insert into author ( name, url ) values ( 'Bryan O''Sullivan', null )"
44− sql "insert into author ( name, url ) values ( 'Emily Pillmore', 'https://cohomolo.gy' )"
45− sql "insert into project ( author_id, name ) values ( 1, 'rel8' )"
46− sql "insert into project ( author_id, name ) values ( 2, 'aeson' )"
47− sql "insert into project ( author_id, name ) values ( 2, 'text' )"
48−
49− doctest (args nixGhcLibdir)
50−
51− where
52− args nixGhcLibdir =
53− flags ++ pkgs ++ foldMap (\x -> ["-package-db" <> x <> "/package.conf.d"]) nixGhcLibdir ++ module_sources
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright 2020 Oliver Charles
1+Copyright 2021 Oliver Charles
2
2
3All rights reserved.
3All rights reserved.
4
4
README.mdnew file+17
@@ -0,0 +1,17 @@
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.hsdeleted−6
@@ -1,6 +0,0 @@
1−module Main where
2−
3−import Distribution.Extra.Doctest (defaultMainWithDoctests)
4−
5−main :: IO ()
6−main = defaultMainWithDoctests "doctests"
cabal.project.haskell-nixnew file+4
@@ -0,0 +1,4 @@
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+7−5
@@ -1,24 +1,26 @@
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-2009;
4+ nixpkgsSrc = haskellNix.sources.nixpkgs-unstable;
5
5
6 nixpkgsArgs = haskellNix.nixpkgsArgs;
6 nixpkgsArgs = haskellNix.nixpkgsArgs;
7
7
8− compiler-nix-name = "ghc8103";
8+ compiler-nix-name = "ghc924";
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+
16 src = pkgs.haskell-nix.haskellLib.cleanGit {
18 src = pkgs.haskell-nix.haskellLib.cleanGit {
17 name = "rel8";
19 name = "rel8";
18 src = ./.;
20 src = ./.;
19 };
21 };
20
22
21− modules = [
23+ modules = [
22 { packages.rel8 = {
24 { packages.rel8 = {
23 preCheck = ''
25 preCheck = ''
24 export PATH="${pkgs.postgresql}/bin:${"$PATH"}"
26 export PATH="${pkgs.postgresql}/bin:${"$PATH"}"
docs/concepts/dbtype.rstnew file+175
@@ -0,0 +1,175 @@
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.rstnew file+74
@@ -0,0 +1,74 @@
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.rstnew file+181
@@ -0,0 +1,181 @@
1+``INSERT``, ``UPDATE`` and ``DELETE``
2+=====================================
3+
4+While the majority of Rel8 is about building and executing ``SELECT``
5+statement, Rel8 also has support for ``INSERT``, ``UPDATE`` and ``DELETE``.
6+These statements are all executed using the ``insert``, ``update`` and
7+``delete`` functions, all of which take a record of parameters.
8+
9+.. note::
10+
11+ This part of Rel8's API uses the ``DuplicateRecordFields`` language
12+ extension. In code that needs to use this API, you should also enable this
13+ language extension, or you may get errors about ambiguous field names.
14+
15+``DELETE``
16+----------
17+
18+To perform a ``DELETE`` statement, construct a ``Delete`` value and execute it
19+using ``delete``. ``Delete`` takes:
20+
21+``from``
22+ The ``TableSchema`` for the table to delete rows from.
23+
24+``using``
25+ This is a simple ``Query`` that forms the ``USING`` clause of the ``DELETE``
26+ statement. This can be used to join against other tables, and the results
27+ can be referenced in the ``deleteWhere`` parameter. For simple ``DELETE``\s
28+ where you don't need to do this, you can set ``using = pure ()``.
29+
30+``deleteWhere``
31+ The ``WHERE`` clause of the ``DELETE`` statement. This is a function that
32+ takes two inputs: the result of the ``using`` query, and the current value
33+ of the row.
34+
35+``returning``
36+ What to return - see :ref:`returning`.
37+
38+``UPDATE``
39+----------
40+
41+To perform a ``UPDATE`` statement, construct a ``Update`` value and execute it
42+using ``update``. ``Update`` takes:
43+
44+``target``
45+ The ``TableSchema`` for the table to update rows in.
46+
47+``from``
48+ This is a simple ``Query`` that forms the ``FROM`` clause of the ``UPDATE``
49+ statement. This can be used to join against other tables, and the results
50+ can be referenced in the ``set`` and ``updateWhere`` parameters. For simple
51+ ``UPDATE``\s where you don't need to do this, you can set ``from = pure ()``.
52+
53+``set``
54+ A row to row transformation function, indicating how to update selected rows.
55+ This function takes rows of the same shape as ``target`` but in the ``Expr``
56+ context. One way to write this function is to use record update syntax::
57+
58+ set = \from row -> row { rowName = "new name" }
59+
60+``updateWhere``
61+ The ``WHERE`` clause of the ``UPDATE`` statement. This is a function that
62+ takes two inputs: the result of the ``from`` query, and the current value of
63+ the row.
64+
65+``returning``
66+ What to return - see :ref:`returning`.
67+
68+``INSERT``
69+----------
70+
71+To perform a ``INSERT`` statement, construct a ``Insert`` value and execute it
72+using ``insert``. ``Insert`` takes:
73+
74+``into``
75+ The ``TableSchema`` for the table to insert rows into.
76+
77+``rows``
78+ The rows to insert. These are the same as ``into``, but in the ``Expr``
79+ context. You can construct rows from their individual fields::
80+
81+ rows = values [ MyTable { myTableA = lit "A", myTableB = lit 42 }
82+
83+ or you can use ``lit`` on a table value in the ``Result`` context::
84+
85+ rows = values [ lit MyTable { myTableA = "A", myTableB = 42 }
86+
87+``onConflict``
88+ What should happen if an insert clashes with rows that already exist. This
89+ corresponds to PostgreSQL's ``ON CONFLICT`` clause. You can specify:
90+
91+ ``Abort``
92+ PostgreSQL should abort the ``INSERT`` with an exception
93+
94+ ``DoNothing``
95+ PostgreSQL should not insert the duplicate rows.
96+
97+ ``DoUpdate``
98+ PostgreSQL should instead try to update any existing rows that conflict
99+ with rows proposed for insertion.
100+
101+``returning``
102+ What to return - see :ref:`returning`.
103+
104+.. _returning:
105+
106+``RETURNING``
107+-------------
108+
109+PostgreSQL has the ability to return extra information after a ``DELETE``,
110+``INSERT`` or ``UPDATE`` statement by attaching a ``RETURNING`` clause. A common
111+use of this clause is to return any automatically generated sequence values for
112+primary key columns. Rel8 supports ``RETURNING`` clauses by filling in the
113+``returning`` field and specifying a ``Projection``. A ``Projection`` is a row
114+to row transformation, allowing you to project out a subset of fields.
115+
116+For example, if we are inserting orders, we might want the order ids returned::
117+
118+ insert Insert
119+ { into = orderSchema
120+ , rows = values [ order ]
121+ , onConflict = Abort
122+ , returning = Projection orderId
123+ }
124+
125+If we don't want to return anything, we can use ``pure ()``::
126+
127+ insert Insert
128+ { into = orderSchema
129+ , rows = values [ order ]
130+ , onConflict = Abort
131+ , returning = pure ()
132+ }
133+
134+Default values
135+--------------
136+
137+It is fairly common to define tables with default values. While Rel8 does not
138+have specific functionality for ``DEFAULT``, there are a few options:
139+
140+``unsafeDefault``
141+~~~~~~~~~~~~~~~~~~~~~~~~~~~
142+
143+Rel8 does not have any special support for ``DEFAULT``. If you need to use
144+default column values in inserts, you can use ``unsafeDefault`` to
145+construct the ``DEFAULT`` expression::
146+
147+ insert Insert
148+ { into = orderSchema
149+ , rows = values [ Order { orderId = unsafeDefault, ... } ]
150+ , onConflict = Abort
151+ , returning = Projection orderId
152+ }
153+
154+.. warning::
155+ As the name suggests, this is an unsafe operation. In particular, Rel8 is not
156+ able to prove that this column does have a default value, so it may be
157+ possible to introduce a runtime error. Furthermore, ``DEFAULT`` is fairly
158+ special in SQL, and cannot be combined like other expressions. For example,
159+ the innocuous expression::
160+
161+ unsafeDefault + 1
162+
163+ will lead to a runtime crash.
164+
165+Reimplement default values in Rel8
166+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
167+
168+If you only need to access default values in Rel8, another option is to specify
169+them in Rel8, rather than in your database schema.
170+
171+.. hint::
172+ A common default value for primary keys is to use `nextval` to obtain the
173+ next value from a sequence. This can be done in Rel8 by using the ``nextval``
174+ function::
175+
176+ insert Insert
177+ { into = orderSchema
178+ , rows = values [ Order { orderId = nextval "order_id_seq", ... } ]
179+ , onConflict = Abort
180+ , returning = Projection orderId
181+ }
docs/concepts/queries.rstnew file+274
@@ -0,0 +1,274 @@
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.rstnew file+60
@@ -0,0 +1,60 @@
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.py+9−5
@@ -7,7 +7,7 @@ sys.path.insert(0, os.path.abspath('.'))
7
7
8version = "1.0.0"
8version = "1.0.0"
9
9
10−extensions = ['sphinx.ext.extlinks', 'sphinx.ext.todo']
10+extensions = ['sphinx.ext.extlinks', 'sphinx.ext.todo', 'sphinx_rtd_theme']
11
11
12templates_path = ['_templates']
12templates_path = ['_templates']
13source_suffix = '.rst'
13source_suffix = '.rst'
@@ -23,10 +23,14 @@ primary_domain = 'haskell'
23
23
24exclude_patterns = ['.build', "*.gen.rst"]
24exclude_patterns = ['.build', "*.gen.rst"]
25
25
26+html_theme = 'sphinx_rtd_theme'
27+html_theme_options = {
28+ 'logo_only': True,
29+ 'navigation_depth': 5,
30+}
31+html_context = {}
32+
26# on_rtd is whether we are on readthedocs.org, this line of code grabbed from docs.readthedocs.org
33# on_rtd is whether we are on readthedocs.org, this line of code grabbed from docs.readthedocs.org
27on_rtd = os.environ.get('READTHEDOCS', None) == 'True'
34on_rtd = os.environ.get('READTHEDOCS', None) == 'True'
28
35
29−if not on_rtd: # only import and set the theme if we're building docs locally
36+todo_include_todos = True
30− import sphinx_rtd_theme
31− html_theme = 'sphinx_rtd_theme'
32− html_theme_path = [sphinx_rtd_theme.get_html_theme_path()]
docs/cookbook.rst+10−8
@@ -72,7 +72,7 @@ can be written as::
72 each myTableSchema
72 each myTableSchema
73
73
74Note that we use ``>$<`` (from ``Data.Functor.Contravariant``) to select table
74Note that we use ``>$<`` (from ``Data.Functor.Contravariant``) to select table
75−columns, and we can use `mconcat` to combine orderings.
75+columns, and we can use ``mconcat`` to combine orderings.
76
76
77If all columns of a table have an ordering, you can also use ``ascTable`` and
77If all columns of a table have an ordering, you can also use ``ascTable`` and
78``descTable``. For example::
78``descTable``. For example::
@@ -142,23 +142,25 @@ rows, but can also return *tree*\s.
142To understand what this means, we'll consider a small example query for blog
142To understand what this means, we'll consider a small example query for blog
143posts. We want our query to return:
143posts. We want our query to return:
144
144
145−1. The latest 5 blog posts.
145+1. The latest 5 blog posts that have at least one tag each.
1462. For each blog post, all tags.
1462. For each blog post, all tags.
147−3. For each blog post, the latest 3 comments.
147+3. For each blog post, the latest 3 comments if they exist.
148
148
149In Rel8, we can write this query as::
149In Rel8, we can write this query as::
150
150
151 latestBlogPosts = do
151 latestBlogPosts = do
152 post <- each postSchema
152 post <- each postSchema
153
153
154+ -- Returns a `NonEmptyTable a` which ends up as a `Data.List.NonEmpty a` after the query is run
154− tags <- aggregate do
155+ tags <- some $ do
155 tag <- each tagSchema
156 tag <- each tagSchema
156 where_ (tagPostId tag ==. postId post)
157 where_ (tagPostId tag ==. postId post)
157− return (listAgg (tagName tag))
158+ return (tagName tag)
158
159
160+ -- Returns a `ListTable a` which ends up as a `[a]` after the query is run
159− latestComments <-
161+ latestComments <-
160− many $
162+ many $
161− limit 3 $
163+ limit 3 $
162 orderBy (commentCreatedAt >$< desc) do
164 orderBy (commentCreatedAt >$< desc) do
163 comment <- each commentSchema
165 comment <- each commentSchema
164 where_ (commentPostId comment ==. postId post)
166 where_ (commentPostId comment ==. postId post)
docs/index.rst+19−4
@@ -1,5 +1,5 @@
1Welcome to Rel8!
1Welcome to Rel8!
2−================================
2+================
3
3
4Welcome to Rel8! Rel8 is a Haskell library for interacting with PostgreSQL
4Welcome to Rel8! Rel8 is a Haskell library for interacting with PostgreSQL
5databases, built on top of the fantastic `Opaleye
5databases, built on top of the fantastic `Opaleye
@@ -17,10 +17,25 @@ The main objectives of Rel8 are:
17* *Familiar*: writing Rel8 queries should feel like normal Haskell programming.
17* *Familiar*: writing Rel8 queries should feel like normal Haskell programming.
18
18
19.. toctree::
19.. toctree::
20− :maxdepth: 3
20+ :caption: Getting Started
21− :caption: Contents:
21+ :maxdepth: 2
22
22
23 tutorial
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+
24 cookbook
39 cookbook
25
40
26
41
@@ -35,4 +50,4 @@ More Resources
35
50
36* If you think you've found a bug, confusing behavior, or have a feature
51* If you think you've found a bug, confusing behavior, or have a feature
37 request, please raise an issue at `Rel8's issue tracker
52 request, please raise an issue at `Rel8's issue tracker
38− <https://github.com/circuithub/rel8>`_.
53+ <https://github.com/circuithub/rel8>`_.
docs/requirements.txt+2−1
@@ -1,3 +1,4 @@
1+docutils == 0.16.*
1−sphinx == 3.1.*
2+sphinx == 3.5.*
2sphinx_rtd_theme
3sphinx_rtd_theme
3
4
docs/tutorial.rst+67−48
@@ -5,24 +5,25 @@ Getting Started
5
5
6In this section, we'll take a look at using Rel8 to work with a small database
6In this section, we'll take a look at using Rel8 to work with a small database
7for Haskell packages. We'll take a look at idiomatic usage of Rel8, mapping
7for Haskell packages. We'll take a look at idiomatic usage of Rel8, mapping
8−tables to Haskell, and then look at writing some simple queries.
8+tables to Haskell, and then look at writing some simple queries.
9
9
10Before we get started, we'll be using the following language extensions and
10Before we get started, we'll be using the following language extensions and
11imports throughout this guide::
11imports throughout this guide::
12
12
13− {-# language -XBlockArguments #-}
13+ {-# language BlockArguments #-}
14− {-# language -XDeriveAnyClass #-}
14+ {-# language DeriveAnyClass #-}
15− {-# language -XDeriveGeneric #-}
15+ {-# language DeriveGeneric #-}
16− {-# language -XDerivingStrategies #-}
16+ {-# language DerivingStrategies #-}
17− {-# language -XDerivingVia #-}
17+ {-# language DerivingVia #-}
18− {-# language -XDuplicateRecordFields #-}
18+ {-# language DuplicateRecordFields #-}
19− {-# language -XGeneralizedNewtypeDeriving #-}
19+ {-# language GeneralizedNewtypeDeriving #-}
20− {-# language -XOverloadedStrings #-}
20+ {-# language OverloadedStrings #-}
21− {-# language -XStandaloneDeriving #-}
21+ {-# language StandaloneDeriving #-}
22− {-# language -XTypeApplications #-}
22+ {-# language TypeApplications #-}
23− {-# language -XTypeFamilies #-}
23+ {-# language TypeFamilies #-}
24
24
25 import Prelude
25 import Prelude
26+ import Rel8
26
27
27The Example Schema
28The Example Schema
28------------------
29------------------
@@ -70,7 +71,7 @@ Following these steps for ``author``, we have::
70 { authorId :: Column f Int64
71 { authorId :: Column f Int64
71 , name :: Column f Text
72 , name :: Column f Text
72 , url :: Column f (Maybe Text)
73 , url :: Column f (Maybe Text)
73− }
74+ }
74 deriving stock (Generic)
75 deriving stock (Generic)
75 deriving anyclass (Rel8able)
76 deriving anyclass (Rel8able)
76
77
@@ -81,7 +82,7 @@ in our project, it would be too easy to accidentally mix them up and create
81nonsensical joins. As Haskell programmers, we often solve this problem by
82nonsensical joins. As Haskell programmers, we often solve this problem by
82creating ``newtype`` wrappers, and we can also use this technique with Rel8::
83creating ``newtype`` wrappers, and we can also use this technique with Rel8::
83
84
84− newtype AuthorId = AuthorId { toInt64 :: Int64 }
85+ newtype AuthorId = AuthorId { toInt64 :: Int64 }
85 deriving newtype (DBEq, DBType, Eq, Show)
86 deriving newtype (DBEq, DBType, Eq, Show)
86
87
87Now we can write our final schema mapping. First, the ``author`` table::
88Now we can write our final schema mapping. First, the ``author`` table::
@@ -90,7 +91,7 @@ Now we can write our final schema mapping. First, the ``author`` table::
90 { authorId :: Column f AuthorId
91 { authorId :: Column f AuthorId
91 , authorName :: Column f Text
92 , authorName :: Column f Text
92 , authorUrl :: Column f (Maybe Text)
93 , authorUrl :: Column f (Maybe Text)
93− }
94+ }
94 deriving stock (Generic)
95 deriving stock (Generic)
95 deriving anyclass (Rel8able)
96 deriving anyclass (Rel8able)
96
97
@@ -99,16 +100,16 @@ And similarly, the ``project`` table::
99 data Project f = Project
100 data Project f = Project
100 { projectAuthorId :: Column f AuthorId
101 { projectAuthorId :: Column f AuthorId
101 , projectName :: Column f Text
102 , projectName :: Column f Text
102− }
103+ }
103 deriving stock (Generic)
104 deriving stock (Generic)
104− deriving anyclass (Rel8able
105+ deriving anyclass (Rel8able)
105
106
106To show query results in this documentation, we'll also need ``Show`` instances:
107To show query results in this documentation, we'll also need ``Show`` instances:
107Unfortunately these definitions look a bit scary, but they are essentially just
108Unfortunately these definitions look a bit scary, but they are essentially just
108``deriving (Show)``::
109``deriving (Show)``::
109
110
110− deriving stock instance f ~ Identity => Show (Author f)
111+ deriving stock instance f ~ Result => Show (Author f)
111− deriving stock instance f ~ Identity => Show (Project f)
112+ deriving stock instance f ~ Result => Show (Project f)
112
113
113These data types describe the structural mapping of the tables, but we also
114These data types describe the structural mapping of the tables, but we also
114need to specify a ``TableSchema`` for each table. A ``TableSchema`` contains
115need to specify a ``TableSchema`` for each table. A ``TableSchema`` contains
@@ -125,9 +126,9 @@ associated with the ``Author`` type::
125
126
126 authorSchema :: TableSchema (Author Name)
127 authorSchema :: TableSchema (Author Name)
127 authorSchema = TableSchema
128 authorSchema = TableSchema
128− { tableName = "author"
129+ { name = "author"
129− , tableSchema = Nothing
130+ , schema = Nothing
130− , tableColumns = Author
131+ , columns = Author
131 { authorId = "author_id"
132 { authorId = "author_id"
132 , authorName = "name"
133 , authorName = "name"
133 , authorUrl = "url"
134 , authorUrl = "url"
@@ -138,14 +139,27 @@ And likewise for ``project`` and ``Project``::
138
139
139 projectSchema :: TableSchema (Project Name)
140 projectSchema :: TableSchema (Project Name)
140 projectSchema = TableSchema
141 projectSchema = TableSchema
141− { tableName = "project"
142+ { name = "project"
142− , tableSchema = Nothing
143+ , schema = Nothing
143− , tableColumns = Project
144+ , columns = Project
144 { projectAuthorId = "author_id"
145 { projectAuthorId = "author_id"
145 , projectName = "name"
146 , projectName = "name"
146 }
147 }
147 }
148 }
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.
149
163
150.. note::
164.. note::
151
165
@@ -169,7 +183,7 @@ database heavy applications.
169
183
170In Rel8, ``SELECT`` statements are built using the ``Query`` monad. You can
184In Rel8, ``SELECT`` statements are built using the ``Query`` monad. You can
171think of this monad like the ordinary ``[]`` (List) monad - but this isn't
185think of this monad like the ordinary ``[]`` (List) monad - but this isn't
172−required knowledge.
186+required knowledge.
173
187
174To start, we'll look at one of the simplest queries possible - a basic ``SELECT
188To start, we'll look at one of the simplest queries possible - a basic ``SELECT
175* FROM`` statement. To select all rows from a table, we use ``each``, and
189* FROM`` statement. To select all rows from a table, we use ``each``, and
@@ -190,25 +204,28 @@ Recall we defined ``projectAuthorId`` as ``Column f AuthorId``. Now we have
190We'll see more about ``Expr`` soon, but you can think of ``Expr a`` as "SQL
204We'll see more about ``Expr`` soon, but you can think of ``Expr a`` as "SQL
191expressions of type ``a``\".
205expressions of type ``a``\".
192
206
193−To execute this ``Query``, we pass it to ``select``::
207+To execute this ``Query``, we pass it to ``select``. This function takes both a
208+database connection (which can be obtained using hasql's ``acquire`` function),
209+and the ``Query`` to run::
194
210
211+ >>> Right conn <- acquire "user=postgres"
195− >>> :t select c (each projectSchema)
212+ >>> :t select conn (each projectSchema)
196− select c (each projectSchema) :: MonadIO m => m [Project Identity]
213+ select conn (each projectSchema) :: MonadIO m => m [Project Result]
197
214
198−When we ``select`` things containing ``Expr``s, Rel8 builds a new response
215+When we ``select`` things containing ``Expr``\s, Rel8 builds a new response
199−table with the ``Identity`` interpretation. This means you'll get back plain
216+table with the ``Result`` interpretation. This means you'll get back plain
200Haskell values. Studying ``projectAuthorId`` again, we have::
217Haskell values. Studying ``projectAuthorId`` again, we have::
201
218
202− >>> let aProjectIdentity = undefined :: Project Identity
219+ >>> let aProjectResult = undefined :: Project Result
203− >>> :t projectAuthorId aProjectIdentity
220+ >>> :t projectAuthorId aProjectResult
204− projectAuthorId aProjectIdentity :: AuthorId
221+ projectAuthorId aProjectResult :: AuthorId
205
222
206−Here ``Column Identity AuthorId`` reduces to just ``AuthorId``, with no
223+Here ``Column Result AuthorId`` reduces to just ``AuthorId``, with no
207wrappping type at all.
224wrappping type at all.
208
225
209Putting this all together, we can run our first query::
226Putting this all together, we can run our first query::
210
227
211− >>> select c (each projectSchema) >>= mapM_ print
228+ >>> select conn (each projectSchema) >>= mapM_ print
212 Project {projectAuthorId = 1, projectName = "rel8"}
229 Project {projectAuthorId = 1, projectName = "rel8"}
213 Project {projectAuthorId = 2, projectName = "aeson"}
230 Project {projectAuthorId = 2, projectName = "aeson"}
214 Project {projectAuthorId = 2, projectName = "text"}
231 Project {projectAuthorId = 2, projectName = "text"}
@@ -218,7 +235,7 @@ sometimes we're only interested in a subset of the columns of a table. To
218restrict the returned columns, we can specify a projection by using ``Query``\s
235restrict the returned columns, we can specify a projection by using ``Query``\s
219``Functor`` instance::
236``Functor`` instance::
220
237
221− >>> select c $ projectName <$> each projectSchema
238+ >>> select conn $ projectName <$> each projectSchema
222 ["rel8","aeson","text"]
239 ["rel8","aeson","text"]
223
240
224Joins
241Joins
@@ -234,7 +251,7 @@ We can do this by simply calling ``each`` twice, and then returning a tuple of
234their results::
251their results::
235
252
236 >>> :{
253 >>> :{
237− mapM_ print =<< select c do
254+ mapM_ print =<< select conn do
238 author <- each authorSchema
255 author <- each authorSchema
239 project <- each projectSchema
256 project <- each projectSchema
240 return (projectName project, authorName author)
257 return (projectName project, authorName author)
@@ -253,7 +270,7 @@ This isn't quite right, though, as we have ended up pairing up the wrong
253projects and authors. To fix this, we can use ``where_`` to restrict the
270projects and authors. To fix this, we can use ``where_`` to restrict the
254returned rows. We could write::
271returned rows. We could write::
255
272
256− select c $ do
273+ select conn $ do
257 author <- each authorSchema
274 author <- each authorSchema
258 project <- each projectSchema
275 project <- each projectSchema
259 where_ $ projectAuthorId project ==. authorId author
276 where_ $ projectAuthorId project ==. authorId author
@@ -270,7 +287,7 @@ for the particular joins in your database. In our case, this would be::
270Our final query is then::
287Our final query is then::
271
288
272 >>> :{
289 >>> :{
273− mapM_ print =<< select c do
290+ mapM_ print =<< select conn do
274 author <- each authorSchema
291 author <- each authorSchema
275 project <- projectsForAuthor author
292 project <- projectsForAuthor author
276 return (projectName project, authorName author)
293 return (projectName project, authorName author)
@@ -289,7 +306,7 @@ transformer to allow for the possibility of the join to fail.
289In our test database, we can see that there's another author who we haven't
306In our test database, we can see that there's another author who we haven't
290seen yet::
307seen yet::
291
308
292− >>> select c $ authorName <$> each authorSchema
309+ >>> select conn $ authorName <$> each authorSchema
293 ["Ollie","Bryan O'Sullivan","Emily Pillmore"]
310 ["Ollie","Bryan O'Sullivan","Emily Pillmore"]
294
311
295Emily wasn't returned in our earlier query because - in our database - she
312Emily wasn't returned in our earlier query because - in our database - she
@@ -297,7 +314,7 @@ doesn't have any registered projects. We can account for this partiality in our
297original query by wrapping the ``projectsForAuthor`` call with ``optional``::
314original query by wrapping the ``projectsForAuthor`` call with ``optional``::
298
315
299 >>> :{
316 >>> :{
300− mapM_ print =<< select c do
317+ mapM_ print =<< select conn do
301 author <- each authorSchema
318 author <- each authorSchema
302 mproject <- optional $ projectsForAuthor author
319 mproject <- optional $ projectsForAuthor author
303 return (authorName author, projectName <$> mproject)
320 return (authorName author, projectName <$> mproject)
@@ -317,7 +334,9 @@ multiple rows to single values. To perform aggregations in Rel8, we can use the
317the aggregation, and returns aggregated rows.
334the aggregation, and returns aggregated rows.
318
335
319To start, let's look at a simple aggregation that tells us how many projects
336To start, let's look at a simple aggregation that tells us how many projects
320−exist::
337+exist:
338+
339+.. todo::
321
340
322 >>> error "TODO"
341 >>> error "TODO"
323
342
@@ -340,9 +359,9 @@ focus on the /type/ of that query::
340 return (author, project)
359 return (author, project)
341 where
360 where
342
361
343− >>> :t select c authorsAndProjects
362+ >>> :t select conn authorsAndProjects
344− select c authorsAndProjects
363+ select conn authorsAndProjects
345− :: MonadIO m => m [(Author Identity, Project Identity)]
364+ :: MonadIO m => m [(Author Result, Project Result)]
346
365
347
366
348Our query gives us a single list of pairs of authors and projects. However,
367Our query gives us a single list of pairs of authors and projects. However,
@@ -350,7 +369,7 @@ with our domain knowledge of the schema, this isn't a great type - what we'd
350rather have is a list of pairs of authors and /lists/ of projects. That is,
369rather have is a list of pairs of authors and /lists/ of projects. That is,
351what we'd like is::
370what we'd like is::
352
371
353− [(Author Identity, [Project Identity])]
372+ [(Author Result, [Project Result])]
354
373
355This would be a much better type! Rel8 can produce a query with this type by
374This would be a much better type! Rel8 can produce a query with this type by
356simply wrapping the call to ``projectsForAuthor`` with either ``some`` or
375simply wrapping the call to ``projectsForAuthor`` with either ``some`` or
@@ -358,7 +377,7 @@ simply wrapping the call to ``projectsForAuthor`` with either ``some`` or
358author to have no projects::
377author to have no projects::
359
378
360 >>> :{
379 >>> :{
361− mapM_ print =<< select c do
380+ mapM_ print =<< select conn do
362 author <- each authorSchema
381 author <- each authorSchema
363 projectNames <- many $ projectName <$> projectsForAuthor author
382 projectNames <- many $ projectName <$> projectsForAuthor author
364 return (authorName author, projectNames)
383 return (authorName author, projectNames)
nix/sources.json+9−9
@@ -5,10 +5,10 @@
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": "input-output-hk",
7 "repo": "haskell.nix",
7 "repo": "haskell.nix",
8− "rev": "486de5bfd4e7a93d999dc09969cb1278b9a43f30",
8+ "rev": "0837156c56cb5350dd9bd84eb424187e00aa1e8a",
9− "sha256": "12mal6p6z946z1w0knv04dkhpjmyqlaccmkf7skv23bf8iqg6gaz",
9+ "sha256": "1djmv5a0vfj78csw2cad6nicrs8iqrp928b9b3v4h7lwwhhzliwl",
10 "type": "tarball",
10 "type": "tarball",
11− "url": "https://github.com/input-output-hk/haskell.nix/archive/486de5bfd4e7a93d999dc09969cb1278b9a43f30.tar.gz",
11+ "url": "https://github.com/input-output-hk/haskell.nix/archive/0837156c56cb5350dd9bd84eb424187e00aa1e8a.tar.gz",
12 "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
12 "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
13 },
13 },
14 "niv": {
14 "niv": {
@@ -17,10 +17,10 @@
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": "af958e8057f345ee1aca714c1247ef3ba1c15f5e",
20+ "rev": "acdb1726783637852c01e0ad639ac9cbec28d8c8",
21− "sha256": "1qjavxabbrsh73yck5dcq8jggvh3r2jkbr6b5nlz5d9yrqm9255n",
21+ "sha256": "1wszl8q70z6wfgkh2dvgmhhry6qp9nar421qq2ifd17hq2jj9ck3",
22 "type": "tarball",
22 "type": "tarball",
23− "url": "https://github.com/nmattia/niv/archive/af958e8057f345ee1aca714c1247ef3ba1c15f5e.tar.gz",
23+ "url": "https://github.com/nmattia/niv/archive/acdb1726783637852c01e0ad639ac9cbec28d8c8.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": {
@@ -29,10 +29,10 @@
29 "homepage": null,
29 "homepage": null,
30 "owner": "nixos",
30 "owner": "nixos",
31 "repo": "nixpkgs",
31 "repo": "nixpkgs",
32− "rev": "da7f4c4842520167f65c20ad75ecdbd14e27ae91",
32+ "rev": "1c1f5649bb9c1b0d98637c8c365228f57126f361",
33− "sha256": "0vdq6lkc1sqj85x8r8idpck3igjns8ix57fqf1r5pm4k0qhy7p2m",
33+ "sha256": "0f2nvdijyxfgl5kwyb4465pppd5vkhqxddx6v40k2s0z9jfhj0xl",
34 "type": "tarball",
34 "type": "tarball",
35− "url": "https://github.com/nixos/nixpkgs/archive/da7f4c4842520167f65c20ad75ecdbd14e27ae91.tar.gz",
35+ "url": "https://github.com/nixos/nixpkgs/archive/1c1f5649bb9c1b0d98637c8c365228f57126f361.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+66−20
@@ -6,25 +6,53 @@ 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: spec:
9+ fetch_file = pkgs: name: spec:
10+ let
11+ name' = sanitizeName name + "-src";
12+ in
10− if spec.builtin or true then
13+ if spec.builtin or true then
11− builtins_fetchurl { inherit (spec) url sha256; }
14+ builtins_fetchurl { inherit (spec) url sha256; name = name'; }
12− else
15+ else
13− pkgs.fetchurl { inherit (spec) url sha256; };
16+ pkgs.fetchurl { inherit (spec) url sha256; name = name'; };
14
17
15 fetch_tarball = pkgs: name: spec:
18 fetch_tarball = pkgs: name: spec:
16 let
19 let
17− ok = str: ! builtins.isNull (builtins.match "[a-zA-Z0-9+-._?=]" str);
20+ name' = sanitizeName name + "-src";
18− # sanitize the name, though nix will still fail if name starts with period
19− name' = stringAsChars (x: if ! ok x then "-" else x) "${name}-src";
20 in
21 in
21 if spec.builtin or true then
22 if spec.builtin or true then
22 builtins_fetchTarball { name = name'; inherit (spec) url sha256; }
23 builtins_fetchTarball { name = name'; inherit (spec) url sha256; }
23 else
24 else
24 pkgs.fetchzip { name = name'; inherit (spec) url sha256; };
25 pkgs.fetchzip { name = name'; inherit (spec) url sha256; };
25
26
26− fetch_git = spec:
27+ fetch_git = name: spec:
28+ let
29+ ref =
30+ if spec ? ref then spec.ref else
31+ if spec ? branch then "refs/heads/${spec.branch}" else
32+ if spec ? tag then "refs/tags/${spec.tag}" else
33+ abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!";
34+ submodules = if spec ? submodules then spec.submodules else false;
35+ submoduleArg =
36+ let
37+ nixSupportsSubmodules = builtins.compareVersions builtins.nixVersion "2.4" >= 0;
38+ emptyArgWithWarning =
39+ if submodules == true
40+ then
41+ builtins.trace
42+ (
43+ "The niv input \"${name}\" uses submodules "
44+ + "but your nix's (${builtins.nixVersion}) builtins.fetchGit "
45+ + "does not support them"
46+ )
47+ {}
48+ else {};
49+ in
50+ if nixSupportsSubmodules
51+ then { inherit submodules; }
52+ else emptyArgWithWarning;
53+ in
54+ builtins.fetchGit
27− builtins.fetchGit { url = spec.repo; inherit (spec) rev ref; };
55+ ({ url = spec.repo; inherit (spec) rev; inherit ref; } // submoduleArg);
28
56
29 fetch_local = spec: spec.path;
57 fetch_local = spec: spec.path;
30
58
@@ -40,11 +68,21 @@ let
40 # Various helpers
68 # Various helpers
41 #
69 #
42
70
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+
43 # The set of packages used when specs are fetched using non-builtins.
81 # The set of packages used when specs are fetched using non-builtins.
44− mkPkgs = sources:
82+ mkPkgs = sources: system:
45 let
83 let
46 sourcesNixpkgs =
84 sourcesNixpkgs =
47− import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) {};
85+ import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; };
48 hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath;
86 hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath;
49 hasThisAsNixpkgsPath = <nixpkgs> == ./.;
87 hasThisAsNixpkgsPath = <nixpkgs> == ./.;
50 in
88 in
@@ -64,9 +102,9 @@ let
64
102
65 if ! builtins.hasAttr "type" spec then
103 if ! builtins.hasAttr "type" spec then
66 abort "ERROR: niv spec ${name} does not have a 'type' attribute"
104 abort "ERROR: niv spec ${name} does not have a 'type' attribute"
67− else if spec.type == "file" then fetch_file pkgs spec
105+ else if spec.type == "file" then fetch_file pkgs name spec
68 else if spec.type == "tarball" then fetch_tarball pkgs name spec
106 else if spec.type == "tarball" then fetch_tarball pkgs name spec
69− else if spec.type == "git" then fetch_git spec
107+ else if spec.type == "git" then fetch_git name spec
70 else if spec.type == "local" then fetch_local spec
108 else if spec.type == "local" then fetch_local spec
71 else if spec.type == "builtin-tarball" then fetch_builtin-tarball name
109 else if spec.type == "builtin-tarball" then fetch_builtin-tarball name
72 else if spec.type == "builtin-url" then fetch_builtin-url name
110 else if spec.type == "builtin-url" then fetch_builtin-url name
@@ -80,7 +118,10 @@ let
80 saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name;
118 saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name;
81 ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}";
119 ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}";
82 in
120 in
83− if ersatz == "" then drv else ersatz;
121+ if ersatz == "" then drv else
122+ # this turns the string into an actual Nix path (for both absolute and
123+ # relative paths)
124+ if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}";
84
125
85 # Ports of functions for older nix versions
126 # Ports of functions for older nix versions
86
127
@@ -98,25 +139,29 @@ let
98
139
99 # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269
140 # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269
100 stringAsChars = f: s: concatStrings (map f (stringToCharacters s));
141 stringAsChars = f: s: concatStrings (map f (stringToCharacters s));
142+ concatMapStrings = f: list: concatStrings (map f list);
101 concatStrings = builtins.concatStringsSep "";
143 concatStrings = builtins.concatStringsSep "";
102
144
145+ # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331
146+ optionalAttrs = cond: as: if cond then as else {};
147+
103 # fetchTarball version that is compatible between all the versions of Nix
148 # fetchTarball version that is compatible between all the versions of Nix
104− builtins_fetchTarball = { url, name, sha256 }@attrs:
149+ builtins_fetchTarball = { url, name ? null, sha256 }@attrs:
105 let
150 let
106 inherit (builtins) lessThan nixVersion fetchTarball;
151 inherit (builtins) lessThan nixVersion fetchTarball;
107 in
152 in
108 if lessThan nixVersion "1.12" then
153 if lessThan nixVersion "1.12" then
109− fetchTarball { inherit name url; }
154+ fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; }))
110 else
155 else
111 fetchTarball attrs;
156 fetchTarball attrs;
112
157
113 # fetchurl version that is compatible between all the versions of Nix
158 # fetchurl version that is compatible between all the versions of Nix
114− builtins_fetchurl = { url, sha256 }@attrs:
159+ builtins_fetchurl = { url, name ? null, sha256 }@attrs:
115 let
160 let
116 inherit (builtins) lessThan nixVersion fetchurl;
161 inherit (builtins) lessThan nixVersion fetchurl;
117 in
162 in
118 if lessThan nixVersion "1.12" then
163 if lessThan nixVersion "1.12" then
119− fetchurl { inherit url; }
164+ fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; }))
120 else
165 else
121 fetchurl attrs;
166 fetchurl attrs;
122
167
@@ -135,7 +180,8 @@ let
135 mkConfig =
180 mkConfig =
136 { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null
181 { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null
137 , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile)
182 , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile)
183+ , system ? builtins.currentSystem
138− , pkgs ? mkPkgs sources
184+ , pkgs ? mkPkgs sources system
139 }: rec {
185 }: rec {
140 # The sources, i.e. the attribute set of spec name to spec
186 # The sources, i.e. the attribute set of spec name to spec
141 inherit sources;
187 inherit sources;
rel8.cabal+77−56
@@ -1,30 +1,36 @@
1cabal-version: 2.0
1cabal-version: 2.0
2name: rel8
2name: rel8
3−version: 0.1.0.0
3+version: 1.4.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
9−build-type: Custom
11+build-type: Simple
12+extra-doc-files:
13+ README.md
14+ Changelog.md
10
15
11−custom-setup
16+source-repository head
12− setup-depends:
17+ type: git
13− base >= 4 && <5,
18+ location: https://github.com/circuithub/rel8
14− Cabal,
15− cabal-doctest >= 1 && <1.1
16
19
17library
20library
18 build-depends:
21 build-depends:
19 aeson
22 aeson
20− , base ^>=4.12 || ^>= 4.13 || ^>= 4.14
23+ , base ^>= 4.14 || ^>=4.15 || ^>=4.16
24+ , bifunctors
21 , bytestring
25 , bytestring
22 , case-insensitive
26 , case-insensitive
23− , casing
27+ , comonad
24 , contravariant
28 , contravariant
25− , hasql
29+ , hasql ^>= 1.4.5.1 || ^>= 1.5.0.0 || ^>= 1.6.0.0
26− , opaleye ^>= 0.7.1.0
30+ , opaleye ^>= 0.9.6.1
31+ , pretty
27 , profunctors
32 , profunctors
33+ , product-profunctors
28 , scientific
34 , scientific
29 , semialign
35 , semialign
30 , semigroupoids
36 , semigroupoids
@@ -35,10 +41,12 @@ library
35 default-language:
41 default-language:
36 Haskell2010
42 Haskell2010
37 ghc-options:
43 ghc-options:
44+ -Werror=missing-methods -Werror=incomplete-patterns -Werror=missing-fields
38 -Weverything -Wno-unsafe -Wno-safe -Wno-missing-safe-haskell-mode
45 -Weverything -Wno-unsafe -Wno-safe -Wno-missing-safe-haskell-mode
39 -Wno-missing-import-lists -Wno-prepositive-qualified-module
46 -Wno-missing-import-lists -Wno-prepositive-qualified-module
40 -Wno-monomorphism-restriction
47 -Wno-monomorphism-restriction
41− -Wno-missing-local-signatures
48+ -Wno-missing-local-signatures
49+ -Wno-missing-kind-signatures
42 hs-source-dirs:
50 hs-source-dirs:
43 src
51 src
44 exposed-modules:
52 exposed-modules:
@@ -48,28 +56,48 @@ library
48 Rel8.Expr.Time
56 Rel8.Expr.Time
49 Rel8.Tabulate
57 Rel8.Tabulate
50
58
51− -- deprecated
52− Rel8.Aggregate.Legacy
53−
54 other-modules:
59 other-modules:
55 Rel8.Aggregate
60 Rel8.Aggregate
56
61
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+
57 Rel8.Expr
72 Rel8.Expr
58 Rel8.Expr.Aggregate
73 Rel8.Expr.Aggregate
59 Rel8.Expr.Array
74 Rel8.Expr.Array
60 Rel8.Expr.Bool
75 Rel8.Expr.Bool
76+ Rel8.Expr.Default
61 Rel8.Expr.Eq
77 Rel8.Expr.Eq
62 Rel8.Expr.Function
78 Rel8.Expr.Function
63 Rel8.Expr.Null
79 Rel8.Expr.Null
64 Rel8.Expr.Opaleye
80 Rel8.Expr.Opaleye
65 Rel8.Expr.Ord
81 Rel8.Expr.Ord
66 Rel8.Expr.Order
82 Rel8.Expr.Order
83+ Rel8.Expr.Sequence
67 Rel8.Expr.Serialize
84 Rel8.Expr.Serialize
85+ Rel8.Expr.Window
68
86
69 Rel8.FCF
87 Rel8.FCF
70
88
71− Rel8.Kind.Labels
89+ Rel8.Kind.Algebra
72− Rel8.Kind.Necessity
90+ Rel8.Kind.Context
91+
92+ Rel8.Generic.Construction
93+ Rel8.Generic.Construction.ADT
94+ Rel8.Generic.Construction.Record
95+ Rel8.Generic.Map
96+ Rel8.Generic.Record
97+ Rel8.Generic.Rel8able
98+ Rel8.Generic.Table
99+ Rel8.Generic.Table.ADT
100+ Rel8.Generic.Table.Record
73
101
74 Rel8.Order
102 Rel8.Order
75
103
@@ -78,28 +106,26 @@ library
78 Rel8.Query.Distinct
106 Rel8.Query.Distinct
79 Rel8.Query.Each
107 Rel8.Query.Each
80 Rel8.Query.Either
108 Rel8.Query.Either
109+ Rel8.Query.Evaluate
81 Rel8.Query.Exists
110 Rel8.Query.Exists
82 Rel8.Query.Filter
111 Rel8.Query.Filter
112+ Rel8.Query.Indexed
83 Rel8.Query.Limit
113 Rel8.Query.Limit
84 Rel8.Query.List
114 Rel8.Query.List
85 Rel8.Query.Maybe
115 Rel8.Query.Maybe
86 Rel8.Query.Null
116 Rel8.Query.Null
87 Rel8.Query.Opaleye
117 Rel8.Query.Opaleye
88 Rel8.Query.Order
118 Rel8.Query.Order
119+ Rel8.Query.Rebind
89 Rel8.Query.Set
120 Rel8.Query.Set
90 Rel8.Query.SQL
121 Rel8.Query.SQL
91 Rel8.Query.These
122 Rel8.Query.These
92 Rel8.Query.Values
123 Rel8.Query.Values
124+ Rel8.Query.Window
93
125
94− Rel8.Schema.Column
95− Rel8.Schema.Context
96− Rel8.Schema.Context.Identity
97− Rel8.Schema.Context.Label
98 Rel8.Schema.Context.Nullify
126 Rel8.Schema.Context.Nullify
99 Rel8.Schema.Dict
127 Rel8.Schema.Dict
100 Rel8.Schema.Field
128 Rel8.Schema.Field
101− Rel8.Schema.Generic
102− Rel8.Schema.Generic.Test
103 Rel8.Schema.HTable
129 Rel8.Schema.HTable
104 Rel8.Schema.HTable.Either
130 Rel8.Schema.HTable.Either
105 Rel8.Schema.HTable.Identity
131 Rel8.Schema.HTable.Identity
@@ -109,55 +135,59 @@ library
109 Rel8.Schema.HTable.Maybe
135 Rel8.Schema.HTable.Maybe
110 Rel8.Schema.HTable.NonEmpty
136 Rel8.Schema.HTable.NonEmpty
111 Rel8.Schema.HTable.Nullify
137 Rel8.Schema.HTable.Nullify
112− Rel8.Schema.HTable.Pair
138+ Rel8.Schema.HTable.Product
113− Rel8.Schema.HTable.Quartet
114− Rel8.Schema.HTable.Quintet
115 Rel8.Schema.HTable.These
139 Rel8.Schema.HTable.These
116− Rel8.Schema.HTable.Trio
117− Rel8.Schema.HTable.Type
118 Rel8.Schema.HTable.Vectorize
140 Rel8.Schema.HTable.Vectorize
119− Rel8.Schema.Insert
120 Rel8.Schema.Kind
141 Rel8.Schema.Kind
121 Rel8.Schema.Name
142 Rel8.Schema.Name
122− Rel8.Schema.Nullability
143+ Rel8.Schema.Null
123− Rel8.Schema.Nullability.Internal
144+ Rel8.Schema.Result
124 Rel8.Schema.Spec
145 Rel8.Schema.Spec
125− Rel8.Schema.Spec.ConstrainDBType
126− Rel8.Schema.Spec.ConstrainType
127 Rel8.Schema.Table
146 Rel8.Schema.Table
128
147
129 Rel8.Statement.Delete
148 Rel8.Statement.Delete
130 Rel8.Statement.Insert
149 Rel8.Statement.Insert
150+ Rel8.Statement.OnConflict
131 Rel8.Statement.Returning
151 Rel8.Statement.Returning
132 Rel8.Statement.Select
152 Rel8.Statement.Select
153+ Rel8.Statement.Set
154+ Rel8.Statement.SQL
133 Rel8.Statement.Update
155 Rel8.Statement.Update
156+ Rel8.Statement.Using
134 Rel8.Statement.View
157 Rel8.Statement.View
158+ Rel8.Statement.Where
135
159
136 Rel8.Table
160 Rel8.Table
161+ Rel8.Table.ADT
137 Rel8.Table.Aggregate
162 Rel8.Table.Aggregate
138 Rel8.Table.Alternative
163 Rel8.Table.Alternative
139 Rel8.Table.Bool
164 Rel8.Table.Bool
165+ Rel8.Table.Cols
140 Rel8.Table.Either
166 Rel8.Table.Either
141 Rel8.Table.Eq
167 Rel8.Table.Eq
142− Rel8.Table.Insert
168+ Rel8.Table.HKD
143− Rel8.Table.Lifted
144 Rel8.Table.List
169 Rel8.Table.List
145 Rel8.Table.Maybe
170 Rel8.Table.Maybe
146 Rel8.Table.Name
171 Rel8.Table.Name
147 Rel8.Table.NonEmpty
172 Rel8.Table.NonEmpty
173+ Rel8.Table.Null
174+ Rel8.Table.Nullify
148 Rel8.Table.Opaleye
175 Rel8.Table.Opaleye
149 Rel8.Table.Ord
176 Rel8.Table.Ord
150 Rel8.Table.Order
177 Rel8.Table.Order
151− Rel8.Table.Recontextualize
178+ Rel8.Table.Projection
179+ Rel8.Table.Rel8able
152 Rel8.Table.Serialize
180 Rel8.Table.Serialize
153− Rel8.Table.Tag
154 Rel8.Table.These
181 Rel8.Table.These
182+ Rel8.Table.Transpose
155 Rel8.Table.Undefined
183 Rel8.Table.Undefined
184+ Rel8.Table.Window
156
185
157 Rel8.Type
186 Rel8.Type
158 Rel8.Type.Array
187 Rel8.Type.Array
159− Rel8.Type.Array1D
188+ Rel8.Type.Composite
160 Rel8.Type.Eq
189 Rel8.Type.Eq
190+ Rel8.Type.Enum
161 Rel8.Type.Information
191 Rel8.Type.Information
162 Rel8.Type.JSONEncoded
192 Rel8.Type.JSONEncoded
163 Rel8.Type.JSONBEncoded
193 Rel8.Type.JSONBEncoded
@@ -170,8 +200,8 @@ library
170 Rel8.Type.Sum
200 Rel8.Type.Sum
171 Rel8.Type.Tag
201 Rel8.Type.Tag
172
202
173− Rel8.Opaque
203+ Rel8.Window
174− Rel8.Schema.Structure
204+
175
205
176test-suite tests
206test-suite tests
177 type: exitcode-stdio-1.0
207 type: exitcode-stdio-1.0
@@ -181,9 +211,9 @@ test-suite tests
181 , case-insensitive
211 , case-insensitive
182 , containers
212 , containers
183 , hasql
213 , hasql
214+ , hasql-transaction
184− , hedgehog ^>=1.0.2
215+ , hedgehog ^>= 1.0 || ^>= 1.1
185− , lifted-base ^>=0.2.3.12
216+ , mmorph
186− , monad-control ^>=1.0.2.3
187 , rel8
217 , rel8
188 , scientific
218 , scientific
189 , tasty
219 , tasty
@@ -191,8 +221,12 @@ test-suite tests
191 , text
221 , text
192 , time
222 , time
193 , tmp-postgres ^>=1.34.1.0
223 , tmp-postgres ^>=1.34.1.0
224+ , transformers
194 , uuid
225 , uuid
195
226
227+ other-modules:
228+ Rel8.Generic.Rel8able.Test
229+
196 main-is: Main.hs
230 main-is: Main.hs
197 hs-source-dirs: tests
231 hs-source-dirs: tests
198 default-language: Haskell2010
232 default-language: Haskell2010
@@ -201,16 +235,3 @@ test-suite tests
201 -Wno-missing-import-lists -Wno-prepositive-qualified-module
235 -Wno-missing-import-lists -Wno-prepositive-qualified-module
202 -Wno-deprecations -Wno-monomorphism-restriction
236 -Wno-deprecations -Wno-monomorphism-restriction
203 -Wno-missing-local-signatures -Wno-implicit-prelude
237 -Wno-missing-local-signatures -Wno-implicit-prelude
204−
205−test-suite doctests
206− type: exitcode-stdio-1.0
207− build-depends:
208− base
209− , base-compat
210− , bytestring
211− , doctest
212− , hasql
213− , tmp-postgres
214−
215− main-is: Doctest.hs
216− default-language: Haskell2010
shell.nix+3−3
@@ -1,11 +1,11 @@
1let
1let
2 sources = import ./nix/sources.nix;
2 sources = import ./nix/sources.nix;
3− pkgs = import sources.nixpkgs {};
3+ pkgs = import sources.nixpkgs {overlays = [];};
4 hsPkgs = import ./default.nix;
4 hsPkgs = import ./default.nix;
5in
5in
6 hsPkgs.shellFor {
6 hsPkgs.shellFor {
7− withHoogle = true;
7+ withHoogle = false;
8− tools = { cabal = "3.2.0.0"; haskell-language-server = "latest"; };
8+ tools = { cabal = "latest"; };
9 exactDeps = false;
9 exactDeps = false;
10 buildInputs = [ pkgs.postgresql pkgs.pythonPackages.sphinx ];
10 buildInputs = [ pkgs.postgresql pkgs.pythonPackages.sphinx ];
11 }
11 }
src/Rel8.hs+383−38
@@ -13,6 +13,10 @@ module Rel8
13 -- **** @ReadShow@
13 -- **** @ReadShow@
14 , ReadShow(..)
14 , ReadShow(..)
15
15
16+ -- **** Generic
17+ , Composite(..), DBComposite(..), compose, decompose
18+ , Enum(..), DBEnum(..), Enumable
19+
16 -- *** @TypeInformation@
20 -- *** @TypeInformation@
17 , TypeInformation(..)
21 , TypeInformation(..)
18 , mapTypeInformation
22 , mapTypeInformation
@@ -24,32 +28,42 @@ module Rel8
24 , DBNum
28 , DBNum
25 , DBIntegral
29 , DBIntegral
26 , DBFractional
30 , DBFractional
31+ , DBFloating
27
32
28 -- * Tables and higher-kinded tables
33 -- * Tables and higher-kinded tables
29− , Rel8able
34+ , Rel8able, KRel8able
30− , Column, Field, Necessity( Required, Optional )
35+ , Column
31− , Default, Label
36+ , HADT
37+ , HEither
32 , HMaybe
38 , HMaybe
33 , HList
39 , HList
34 , HNonEmpty
40 , HNonEmpty
41+ , HNull
35 , HThese
42 , HThese
43+ , Lift
36
44
37− , Table
45+ , Table(..)
46+ , HTable
47+ , Transposes
38 , AltTable((<|>:))
48 , AltTable((<|>:))
49+ , AlternativeTable( emptyTable )
39− , EqTable, (==:), (/=:)
50+ , EqTable(..), (==:), (/=:)
40− , OrdTable, ascTable, descTable
51+ , OrdTable(..), (<:), (<=:), (>:), (>=:), ascTable, descTable, greatest, least
41 , lit
52 , lit
42 , bool
53 , bool
43 , case_
54 , case_
55+ , castTable
44
56
45 -- ** @MaybeTable@
57 -- ** @MaybeTable@
46 , MaybeTable
58 , MaybeTable
47 , maybeTable, ($?), nothingTable, justTable
59 , maybeTable, ($?), nothingTable, justTable
48 , isNothingTable, isJustTable
60 , isNothingTable, isJustTable
61+ , fromMaybeTable
49 , optional
62 , optional
50 , catMaybeTable
63 , catMaybeTable
51− , bindMaybeTable
52 , traverseMaybeTable
64 , traverseMaybeTable
65+ , aggregateMaybeTable
66+ , nameMaybeTable
53
67
54 -- ** @EitherTable@
68 -- ** @EitherTable@
55 , EitherTable
69 , EitherTable
@@ -57,8 +71,9 @@ module Rel8
57 , isLeftTable, isRightTable
71 , isLeftTable, isRightTable
58 , keepLeftTable
72 , keepLeftTable
59 , keepRightTable
73 , keepRightTable
60− , bindEitherTable
61 , bitraverseEitherTable
74 , bitraverseEitherTable
75+ , aggregateEitherTable
76+ , nameEitherTable
62
77
63 -- ** @TheseTable@
78 -- ** @TheseTable@
64 , TheseTable
79 , TheseTable
@@ -66,22 +81,73 @@ module Rel8
66 , isThisTable, isThatTable, isThoseTable
81 , isThisTable, isThatTable, isThoseTable
67 , hasHereTable, hasThereTable
82 , hasHereTable, hasThereTable
68 , justHereTable, justThereTable
83 , justHereTable, justThereTable
84+ , alignMaybeTable
69 , alignBy
85 , alignBy
70 , keepHereTable, loseHereTable
86 , keepHereTable, loseHereTable
71 , keepThereTable, loseThereTable
87 , keepThereTable, loseThereTable
72 , keepThisTable, loseThisTable
88 , keepThisTable, loseThisTable
73 , keepThatTable, loseThatTable
89 , keepThatTable, loseThatTable
74 , keepThoseTable, loseThoseTable
90 , keepThoseTable, loseThoseTable
75− , bindTheseTable
76 , bitraverseTheseTable
91 , bitraverseTheseTable
92+ , aggregateTheseTable
93+ , nameTheseTable
77
94
78 -- ** @ListTable@
95 -- ** @ListTable@
79 , ListTable
96 , ListTable
97+ , listTable, ($*)
98+ , nameListTable
80 , many
99 , many
100+ , manyExpr
101+ , catListTable
102+ , catList
81
103
82 -- ** @NonEmptyTable@
104 -- ** @NonEmptyTable@
83 , NonEmptyTable
105 , NonEmptyTable
106+ , nonEmptyTable, ($+)
107+ , nameNonEmptyTable
84 , some
108 , 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
85
151
86 -- ** Table schemas
152 -- ** Table schemas
87 , TableSchema(..)
153 , TableSchema(..)
@@ -94,16 +160,20 @@ module Rel8
94 , Sql
160 , Sql
95 , litExpr
161 , litExpr
96 , unsafeCastExpr
162 , unsafeCastExpr
163+ , unsafeLiteral
97
164
98 -- ** @null@
165 -- ** @null@
166+ , NotNull
167+ , Nullable
168+ , Homonullable
99 , null
169 , null
100 , nullify
170 , nullify
101 , nullable
171 , nullable
102 , isNull
172 , isNull
103 , isNonNull
173 , isNonNull
104− , mapNullable
174+ , mapNull
105− , liftOpNullable
175+ , liftOpNull
106− , catNullable
176+ , catNull
107 , coalesce
177 , coalesce
108
178
109 -- ** Boolean operations
179 -- ** Boolean operations
@@ -114,6 +184,7 @@ module Rel8
114 , (==.), (/=.), (==?), (/=?)
184 , (==.), (/=.), (==?), (/=?)
115 , in_
185 , in_
116 , boolExpr, caseExpr
186 , boolExpr, caseExpr
187+ , like, ilike
117
188
118 -- ** Ordering
189 -- ** Ordering
119 , DBOrd
190 , DBOrd
@@ -131,6 +202,13 @@ module Rel8
131 , Query
202 , Query
132 , showQuery
203 , showQuery
133
204
205+ -- ** Projection
206+ , Projection
207+ , Projectable( project )
208+ , Biprojectable( biproject )
209+ , Projecting
210+ , Field
211+
134 -- ** Selecting rows
212 -- ** Selecting rows
135 , Selects
213 , Selects
136 , each
214 , each
@@ -139,8 +217,8 @@ module Rel8
139 -- ** Filtering
217 -- ** Filtering
140 , filter
218 , filter
141 , where_
219 , where_
142− , whereExists
220+ , present
143− , whereNotExists
221+ , absent
144 , distinct
222 , distinct
145 , distinctOn
223 , distinctOn
146 , distinctOnBy
224 , distinctOnBy
@@ -170,14 +248,16 @@ module Rel8
170
248
171 -- ** Aggregation
249 -- ** Aggregation
172 , Aggregate
250 , Aggregate
251+ , Aggregates
173 , aggregate
252 , aggregate
174 , countRows
253 , countRows
254+ , groupBy
175 , listAgg, listAggExpr
255 , listAgg, listAggExpr
256+ , mode
176 , nonEmptyAgg, nonEmptyAggExpr
257 , nonEmptyAgg, nonEmptyAggExpr
177− , groupBy
178 , DBMax, max
258 , DBMax, max
179 , DBMin, min
259 , DBMin, min
180− , DBSum, sum, sumWhere
260+ , DBSum, sum, sumWhere, avg
181 , DBString, stringAgg
261 , DBString, stringAgg
182 , count
262 , count
183 , countStar
263 , countStar
@@ -194,43 +274,71 @@ module Rel8
194 , nullsFirst
274 , nullsFirst
195 , nullsLast
275 , nullsLast
196
276
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+
197 -- * IO
303 -- * IO
198 , Serializable
304 , Serializable
305+ , ToExprs
306+ , Result
199
307
200 -- * Running statements
308 -- * Running statements
309+ -- $running
310+
201 -- ** @SELECT@
311 -- ** @SELECT@
202 , select
312 , select
203
313
204 -- ** @INSERT@
314 -- ** @INSERT@
205 , Insert(..)
315 , Insert(..)
206 , OnConflict(..)
316 , OnConflict(..)
317+ , Upsert(..)
207 , insert
318 , insert
208− , toInsert
319+ , unsafeDefault
209− , toInsertDefaults
320+ , showInsert
210
321
211 -- ** @DELETE@
322 -- ** @DELETE@
212 , Delete(..)
323 , Delete(..)
213 , delete
324 , delete
325+ , showDelete
214
326
215 -- ** @UPDATE@
327 -- ** @UPDATE@
216− , update
217 , Update(..)
328 , Update(..)
329+ , update
330+ , showUpdate
218
331
219 -- ** @.. RETURNING@
332 -- ** @.. RETURNING@
220 , Returning(..)
333 , Returning(..)
221
334
222 -- ** @CREATE VIEW@
335 -- ** @CREATE VIEW@
223 , createView
336 , createView
337+ , createOrReplaceView
224
338
225− -- * TODO
339+ -- ** Sequences
226− -- TODO
340+ , nextval
227− -- These need organizing, but are reachable from Rel8's documentation so we
341+ , evaluate
228− -- do need to export and document them.
229− , HasNullability
230− , NotNull
231− , HTable
232− , Labelable
233− , Context
234 ) where
342 ) where
235
343
236-- base
344-- base
@@ -238,65 +346,91 @@ import Prelude ()
238
346
239-- rel8
347-- rel8
240import Rel8.Aggregate
348import Rel8.Aggregate
349+import Rel8.Column
350+import Rel8.Column.ADT
351+import Rel8.Column.Either
352+import Rel8.Column.Lift
353+import Rel8.Column.List
354+import Rel8.Column.Maybe
355+import Rel8.Column.NonEmpty
356+import Rel8.Column.Null
357+import Rel8.Column.These
241import Rel8.Expr
358import Rel8.Expr
242import Rel8.Expr.Aggregate
359import Rel8.Expr.Aggregate
243import Rel8.Expr.Bool
360import Rel8.Expr.Bool
361+import Rel8.Expr.Default
244import Rel8.Expr.Eq
362import Rel8.Expr.Eq
245import Rel8.Expr.Function
363import Rel8.Expr.Function
246import Rel8.Expr.Null
364import Rel8.Expr.Null
247−import Rel8.Expr.Opaleye (unsafeCastExpr)
365+import Rel8.Expr.Opaleye (unsafeCastExpr, unsafeLiteral)
248import Rel8.Expr.Ord
366import Rel8.Expr.Ord
249import Rel8.Expr.Order
367import Rel8.Expr.Order
250import Rel8.Expr.Serialize
368import Rel8.Expr.Serialize
251−import Rel8.Kind.Necessity
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 )
252import Rel8.Order
373import Rel8.Order
253import Rel8.Query
374import Rel8.Query
254import Rel8.Query.Aggregate
375import Rel8.Query.Aggregate
255import Rel8.Query.Distinct
376import Rel8.Query.Distinct
256import Rel8.Query.Each
377import Rel8.Query.Each
257import Rel8.Query.Either
378import Rel8.Query.Either
379+import Rel8.Query.Evaluate
258import Rel8.Query.Exists
380import Rel8.Query.Exists
259import Rel8.Query.Filter
381import Rel8.Query.Filter
382+import Rel8.Query.Indexed
260import Rel8.Query.Limit
383import Rel8.Query.Limit
261import Rel8.Query.List
384import Rel8.Query.List
262import Rel8.Query.Maybe
385import Rel8.Query.Maybe
263import Rel8.Query.Null
386import Rel8.Query.Null
264import Rel8.Query.Order
387import Rel8.Query.Order
388+import Rel8.Query.Rebind
265import Rel8.Query.SQL (showQuery)
389import Rel8.Query.SQL (showQuery)
266import Rel8.Query.Set
390import Rel8.Query.Set
267import Rel8.Query.These
391import Rel8.Query.These
268import Rel8.Query.Values
392import Rel8.Query.Values
269−import Rel8.Schema.Column
393+import Rel8.Query.Window
270−import Rel8.Schema.Context.Label
271−import Rel8.Schema.Field (Field)
394+import Rel8.Schema.Field
272−import Rel8.Schema.Generic
273import Rel8.Schema.HTable
395import Rel8.Schema.HTable
274import Rel8.Schema.Name
396import Rel8.Schema.Name
275−import Rel8.Schema.Nullability
397+import Rel8.Schema.Null hiding ( nullable )
398+import Rel8.Schema.Result ( Result )
276import Rel8.Schema.Table
399import Rel8.Schema.Table
277import Rel8.Statement.Delete
400import Rel8.Statement.Delete
278import Rel8.Statement.Insert
401import Rel8.Statement.Insert
402+import Rel8.Statement.OnConflict
279import Rel8.Statement.Returning
403import Rel8.Statement.Returning
280import Rel8.Statement.Select
404import Rel8.Statement.Select
405+import Rel8.Statement.SQL
281import Rel8.Statement.Update
406import Rel8.Statement.Update
282import Rel8.Statement.View
407import Rel8.Statement.View
283import Rel8.Table
408import Rel8.Table
409+import Rel8.Table.ADT
284import Rel8.Table.Aggregate
410import Rel8.Table.Aggregate
285import Rel8.Table.Alternative
411import Rel8.Table.Alternative
286import Rel8.Table.Bool
412import Rel8.Table.Bool
287import Rel8.Table.Either
413import Rel8.Table.Either
288import Rel8.Table.Eq
414import Rel8.Table.Eq
289−import Rel8.Table.Insert
415+import Rel8.Table.HKD
290import Rel8.Table.List
416import Rel8.Table.List
291import Rel8.Table.Maybe
417import Rel8.Table.Maybe
292import Rel8.Table.Name
418import Rel8.Table.Name
293import Rel8.Table.NonEmpty
419import Rel8.Table.NonEmpty
420+import Rel8.Table.Null
421+import Rel8.Table.Opaleye ( castTable )
294import Rel8.Table.Ord
422import Rel8.Table.Ord
295import Rel8.Table.Order
423import Rel8.Table.Order
424+import Rel8.Table.Projection
425+import Rel8.Table.Rel8able ()
296import Rel8.Table.Serialize
426import Rel8.Table.Serialize
297import Rel8.Table.These
427import Rel8.Table.These
428+import Rel8.Table.Transpose
429+import Rel8.Table.Window
298import Rel8.Type
430import Rel8.Type
431+import Rel8.Type.Composite
299import Rel8.Type.Eq
432import Rel8.Type.Eq
433+import Rel8.Type.Enum
300import Rel8.Type.Information
434import Rel8.Type.Information
301import Rel8.Type.JSONBEncoded
435import Rel8.Type.JSONBEncoded
302import Rel8.Type.JSONEncoded
436import Rel8.Type.JSONEncoded
@@ -307,5 +441,216 @@ import Rel8.Type.ReadShow
307import Rel8.Type.Semigroup
441import Rel8.Type.Semigroup
308import Rel8.Type.String
442import Rel8.Type.String
309import Rel8.Type.Sum
443import Rel8.Type.Sum
310−
444+import Rel8.Window
311−
445+
446+
447+-- $running
448+-- To run queries and otherwise interact with a PostgreSQL database, Rel8
449+-- provides 'select', 'insert', 'update' and 'delete' functions. Note that
450+-- 'insert', 'update' and 'delete' will generally need the
451+-- `DuplicateRecordFields` language extension enabled.
452+
453+-- $adts
454+-- Algebraic data types can be modelled between Haskell and SQL.
455+--
456+-- * Your SQL table needs a certain text field that tags which Haskell constructor is in use.
457+-- * You have to use a few combinators to specify the sum type's individual constructors.
458+-- * If you want to do case analysis at the @Expr@ (SQL) level, you can use 'maybe'/'either'-like eliminators.
459+--
460+-- The documentation in this section will assume a set of database types like this:
461+--
462+-- @
463+-- data Thing f = ThingEmployer (Employer f) | ThingPotato (Potato f) | Nullary
464+-- deriving stock Generic
465+--
466+-- data Employer f = Employer { employerId :: f Int32, employerName :: f Text}
467+-- deriving stock Generic
468+-- deriving anyclass Rel8able
469+--
470+-- data Potato f = Potato { size :: f Int32, grower :: f Text }
471+-- deriving stock Generic
472+-- deriving anyclass Rel8able
473+-- @
474+
475+-- $naming
476+--
477+-- First, in your 'TableSchema', name your type like this:
478+--
479+-- @
480+-- thingSchema :: TableSchema (ADT Thing Name)
481+-- thingSchema =
482+-- TableSchema
483+-- { schema = Nothing,
484+-- name = \"thing\",
485+-- columns =
486+-- nameADT @Thing
487+-- \"tag\"
488+-- Employer
489+-- { employerName = \"name\",
490+-- employerId = \"id\"
491+-- }
492+-- Potato {size = \"size\", grower = \"Mary\"}
493+-- }
494+-- @
495+--
496+-- Note that @nameADT \@Thing "tag"@ is variadic: it accepts one
497+-- argument per constructor, except the nullary ones (Nullary) because
498+-- there's nothing to do for them.
499+
500+-- $deconstruction
501+--
502+-- To deconstruct sum types at the SQL level, use 'deconstructADT',
503+-- which is also variadic, and has one argument for each
504+-- constructor. Similar to 'maybe'.
505+--
506+-- @
507+-- query :: Query (ADT Thing Expr)
508+-- query = do
509+-- thingExpr <- each thingSchema
510+-- where_ $
511+-- deconstructADT @Thing
512+-- (\employer -> employerName employer ==. lit \"Mary\")
513+-- (\potato -> grower potato ==. lit \"Mary\")
514+-- (lit False) -- Nullary case
515+-- thingExpr
516+-- pure thingExpr
517+-- @
518+--
519+-- SQL output:
520+--
521+-- @
522+-- SELECT
523+-- CAST("tag0_1" AS text) as "tag",
524+-- CAST("id1_1" AS int4) as "ThingEmployer/_1/employerId",
525+-- CAST("name2_1" AS text) as "ThingEmployer/_1/employerName",
526+-- CAST("size3_1" AS int4) as "ThingPotato/_1/size",
527+-- CAST("Mary4_1" AS text) as "ThingPotato/_1/grower"
528+-- FROM (SELECT
529+-- *
530+-- FROM (SELECT
531+-- "tag" as "tag0_1",
532+-- "id" as "id1_1",
533+-- "name" as "name2_1",
534+-- "size" as "size3_1",
535+-- "Mary" as "Mary4_1"
536+-- FROM "thing" as "T1") as "T1"
537+-- WHERE (CASE WHEN ("tag0_1") = (CAST(E'ThingPotato' AS text)) THEN ("Mary4_1") = (CAST(E'Mary' AS text))
538+-- WHEN ("tag0_1") = (CAST(E'Nullary' AS text)) THEN CAST(FALSE AS bool) ELSE ("name2_1") = (CAST(E'Mary' AS text)) END)) as "T1"
539+-- @
540+
541+-- $construction
542+--
543+-- To construct an ADT, you can use 'buildADT' or 'constructADT'. Consider the following type:
544+--
545+-- @
546+-- data Task f = Pending | Complete (CompletedTask f)
547+-- @
548+--
549+-- 'buildADT' is for constructing values of 'Task' in the 'Expr'
550+-- context. 'buildADT' needs two type-level arguments before its type
551+-- makes any sense. The first argument is the type of the "ADT", which
552+-- in our case is 'Task'. The second is the name of the constructor we
553+-- want to use. So that means we have the following possible
554+-- instantiations of 'buildADT' for 'Task':
555+--
556+-- @
557+-- > :t buildADT @Task @\"Pending\"
558+-- buildADT @Task @\"Pending\" :: ADT Task Expr
559+-- > :t buildADT @Task @\"Complete\"
560+-- buildADT @Task @\"Complete\" :: CompletedTask Expr -> ADT Task Expr
561+-- @
562+--
563+-- Note that as the "Pending" constructor has no fields, @buildADT
564+-- \@Task \@"Pending"@ is equivalent to @lit Pending@. But @buildADT
565+-- \@Task \@"Complete"@ is not the same as @lit . Complete@:
566+--
567+-- @
568+-- > :t lit . Complete
569+-- lit . Complete :: CompletedTask Result -> ADT Task Expr
570+-- @
571+--
572+--
573+-- Note that the former takes a @CompletedTask Expr@ while the latter
574+-- takes a @CompletedTask Result@. The former is more powerful because
575+-- you can construct @Task@s using dynamic values coming a database
576+-- query.
577+--
578+-- To show what this can look like in SQL, consider:
579+--
580+-- @
581+-- > :{
582+-- showQuery $ values
583+-- [ buildADT @Task @\"Pending\"
584+-- , buildADT @Task @\"Complete\" CompletedTask {date = Rel8.Expr.Time.now}
585+-- ]
586+-- :}
587+-- @
588+--
589+-- This produces the following SQL:
590+--
591+-- @
592+-- SELECT
593+-- CAST(\"values0_1\" AS text) as \"tag\",
594+-- CAST(\"values1_1\" AS timestamptz) as \"Complete/_1/date\"
595+-- FROM (SELECT
596+-- *
597+-- FROM (SELECT \"column1\" as \"values0_1\",
598+-- \"column2\" as \"values1_1\"
599+-- FROM
600+-- (VALUES
601+-- (CAST(E'Pending' AS text),CAST(NULL AS timestamptz)),
602+-- (CAST(E'Complete' AS text),CAST(now() AS timestamptz))) as \"V\") as \"T1\") as \"T1\"
603+-- @
604+--
605+-- This is what you get if you run it in @psql@:
606+--
607+--
608+-- @
609+-- tag | Complete/_1/date
610+-- ----------+-------------------------------
611+-- Pending |
612+-- Complete | 2022-05-19 21:28:23.969065+00
613+-- (2 rows)
614+-- @
615+--
616+-- "constructADT" is less convenient but more general alternative to
617+-- "buildADT". It requires only one type-level argument for its type
618+-- to make sense:
619+--
620+-- @
621+-- > :t constructADT @Task
622+-- constructADT @Task
623+-- :: (forall r. r -> (CompletedTask Expr -> r) -> r) -> ADT Task Expr
624+-- @
625+--
626+-- This might still seem a bit opaque, but basically it gives you a
627+-- Church-encoded constructor for arbitrary algebraic data types. You
628+-- might use it as follows:
629+--
630+-- @
631+-- let
632+-- pending :: ADT Task Expr
633+-- pending = constructADT @Task $ \pending _complete -> pending
634+--
635+-- complete :: ADT Task Expr
636+-- complete = constructADT @Task $ \_pending complete -> complete CompletedTask {date = Rel8.Expr.Time.now}
637+-- @
638+--
639+-- These values are otherwise identical to the ones we saw above with
640+-- @buildADT@, it's just a different style of constructing them.
641+--
642+
643+-- $misc-notes
644+--
645+-- 1. Note that the order of the arguments for all of these functions
646+-- is determined by the order of the constructors in the data
647+-- definition. If it were @data Task = Complete (CompletedTask f) |
648+-- Pending@ then the order of all the invocations of @constructADT@
649+-- and @deconstructADT@ would need to change.
650+--
651+-- 2. Maybe this is obvious, but just to spell it out: once you're in
652+-- the @Result@ context, you can of course construct @Task@ values
653+-- normally and use standard Haskell pattern-matching. @constructADT@
654+-- and @deconstructADT@ are specifically only needed in the @Expr@
655+-- context, and they allow you to do the equivalent of pattern
656+-- matching in PostgreSQL.
src/Rel8/Aggregate.hs+46−119
@@ -1,156 +1,83 @@
1{-# language DataKinds #-}
1{-# language DataKinds #-}
2−{-# language DerivingVia #-}
3{-# language FlexibleContexts #-}
2{-# language FlexibleContexts #-}
4{-# language FlexibleInstances #-}
3{-# language FlexibleInstances #-}
5−{-# language GADTs #-}
6−{-# language GeneralizedNewtypeDeriving #-}
7{-# language MultiParamTypeClasses #-}
4{-# language MultiParamTypeClasses #-}
8−{-# language NamedFieldPuns #-}
5+{-# language RankNTypes #-}
9{-# language StandaloneKindSignatures #-}
6{-# language StandaloneKindSignatures #-}
10{-# language TypeFamilies #-}
7{-# language TypeFamilies #-}
11{-# language UndecidableInstances #-}
8{-# language UndecidableInstances #-}
12−{-# language UndecidableSuperClasses #-}
13
9
14module Rel8.Aggregate
10module Rel8.Aggregate
15− ( Aggregate(..), foldInputs, mapInputs
11+ ( Aggregate(..), zipOutputs
16− , Aggregator(..), unsafeMakeAggregate
12+ , unsafeMakeAggregate
17 , Aggregates
13 , Aggregates
18− , Col( Aggregation )
19 )
14 )
20where
15where
21
16
22-- base
17-- base
23−import Data.Functor.Const ( Const( Const ), getConst )
18+import Control.Applicative ( liftA2 )
24−import Data.Functor.Identity ( Identity )
19+import Data.Functor.Identity ( Identity( Identity ) )
25import Data.Kind ( Constraint, Type )
20import Data.Kind ( Constraint, Type )
26import Prelude
21import Prelude
27
22
23+-- profunctors
24+import Data.Profunctor ( dimap )
25+
28-- opaleye
26-- opaleye
29−import qualified Opaleye.Internal.Aggregate as Opaleye
27+import qualified Opaleye.Aggregate as Opaleye
30import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
28import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
31−import qualified Opaleye.Internal.PackMap as Opaleye
29+import qualified Opaleye.Internal.Column as Opaleye
32
30
33-- rel8
31-- rel8
34−import Rel8.Expr ( Expr, Col(..) )
32+import Rel8.Expr ( Expr )
35−import Rel8.Opaque ( Opaque )
36−import Rel8.Schema.Context ( Interpretation(..) )
37−import Rel8.Schema.Context.Label ( Labelable(..) )
38−import Rel8.Schema.HTable ( hfield, htabulate, htabulateA, hspecs )
33+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
39−import Rel8.Schema.Name ( Name )
34+import qualified Rel8.Schema.Kind as K
40−import Rel8.Schema.Nullability ( Sql )
35+import Rel8.Schema.Null ( Sql )
41−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
36+import Rel8.Table
42−import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
37+ ( Table, Columns, Context, fromColumns, toColumns
43−import Rel8.Table.Recontextualize ( Recontextualize )
38+ , FromExprs, fromResult, toResult
39+ , Transpose
40+ )
41+import Rel8.Table.Transpose ( Transposes )
44import Rel8.Type ( DBType )
42import Rel8.Type ( DBType )
45
43
46−-- semigroupoids
47−import Data.Functor.Apply ( Apply, WrappedApplicative(..) )
48−
49−
50−-- | An @Aggregate a@ describes how to aggregate @Table@s of type @a@. You can
51−-- unpack an @Aggregate@ back to @a@ by running it with 'aggregate'. As
52−-- @Aggregate@ is almost an 'Applicative' functor - but there is no 'pure'
53−-- operation. This means 'Aggregate' is an instance of 'Apply', and you can
54−-- combine @Aggregate@s using the @<.>@ combinator.
55−type Aggregate :: Type -> Type
56−newtype Aggregate a = Aggregate (Opaleye.Aggregator () a)
57− deriving newtype Functor
58− deriving Apply via (WrappedApplicative (Opaleye.Aggregator ()))
59
44
45+-- | 'Aggregate' is a special context used by 'Rel8.aggregate'.
46+type Aggregate :: K.Context
47+newtype Aggregate a = Aggregate (Opaleye.Aggregator () (Expr a))
60
48
61−instance Interpretation Aggregate where
62− data Col Aggregate _spec where
63− Aggregation :: ()
64− => Aggregate (Expr a)
65− -> Col Aggregate ('Spec labels necessity a)
66
49
67−
68−instance Table Expr a => Table Aggregate (Aggregate a) where
50+instance Sql DBType a => Table Aggregate (Aggregate a) where
69− type Columns (Aggregate a) = Columns a
51+ type Columns (Aggregate a) = HIdentity a
70 type Context (Aggregate a) = Aggregate
52 type Context (Aggregate a) = Aggregate
53+ type FromExprs (Aggregate a) = a
54+ type Transpose to (Aggregate a) = to a
71
55
72− toColumns a = htabulate $ \field -> case hfield hspecs field of
56+ toColumns = HIdentity
73− SSpec {} -> Aggregation $ unDB . (`hfield` field) . toColumns <$> a
57+ fromColumns (HIdentity a) = a
74− fromColumns as = fmap fromColumns $ htabulateA $ \field ->
58+ toResult = HIdentity . Identity
75− case hfield as field of
59+ fromResult (HIdentity (Identity a)) = a
76− Aggregation a -> DB <$> a
77−
78−
79−instance Sql DBType a =>
80− Recontextualize Aggregate Aggregate (Aggregate (Expr a)) (Aggregate (Expr a))
81−
82−
83−instance Sql DBType a =>
84− Recontextualize Aggregate Expr (Aggregate (Expr a)) (Expr a)
85−
86−
87−instance Sql DBType a =>
88− Recontextualize Aggregate Identity (Aggregate (Expr a)) (Identity a)
89−
90−
91−instance Sql DBType a =>
92− Recontextualize Aggregate Name (Aggregate (Expr a)) (Name a)
93
60
94
61
95−instance Sql DBType a =>
96− Recontextualize Expr Aggregate (Expr a) (Aggregate (Expr a))
97−
98−
99−instance Sql DBType a =>
100− Recontextualize Identity Aggregate (Identity a) (Aggregate (Expr a))
101−
102−
103−instance Sql DBType a =>
104− Recontextualize Name Aggregate (Name a) (Aggregate (Expr a))
105−
106−
107−instance Labelable Aggregate where
108− labeler (Aggregation aggregate) = Aggregation aggregate
109− unlabeler (Aggregation aggregate) = Aggregation aggregate
110−
111−
112−-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate' 'Expr's
62+-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate's
113−-- for the columns in @b@.
63+-- for the 'Expr' columns in @b@.
114type Aggregates :: Type -> Type -> Constraint
64type Aggregates :: Type -> Type -> Constraint
115−class Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs
65+class Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs
116−instance Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs
66+instance Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs
117−instance {-# OVERLAPPING #-} Aggregates (Opaque Aggregate Opaque) (Opaque Expr Opaque)
118−
119−
120−foldInputs :: Monoid b
121− => (Maybe Aggregator -> Opaleye.PrimExpr -> b) -> Aggregate a -> b
122−foldInputs f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =
123− getConst $ flip agg () $ \(aggregator, a) ->
124− Const $ f (detuplize <$> aggregator) a
125− where
126− detuplize (operation, ordering, distinction) =
127− Aggregator {operation, ordering, distinction}
128−
129−
130−mapInputs :: ()
131− => (Opaleye.PrimExpr -> Opaleye.PrimExpr) -> Aggregate a -> Aggregate a
132−mapInputs transform (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =
133− Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ agg . \f input ->
134− f (fmap transform input)
135
67
136
68
137−type Aggregator :: Type
69+zipOutputs :: ()
138−data Aggregator = Aggregator
70+ => (Expr a -> Expr b -> Expr c) -> Aggregate a -> Aggregate b -> Aggregate c
139− { operation :: Opaleye.AggrOp
71+zipOutputs f (Aggregate a) (Aggregate b) = Aggregate (liftA2 f a b)
140− , ordering :: [Opaleye.OrderExpr]
141− , distinction :: Opaleye.AggrDistinct
142− }
143
72
144
73
145−unsafeMakeAggregate :: ()
74+unsafeMakeAggregate :: forall (input :: Type) (output :: Type) n n' a a'. ()
146− => (input -> Opaleye.PrimExpr)
75+ => (Expr input -> Opaleye.PrimExpr)
147− -> (Opaleye.PrimExpr -> output)
76+ -> (Opaleye.PrimExpr -> Expr output)
148− -> Maybe Aggregator
77+ -> Opaleye.Aggregator (Opaleye.Field_ n a) (Opaleye.Field_ n' a')
149− -> input
78+ -> Expr input
150 -> Aggregate output
79 -> Aggregate output
151unsafeMakeAggregate input output aggregator expr =
80unsafeMakeAggregate input output aggregator expr =
152− Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ \f _ ->
81+ Aggregate $ dimap in_ out aggregator
153− output <$> f (tuplize <$> aggregator, input expr)
82+ where out = output . Opaleye.unColumn
154− where
83+ in_ = Opaleye.Column . input . const expr
155− tuplize Aggregator {operation, ordering, distinction} =
156− (operation, ordering, distinction)
src/Rel8/Aggregate/Legacy.hsdeleted−93
@@ -1,93 +0,0 @@
1−{-# language FlexibleContexts #-}
2−{-# language NamedFieldPuns #-}
3−{-# language ScopedTypeVariables #-}
4−{-# language TypeApplications #-}
5−{-# language TypeFamilies #-}
6−{-# language ViewPatterns #-}
7−
8−module Rel8.Aggregate.Legacy
9− ( Aggregates
10− , aggregate
11− , aggregateTabulation
12− , groupBy
13− , listAgg
14− , nonEmptyAgg
15− )
16−where
17−
18−-- base
19−import Data.Functor.Identity ( Identity( Identity ) )
20−import Prelude
21−
22−-- opaleye
23−import qualified Opaleye.Aggregate as Opaleye
24−
25−-- rel8
26−import Rel8.Aggregate ( Aggregates, Col(..) )
27−import Rel8.Expr ( Col(..) )
28−import Rel8.Expr.Aggregate ( groupByExpr, listAggExpr, nonEmptyAggExpr )
29−import Rel8.Query ( Query )
30−import Rel8.Query.Opaleye ( mapOpaleye )
31−import Rel8.Schema.Dict ( Dict( Dict ) )
32−import Rel8.Schema.HTable ( htabulate, hfield )
33−import Rel8.Schema.HTable.Vectorize ( hvectorize )
34−import Rel8.Table ( toColumns, fromColumns )
35−import Rel8.Table.Eq ( EqTable, eqTable )
36−import Rel8.Table.List ( ListTable )
37−import Rel8.Table.NonEmpty ( NonEmptyTable )
38−import Rel8.Table.Opaleye ( aggregator )
39−import Rel8.Tabulate ( Tabulation )
40−import qualified Rel8.Tabulate
41−
42−
43−-- | Apply an aggregation to all rows returned by a 'Query'.
44−aggregate :: Aggregates aggregates exprs => Query aggregates -> Query exprs
45−aggregate = mapOpaleye (Opaleye.aggregate aggregator) . fmap (fromColumns . toColumns)
46−
47−
48−aggregateTabulation
49− :: (EqTable k, Aggregates aggregates exprs)
50− => (t -> aggregates) -> Tabulation k t -> Tabulation k exprs
51−aggregateTabulation f =
52− Rel8.Tabulate.aggregateTabulation . fmap (fromColumns . toColumns . f)
53−
54−
55−-- | Group equal tables together. This works by aggregating each column in the
56−-- given table with 'groupByExpr'.
57−groupBy :: forall exprs aggregates. (EqTable exprs, Aggregates aggregates exprs)
58− => exprs -> aggregates
59−groupBy (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
60− case hfield (eqTable @exprs) field of
61− Dict -> case hfield exprs field of
62− DB expr -> Aggregation $ groupByExpr expr
63−
64−
65−-- | Aggregate rows into a single row containing an array of all aggregated
66−-- rows. This can be used to associate multiple rows with a single row, without
67−-- changing the over cardinality of the query. This allows you to essentially
68−-- return a tree-like structure from queries.
69−--
70−-- For example, if we have a table of orders and each orders contains multiple
71−-- items, we could aggregate the table of orders, pairing each order with its
72−-- items:
73−--
74−-- @
75−-- ordersWithItems :: Query (Order Expr, ListTable (Item Expr))
76−-- ordersWithItems = do
77−-- order <- each orderSchema
78−-- items <- aggregate $ listAgg <$> itemsFromOrder order
79−-- return (order, items)
80−-- @
81−listAgg :: Aggregates aggregates exprs => exprs -> ListTable aggregates
82−listAgg (toColumns -> exprs) = fromColumns $
83− hvectorize
84− (\_ (Identity (DB a)) -> Aggregation $ listAggExpr a)
85− (pure exprs)
86−
87−
88−-- | Like 'listAgg', but the result is guaranteed to be a non-empty list.
89−nonEmptyAgg :: Aggregates aggregates exprs => exprs -> NonEmptyTable aggregates
90−nonEmptyAgg (toColumns -> exprs) = fromColumns $
91− hvectorize
92− (\_ (Identity (DB a)) -> Aggregation $ nonEmptyAggExpr a)
93− (pure exprs)
src/Rel8/Column.hsnew file+31
@@ -0,0 +1,31 @@
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.hsnew file+23
@@ -0,0 +1,23 @@
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.hsnew file+26
@@ -0,0 +1,26 @@
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.hsnew file+23
@@ -0,0 +1,23 @@
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.hsnew file+25
@@ -0,0 +1,25 @@
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.hsnew file+26
@@ -0,0 +1,26 @@
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.hsnew file+27
@@ -0,0 +1,27 @@
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.hsnew file+26
@@ -0,0 +1,26 @@
1+{-# language DataKinds #-}
2+{-# language StandaloneKindSignatures #-}
3+{-# language TypeFamilyDependencies #-}
4+
5+module Rel8.Column.Null
6+ ( HNull
7+ )
8+where
9+
10+-- base
11+import Data.Kind ( Type )
12+import Prelude
13+
14+-- rel8
15+import qualified Rel8.Schema.Kind as K
16+import Rel8.Schema.Result ( Result )
17+import Rel8.Table.Null ( NullTable )
18+
19+
20+-- | Nest a 'Null' value within a 'Rel8able'. @HNull f a@ will produce a
21+-- 'NullTable' @a@ in the 'Expr' context, and a @'Maybe' a@ in the 'Result'
22+-- context.
23+type HNull :: K.Context -> Type -> Type
24+type family HNull context = maybe | maybe -> context where
25+ HNull Result = Maybe
26+ HNull context = NullTable context
src/Rel8/Column/These.hsnew file+29
@@ -0,0 +1,29 @@
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+48−49
@@ -1,26 +1,21 @@
1{-# language DataKinds #-}
1{-# language DataKinds #-}
2{-# language DerivingStrategies #-}
2{-# language DerivingStrategies #-}
3+{-# language FlexibleContexts #-}
3{-# language FlexibleInstances #-}
4{-# language FlexibleInstances #-}
4−{-# language GADTs #-}
5{-# language MultiParamTypeClasses #-}
5{-# language MultiParamTypeClasses #-}
6−{-# language NamedFieldPuns #-}
7−{-# language RoleAnnotations #-}
8{-# language ScopedTypeVariables #-}
6{-# language ScopedTypeVariables #-}
9{-# language StandaloneKindSignatures #-}
7{-# language StandaloneKindSignatures #-}
10{-# language TypeApplications #-}
8{-# language TypeApplications #-}
11{-# language TypeFamilies #-}
9{-# language TypeFamilies #-}
12{-# language UndecidableInstances #-}
10{-# language UndecidableInstances #-}
13−{-# language UndecidableSuperClasses #-}
14
11
15module Rel8.Expr
12module Rel8.Expr
16 ( Expr(..)
13 ( Expr(..)
17− , Col( DB, unDB )
18 )
14 )
19where
15where
20
16
21-- base
17-- base
22−import Data.Functor.Identity ( Identity )
18+import Data.Functor.Identity ( Identity( Identity ) )
23−import Data.Kind ( Type )
24import Data.String ( IsString, fromString )
19import Data.String ( IsString, fromString )
25import Prelude hiding ( null )
20import Prelude hiding ( null )
26
21
@@ -28,7 +23,8 @@ import Prelude hiding ( null )
28import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
23import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
29
24
30-- rel8
25-- rel8
31−import Rel8.Expr.Null ( liftOpNullable, nullify )
26+import Rel8.Expr.Function ( function, nullaryFunction )
27+import Rel8.Expr.Null ( liftOpNull, nullify )
32import Rel8.Expr.Opaleye
28import Rel8.Expr.Opaleye
33 ( castExpr
29 ( castExpr
34 , fromPrimExpr
30 , fromPrimExpr
@@ -36,47 +32,44 @@ import Rel8.Expr.Opaleye
36 , zipPrimExprsWith
32 , zipPrimExprsWith
37 )
33 )
38import Rel8.Expr.Serialize ( litExpr )
34import Rel8.Expr.Serialize ( litExpr )
39−import Rel8.Schema.Context ( Interpretation, Col )
35+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
40−import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
41−import Rel8.Schema.HTable.Type ( HType( HType ) )
42−import Rel8.Schema.Nullability
36+import qualified Rel8.Schema.Kind as K
43− ( Nullability( Nullable, NonNullable )
37+import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
44− , Sql, nullabilization
38+import Rel8.Table
39+ ( Table, Columns, Context, fromColumns, toColumns
40+ , FromExprs, fromResult, toResult
41+ , Transpose
45 )
42 )
46−import Rel8.Schema.Spec ( Spec( Spec ) )
47−import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
48−import Rel8.Table.Recontextualize ( Recontextualize )
49import Rel8.Type ( DBType )
43import Rel8.Type ( DBType )
50import Rel8.Type.Monoid ( DBMonoid, memptyExpr )
44import Rel8.Type.Monoid ( DBMonoid, memptyExpr )
51−import Rel8.Type.Num ( DBFractional, DBNum )
45+import Rel8.Type.Num ( DBFloating, DBFractional, DBNum )
52import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )
46import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )
53
47
54
48
55-- | Typed SQL expressions.
49-- | Typed SQL expressions.
56−type role Expr representational
50+type Expr :: K.Context
57−type Expr :: Type -> Type
58newtype Expr a = Expr Opaleye.PrimExpr
51newtype Expr a = Expr Opaleye.PrimExpr
59 deriving stock Show
52 deriving stock Show
60
53
61
54
62instance Sql DBSemigroup a => Semigroup (Expr a) where
55instance Sql DBSemigroup a => Semigroup (Expr a) where
63− (<>) = case nullabilization @a of
56+ (<>) = case nullable @a of
64− Nullable -> liftOpNullable (<>.)
57+ Null -> liftOpNull (<>.)
65− NonNullable -> (<>.)
58+ NotNull -> (<>.)
66 {-# INLINABLE (<>) #-}
59 {-# INLINABLE (<>) #-}
67
60
68
61
69instance Sql DBMonoid a => Monoid (Expr a) where
62instance Sql DBMonoid a => Monoid (Expr a) where
70− mempty = case nullabilization @a of
63+ mempty = case nullable @a of
71− Nullable -> nullify memptyExpr
64+ Null -> nullify memptyExpr
72− NonNullable -> memptyExpr
65+ NotNull -> memptyExpr
73 {-# INLINABLE mempty #-}
66 {-# INLINABLE mempty #-}
74
67
75
68
76instance (Sql IsString a, Sql DBType a) => IsString (Expr a) where
69instance (Sql IsString a, Sql DBType a) => IsString (Expr a) where
77− fromString = litExpr . case nullabilization @a of
70+ fromString = litExpr . case nullable @a of
78− Nullable -> Just . fromString
71+ Null -> Just . fromString
79− NonNullable -> fromString
72+ NotNull -> fromString
80
73
81
74
82instance Sql DBNum a => Num (Expr a) where
75instance Sql DBNum a => Num (Expr a) where
@@ -99,28 +92,34 @@ instance Sql DBFractional a => Fractional (Expr a) where
99 castExpr . Expr . Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac
92 castExpr . Expr . Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac
100
93
101
94
102−instance Interpretation Expr where
95+instance Sql DBFloating a => Floating (Expr a) where
103− data Col Expr _spec where
96+ pi = nullaryFunction "PI"
104− DB :: {unDB :: Expr a} -> Col Expr ('Spec labels necessity a)
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"
105
114
106
115
107instance Sql DBType a => Table Expr (Expr a) where
116instance Sql DBType a => Table Expr (Expr a) where
108− type Columns (Expr a) = HType a
117+ type Columns (Expr a) = HIdentity a
109 type Context (Expr a) = Expr
118 type Context (Expr a) = Expr
119+ type FromExprs (Expr a) = a
120+ type Transpose to (Expr a) = to a
110
121
111− toColumns a = HType (DB a)
122+ toColumns a = HIdentity a
112− fromColumns (HType (DB a)) = a
123+ fromColumns (HIdentity a) = a
113−
124+ toResult a = HIdentity (Identity a)
114−
125+ fromResult (HIdentity (Identity a)) = a
115−instance Sql DBType a => Recontextualize Expr Expr (Expr a) (Expr a)
116−
117−
118−instance Sql DBType a => Recontextualize Expr Identity (Expr a) (Identity a)
119−
120−
121−instance Sql DBType a => Recontextualize Identity Expr (Identity a) (Expr a)
122−
123−
124−instance Labelable Expr where
125− labeler (DB a) = DB a
126− unlabeler (DB a) = DB a
src/Rel8/Expr.hs-boot+5−4
@@ -1,4 +1,4 @@
1−{-# language RoleAnnotations #-}
1+{-# language DataKinds #-}
2{-# language StandaloneKindSignatures #-}
2{-# language StandaloneKindSignatures #-}
3
3
4module Rel8.Expr
4module Rel8.Expr
@@ -7,13 +7,14 @@ module Rel8.Expr
7where
7where
8
8
9-- base
9-- base
10−import Data.Kind ( Type )
11import Prelude ()
10import Prelude ()
12
11
13-- opaleye
12-- opaleye
14import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
13import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
15
14
15+-- rel8
16+import Rel8.Schema.Kind ( Context )
16
17
17−type role Expr representational
18+
18−type Expr :: Type -> Type
19+type Expr :: Context
19newtype Expr a = Expr Opaleye.PrimExpr
20newtype Expr a = Expr Opaleye.PrimExpr
src/Rel8/Expr/Aggregate.hs+59−83
@@ -1,7 +1,6 @@
1{-# language DataKinds #-}
1{-# language DataKinds #-}
2{-# language FlexibleContexts #-}
2{-# language FlexibleContexts #-}
3{-# language ScopedTypeVariables #-}
3{-# language ScopedTypeVariables #-}
4−{-# language TypeApplications #-}
5{-# language TypeFamilies #-}
4{-# language TypeFamilies #-}
6
5
7{-# options_ghc -fno-warn-redundant-constraints #-}
6{-# options_ghc -fno-warn-redundant-constraints #-}
@@ -11,9 +10,11 @@ module Rel8.Expr.Aggregate
11 , and, or
10 , and, or
12 , min, max
11 , min, max
13 , sum, sumWhere
12 , sum, sumWhere
13+ , avg
14 , stringAgg
14 , stringAgg
15 , groupByExpr
15 , groupByExpr
16 , listAggExpr, nonEmptyAggExpr
16 , listAggExpr, nonEmptyAggExpr
17+ , slistAggExpr, snonEmptyAggExpr
17 )
18 )
18where
19where
19
20
@@ -23,10 +24,12 @@ import Data.List.NonEmpty ( NonEmpty )
23import Prelude hiding ( and, max, min, null, or, sum )
24import Prelude hiding ( and, max, min, null, or, sum )
24
25
25-- opaleye
26-- opaleye
26−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
27+import qualified Opaleye.Internal.Aggregate as Opaleye
28+import Opaleye.Internal.Column ( Field_( Column ) )
29+import qualified Opaleye.Aggregate as Opaleye
27
30
28-- rel8
31-- rel8
29−import Rel8.Aggregate ( Aggregate, Aggregator(..), unsafeMakeAggregate )
32+import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )
30import Rel8.Expr ( Expr )
33import Rel8.Expr ( Expr )
31import Rel8.Expr.Bool ( caseExpr )
34import Rel8.Expr.Bool ( caseExpr )
32import Rel8.Expr.Opaleye
35import Rel8.Expr.Opaleye
@@ -37,9 +40,11 @@ import Rel8.Expr.Opaleye
37 )
40 )
38import Rel8.Expr.Null ( null )
41import Rel8.Expr.Null ( null )
39import Rel8.Expr.Serialize ( litExpr )
42import Rel8.Expr.Serialize ( litExpr )
40−import Rel8.Schema.Nullability ( Sql )
43+import Rel8.Schema.Null ( Sql, Unnullify )
44+import Rel8.Type ( DBType, typeInformation )
41−import Rel8.Type.Array ( fromPrimArray )
45+import Rel8.Type.Array ( encodeArrayElement )
42import Rel8.Type.Eq ( DBEq )
46import Rel8.Type.Eq ( DBEq )
47+import Rel8.Type.Information ( TypeInformation )
43import Rel8.Type.Num ( DBNum )
48import Rel8.Type.Num ( DBNum )
44import Rel8.Type.Ord ( DBMax, DBMin )
49import Rel8.Type.Ord ( DBMax, DBMin )
45import Rel8.Type.String ( DBString )
50import Rel8.Type.String ( DBString )
@@ -47,128 +52,99 @@ import Rel8.Type.Sum ( DBSum )
47
52
48
53
49-- | Count the occurances of a single column. Corresponds to @COUNT(a)@
54-- | Count the occurances of a single column. Corresponds to @COUNT(a)@
50−count :: Expr a -> Aggregate (Expr Int64)
55+count :: Expr a -> Aggregate Int64
51−count = unsafeMakeAggregate toPrimExpr fromPrimExpr $
56+count = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.count
52− Just Aggregator
53− { operation = Opaleye.AggrCount
54− , ordering = []
55− , distinction = Opaleye.AggrAll
56− }
57−
58
57
59-- | Count the number of distinct occurances of a single column. Corresponds to
58-- | Count the number of distinct occurances of a single column. Corresponds to
60-- @COUNT(DISTINCT a)@
59-- @COUNT(DISTINCT a)@
61−countDistinct :: Sql DBEq a => Expr a -> Aggregate (Expr Int64)
60+countDistinct :: Sql DBEq a => Expr a -> Aggregate Int64
62countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $
61countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $
63− Just Aggregator
62+ Opaleye.distinctAggregator Opaleye.count
64− { operation = Opaleye.AggrCount
65− , ordering = []
66− , distinction = Opaleye.AggrDistinct
67− }
68
63
69
64
70-- | Corresponds to @COUNT(*)@.
65-- | Corresponds to @COUNT(*)@.
71−countStar :: Aggregate (Expr Int64)
66+countStar :: Aggregate Int64
72countStar = count (litExpr True)
67countStar = count (litExpr True)
73
68
74
69
75-- | A count of the number of times a given expression is @true@.
70-- | A count of the number of times a given expression is @true@.
76−countWhere :: Expr Bool -> Aggregate (Expr Int64)
71+countWhere :: Expr Bool -> Aggregate Int64
77countWhere condition = count (caseExpr [(condition, litExpr (Just True))] null)
72countWhere condition = count (caseExpr [(condition, litExpr (Just True))] null)
78
73
79
74
80-- | Corresponds to @bool_and@.
75-- | Corresponds to @bool_and@.
81−and :: Expr Bool -> Aggregate (Expr Bool)
76+and :: Expr Bool -> Aggregate Bool
82−and = unsafeMakeAggregate toPrimExpr fromPrimExpr $
77+and = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolAnd
83− Just Aggregator
84− { operation = Opaleye.AggrBoolAnd
85− , ordering = []
86− , distinction = Opaleye.AggrAll
87− }
88
78
89
79
90-- | Corresponds to @bool_or@.
80-- | Corresponds to @bool_or@.
91−or :: Expr Bool -> Aggregate (Expr Bool)
81+or :: Expr Bool -> Aggregate Bool
92−or = unsafeMakeAggregate toPrimExpr fromPrimExpr $
82+or = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolOr
93− Just Aggregator
94− { operation = Opaleye.AggrBoolOr
95− , ordering = []
96− , distinction = Opaleye.AggrAll
97− }
98
83
99
84
100-- | Produce an aggregation for @Expr a@ using the @max@ function.
85-- | Produce an aggregation for @Expr a@ using the @max@ function.
101−max :: Sql DBMax a => Expr a -> Aggregate (Expr a)
86+max :: Sql DBMax a => Expr a -> Aggregate a
102−max = unsafeMakeAggregate toPrimExpr fromPrimExpr $
87+max = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMax
103− Just Aggregator
104− { operation = Opaleye.AggrMax
105− , ordering = []
106− , distinction = Opaleye.AggrAll
107− }
108
88
109
89
110-- | Produce an aggregation for @Expr a@ using the @max@ function.
90-- | Produce an aggregation for @Expr a@ using the @max@ function.
111−min :: Sql DBMin a => Expr a -> Aggregate (Expr a)
91+min :: Sql DBMin a => Expr a -> Aggregate a
112−min = unsafeMakeAggregate toPrimExpr fromPrimExpr $
92+min = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMin
113− Just Aggregator
114− { operation = Opaleye.AggrMin
115− , ordering = []
116− , distinction = Opaleye.AggrAll
117− }
118
93
119-- | Corresponds to @sum@. Note that in SQL, @sum@ is type changing - for
94-- | Corresponds to @sum@. Note that in SQL, @sum@ is type changing - for
120-- example the @sum@ of @integer@ returns a @bigint@. Rel8 doesn't support
95-- example the @sum@ of @integer@ returns a @bigint@. Rel8 doesn't support
121−-- this, and will add explicit cast back to the original input type. This can
96+-- this, and will add explicit casts back to the original input type. This can
122-- lead to overflows, and if you anticipate very large sums, you should upcast
97-- lead to overflows, and if you anticipate very large sums, you should upcast
123-- your input.
98-- your input.
124−sum :: Sql DBSum a => Expr a -> Aggregate (Expr a)
99+sum :: Sql DBSum a => Expr a -> Aggregate a
125−sum = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $
100+sum = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) Opaleye.unsafeSum
126− Just Aggregator
101+
127− { operation = Opaleye.AggrSum
128− , ordering = []
129− , distinction = Opaleye.AggrAll
130− }
131
102
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
132
110
111+-- | Take the sum of all expressions that satisfy a predicate.
133sumWhere :: (Sql DBNum a, Sql DBSum a)
112sumWhere :: (Sql DBNum a, Sql DBSum a)
134− => Expr Bool -> Expr a -> Aggregate (Expr a)
113+ => Expr Bool -> Expr a -> Aggregate a
135sumWhere condition a = sum (caseExpr [(condition, a)] 0)
114sumWhere condition a = sum (caseExpr [(condition, a)] 0)
136
115
137
116
138-- | Corresponds to @string_agg()@.
117-- | Corresponds to @string_agg()@.
139stringAgg :: Sql DBString a
118stringAgg :: Sql DBString a
140− => Expr db -> Expr a -> Aggregate (Expr a)
119+ => Expr db -> Expr a -> Aggregate a
141stringAgg delimiter =
120stringAgg delimiter =
142− unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $
121+ unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) (Opaleye.stringAgg (Column (toPrimExpr delimiter)))
143− Just Aggregator
144− { operation = Opaleye.AggrStringAggr (toPrimExpr delimiter)
145− , ordering = []
146− , distinction = Opaleye.AggrAll
147− }
148
122
149
123
150-- | Aggregate a value by grouping by it.
124-- | Aggregate a value by grouping by it.
151−groupByExpr :: Sql DBEq a => Expr a -> Aggregate (Expr a)
125+groupByExpr :: Sql DBEq a => Expr a -> Aggregate a
152−groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Nothing
126+groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.groupBy
127+
128+
129+-- | Collect expressions values as a list.
130+listAggExpr :: Sql DBType a => Expr a -> Aggregate [a]
131+listAggExpr = slistAggExpr typeInformation
132+
133+
134+-- | Collect expressions values as a non-empty list.
135+nonEmptyAggExpr :: Sql DBType a => Expr a -> Aggregate (NonEmpty a)
136+nonEmptyAggExpr = snonEmptyAggExpr typeInformation
153
137
154
138
139+slistAggExpr :: ()
155−listAggExpr :: Expr a -> Aggregate (Expr [a])
140+ => TypeInformation (Unnullify a) -> Expr a -> Aggregate [a]
156−listAggExpr = unsafeMakeAggregate toPrimExpr from $ Just
141+slistAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg
157− Aggregator
158− { operation = Opaleye.AggrArr
159− , ordering = []
160− , distinction = Opaleye.AggrAll
161− }
162 where
142 where
163− from = fromPrimExpr . fromPrimArray
143+ to = encodeArrayElement info . toPrimExpr
164
144
165
145
146+snonEmptyAggExpr :: ()
166−nonEmptyAggExpr :: Expr a -> Aggregate (Expr (NonEmpty a))
147+ => TypeInformation (Unnullify a) -> Expr a -> Aggregate (NonEmpty a)
167−nonEmptyAggExpr = unsafeMakeAggregate toPrimExpr from $ Just
148+snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg
168− Aggregator
169− { operation = Opaleye.AggrArr
170− , ordering = []
171− , distinction = Opaleye.AggrAll
172− }
173 where
149 where
174− from = fromPrimExpr . fromPrimArray
150+ to = encodeArrayElement info . toPrimExpr
src/Rel8/Expr/Array.hs+6−6
@@ -25,21 +25,21 @@ import Rel8.Expr.Opaleye
25 , zipPrimExprsWith
25 , zipPrimExprsWith
26 )
26 )
27import Rel8.Type ( DBType, typeInformation )
27import Rel8.Type ( DBType, typeInformation )
28−import Rel8.Type.Array ( array, zipPrimArraysWith )
28+import Rel8.Type.Array ( array )
29import Rel8.Type.Information ( TypeInformation(..) )
29import Rel8.Type.Information ( TypeInformation(..) )
30−import Rel8.Schema.Nullability ( Unnullify, Nullability, Sql )
30+import Rel8.Schema.Null ( Unnullify, Sql )
31
31
32
32
33sappend :: Expr [a] -> Expr [a] -> Expr [a]
33sappend :: Expr [a] -> Expr [a] -> Expr [a]
34−sappend = zipPrimExprsWith (zipPrimArraysWith (Opaleye.BinExpr (Opaleye.:||)))
34+sappend = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
35
35
36
36
37sappend1 :: Expr (NonEmpty a) -> Expr (NonEmpty a) -> Expr (NonEmpty a)
37sappend1 :: Expr (NonEmpty a) -> Expr (NonEmpty a) -> Expr (NonEmpty a)
38−sappend1 = zipPrimExprsWith (zipPrimArraysWith (Opaleye.BinExpr (Opaleye.:||)))
38+sappend1 = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
39
39
40
40
41−sempty :: Nullability a -> TypeInformation (Unnullify a) -> Expr [a]
41+sempty :: TypeInformation (Unnullify a) -> Expr [a]
42−sempty _ info = fromPrimExpr $ array info []
42+sempty info = fromPrimExpr $ array info []
43
43
44
44
45slistOf :: TypeInformation (Unnullify a) -> [Expr a] -> Expr [a]
45slistOf :: TypeInformation (Unnullify a) -> [Expr a] -> Expr [a]
src/Rel8/Expr/Bool.hs+8−42
@@ -1,3 +1,5 @@
1+{-# language GADTs #-}
2+
1module Rel8.Expr.Bool
3module Rel8.Expr.Bool
2 ( false, true
4 ( false, true
3 , (&&.), (||.), not_
5 , (&&.), (||.), not_
@@ -17,7 +19,7 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
17
19
18-- rel8
20-- rel8
19import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
21import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
20−import Rel8.Expr.Opaleye ( mapPrimExpr, zipPrimExprsWith )
22+import Rel8.Expr.Opaleye ( mapPrimExpr, toPrimExpr, zipPrimExprsWith )
21import Rel8.Expr.Serialize ( litExpr )
23import Rel8.Expr.Serialize ( litExpr )
22
24
23
25
@@ -32,68 +34,28 @@ true = litExpr True
32
34
33
35
34-- | The SQL @AND@ operator.
36-- | 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)
46(&&.) :: Expr Bool -> Expr Bool -> Expr Bool
37(&&.) :: Expr Bool -> Expr Bool -> Expr Bool
47(&&.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpAnd)
38(&&.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpAnd)
48infixr 3 &&.
39infixr 3 &&.
49
40
50
41
51-- | The SQL @OR@ operator.
42-- | 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)
63(||.) :: Expr Bool -> Expr Bool -> Expr Bool
43(||.) :: Expr Bool -> Expr Bool -> Expr Bool
64(||.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpOr)
44(||.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpOr)
65infixr 2 ||.
45infixr 2 ||.
66
46
67
47
68-- | The SQL @NOT@ operator.
48-- | The SQL @NOT@ operator.
69−--
70−-- >>> select c $ pure $ not_ $ lit True
71−-- [False]
72−--
73−-- >>> select c $ pure $ not_ $ lit False
74−-- [True]
75not_ :: Expr Bool -> Expr Bool
49not_ :: Expr Bool -> Expr Bool
76not_ = mapPrimExpr (Opaleye.UnExpr Opaleye.OpNot)
50not_ = mapPrimExpr (Opaleye.UnExpr Opaleye.OpNot)
77
51
78
52
79-- | Fold @AND@ over a collection of expressions.
53-- | 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]
86and_ :: Foldable f => f (Expr Bool) -> Expr Bool
54and_ :: Foldable f => f (Expr Bool) -> Expr Bool
87and_ = foldl' (&&.) true
55and_ = foldl' (&&.) true
88
56
89
57
90-- | Fold @OR@ over a collection of expressions.
58-- | 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]
97or_ :: Foldable f => f (Expr Bool) -> Expr Bool
59or_ :: Foldable f => f (Expr Bool) -> Expr Bool
98or_ = foldl' (||.) false
60or_ = foldl' (||.) false
99
61
@@ -115,9 +77,13 @@ caseExpr :: [(Expr Bool, Expr a)] -> Expr a -> Expr a
115caseExpr branches (Expr fallback) =
77caseExpr branches (Expr fallback) =
116 Expr $ Opaleye.CaseExpr (map go branches) fallback
78 Expr $ Opaleye.CaseExpr (map go branches) fallback
117 where
79 where
118− go (Expr condition, Expr value) = (condition, value)
80+ go (condition, value) = (toPrimExpr condition, toPrimExpr value)
119
81
120
82
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.
121coalesce :: Expr (Maybe Bool) -> Expr Bool
87coalesce :: Expr (Maybe Bool) -> Expr Bool
122coalesce (Expr a) = Expr a &&. Expr (Opaleye.FunExpr "COALESCE" [a, untrue])
88coalesce (Expr a) = Expr a &&. Expr (Opaleye.FunExpr "COALESCE" [a, untrue])
123 where
89 where
src/Rel8/Expr/Default.hsnew file+35
@@ -0,0 +1,35 @@
1+module Rel8.Expr.Default
2+ ( unsafeDefault
3+ )
4+where
5+
6+-- base
7+import Prelude ()
8+
9+-- opaleye
10+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
11+
12+-- rel8
13+import Rel8.Expr ( Expr )
14+import Rel8.Expr.Opaleye ( fromPrimExpr )
15+
16+
17+-- | Corresponds to the SQL @DEFAULT@ expression.
18+--
19+-- This 'Expr' is unsafe for numerous reasons, and should be used with care:
20+--
21+-- 1. This 'Expr' only makes sense in an @INSERT@ or @UPDATE@ statement.
22+--
23+-- 2. Rel8 is not able to verify that a particular column actually has a
24+-- @DEFAULT@ value. Trying to use @unsafeDefault@ where there is no default
25+-- will cause a runtime crash
26+--
27+-- 3. @DEFAULT@ values can not be transformed. For example, the innocuous Rel8
28+-- code @unsafeDefault + 1@ will crash, despite type checking.
29+--
30+-- Given all these caveats, we suggest avoiding the use of default values where
31+-- possible, instead being explicit. A common scenario where default values are
32+-- used is with auto-incrementing identifier columns. In this case, we suggest
33+-- using 'Rel8.nextval' instead.
34+unsafeDefault :: Expr a
35+unsafeDefault = fromPrimExpr Opaleye.DefaultInsertExpr
src/Rel8/Expr/Eq.hs+15−35
@@ -1,6 +1,5 @@
1{-# language FlexibleContexts #-}
1{-# language FlexibleContexts #-}
2{-# language GADTs #-}
2{-# language GADTs #-}
3−{-# language LambdaCase #-}
4{-# language ScopedTypeVariables #-}
3{-# language ScopedTypeVariables #-}
5{-# language TypeApplications #-}
4{-# language TypeApplications #-}
6{-# language ViewPatterns #-}
5{-# language ViewPatterns #-}
@@ -25,12 +24,9 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
25-- rel8
24-- rel8
26import Rel8.Expr ( Expr )
25import Rel8.Expr ( Expr )
27import Rel8.Expr.Bool ( (&&.), (||.), false, or_, coalesce )
26import Rel8.Expr.Bool ( (&&.), (||.), false, or_, coalesce )
28−import Rel8.Expr.Null ( isNull, unsafeLiftOpNullable )
27+import Rel8.Expr.Null ( isNull, unsafeLiftOpNull )
29import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr, zipPrimExprsWith )
28import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr, zipPrimExprsWith )
30−import Rel8.Schema.Nullability
29+import Rel8.Schema.Null ( Nullity( NotNull, Null ), Sql, nullable )
31− ( Nullability( NonNullable, Nullable )
32− , Sql, nullabilization
33− )
34import Rel8.Type.Eq ( DBEq )
30import Rel8.Type.Eq ( DBEq )
35
31
36
32
@@ -49,10 +45,11 @@ ne = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:<>))
49-- This operator matches Haskell's '==' operator. For an operator identical to
45-- This operator matches Haskell's '==' operator. For an operator identical to
50-- SQL @=@, see '==?'.
46-- SQL @=@, see '==?'.
51(==.) :: forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool
47(==.) :: forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool
52−(==.) = case nullabilization @a of
48+(==.) = case nullable @a of
53− Nullable -> \ma mb -> isNull ma &&. isNull mb ||. ma ==? mb
49+ Null -> \ma mb -> isNull ma &&. isNull mb ||. ma ==? mb
54− NonNullable -> eq
50+ NotNull -> eq
55infix 4 ==.
51infix 4 ==.
52+{-# INLINABLE (==.) #-}
56
53
57
54
58-- | Test if two expressions are different (not equal).
55-- | Test if two expressions are different (not equal).
@@ -62,10 +59,11 @@ infix 4 ==.
62-- which would return @null@. This operator is closer to Haskell's '=='
59-- which would return @null@. This operator is closer to Haskell's '=='
63-- operator. For an operator identical to SQL @=@, see '/=?'.
60-- operator. For an operator identical to SQL @=@, see '/=?'.
64(/=.) :: forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool
61(/=.) :: forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool
65−(/=.) = case nullabilization @a of
62+(/=.) = case nullable @a of
66− Nullable -> \ma mb -> isNull ma `ne` isNull mb ||. ma /=? mb
63+ Null -> \ma mb -> isNull ma `ne` isNull mb ||. ma /=? mb
67− NonNullable -> ne
64+ NotNull -> ne
68infix 4 /=.
65infix 4 /=.
66+{-# INLINABLE (/=.) #-}
69
67
70
68
71-- | Test if two expressions are equal. This operator is usually the best
69-- | Test if two expressions are equal. This operator is usually the best
@@ -74,14 +72,8 @@ infix 4 /=.
74--
72--
75-- This corresponds to the SQL @=@ operator, though it will always return a
73-- This corresponds to the SQL @=@ operator, though it will always return a
76-- 'Bool'.
74-- 'Bool'.
77−--
78−-- >>> select c $ pure $ lit Nothing ==? lit True
79−-- False
80−--
81−-- >>> select c $ pure $ lit Nothing ==? lit Nothing
82−-- False
83(==?) :: DBEq a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
75(==?) :: DBEq a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
84−a ==? b = coalesce $ unsafeLiftOpNullable eq a b
76+a ==? b = coalesce $ unsafeLiftOpNull eq a b
85infix 4 ==?
77infix 4 ==?
86
78
87
79
@@ -89,30 +81,18 @@ infix 4 ==?
89--
81--
90-- This corresponds to the SQL @<>@ operator, though it will always return a
82-- This corresponds to the SQL @<>@ operator, though it will always return a
91-- 'Bool'.
83-- 'Bool'.
92−--
93−-- >>> select c $ pure $ lit Nothing /=? lit True
94−-- True
95−--
96−-- >>> select c $ pure $ lit Nothing /=? lit Nothing
97−-- False
98(/=?) :: DBEq a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
84(/=?) :: DBEq a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
99−a /=? b = coalesce $ unsafeLiftOpNullable ne a b
85+a /=? b = coalesce $ unsafeLiftOpNull ne a b
100infix 4 /=?
86infix 4 /=?
101
87
102
88
103-- | Like the SQL @IN@ operator, but implemented by folding over a list with
89-- | Like the SQL @IN@ operator, but implemented by folding over a list with
104-- '==.' and '||.'.
90-- '==.' and '||.'.
105−--
106−-- >>> select c $ return $ lit (5 :: Int32) `in_` [ lit x | x <- [1..5] ]
107−-- [True]
108−--
109−-- >>> select c $ return $ lit (42 :: Int32) `in_` [ lit x | x <- [1..5] ]
110−-- [False]
111in_ :: forall a f. (Sql DBEq a, Foldable f)
91in_ :: forall a f. (Sql DBEq a, Foldable f)
112 => Expr a -> f (Expr a) -> Expr Bool
92 => Expr a -> f (Expr a) -> Expr Bool
113−in_ a (toList -> as) = case nullabilization @a of
93+in_ a (toList -> as) = case nullable @a of
114− Nullable -> or_ $ map (a ==.) as
94+ Null -> or_ $ map (a ==.) as
115− NonNullable -> case nonEmpty as of
95+ NotNull -> case nonEmpty as of
116 Nothing -> false
96 Nothing -> false
117 Just xs ->
97 Just xs ->
118 fromPrimExpr $
98 fromPrimExpr $
src/Rel8/Expr/Function.hs+2−33
@@ -20,12 +20,12 @@ 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 Rel8.Expr ( Expr( Expr ) )
23+import {-# SOURCE #-} 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.Nullability ( Sql )
28+import Rel8.Schema.Null ( Sql )
29import Rel8.Type ( DBType )
29import Rel8.Type ( DBType )
30
30
31
31
@@ -47,42 +47,11 @@ instance (arg ~ Expr a, Function args res) => Function arg (args -> res) where
47
47
48-- | Construct an n-ary function that produces an 'Expr' that when called runs
48-- | Construct an n-ary function that produces an 'Expr' that when called runs
49-- a SQL function.
49-- a SQL function.
50−--
51−-- For example, here's how we can wrap PostgreSQL's @factorial@ function:
52−--
53−-- >>> :{
54−-- factorial :: Expr Int64 -> Expr Data.Scientific.Scientific
55−-- factorial = function "factorial"
56−-- :}
57−--
58−-- >>> select c $ pure $ factorial 5
59−-- [120.0]
60−--
61−-- The same approach works for any number of arguments:
62−--
63−-- >>> :{
64−-- power :: Expr Float -> Expr Float -> Expr Double
65−-- power = function "power"
66−-- :}
67−--
68−-- >>> select c $ pure $ power 9 3
69−-- [729.0]
70function :: Function args result => String -> args -> result
50function :: Function args result => String -> args -> result
71function = applyArgument . Opaleye.FunExpr
51function = applyArgument . Opaleye.FunExpr
72
52
73
53
74-- | Construct a function call for functions with no arguments.
54-- | Construct a function call for functions with no arguments.
75−--
76−-- For example, we can call the database function @pi()@ by using
77−-- @nullaryFunction@:
78−--
79−-- >>> :{
80−-- sqlPi :: Expr Double
81−-- sqlPi = nullaryFunction "pi"
82−-- :}
83−--
84−-- >>> select c $ pure $ sqlPi
85−-- [3.141592653589793]
86nullaryFunction :: Sql DBType a => String -> Expr a
55nullaryFunction :: Sql DBType a => String -> Expr a
87nullaryFunction name = castExpr $ Expr (Opaleye.FunExpr name [])
56nullaryFunction name = castExpr $ Expr (Opaleye.FunExpr name [])
88
57
src/Rel8/Expr/Null.hs+20−31
@@ -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, nullable, nullableOf
8+ ( null, snull, nullableExpr, nullableOf
9 , isNull, isNonNull
9 , isNull, isNonNull
10 , nullify, unsafeUnnullify
10 , nullify, unsafeUnnullify
11− , mapNullable, liftOpNullable
11+ , mapNull, liftOpNull
12− , unsafeMapNullable, unsafeLiftOpNullable
12+ , unsafeMapNull, unsafeLiftOpNull
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.Nullability ( NotNull )
26+import Rel8.Schema.Null ( NotNull )
27import Rel8.Type ( DBType, typeInformation )
27import Rel8.Type ( DBType, typeInformation )
28import Rel8.Type.Information ( TypeInformation )
28import Rel8.Type.Information ( TypeInformation )
29
29
@@ -40,56 +40,45 @@ 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]
49−nullable :: Expr b -> (Expr a -> Expr b) -> Expr (Maybe a) -> Expr b
43+nullableExpr :: Expr b -> (Expr a -> Expr b) -> Expr (Maybe a) -> Expr b
50−nullable b f ma = boolExpr (f (unsafeUnnullify ma)) b (isNull ma)
44+nullableExpr b f ma = boolExpr (f (unsafeUnnullify ma)) b (isNull ma)
51
45
52
46
53nullableOf :: DBType a => Maybe (Expr a) -> Expr (Maybe a)
47nullableOf :: DBType a => Maybe (Expr a) -> Expr (Maybe a)
54nullableOf = maybe null nullify
48nullableOf = maybe null nullify
55
49
56
50
57−-- | Like 'isNothing', but for @null@.
51+-- | Like 'Data.Maybe.isNothing', but for @null@.
58−--
59−-- >>> select c $ pure $ isNull (nullExpr :: Expr (Maybe Int32))
60−-- [True]
61−--
62−-- >>> select c $ pure $ isNull (lit (Just 42) :: Expr (Maybe Int32))
63−-- [False]
64isNull :: Expr (Maybe a) -> Expr Bool
52isNull :: Expr (Maybe a) -> Expr Bool
65isNull = mapPrimExpr (Opaleye.UnExpr Opaleye.OpIsNull)
53isNull = mapPrimExpr (Opaleye.UnExpr Opaleye.OpIsNull)
66
54
67
55
68−-- | Like 'isJust', but for @null@.
56+-- | Like 'Data.Maybe.isJust', but for @null@.
69isNonNull :: Expr (Maybe a) -> Expr Bool
57isNonNull :: Expr (Maybe a) -> Expr Bool
70isNonNull = mapPrimExpr (Opaleye.UnExpr Opaleye.OpIsNotNull)
58isNonNull = mapPrimExpr (Opaleye.UnExpr Opaleye.OpIsNotNull)
71
59
72
60
73-- | Lift an operation on non-@null@ values to an operation on possibly @null@
61-- | Lift an operation on non-@null@ values to an operation on possibly @null@
74−-- values. When given @null@, @mapNullable f@ returns @null@.
62+-- values. When given @null@, @mapNull f@ returns @null@.
75--
63--
76-- This is like 'fmap' for 'Maybe'.
64-- This is like 'fmap' for 'Maybe'.
77−mapNullable :: DBType b
65+mapNull :: DBType b
78 => (Expr a -> Expr b) -> Expr (Maybe a) -> Expr (Maybe b)
66 => (Expr a -> Expr b) -> Expr (Maybe a) -> Expr (Maybe b)
79−mapNullable f ma = boolExpr (unsafeMapNullable f ma) null (isNull ma)
67+mapNull f ma = boolExpr (unsafeMapNull f ma) null (isNull ma)
80
68
81
69
82-- | Lift a binary operation on non-@null@ expressions to an equivalent binary
70-- | Lift a binary operation on non-@null@ expressions to an equivalent binary
83-- operator on possibly @null@ expressions. If either of the final arguments
71-- operator on possibly @null@ expressions. If either of the final arguments
84−-- are @null@, @liftOpNullable@ returns @null@.
72+-- are @null@, @liftOpNull@ returns @null@.
85--
73--
86-- This is like 'liftA2' for 'Maybe'.
74-- This is like 'liftA2' for 'Maybe'.
87−liftOpNullable :: DBType c
75+liftOpNull :: DBType c
88 => (Expr a -> Expr b -> Expr c)
76 => (Expr a -> Expr b -> Expr c)
89 -> Expr (Maybe a) -> Expr (Maybe b) -> Expr (Maybe c)
77 -> Expr (Maybe a) -> Expr (Maybe b) -> Expr (Maybe c)
90−liftOpNullable f ma mb =
78+liftOpNull f ma mb =
91− boolExpr (unsafeLiftOpNullable f ma mb) null
79+ boolExpr (unsafeLiftOpNull f ma mb) null
92 (isNull ma ||. isNull mb)
80 (isNull ma ||. isNull mb)
81+{-# INLINABLE liftOpNull #-}
93
82
94
83
95snull :: TypeInformation a -> Expr (Maybe a)
84snull :: TypeInformation a -> Expr (Maybe a)
@@ -101,13 +90,13 @@ null :: DBType a => Expr (Maybe a)
101null = snull typeInformation
90null = snull typeInformation
102
91
103
92
104−unsafeMapNullable :: NotNull b
93+unsafeMapNull :: NotNull b
105 => (Expr a -> Expr b) -> Expr (Maybe a) -> Expr (Maybe b)
94 => (Expr a -> Expr b) -> Expr (Maybe a) -> Expr (Maybe b)
106−unsafeMapNullable f ma = nullify (f (unsafeUnnullify ma))
95+unsafeMapNull f ma = nullify (f (unsafeUnnullify ma))
107
96
108
97
109−unsafeLiftOpNullable :: NotNull c
98+unsafeLiftOpNull :: NotNull c
110 => (Expr a -> Expr b -> Expr c)
99 => (Expr a -> Expr b -> Expr c)
111 -> Expr (Maybe a) -> Expr (Maybe b) -> Expr (Maybe c)
100 -> Expr (Maybe a) -> Expr (Maybe b) -> Expr (Maybe c)
112−unsafeLiftOpNullable f ma mb =
101+unsafeLiftOpNull f ma mb =
113 nullify (f (unsafeUnnullify ma) (unsafeUnnullify mb))
102 nullify (f (unsafeUnnullify ma) (unsafeUnnullify mb))
src/Rel8/Expr/Num.hs+62−9
@@ -4,54 +4,107 @@
4{-# options_ghc -fno-warn-redundant-constraints #-}
4{-# options_ghc -fno-warn-redundant-constraints #-}
5
5
6module Rel8.Expr.Num
6module Rel8.Expr.Num
7+ ( fromIntegral
8+ , realToFrac
9+ , div, mod, divMod
10+ , quot, rem, quotRem
7− ( fromIntegral, realToFrac, div, mod, ceiling, floor, round, truncate
11+ , ceiling, floor, round, truncate
8 )
12 )
9where
13where
10
14
11-- base
15-- base
12−import Prelude ()
16+import Prelude ( (+), (-), fst, negate, signum, snd )
13
17
14-- rel
18-- rel
15import Rel8.Expr ( Expr( Expr ) )
19import Rel8.Expr ( Expr( Expr ) )
20+import Rel8.Expr.Eq ( (==.) )
16import Rel8.Expr.Function ( function )
21import Rel8.Expr.Function ( function )
17import Rel8.Expr.Opaleye ( castExpr )
22import Rel8.Expr.Opaleye ( castExpr )
18−import Rel8.Schema.Nullability ( Homonullable, Sql )
23+import Rel8.Schema.Null ( Homonullable, Sql )
24+import Rel8.Table.Bool ( bool )
19import Rel8.Type.Num ( DBFractional, DBIntegral, DBNum )
25import Rel8.Type.Num ( DBFractional, DBIntegral, DBNum )
20
26
21
27
28+-- | Cast 'DBIntegral' types to 'DBNum' types. For example, this can be useful
29+-- if you need to turn an @Expr Int32@ into an @Expr Double@.
22fromIntegral :: (Sql DBIntegral a, Sql DBNum b, Homonullable a b)
30fromIntegral :: (Sql DBIntegral a, Sql DBNum b, Homonullable a b)
23 => Expr a -> Expr b
31 => Expr a -> Expr b
24fromIntegral (Expr a) = castExpr (Expr a)
32fromIntegral (Expr a) = castExpr (Expr a)
25
33
26
34
35+-- | Cast 'DBNum' types to 'DBFractional' types. For example, his can be useful
36+-- to convert @Expr Float@ to @Expr Double@.
27realToFrac :: (Sql DBNum a, Sql DBFractional b, Homonullable a b)
37realToFrac :: (Sql DBNum a, Sql DBFractional b, Homonullable a b)
28 => Expr a -> Expr b
38 => Expr a -> Expr b
29realToFrac (Expr a) = castExpr (Expr a)
39realToFrac (Expr a) = castExpr (Expr a)
30
40
31
41
42+-- | Round a 'DBFractional' to a 'DBIntegral' by rounding to the nearest larger
43+-- integer.
44+--
45+-- Corresponds to the @ceiling()@ function.
32ceiling :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)
46ceiling :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)
33 => Expr a -> Expr b
47 => Expr a -> Expr b
34−ceiling = function "CEILING"
48+ceiling = function "ceiling"
35
49
36
50
51+-- | Emulates the behaviour of the Haskell function 'Prelude.div' in
52+-- PostgreSQL.
37div :: Sql DBIntegral a => Expr a -> Expr a -> Expr a
53div :: Sql DBIntegral a => Expr a -> Expr a -> Expr a
38−div = function "DIV"
54+div n d = fst (divMod n d)
39
55
40
56
57+-- | Emulates the behaviour of the Haskell function 'Prelude.mod' in
58+-- PostgreSQL.
41mod :: Sql DBIntegral a => Expr a -> Expr a -> Expr a
59mod :: Sql DBIntegral a => Expr a -> Expr a -> Expr a
42−mod = function "MOD"
60+mod n d = snd (divMod n d)
43
61
44
62
63+-- | Simultaneous 'div' and 'mod'.
64+divMod :: Sql DBIntegral a => Expr a -> Expr a -> (Expr a, Expr a)
65+divMod n d = bool qr (q - 1, r + d) (signum r ==. negate (signum d))
66+ where
67+ qr@(q, r) = quotRem n d
68+
69+
70+-- | Perform integral division. Corresponds to the @div()@ function in
71+-- PostgreSQL, which behaves like Haskell's 'Prelude.quot' rather than
72+-- 'Prelude.div'.
73+quot :: Sql DBIntegral a => Expr a -> Expr a -> Expr a
74+quot = function "div"
75+
76+
77+-- | Corresponds to the @mod()@ function in PostgreSQL, which behaves like
78+-- Haskell's 'Prelude.rem' rather than 'Prelude.mod'.
79+rem :: Sql DBIntegral a => Expr a -> Expr a -> Expr a
80+rem = function "mod"
81+
82+
83+-- | Simultaneous 'quot' and 'rem'.
84+quotRem :: Sql DBIntegral a => Expr a -> Expr a -> (Expr a, Expr a)
85+quotRem n d = (quot n d, rem n d)
86+
87+
88+-- | Round a 'DFractional' to a 'DBIntegral' by rounding to the nearest smaller
89+-- integer.
90+--
91+-- Corresponds to the @floor()@ function.
45floor :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)
92floor :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)
46 => Expr a -> Expr b
93 => Expr a -> Expr b
47−floor = function "FLOOR"
94+floor = function "floor"
48
95
49
96
97+-- | Round a 'DBFractional' to a 'DBIntegral' by rounding to the nearest
98+-- integer.
99+--
100+-- Corresponds to the @round()@ function.
50round :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)
101round :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)
51 => Expr a -> Expr b
102 => Expr a -> Expr b
52−round = function "ROUND"
103+round = function "round"
53
104
54
105
106+-- | Round a 'DBFractional' to a 'DBIntegral' by rounding to the nearest
107+-- integer towards zero.
55truncate :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)
108truncate :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)
56 => Expr a -> Expr b
109 => Expr a -> Expr b
57−truncate = function "TRUNC"
110+truncate = function "trunc"
src/Rel8/Expr/Opaleye.hs+22−8
@@ -1,8 +1,6 @@
1{-# language FlexibleContexts #-}
1{-# language FlexibleContexts #-}
2−{-# language LambdaCase #-}
3{-# language NamedFieldPuns #-}
2{-# language NamedFieldPuns #-}
4{-# language ScopedTypeVariables #-}
3{-# language ScopedTypeVariables #-}
5−{-# language TypeApplications #-}
6{-# language TypeFamilies #-}
4{-# language TypeFamilies #-}
7
5
8{-# options_ghc -fno-warn-redundant-constraints #-}
6{-# options_ghc -fno-warn-redundant-constraints #-}
@@ -12,7 +10,7 @@ module Rel8.Expr.Opaleye
12 , scastExpr, sunsafeCastExpr
10 , scastExpr, sunsafeCastExpr
13 , unsafeLiteral
11 , unsafeLiteral
14 , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith, traversePrimExpr
12 , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith, traversePrimExpr
15− , toColumn, fromColumn
13+ , toColumn, fromColumn, traverseFieldP
16 )
14 )
17where
15where
18
16
@@ -25,15 +23,20 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
25
23
26-- rel8
24-- rel8
27import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
25import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
28−import Rel8.Schema.Nullability ( Unnullify, Sql )
26+import Rel8.Schema.Null ( Unnullify, Sql )
29import Rel8.Type ( DBType, typeInformation )
27import Rel8.Type ( DBType, typeInformation )
30import Rel8.Type.Information ( TypeInformation(..) )
28import Rel8.Type.Information ( TypeInformation(..) )
31
29
30+-- profunctors
31+import Data.Profunctor ( Profunctor, dimap )
32+
32
33
33castExpr :: Sql DBType a => Expr a -> Expr a
34castExpr :: Sql DBType a => Expr a -> Expr a
34castExpr = scastExpr typeInformation
35castExpr = scastExpr typeInformation
35
36
36
37
38+-- | Cast an expression to a different type. Corresponds to a @CAST()@ function
39+-- call.
37unsafeCastExpr :: Sql DBType b => Expr a -> Expr b
40unsafeCastExpr :: Sql DBType b => Expr a -> Expr b
38unsafeCastExpr = sunsafeCastExpr typeInformation
41unsafeCastExpr = sunsafeCastExpr typeInformation
39
42
@@ -48,8 +51,13 @@ sunsafeCastExpr TypeInformation {typeName} =
48 fromPrimExpr . Opaleye.CastExpr typeName . toPrimExpr
51 fromPrimExpr . Opaleye.CastExpr typeName . toPrimExpr
49
52
50
53
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!
51−unsafeLiteral :: Sql DBType a => String -> Expr a
59+unsafeLiteral :: String -> Expr a
52−unsafeLiteral = castExpr . Expr . Opaleye.ConstExpr . Opaleye.OtherLit
60+unsafeLiteral = Expr . Opaleye.ConstExpr . Opaleye.OtherLit
53
61
54
62
55fromPrimExpr :: Opaleye.PrimExpr -> Expr a
63fromPrimExpr :: Opaleye.PrimExpr -> Expr a
@@ -75,9 +83,15 @@ traversePrimExpr :: Functor f
75traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr
83traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr
76
84
77
85
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+
78−toColumn :: Opaleye.PrimExpr -> Opaleye.Column b
92+toColumn :: Opaleye.PrimExpr -> Opaleye.Field_ n b
79toColumn = Opaleye.Column
93toColumn = Opaleye.Column
80
94
81
95
82−fromColumn :: Opaleye.Column b -> Opaleye.PrimExpr
96+fromColumn :: Opaleye.Field_ n b -> Opaleye.PrimExpr
83fromColumn (Opaleye.Column a) = a
97fromColumn (Opaleye.Column a) = a
src/Rel8/Expr/Ord.hs+28−31
@@ -1,6 +1,5 @@
1{-# language DataKinds #-}
1{-# language DataKinds #-}
2{-# language FlexibleContexts #-}
2{-# language FlexibleContexts #-}
3−{-# language LambdaCase #-}
4{-# language GADTs #-}
3{-# language GADTs #-}
5{-# language ScopedTypeVariables #-}
4{-# language ScopedTypeVariables #-}
6{-# language TypeApplications #-}
5{-# language TypeApplications #-}
@@ -23,12 +22,9 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
23-- rel8
22-- rel8
24import Rel8.Expr ( Expr( Expr ) )
23import Rel8.Expr ( Expr( Expr ) )
25import Rel8.Expr.Bool ( (&&.), (||.), coalesce )
24import Rel8.Expr.Bool ( (&&.), (||.), coalesce )
26−import Rel8.Expr.Null ( isNull, isNonNull, nullable, unsafeLiftOpNullable )
25+import Rel8.Expr.Null ( isNull, isNonNull, nullableExpr, unsafeLiftOpNull )
27−import Rel8.Expr.Opaleye ( zipPrimExprsWith )
26+import Rel8.Expr.Opaleye ( toPrimExpr, zipPrimExprsWith )
28−import Rel8.Schema.Nullability
27+import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
29− ( Nullability( NonNullable, Nullable )
30− , Sql, nullabilization
31− )
32import Rel8.Type.Ord ( DBOrd )
28import Rel8.Type.Ord ( DBOrd )
33
29
34
30
@@ -52,9 +48,9 @@ ge = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:>=))
52-- as @null@ will sort below any other value. For a version of @<@ that exactly
48-- as @null@ will sort below any other value. For a version of @<@ that exactly
53-- matches SQL, see '(<?)'.
49-- matches SQL, see '(<?)'.
54(<.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool
50(<.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool
55−(<.) = case nullabilization @a of
51+(<.) = case nullable @a of
56− Nullable -> \ma mb -> isNull ma &&. isNonNull mb ||. ma <? mb
52+ Null -> \ma mb -> isNull ma &&. isNonNull mb ||. ma <? mb
57− NonNullable -> lt
53+ NotNull -> lt
58infix 4 <.
54infix 4 <.
59
55
60
56
@@ -62,9 +58,9 @@ infix 4 <.
62-- as @null@ will sort below any other value. For a version of @<=@ that exactly
58-- as @null@ will sort below any other value. For a version of @<=@ that exactly
63-- matches SQL, see '(<=?)'.
59-- matches SQL, see '(<=?)'.
64(<=.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool
60(<=.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool
65−(<=.) = case nullabilization @a of
61+(<=.) = case nullable @a of
66− Nullable -> \ma mb -> isNull ma ||. ma <=? mb
62+ Null -> \ma mb -> isNull ma ||. ma <=? mb
67− NonNullable -> le
63+ NotNull -> le
68infix 4 <=.
64infix 4 <=.
69
65
70
66
@@ -72,9 +68,9 @@ infix 4 <=.
72-- as @null@ will sort below any other value. For a version of @>@ that exactly
68-- as @null@ will sort below any other value. For a version of @>@ that exactly
73-- matches SQL, see '(>?)'.
69-- matches SQL, see '(>?)'.
74(>.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool
70(>.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool
75−(>.) = case nullabilization @a of
71+(>.) = case nullable @a of
76− Nullable -> \ma mb -> isNonNull ma &&. isNull mb ||. ma >? mb
72+ Null -> \ma mb -> isNonNull ma &&. isNull mb ||. ma >? mb
77− NonNullable -> gt
73+ NotNull -> gt
78infix 4 >.
74infix 4 >.
79
75
80
76
@@ -82,37 +78,37 @@ infix 4 >.
82-- as @null@ will sort below any other value. For a version of @>=@ that
78-- as @null@ will sort below any other value. For a version of @>=@ that
83-- exactly matches SQL, see '(>=?)'.
79-- exactly matches SQL, see '(>=?)'.
84(>=.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool
80(>=.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool
85−(>=.) = case nullabilization @a of
81+(>=.) = case nullable @a of
86− Nullable -> \ma mb -> isNull mb ||. ma >=? mb
82+ Null -> \ma mb -> isNull mb ||. ma >=? mb
87− NonNullable -> ge
83+ NotNull -> ge
88infix 4 >=.
84infix 4 >=.
89
85
90
86
91-- | Corresponds to the SQL @<@ operator. Returns @null@ if either arguments
87-- | Corresponds to the SQL @<@ operator. Returns @null@ if either arguments
92-- are @null@.
88-- are @null@.
93(<?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
89(<?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
94−a <? b = coalesce $ unsafeLiftOpNullable lt a b
90+a <? b = coalesce $ unsafeLiftOpNull lt a b
95infix 4 <?
91infix 4 <?
96
92
97
93
98-- | Corresponds to the SQL @<=@ operator. Returns @null@ if either arguments
94-- | Corresponds to the SQL @<=@ operator. Returns @null@ if either arguments
99-- are @null@.
95-- are @null@.
100(<=?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
96(<=?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
101−a <=? b = coalesce $ unsafeLiftOpNullable le a b
97+a <=? b = coalesce $ unsafeLiftOpNull le a b
102infix 4 <=?
98infix 4 <=?
103
99
104
100
105-- | Corresponds to the SQL @>@ operator. Returns @null@ if either arguments
101-- | Corresponds to the SQL @>@ operator. Returns @null@ if either arguments
106-- are @null@.
102-- are @null@.
107(>?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
103(>?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
108−a >? b = coalesce $ unsafeLiftOpNullable gt a b
104+a >? b = coalesce $ unsafeLiftOpNull gt a b
109infix 4 >?
105infix 4 >?
110
106
111
107
112-- | Corresponds to the SQL @>=@ operator. Returns @null@ if either arguments
108-- | Corresponds to the SQL @>=@ operator. Returns @null@ if either arguments
113-- are @null@.
109-- are @null@.
114(>=?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
110(>=?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
115−a >=? b = coalesce $ unsafeLiftOpNullable ge a b
111+a >=? b = coalesce $ unsafeLiftOpNull ge a b
116infix 4 >=?
112infix 4 >=?
117
113
118
114
@@ -121,11 +117,11 @@ infix 4 >=?
121--
117--
122-- Corresponds to the SQL @least()@ function.
118-- Corresponds to the SQL @least()@ function.
123leastExpr :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr a
119leastExpr :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr a
124−leastExpr ma mb = case nullabilization @a of
120+leastExpr ma mb = case nullable @a of
125− Nullable -> nullable ma (\a -> nullable mb (least_ a) mb) ma
121+ Null -> nullableExpr ma (\a -> nullableExpr mb (least_ a) mb) ma
126− NonNullable -> least_ ma mb
122+ NotNull -> least_ ma mb
127 where
123 where
128− least_ (Expr a) (Expr b) = Expr (Opaleye.FunExpr "LEAST" [a, b])
124+ least_ a b = Expr (Opaleye.FunExpr "LEAST" [toPrimExpr a, toPrimExpr b])
129
125
130
126
131-- | Given two expressions, return the expression that sorts greater than the
127-- | Given two expressions, return the expression that sorts greater than the
@@ -133,8 +129,9 @@ leastExpr ma mb = case nullabilization @a of
133--
129--
134-- Corresponds to the SQL @greatest()@ function.
130-- Corresponds to the SQL @greatest()@ function.
135greatestExpr :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr a
131greatestExpr :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr a
136−greatestExpr ma mb = case nullabilization @a of
132+greatestExpr ma mb = case nullable @a of
137− Nullable -> nullable mb (\a -> nullable ma (greatest_ a) mb) ma
133+ Null -> nullableExpr mb (\a -> nullableExpr ma (greatest_ a) mb) ma
138− NonNullable -> greatest_ ma mb
134+ NotNull -> greatest_ ma mb
139 where
135 where
136+ greatest_ a b =
140− greatest_ (Expr a) (Expr b) = Expr (Opaleye.FunExpr "GREATEST" [a, b])
137+ Expr (Opaleye.FunExpr "GREATEST" [toPrimExpr a, toPrimExpr b])
src/Rel8/Expr/Order.hs−12
@@ -28,9 +28,6 @@ import Rel8.Type.Ord ( DBOrd )
28
28
29
29
30-- | Sort a column in ascending order.
30-- | Sort a column in ascending order.
31−--
32−-- >>> select c $ orderBy asc $ values [ lit x | x <- [1..5 :: Int32] ]
33−-- [1,2,3,4,5]
34asc :: DBOrd a => Order (Expr a)
31asc :: DBOrd a => Order (Expr a)
35asc = Order $ Opaleye.Order (\expr -> [(orderOp, toPrimExpr expr)])
32asc = Order $ Opaleye.Order (\expr -> [(orderOp, toPrimExpr expr)])
36 where
33 where
@@ -42,9 +39,6 @@ asc = Order $ Opaleye.Order (\expr -> [(orderOp, toPrimExpr expr)])
42
39
43
40
44-- | Sort a column in descending order.
41-- | Sort a column in descending order.
45−--
46−-- >>> select c $ orderBy desc $ values [ lit x | x <- [1..5 :: Int32] ]
47−-- [5,4,3,2,1]
48desc :: DBOrd a => Order (Expr a)
42desc :: DBOrd a => Order (Expr a)
49desc = Order $ Opaleye.Order (\expr -> [(orderOp, toPrimExpr expr)])
43desc = Order $ Opaleye.Order (\expr -> [(orderOp, toPrimExpr expr)])
50 where
44 where
@@ -57,9 +51,6 @@ desc = Order $ Opaleye.Order (\expr -> [(orderOp, toPrimExpr expr)])
57
51
58-- | Transform an ordering so that @null@ values appear first. This corresponds
52-- | Transform an ordering so that @null@ values appear first. This corresponds
59-- to @NULLS FIRST@ in SQL.
53-- to @NULLS FIRST@ in SQL.
60−--
61−-- >>> select c $ orderBy (nullsFirst desc) $ values $ [ nullExpr, nullExpr ] <> [ lit (Just x) | x <- [1..5 :: Int32] ]
62−-- [Nothing,Nothing,Just 5,Just 4,Just 3,Just 2,Just 1]
63nullsFirst :: Order (Expr a) -> Order (Expr (Maybe a))
54nullsFirst :: Order (Expr a) -> Order (Expr (Maybe a))
64nullsFirst (Order (Opaleye.Order f)) =
55nullsFirst (Order (Opaleye.Order f)) =
65 Order $ Opaleye.Order $ fmap (first g) . f . unsafeUnnullify
56 Order $ Opaleye.Order $ fmap (first g) . f . unsafeUnnullify
@@ -70,9 +61,6 @@ nullsFirst (Order (Opaleye.Order f)) =
70
61
71-- | Transform an ordering so that @null@ values appear first. This corresponds
62-- | Transform an ordering so that @null@ values appear first. This corresponds
72-- to @NULLS LAST@ in SQL.
63-- to @NULLS LAST@ in SQL.
73−--
74−-- >>> select c $ orderBy (nullsLast desc) $ values $ [ nullExpr, nullExpr ] <> [ lit (Just x) | x <- [1..5 :: Int32] ]
75−-- [Just 5,Just 4,Just 3,Just 2,Just 1,Nothing,Nothing]
76nullsLast :: Order (Expr a) -> Order (Expr (Maybe a))
64nullsLast :: Order (Expr a) -> Order (Expr (Maybe a))
77nullsLast (Order (Opaleye.Order f)) =
65nullsLast (Order (Opaleye.Order f)) =
78 Order $ Opaleye.Order $ fmap (first g) . f . unsafeUnnullify
66 Order $ Opaleye.Order $ fmap (first g) . f . unsafeUnnullify
src/Rel8/Expr/Sequence.hsnew file+22
@@ -0,0 +1,22 @@
1+module Rel8.Expr.Sequence
2+ ( nextval
3+ )
4+where
5+
6+-- base
7+import Data.Int ( Int64 )
8+import Prelude
9+
10+-- rel8
11+import Rel8.Expr ( Expr )
12+import Rel8.Expr.Function ( function )
13+import Rel8.Expr.Serialize ( litExpr )
14+import Rel8.Expr.Text ( quoteIdent )
15+
16+-- text
17+import Data.Text ( pack )
18+
19+
20+-- | See https://www.postgresql.org/docs/current/functions-sequence.html
21+nextval :: String -> Expr Int64
22+nextval = function "nextval" . quoteIdent . litExpr . pack
src/Rel8/Expr/Serialize.hs+15−15
@@ -21,29 +21,29 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
21-- rel8
21-- rel8
22import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
22import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
23import Rel8.Expr.Opaleye ( scastExpr )
23import Rel8.Expr.Opaleye ( scastExpr )
24−import Rel8.Schema.Nullability
24+import Rel8.Schema.Null ( Unnullify, Nullity( Null, NotNull ), Sql, nullable )
25− ( Unnullify
26− , Nullability( Nullable, NonNullable )
27− , Sql, nullabilization
28− )
29import Rel8.Type ( DBType, typeInformation )
25import Rel8.Type ( DBType, typeInformation )
30import Rel8.Type.Information ( TypeInformation(..) )
26import Rel8.Type.Information ( TypeInformation(..) )
31
27
32
28
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.
33litExpr :: Sql DBType a => a -> Expr a
33litExpr :: Sql DBType a => a -> Expr a
34−litExpr = slitExpr nullabilization typeInformation
34+litExpr = slitExpr nullable typeInformation
35
35
36
36
37−slitExpr :: Nullability a -> TypeInformation (Unnullify a) -> a -> Expr a
37+slitExpr :: Nullity a -> TypeInformation (Unnullify a) -> a -> Expr a
38−slitExpr nullability info@TypeInformation {encode} =
38+slitExpr nullity info@TypeInformation {encode} =
39 scastExpr info . Expr . encoder
39 scastExpr info . Expr . encoder
40 where
40 where
41− encoder = case nullability of
41+ encoder = case nullity of
42− Nullable -> maybe (Opaleye.ConstExpr Opaleye.NullLit) encode
42+ Null -> maybe (Opaleye.ConstExpr Opaleye.NullLit) encode
43− NonNullable -> encode
43+ NotNull -> encode
44
44
45
45
46−sparseValue :: Nullability a -> TypeInformation (Unnullify a) -> Hasql.Row a
46+sparseValue :: Nullity a -> TypeInformation (Unnullify a) -> Hasql.Row a
47−sparseValue nullability TypeInformation {decode, out} = case nullability of
47+sparseValue nullity TypeInformation {decode} = case nullity of
48− Nullable -> Hasql.column $ Hasql.nullable $ out <$> decode
48+ Null -> Hasql.column $ Hasql.nullable decode
49− NonNullable -> Hasql.column $ Hasql.nonNullable $ out <$> decode
49+ NotNull -> Hasql.column $ Hasql.nonNullable decode
src/Rel8/Expr/Text.hs+66−11
@@ -16,7 +16,10 @@ 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, toAscii, toHex, translate
19+ , splitPart, strpos, substr, translate
20+
21+ -- * @LIKE@ and @ILIKE@
22+ , like, ilike
20 )
23 )
21where
24where
22
25
@@ -24,7 +27,7 @@ where
24import Data.Bool ( Bool )
27import Data.Bool ( Bool )
25import Data.Int ( Int32 )
28import Data.Int ( Int32 )
26import Data.Maybe ( Maybe( Nothing, Just ) )
29import Data.Maybe ( Maybe( Nothing, Just ) )
27−import Prelude ()
30+import Prelude ( flip )
28
31
29-- bytestring
32-- bytestring
30import Data.ByteString ( ByteString )
33import Data.ByteString ( ByteString )
@@ -32,7 +35,6 @@ import Data.ByteString ( ByteString )
32-- rel8
35-- rel8
33import Rel8.Expr ( Expr )
36import Rel8.Expr ( Expr )
34import Rel8.Expr.Function ( binaryOperator, function, nullaryFunction )
37import Rel8.Expr.Function ( binaryOperator, function, nullaryFunction )
35−import Rel8.Type.Array1D ( Array1D )
36
38
37-- text
39-- text
38import Data.Text (Text)
40import Data.Text (Text)
@@ -50,24 +52,32 @@ infixr 6 ++.
50
52
51
53
52-- | Matches regular expression, case sensitive
54-- | Matches regular expression, case sensitive
55+--
56+-- Corresponds to the @~.@ operator.
53(~.) :: Expr Text -> Expr Text -> Expr Bool
57(~.) :: Expr Text -> Expr Text -> Expr Bool
54(~.) = binaryOperator "~."
58(~.) = binaryOperator "~."
55infix 2 ~.
59infix 2 ~.
56
60
57
61
58-- | Matches regular expression, case insensitive
62-- | Matches regular expression, case insensitive
63+--
64+-- Corresponds to the @~*@ operator.
59(~*) :: Expr Text -> Expr Text -> Expr Bool
65(~*) :: Expr Text -> Expr Text -> Expr Bool
60(~*) = binaryOperator "~*"
66(~*) = binaryOperator "~*"
61infix 2 ~*
67infix 2 ~*
62
68
63
69
64-- | Does not match regular expression, case sensitive
70-- | Does not match regular expression, case sensitive
71+--
72+-- Corresponds to the @!~@ operator.
65(!~) :: Expr Text -> Expr Text -> Expr Bool
73(!~) :: Expr Text -> Expr Text -> Expr Bool
66(!~) = binaryOperator "!~"
74(!~) = binaryOperator "!~"
67infix 2 !~
75infix 2 !~
68
76
69
77
70-- | Does not match regular expression, case insensitive
78-- | Does not match regular expression, case insensitive
79+--
80+-- Corresponds to the @!~*@ operator.
71(!~*) :: Expr Text -> Expr Text -> Expr Bool
81(!~*) :: Expr Text -> Expr Text -> Expr Bool
72(!~*) = binaryOperator "!~*"
82(!~*) = binaryOperator "!~*"
73infix 2 !~*
83infix 2 !~*
@@ -78,164 +88,209 @@ infix 2 !~*
78-- * Standard SQL functions
88-- * Standard SQL functions
79
89
80
90
91+-- | Corresponds to the @bit_length@ function.
81bitLength :: Expr Text -> Expr Int32
92bitLength :: Expr Text -> Expr Int32
82bitLength = function "bit_length"
93bitLength = function "bit_length"
83
94
84
95
96+-- | Corresponds to the @char_length@ function.
85charLength :: Expr Text -> Expr Int32
97charLength :: Expr Text -> Expr Int32
86charLength = function "char_length"
98charLength = function "char_length"
87
99
88
100
101+-- | Corresponds to the @lower@ function.
89lower :: Expr Text -> Expr Text
102lower :: Expr Text -> Expr Text
90lower = function "lower"
103lower = function "lower"
91
104
92
105
106+-- | Corresponds to the @octet_length@ function.
93octetLength :: Expr Text -> Expr Int32
107octetLength :: Expr Text -> Expr Int32
94octetLength = function "octet_length"
108octetLength = function "octet_length"
95
109
96
110
111+-- | Corresponds to the @upper@ function.
97upper :: Expr Text -> Expr Text
112upper :: Expr Text -> Expr Text
98upper = function "upper"
113upper = function "upper"
99
114
100
115
101−-- * PostgreSQL functions
116+-- | Corresponds to the @ascii@ function.
102ascii :: Expr Text -> Expr Int32
117ascii :: Expr Text -> Expr Int32
103ascii = function "ascii"
118ascii = function "ascii"
104
119
105
120
121+-- | Corresponds to the @btrim@ function.
106btrim :: Expr Text -> Maybe (Expr Text) -> Expr Text
122btrim :: Expr Text -> Maybe (Expr Text) -> Expr Text
107btrim a (Just b) = function "btrim" a b
123btrim a (Just b) = function "btrim" a b
108btrim a Nothing = function "btrim" a
124btrim a Nothing = function "btrim" a
109
125
110
126
127+-- | Corresponds to the @chr@ function.
111chr :: Expr Int32 -> Expr Text
128chr :: Expr Int32 -> Expr Text
112chr = function "chr"
129chr = function "chr"
113
130
114
131
132+-- | Corresponds to the @convert@ function.
115convert :: Expr ByteString -> Expr Text -> Expr Text -> Expr ByteString
133convert :: Expr ByteString -> Expr Text -> Expr Text -> Expr ByteString
116convert = function "convert"
134convert = function "convert"
117
135
118
136
137+-- | Corresponds to the @convert_from@ function.
119convertFrom :: Expr ByteString -> Expr Text -> Expr Text
138convertFrom :: Expr ByteString -> Expr Text -> Expr Text
120convertFrom = function "convert_from"
139convertFrom = function "convert_from"
121
140
122
141
142+-- | Corresponds to the @convert_to@ function.
123convertTo :: Expr Text -> Expr Text -> Expr ByteString
143convertTo :: Expr Text -> Expr Text -> Expr ByteString
124convertTo = function "convert_to"
144convertTo = function "convert_to"
125
145
126
146
147+-- | Corresponds to the @decode@ function.
127decode :: Expr Text -> Expr Text -> Expr ByteString
148decode :: Expr Text -> Expr Text -> Expr ByteString
128decode = function "decode"
149decode = function "decode"
129
150
130
151
152+-- | Corresponds to the @encode@ function.
131encode :: Expr ByteString -> Expr Text -> Expr Text
153encode :: Expr ByteString -> Expr Text -> Expr Text
132encode = function "encode"
154encode = function "encode"
133
155
134
156
157+-- | Corresponds to the @initcap@ function.
135initcap :: Expr Text -> Expr Text
158initcap :: Expr Text -> Expr Text
136initcap = function "initcap"
159initcap = function "initcap"
137
160
138
161
162+-- | Corresponds to the @left@ function.
139left :: Expr Text -> Expr Int32 -> Expr Text
163left :: Expr Text -> Expr Int32 -> Expr Text
140left = function "left"
164left = function "left"
141
165
142
166
167+-- | Corresponds to the @length@ function.
143length :: Expr Text -> Expr Int32
168length :: Expr Text -> Expr Int32
144length = function "length"
169length = function "length"
145
170
146
171
172+-- | Corresponds to the @length@ function.
147lengthEncoding :: Expr ByteString -> Expr Text -> Expr Int32
173lengthEncoding :: Expr ByteString -> Expr Text -> Expr Int32
148lengthEncoding = function "length"
174lengthEncoding = function "length"
149
175
150
176
177+-- | Corresponds to the @lpad@ function.
151lpad :: Expr Text -> Expr Int32 -> Maybe (Expr Text) -> Expr Text
178lpad :: Expr Text -> Expr Int32 -> Maybe (Expr Text) -> Expr Text
152lpad a b (Just c) = function "lpad" a b c
179lpad a b (Just c) = function "lpad" a b c
153lpad a b Nothing = function "lpad" a b
180lpad a b Nothing = function "lpad" a b
154
181
155
182
183+-- | Corresponds to the @ltrim@ function.
156ltrim :: Expr Text -> Maybe (Expr Text) -> Expr Text
184ltrim :: Expr Text -> Maybe (Expr Text) -> Expr Text
157ltrim a (Just b) = function "ltrim" a b
185ltrim a (Just b) = function "ltrim" a b
158ltrim a Nothing = function "ltrim" a
186ltrim a Nothing = function "ltrim" a
159
187
160
188
189+-- | Corresponds to the @md5@ function.
161md5 :: Expr Text -> Expr Text
190md5 :: Expr Text -> Expr Text
162md5 = function "md5"
191md5 = function "md5"
163
192
164
193
194+-- | Corresponds to the @pg_client_encoding()@ expression.
165pgClientEncoding :: Expr Text
195pgClientEncoding :: Expr Text
166pgClientEncoding = nullaryFunction "pg_client_encoding"
196pgClientEncoding = nullaryFunction "pg_client_encoding"
167
197
168
198
199+-- | Corresponds to the @quote_ident@ function.
169quoteIdent :: Expr Text -> Expr Text
200quoteIdent :: Expr Text -> Expr Text
170quoteIdent = function "quote_ident"
201quoteIdent = function "quote_ident"
171
202
172
203
204+-- | Corresponds to the @quote_literal@ function.
173quoteLiteral :: Expr Text -> Expr Text
205quoteLiteral :: Expr Text -> Expr Text
174quoteLiteral = function "quote_literal"
206quoteLiteral = function "quote_literal"
175
207
176
208
209+-- | Corresponds to the @quote_nullable@ function.
177quoteNullable :: Expr Text -> Expr Text
210quoteNullable :: Expr Text -> Expr Text
178quoteNullable = function "quote_nullable"
211quoteNullable = function "quote_nullable"
179
212
180
213
214+-- | Corresponds to the @regexp_replace@ function.
181regexpReplace :: ()
215regexpReplace :: ()
182 => Expr Text -> Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr Text
216 => Expr Text -> Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr Text
183regexpReplace a b c (Just d) = function "regexp_replace" a b c d
217regexpReplace a b c (Just d) = function "regexp_replace" a b c d
184regexpReplace a b c Nothing = function "regexp_replace" a b c
218regexpReplace a b c Nothing = function "regexp_replace" a b c
185
219
186
220
221+-- | Corresponds to the @regexp_split_to_array@ function.
187regexpSplitToArray :: ()
222regexpSplitToArray :: ()
188− => Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr (Array1D Text)
223+ => Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr [Text]
189regexpSplitToArray a b (Just c) = function "regexp_split_to_array" a b c
224regexpSplitToArray a b (Just c) = function "regexp_split_to_array" a b c
190regexpSplitToArray a b Nothing = function "regexp_split_to_array" a b
225regexpSplitToArray a b Nothing = function "regexp_split_to_array" a b
191
226
192
227
228+-- | Corresponds to the @repeat@ function.
193repeat :: Expr Text -> Expr Int32 -> Expr Text
229repeat :: Expr Text -> Expr Int32 -> Expr Text
194repeat = function "repeat"
230repeat = function "repeat"
195
231
196
232
233+-- | Corresponds to the @replace@ function.
197replace :: Expr Text -> Expr Text -> Expr Text -> Expr Text
234replace :: Expr Text -> Expr Text -> Expr Text -> Expr Text
198replace = function "replace"
235replace = function "replace"
199
236
200
237
238+-- | Corresponds to the @reverse@ function.
201reverse :: Expr Text -> Expr Text
239reverse :: Expr Text -> Expr Text
202reverse = function "reverse"
240reverse = function "reverse"
203
241
204
242
243+-- | Corresponds to the @right@ function.
205right :: Expr Text -> Expr Int32 -> Expr Text
244right :: Expr Text -> Expr Int32 -> Expr Text
206right = function "right"
245right = function "right"
207
246
208
247
248+-- | Corresponds to the @rpad@ function.
209rpad :: Expr Text -> Expr Int32 -> Maybe (Expr Text) -> Expr Text
249rpad :: Expr Text -> Expr Int32 -> Maybe (Expr Text) -> Expr Text
210rpad a b (Just c) = function "rpad" a b c
250rpad a b (Just c) = function "rpad" a b c
211rpad a b Nothing = function "rpad" a b
251rpad a b Nothing = function "rpad" a b
212
252
213
253
254+-- | Corresponds to the @rtrim@ function.
214rtrim :: Expr Text -> Maybe (Expr Text) -> Expr Text
255rtrim :: Expr Text -> Maybe (Expr Text) -> Expr Text
215rtrim a (Just b) = function "rtrim" a b
256rtrim a (Just b) = function "rtrim" a b
216rtrim a Nothing = function "rtrim" a
257rtrim a Nothing = function "rtrim" a
217
258
218
259
260+-- | Corresponds to the @split_part@ function.
219splitPart :: Expr Text -> Expr Text -> Expr Int32 -> Expr Text
261splitPart :: Expr Text -> Expr Text -> Expr Int32 -> Expr Text
220splitPart = function "split_part"
262splitPart = function "split_part"
221
263
222
264
265+-- | Corresponds to the @strpos@ function.
223strpos :: Expr Text -> Expr Text -> Expr Int32
266strpos :: Expr Text -> Expr Text -> Expr Int32
224strpos = function "strpos"
267strpos = function "strpos"
225
268
226
269
270+-- | Corresponds to the @substr@ function.
227substr :: Expr Text -> Expr Int32 -> Maybe (Expr Int32) -> Expr Text
271substr :: Expr Text -> Expr Int32 -> Maybe (Expr Int32) -> Expr Text
228substr a b (Just c) = function "substr" a b c
272substr a b (Just c) = function "substr" a b c
229substr a b Nothing = function "substr" a b
273substr a b Nothing = function "substr" a b
230
274
231
275
276+-- | Corresponds to the @translate@ function.
232−toAscii :: Expr Text -> Expr Text -> Expr Text
277+translate :: Expr Text -> Expr Text -> Expr Text -> Expr Text
233−toAscii = function "toAscii"
278+translate = function "translate"
234
279
235
280
281+-- | @like x y@ corresponds to the expression @y LIKE x@.
282+--
283+-- Note that the arguments to @like@ are swapped. This is to aid currying, so
284+-- you can write expressions like
285+-- @filter (like "Rel%" . packageName) =<< each haskellPackages@
236−toHex :: Expr Int32 -> Expr Text
286+like :: Expr Text -> Expr Text -> Expr Bool
237−toHex = function "toHex"
287+like = flip (binaryOperator "LIKE")
238
288
239
289
290+-- | @ilike x y@ corresponds to the expression @y ILIKE x@.
291+--
292+-- Note that the arguments to @ilike@ are swapped. This is to aid currying, so
293+-- you can write expressions like
294+-- @filter (ilike "Rel%" . packageName) =<< each haskellPackages@
240−translate :: Expr Text -> Expr Text -> Expr Text -> Expr Text
295+ilike :: Expr Text -> Expr Text -> Expr Bool
241−translate = function "translate"
296+ilike = flip (binaryOperator "ILIKE")
src/Rel8/Expr/Time.hs+2−2
@@ -31,7 +31,7 @@ import Prelude
31-- rel8
31-- rel8
32import Rel8.Expr ( Expr )
32import Rel8.Expr ( Expr )
33import Rel8.Expr.Function ( binaryOperator, nullaryFunction )
33import Rel8.Expr.Function ( binaryOperator, nullaryFunction )
34−import Rel8.Expr.Opaleye ( unsafeCastExpr, unsafeLiteral )
34+import Rel8.Expr.Opaleye ( castExpr, unsafeCastExpr, unsafeLiteral )
35
35
36-- time
36-- time
37import Data.Time.Calendar ( Day )
37import Data.Time.Calendar ( Day )
@@ -164,4 +164,4 @@ years = (`scaleInterval` year)
164
164
165
165
166singleton :: String -> Expr CalendarDiffTime
166singleton :: String -> Expr CalendarDiffTime
167−singleton unit = unsafeLiteral $ "'1 " ++ unit ++ "'"
167+singleton unit = castExpr $ unsafeLiteral $ "'1 " ++ unit ++ "'"
src/Rel8/Expr/Window.hsnew file+121
@@ -0,0 +1,121 @@
1+module Rel8.Expr.Window
2+ ( cumulative
3+ , rowNumber
4+ , rank
5+ , denseRank
6+ , percentRank
7+ , cumeDist
8+ , ntile
9+ , lag
10+ , lead
11+ , firstValue
12+ , lastValue
13+ , nthValue
14+ )
15+where
16+
17+-- base
18+import Data.Int ( Int32, Int64 )
19+import Prelude
20+
21+-- opaleye
22+import qualified Opaleye.Internal.Aggregate as Opaleye
23+import qualified Opaleye.Internal.PackMap as Opaleye
24+import qualified Opaleye.Internal.Window as Opaleye
25+import qualified Opaleye.Window as Opaleye
26+
27+-- profunctors
28+import Data.Profunctor (dimap)
29+
30+-- rel8
31+import Rel8.Aggregate ( Aggregate( Aggregate ) )
32+import Rel8.Expr ( Expr )
33+import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr, toColumn, toPrimExpr )
34+import Rel8.Schema.Null ( Nullify )
35+import Rel8.Window ( Window( Window ) )
36+
37+
38+cumulative :: (a -> Aggregate b) -> Window a (Expr b)
39+cumulative f =
40+ fromWindowFunction $ Opaleye.aggregatorWindowFunction (fromAggregate f) id
41+
42+
43+-- | [@row_number()@](https://www.postgresql.org/docs/current/functions-window.html)
44+rowNumber :: Window a (Expr Int64)
45+rowNumber = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.rowNumber
46+
47+
48+-- | [@rank()@](https://www.postgresql.org/docs/current/functions-window.html)
49+rank :: Window a (Expr Int64)
50+rank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.rank
51+
52+
53+-- | [@dense_rank()@](https://www.postgresql.org/docs/current/functions-window.html)
54+denseRank :: Window a (Expr Int64)
55+denseRank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.denseRank
56+
57+
58+-- | [@percent_rank()@](https://www.postgresql.org/docs/current/functions-window.html)
59+percentRank :: Window a (Expr Double)
60+percentRank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.percentRank
61+
62+
63+-- | [@cume_dist()@](https://www.postgresql.org/docs/current/functions-window.html)
64+cumeDist :: Window a (Expr Double)
65+cumeDist = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.cumeDist
66+
67+
68+-- | [@ntile(num_buckets)@](https://www.postgresql.org/docs/current/functions-window.html)
69+ntile :: Expr Int32 -> Window a (Expr Int32)
70+ntile buckets = fromWindowFunction $ fromPrimExpr . fromColumn <$>
71+ Opaleye.ntile (toColumn (toPrimExpr buckets))
72+
73+
74+-- | [@lag(value, offset, default)@](https://www.postgresql.org/docs/current/functions-window.html)
75+lag :: Expr Int32 -> Expr a -> Window (Expr a) (Expr a)
76+lag offset def =
77+ fromWindowFunction $
78+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $
79+ Opaleye.lag (toColumn (toPrimExpr offset)) (toColumn (toPrimExpr def))
80+
81+
82+-- | [@lead(value, offset, default)@](https://www.postgresql.org/docs/current/functions-window.html)
83+lead :: Expr Int32 -> Expr a -> Window (Expr a) (Expr a)
84+lead offset def =
85+ fromWindowFunction $
86+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $
87+ Opaleye.lead (toColumn (toPrimExpr offset)) (toColumn (toPrimExpr def))
88+
89+
90+-- | [@first_value(value)@](https://www.postgresql.org/docs/current/functions-window.html)
91+firstValue :: Window (Expr a) (Expr a)
92+firstValue =
93+ fromWindowFunction $
94+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn)
95+ Opaleye.firstValue
96+
97+
98+-- | [@last_value(value)@](https://www.postgresql.org/docs/current/functions-window.html)
99+lastValue :: Window (Expr a) (Expr a)
100+lastValue =
101+ fromWindowFunction $
102+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn)
103+ Opaleye.lastValue
104+
105+
106+-- | [@nth_value(value, n)@](https://www.postgresql.org/docs/current/functions-window.html)
107+nthValue :: Expr Int32 -> Window (Expr a) (Expr (Nullify a))
108+nthValue n =
109+ fromWindowFunction $
110+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $
111+ Opaleye.nthValue (toColumn (toPrimExpr n))
112+
113+
114+fromAggregate :: (a -> Aggregate b) -> Opaleye.Aggregator a (Expr b)
115+fromAggregate f = Opaleye.Aggregator $ Opaleye.PackMap $ \w a -> case f a of
116+ Aggregate (Opaleye.Aggregator (Opaleye.PackMap x)) -> x w ()
117+
118+
119+fromWindowFunction :: Opaleye.WindowFunction a b -> Window a b
120+fromWindowFunction (Opaleye.WindowFunction (Opaleye.PackMap w)) =
121+ Window $ Opaleye.Windows $ Opaleye.PackMap $ \f -> w $ \o -> f (o, mempty)
src/Rel8/FCF.hs+9−1
@@ -3,7 +3,11 @@
3{-# language StandaloneKindSignatures #-}
3{-# language StandaloneKindSignatures #-}
4{-# language TypeFamilies #-}
4{-# language TypeFamilies #-}
5
5
6−module Rel8.FCF ( Exp, Eval ) where
6+module Rel8.FCF
7+ ( Exp, Eval
8+ , Id
9+ )
10+where
7
11
8-- base
12-- base
9import Data.Kind ( Type )
13import Data.Kind ( Type )
@@ -16,3 +20,7 @@ type Exp e = e -> Type
16
20
17type Eval :: Exp e -> e
21type Eval :: Exp e -> e
18type family Eval a
22type family Eval a
23+
24+
25+data Id :: a -> Exp a
26+type instance Eval (Id a) = a
src/Rel8/Generic/Construction.hsnew file+352
@@ -0,0 +1,352 @@
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.hsnew file+478
@@ -0,0 +1,478 @@
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.hsnew file+168
@@ -0,0 +1,168 @@
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.hsnew file+49
@@ -0,0 +1,49 @@
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.hsnew file+155
@@ -0,0 +1,155 @@
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.hsnew file+281
@@ -0,0 +1,281 @@
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.hsnew file+103
@@ -0,0 +1,103 @@
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.hsnew file+221
@@ -0,0 +1,221 @@
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.hsnew file+181
@@ -0,0 +1,181 @@
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.hsnew file+38
@@ -0,0 +1,38 @@
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.hsnew file+56
@@ -0,0 +1,56 @@
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.hsdeleted−61
@@ -1,61 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
3−{-# language FlexibleInstances #-}
4−{-# language GADTs #-}
5−{-# language LambdaCase #-}
6−{-# language StandaloneKindSignatures #-}
7−{-# language TypeOperators #-}
8−
9−module Rel8.Kind.Labels
10− ( Labels
11− , SLabels( 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.hsdeleted−38
@@ -1,38 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language FlexibleContexts #-}
3−{-# language GADTs #-}
4−{-# language StandaloneKindSignatures #-}
5−
6−module Rel8.Kind.Necessity
7− ( Necessity( Optional, Required )
8− , SNecessity( SOptional, SRequired )
9− , KnownNecessity( necessitySing )
10− )
11−where
12−
13−-- base
14−import Data.Kind ( Constraint, Type )
15−import Prelude ()
16−
17−
18−type Necessity :: Type
19−data Necessity = Optional | Required
20−
21−
22−type SNecessity :: Necessity -> Type
23−data SNecessity necessity where
24− SOptional :: SNecessity 'Optional
25− SRequired :: SNecessity 'Required
26−
27−
28−type KnownNecessity :: Necessity -> Constraint
29−class KnownNecessity necessity where
30− necessitySing :: SNecessity necessity
31−
32−
33−instance KnownNecessity 'Optional where
34− necessitySing = SOptional
35−
36−
37−instance KnownNecessity 'Required where
38− necessitySing = SRequired
src/Rel8/Opaque.hsdeleted−15
@@ -1,15 +0,0 @@
1−{-# language PolyKinds #-}
2−{-# language StandaloneKindSignatures #-}
3−{-# language TypeFamilies #-}
4−
5−module Rel8.Opaque
6− ( Opaque
7− )
8−where
9−
10−-- base
11−import Prelude ()
12−
13−
14−type Opaque :: k
15−data family Opaque :: k
src/Rel8/Order.hs+5−14
@@ -16,24 +16,15 @@ 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.Internal.Order as Opaleye
19+import qualified Opaleye.Order as Opaleye
20
20
21
21
22−-- | An ordering expression for @a@. Primitive orderings are defined with 'asc'
22+-- | An ordering expression for @a@. Primitive orderings are defined with
23−-- and 'desc', and you can combine @Order@ via its various instances.
23+-- 'Rel8.asc' and 'Rel8.desc', and you can combine @Order@ via its various
24+-- instances.
24--
25--
25-- A common pattern is to use '<>' to combine multiple orderings in sequence,
26-- A common pattern is to use '<>' to combine multiple orderings in sequence,
26−-- and '>$<' (from 'Contravariant') to select individual columns. For example,
27−-- to sort a @Query@ on two columns, we could do:
28−--
29−-- >>> import Data.Functor.Contravariant ((>$<))
27+-- and 'Data.Functor.Contravariant.>$<' to select individual columns.
30−-- >>> :{
31−-- select c $ orderBy (mconcat [fst >$< asc, snd >$< desc]) $ do
32−-- x <- values [ lit x | x <- [1..3 :: Int32 ] ]
33−-- y <- values [ lit x | x <- [1..3 :: Int32 ] ]
34−-- return (x, y)
35−-- :}
36−-- [(1,3),(1,2),(1,1),(2,3),(2,2),(2,1),(3,3),(3,2),(3,1)]
37type Order :: Type -> Type
28type Order :: Type -> Type
38newtype Order a = Order (Opaleye.Order a)
29newtype Order a = Order (Opaleye.Order a)
39 deriving newtype (Contravariant, Divisible, Decidable, Semigroup, Monoid)
30 deriving newtype (Contravariant, Divisible, Decidable, Semigroup, Monoid)
src/Rel8/Query.hs+181−8
@@ -1,7 +1,6 @@
1−{-# language DerivingStrategies #-}
1+{-# language FlexibleContexts #-}
2−{-# language DerivingVia #-}
3−{-# language GeneralizedNewtypeDeriving #-}
4{-# language StandaloneKindSignatures #-}
2{-# language StandaloneKindSignatures #-}
3+{-# language UndecidableInstances #-}
5
4
6module Rel8.Query
5module Rel8.Query
7 ( Query( Query )
6 ( Query( Query )
@@ -9,37 +8,201 @@ module Rel8.Query
9where
8where
10
9
11-- base
10-- base
11+import Control.Applicative ( liftA2 )
12+import Control.Monad ( liftM2 )
12import Data.Kind ( Type )
13import Data.Kind ( Type )
14+import Data.Monoid ( Any( Any ) )
13import Prelude
15import Prelude
14
16
15-- opaleye
17-- opaleye
16−import qualified Opaleye.Select as Opaleye
18+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
19+import qualified Opaleye.Internal.PackMap as Opaleye
20+import qualified Opaleye.Internal.PrimQuery as Opaleye hiding (lateral)
21+import qualified Opaleye.Internal.QueryArr as Opaleye
22+import qualified Opaleye.Internal.Tag as Opaleye
17
23
18-- rel8
24-- rel8
25+import Rel8.Expr ( Expr )
19import Rel8.Query.Set ( unionAll )
26import Rel8.Query.Set ( unionAll )
27+import Rel8.Query.Opaleye ( fromOpaleye )
20import Rel8.Query.Values ( values )
28import Rel8.Query.Values ( values )
29+import Rel8.Table ( Table, fromColumns, toColumns )
21import Rel8.Table.Alternative
30import Rel8.Table.Alternative
22 ( AltTable, (<|>:)
31 ( AltTable, (<|>:)
23 , AlternativeTable, emptyTable
32 , AlternativeTable, emptyTable
24 )
33 )
34+import Rel8.Table.Projection ( Projectable, apply, project )
25
35
26-- semigroupoids
36-- semigroupoids
27−import Data.Functor.Apply ( Apply, WrappedApplicative(..) )
37+import Data.Functor.Apply ( Apply, (<.>) )
28import Data.Functor.Bind ( Bind, (>>-) )
38import Data.Functor.Bind ( Bind, (>>-) )
29
39
30
40
31-- | The @Query@ monad allows you to compose a @SELECT@ query. This monad has
41-- | The @Query@ monad allows you to compose a @SELECT@ query. This monad has
32-- semantics similar to the list (@[]@) monad.
42-- semantics similar to the list (@[]@) monad.
33type Query :: Type -> Type
43type Query :: Type -> Type
34−newtype Query a = Query (Opaleye.Select a)
44+newtype Query a =
35− deriving newtype (Functor, Applicative, Monad)
45+ Query (
36− deriving Apply via (WrappedApplicative Opaleye.Select)
46+ -- This is based on Opaleye's Select monad, but with two addtions. We
47+ -- maintain a stack of PrimExprs from parent previous subselects. In
48+ -- practice, these are always the results of dummy calls to random().
49+ --
50+ -- We also return a Bool that indicates to the parent subselect whether
51+ -- or not that stack of PrimExprs were used at any point. If they weren't,
52+ -- then the call to random() is never added to the query.
53+ --
54+ -- This is all needed to implement evaluate. Consider the following code:
55+ --
56+ -- do
57+ -- x <- values [lit 'a', lit 'b', lit 'c']
58+ -- y <- evaluate $ nextval "user_id_seq"
59+ -- pure (x, y)
60+ --
61+ -- If we just used Opaleye's Select monad directly, the SQL would come out
62+ -- like this:
63+ --
64+ -- SELECT
65+ -- a, b
66+ -- FROM
67+ -- (VALUES ('a'), ('b'), ('c')) Q1(a),
68+ -- LATERAL (SELECT nextval('user_id_seq')) Q2(b);
69+ --
70+ -- From the Haskell code, you would intuitively expect to get back the
71+ -- results of three different calls to nextval(), but from Postgres' point
72+ -- of view, because the Q2 subquery doesn't reference anything from the Q1
73+ -- query, it thinks it only needs to call nextval() once. This is actually
74+ -- exactly the same problem you get with the deprecated ListT IO monad from
75+ -- the transformers package — *> behaves differently to >>=, so
76+ -- using ApplicativeDo can change the results of a program. ApplicativeDo
77+ -- is exactly the optimisation Postgres does on a "LATERAL" query that
78+ -- doesn't make any references to previous subselects.
79+ --
80+ -- Rel8's solution is generate the following SQL instead:
81+ --
82+ -- SELECT
83+ -- a, b
84+ -- FROM
85+ -- (SELECT
86+ -- random() AS dummy,
87+ -- *
88+ -- FROM
89+ -- (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1,
90+ -- LATERAL (SELECT
91+ -- CASE
92+ -- WHEN dummy IS NOT NULL
93+ -- THEN nextval('user_id_seq')
94+ -- END) Q2(b);
95+ --
96+ -- We use random() here as the dummy value (and not some constant) because
97+ -- Postgres will again optimize if it sees that a value is constant
98+ -- (and thus only call nextval() once), but because random() is marked as
99+ -- VOLATILE, this inhibits Postgres from doing that optimisation.
100+ --
101+ -- Why not just reference the a column from the previous query directly
102+ -- instead of adding a dummy value? Basically, even if we extract out all
103+ -- the bindings introduced in a PrimQuery, we can't always be sure which
104+ -- ones refer to constant values, so if we end up laterally referencing a
105+ -- constant value, then all of this would be for nothing.
106+ --
107+ -- Why not just add the call to the previous subselect directly, like so:
108+ --
109+ -- SELECT
110+ -- a, b
111+ -- FROM
112+ -- (SELECT
113+ -- nextval('user_id_seq') AS eval,
114+ -- *
115+ -- FROM
116+ -- (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1,
117+ -- LATERAL (SELECT eval) Q2(b);
118+ --
119+ -- That would work in this case. But consider the following Rel8 code:
120+ --
121+ -- do
122+ -- x <- values [lit 'a', lit 'b', lit 'c']
123+ -- y <- values [lit 'd', lit 'e', lit 'f']
124+ -- z <- evaluate $ nextval "user_id_seq"
125+ -- pure (x, y, z)
126+ --
127+ -- How many calls to nextval should there be? Our Haskell intuition says
128+ -- nine. But that's not what you would get if you used the above
129+ -- technique. The problem is, which VALUES query should the nextval be
130+ -- added to? You can choose one or the other to get three calls to
131+ -- nextval, but you still need to make a superfluous LATERAL references to
132+ -- the other if you want nine calls. So for the above Rel8 code we generate
133+ -- the following SQL:
134+ --
135+ -- SELECT
136+ -- a, b, c
137+ -- FROM
138+ -- (SELECT
139+ -- random() AS dummy,
140+ -- *
141+ -- FROM
142+ -- (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1,
143+ -- (SELECT
144+ -- random() AS dummy,
145+ -- *
146+ -- FROM
147+ -- (VALUES ('d'), ('e'), ('f')) Q2(b)) Q2,
148+ -- LATERAL (SELECT
149+ -- CASE
150+ -- WHEN Q1.dummy IS NOT NULL AND Q2.dummy IS NOT NULL
151+ -- THEN nextval('user_id_seq')
152+ -- END) Q3(c);
153+ --
154+ -- This gives nine calls to nextval() as we would expect.
155+ [Opaleye.PrimExpr] -> Opaleye.Select (Any, a)
156+ )
157+
158+
159+instance Projectable Query where
160+ project f = fmap (fromColumns . apply f . toColumns)
161+
162+
163+instance Functor Query where
164+ fmap f (Query a) = Query (fmap (fmap (fmap f)) a)
165+
166+
167+instance Apply Query where
168+ (<.>) = (<*>)
169+
170+
171+instance Applicative Query where
172+ pure = fromOpaleye . pure
173+ liftA2 = liftM2
37
174
38
175
39instance Bind Query where
176instance Bind Query where
40 (>>-) = (>>=)
177 (>>-) = (>>=)
41
178
42
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+
43-- | '<|>:' = 'unionAll'.
206-- | '<|>:' = 'unionAll'.
44instance AltTable Query where
207instance AltTable Query where
45 (<|>:) = unionAll
208 (<|>:) = unionAll
@@ -48,3 +211,13 @@ instance AltTable Query where
48-- | 'emptyTable' = 'values' @[]@.
211-- | 'emptyTable' = 'values' @[]@.
49instance AlternativeTable Query where
212instance AlternativeTable Query where
50 emptyTable = values []
213 emptyTable = values []
214+
215+
216+-- | '<>' = 'unionAll'.
217+instance Table Expr a => Semigroup (Query a) where
218+ (<>) = (<|>:)
219+
220+
221+-- | 'mempty' = @'values' []@.
222+instance Table Expr a => Monoid (Query a) where
223+ mempty = emptyTable
src/Rel8/Query.hs-boot+3−1
@@ -7,11 +7,13 @@ where
7
7
8-- base
8-- base
9import Data.Kind ( Type )
9import Data.Kind ( Type )
10+import Data.Monoid ( Any )
10import Prelude ()
11import Prelude ()
11
12
12-- opaleye
13-- opaleye
14+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
13import qualified Opaleye.Select as Opaleye
15import qualified Opaleye.Select as Opaleye
14
16
15
17
16type Query :: Type -> Type
18type Query :: Type -> Type
17−newtype Query a = Query (Opaleye.Select a)
19+newtype Query a = Query ([Opaleye.PrimExpr] -> Opaleye.Select (Any, a))
src/Rel8/Query/Aggregate.hs+25−2
@@ -1,12 +1,17 @@
1{-# language FlexibleContexts #-}
1{-# language FlexibleContexts #-}
2+{-# language MonoLocalBinds #-}
3+{-# language ScopedTypeVariables #-}
4+{-# language TypeApplications #-}
2
5
3module Rel8.Query.Aggregate
6module Rel8.Query.Aggregate
4 ( aggregate
7 ( aggregate
5 , countRows
8 , countRows
9+ , mode
6 )
10 )
7where
11where
8
12
9-- base
13-- base
14+import Data.Functor.Contravariant ( (>$<) )
10import Data.Int ( Int64 )
15import Data.Int ( Int64 )
11import Prelude
16import Prelude
12
17
@@ -14,20 +19,38 @@ import Prelude
14import qualified Opaleye.Aggregate as Opaleye
19import qualified Opaleye.Aggregate as Opaleye
15
20
16-- rel8
21-- rel8
17−import Rel8.Aggregate ( Aggregate )
22+import Rel8.Aggregate ( Aggregates )
18import Rel8.Expr ( Expr )
23import Rel8.Expr ( Expr )
19import Rel8.Expr.Aggregate ( countStar )
24import Rel8.Expr.Aggregate ( countStar )
25+import Rel8.Expr.Order ( desc )
20import Rel8.Query ( Query )
26import Rel8.Query ( Query )
27+import Rel8.Query.Limit ( limit )
21import Rel8.Query.Maybe ( optional )
28import Rel8.Query.Maybe ( optional )
22import Rel8.Query.Opaleye ( mapOpaleye )
29import 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 )
23import Rel8.Table.Opaleye ( aggregator )
35import Rel8.Table.Opaleye ( aggregator )
24import Rel8.Table.Maybe ( maybeTable )
36import Rel8.Table.Maybe ( maybeTable )
25
37
26
38
27-- | Apply an aggregation to all rows returned by a 'Query'.
39-- | Apply an aggregation to all rows returned by a 'Query'.
28−aggregate :: Query (Aggregate exprs) -> Query exprs
40+aggregate :: Aggregates aggregates exprs => Query aggregates -> Query exprs
29aggregate = mapOpaleye (Opaleye.aggregate aggregator)
41aggregate = mapOpaleye (Opaleye.aggregate aggregator)
30
42
31
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@.
32countRows :: Query a -> Query (Expr Int64)
47countRows :: Query a -> Query (Expr Int64)
33countRows = fmap (maybeTable 0 id) . optional . aggregate . fmap (const countStar)
48countRows = fmap (maybeTable 0 id) . optional . aggregate . fmap (const countStar)
49+
50+
51+-- | Return the most common row in a query.
52+mode :: forall a. EqTable a => Query a -> Query a
53+mode rows = limit 1 $ fmap (fromCols . snd) $ orderBy (fst >$< desc) $ do
54+ aggregate $ do
55+ row <- toColumns <$> rows
56+ pure (countStar, Cols $ hgroupBy (eqTable @a) row)
src/Rel8/Query/Distinct.hs+4−12
@@ -1,5 +1,3 @@
1−{-# options_ghc -fno-warn-redundant-constraints #-}
2−
3module Rel8.Query.Distinct
1module Rel8.Query.Distinct
4 ( distinct
2 ( distinct
5 , distinctOn
3 , distinctOn
@@ -8,12 +6,11 @@ module Rel8.Query.Distinct
8where
6where
9
7
10-- base
8-- base
11−import Prelude
9+import Prelude ()
12
10
13-- opaleye
11-- opaleye
14import qualified Opaleye.Distinct as Opaleye
12import qualified Opaleye.Distinct as Opaleye
15−import qualified Opaleye.Internal.Order as Opaleye
13+import qualified Opaleye.Order as Opaleye
16−import qualified Opaleye.Internal.QueryArr as Opaleye
17
14
18-- rel8
15-- rel8
19import Rel8.Order ( Order( Order ) )
16import Rel8.Order ( Order( Order ) )
@@ -25,9 +22,6 @@ import Rel8.Table.Opaleye ( distinctspec, unpackspec )
25
22
26-- | Select all distinct rows from a query, removing duplicates. @distinct q@
23-- | Select all distinct rows from a query, removing duplicates. @distinct q@
27-- is equivalent to the SQL statement @SELECT DISTINCT q@.
24-- is equivalent to the SQL statement @SELECT DISTINCT q@.
28−--
29−-- >>> select c $ distinct $ values [ lit True, lit True, lit False ]
30−-- [False,True]
31distinct :: EqTable a => Query a -> Query a
25distinct :: EqTable a => Query a -> Query a
32distinct = mapOpaleye (Opaleye.distinctExplicit distinctspec)
26distinct = mapOpaleye (Opaleye.distinctExplicit distinctspec)
33
27
@@ -36,13 +30,11 @@ distinct = mapOpaleye (Opaleye.distinctExplicit distinctspec)
36-- to a projection. If multiple rows have the same projection, it is
30-- to a projection. If multiple rows have the same projection, it is
37-- unspecified which row will be returned. If this matters, use 'distinctOnBy'.
31-- unspecified which row will be returned. If this matters, use 'distinctOnBy'.
38distinctOn :: EqTable b => (a -> b) -> Query a -> Query a
32distinctOn :: EqTable b => (a -> b) -> Query a -> Query a
39−distinctOn proj =
40− mapOpaleye (\q -> Opaleye.productQueryArr (Opaleye.distinctOn unpackspec proj . Opaleye.runSimpleQueryArr q))
33+distinctOn proj = mapOpaleye (Opaleye.distinctOnExplicit unpackspec proj)
41
34
42
35
43-- | Select all distinct rows from a query, where rows are equivalent according
36-- | Select all distinct rows from a query, where rows are equivalent according
44-- to a projection. If there are multiple rows with the same projection, the
37-- to a projection. If there are multiple rows with the same projection, the
45-- first row according to the specified 'Order' will be returned.
38-- first row according to the specified 'Order' will be returned.
46distinctOnBy :: EqTable b => (a -> b) -> Order a -> Query a -> Query a
39distinctOnBy :: EqTable b => (a -> b) -> Order a -> Query a -> Query a
47−distinctOnBy proj (Order order) =
40+distinctOnBy proj (Order order) = mapOpaleye (Opaleye.distinctOnByExplicit unpackspec proj order)
48− mapOpaleye (\q -> Opaleye.productQueryArr (Opaleye.distinctOnBy unpackspec proj order . Opaleye.runSimpleQueryArr q))
src/Rel8/Query/Each.hs+4−8
@@ -1,4 +1,5 @@
1{-# language FlexibleContexts #-}
1{-# language FlexibleContexts #-}
2+{-# language MonoLocalBinds #-}
2
3
3module Rel8.Query.Each
4module Rel8.Query.Each
4 ( each
5 ( each
@@ -16,21 +17,16 @@ import Rel8.Query ( Query )
16import Rel8.Query.Opaleye ( fromOpaleye )
17import Rel8.Query.Opaleye ( fromOpaleye )
17import Rel8.Schema.Name ( Selects )
18import Rel8.Schema.Name ( Selects )
18import Rel8.Schema.Table ( TableSchema )
19import Rel8.Schema.Table ( TableSchema )
19−import Rel8.Table ( fromColumns, toColumns )
20+import Rel8.Table.Cols ( fromCols, toCols )
20import Rel8.Table.Opaleye ( table, unpackspec )
21import Rel8.Table.Opaleye ( table, unpackspec )
21
22
22
23
23-- | Select each row from a table definition. This is equivalent to @FROM
24-- | Select each row from a table definition. This is equivalent to @FROM
24-- table@.
25-- table@.
25−--
26−-- >>> mapM_ print =<< select c (each projectSchema)
27−-- Project {projectAuthorId = 1, projectName = "rel8"}
28−-- Project {projectAuthorId = 2, projectName = "aeson"}
29−-- Project {projectAuthorId = 2, projectName = "text"}
30each :: Selects names exprs => TableSchema names -> Query exprs
26each :: Selects names exprs => TableSchema names -> Query exprs
31each =
27each =
32− fmap fromColumns .
28+ fmap fromCols .
33 fromOpaleye .
29 fromOpaleye .
34 Opaleye.selectTableExplicit unpackspec .
30 Opaleye.selectTableExplicit unpackspec .
35 table .
31 table .
36− fmap toColumns
32+ fmap toCols
src/Rel8/Query/Either.hs+27−17
@@ -3,23 +3,22 @@
3module Rel8.Query.Either
3module Rel8.Query.Either
4 ( keepLeftTable
4 ( keepLeftTable
5 , keepRightTable
5 , keepRightTable
6− , bindEitherTable
7 , bitraverseEitherTable
6 , bitraverseEitherTable
8 )
7 )
9where
8where
10
9
11-- base
10-- base
12−import Data.Functor ( (<&>) )
13import Prelude
11import Prelude
14
12
13+-- comonad
14+import Control.Comonad ( extract )
15+
15-- rel8
16-- rel8
16import Rel8.Expr ( Expr )
17import Rel8.Expr ( Expr )
17import Rel8.Expr.Eq ( (==.) )
18import Rel8.Expr.Eq ( (==.) )
18import Rel8.Query ( Query )
19import Rel8.Query ( Query )
19import Rel8.Query.Filter ( where_ )
20import Rel8.Query.Filter ( where_ )
20import Rel8.Query.Maybe ( optional )
21import Rel8.Query.Maybe ( optional )
21−import Rel8.Table ( Table )
22−import Rel8.Table.Bool ( bool )
23import Rel8.Table.Either
22import Rel8.Table.Either
24 ( EitherTable( EitherTable )
23 ( EitherTable( EitherTable )
25 , isLeftTable, isRightTable
24 , isLeftTable, isRightTable
@@ -27,30 +26,41 @@ import Rel8.Table.Either
27import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
26import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
28
27
29
28
29+-- | Filter 'EitherTable's, keeping only 'leftTable's.
30−keepLeftTable :: EitherTable a b -> Query a
30+keepLeftTable :: EitherTable Expr a b -> Query a
31keepLeftTable e@(EitherTable _ a _) = do
31keepLeftTable e@(EitherTable _ a _) = do
32 where_ $ isLeftTable e
32 where_ $ isLeftTable e
33− pure a
33+ pure (extract a)
34
34
35
35
36+-- | Filter 'EitherTable's, keeping only 'rightTable's.
36−keepRightTable :: EitherTable a b -> Query b
37+keepRightTable :: EitherTable Expr a b -> Query b
37keepRightTable e@(EitherTable _ _ b) = do
38keepRightTable e@(EitherTable _ _ b) = do
38 where_ $ isRightTable e
39 where_ $ isRightTable e
39− pure b
40+ pure (extract b)
40−
41−
42−bindEitherTable :: (Table Expr a, Functor m)
43− => (i -> m (EitherTable a b)) -> EitherTable a i -> m (EitherTable a b)
44−bindEitherTable query e@(EitherTable input a i) = do
45− query i <&> \(EitherTable output a' b) ->
46− EitherTable (input <> output) (bool a a' (isRightTable e)) b
47
41
48
42
43+-- | @bitraverseEitherTable f g x@ will pass all @leftTable@s through @f@ and
44+-- all @rightTable@s through @g@. The results are then lifted back into
45+-- @leftTable@ and @rightTable@, respectively. This is similar to 'bitraverse'
46+-- for 'Either'.
47+--
48+-- For example,
49+--
50+-- >>> :{
51+-- select do
52+-- x <- values (map lit [ Left True, Right (42 :: Int32) ])
53+-- bitraverseEitherTable (\y -> values [y, not_ y]) (\y -> pure (y * 100)) x
54+-- :}
55+-- [ Left True
56+-- , Left False
57+-- , Right 4200
58+-- ]
49bitraverseEitherTable :: ()
59bitraverseEitherTable :: ()
50 => (a -> Query c)
60 => (a -> Query c)
51 -> (b -> Query d)
61 -> (b -> Query d)
52− -> EitherTable a b
62+ -> EitherTable Expr a b
53− -> Query (EitherTable c d)
63+ -> Query (EitherTable Expr c d)
54bitraverseEitherTable f g e@(EitherTable tag _ _) = do
64bitraverseEitherTable f g e@(EitherTable tag _ _) = do
55 mc@(MaybeTable _ c) <- optional (f =<< keepLeftTable e)
65 mc@(MaybeTable _ c) <- optional (f =<< keepLeftTable e)
56 md@(MaybeTable _ d) <- optional (g =<< keepRightTable e)
66 md@(MaybeTable _ d) <- optional (g =<< keepRightTable e)
src/Rel8/Query/Evaluate.hsnew file+49
@@ -0,0 +1,49 @@
1+{-# language FlexibleContexts #-}
2+{-# language TupleSections #-}
3+
4+module Rel8.Query.Evaluate
5+ ( evaluate
6+ )
7+where
8+
9+-- base
10+import Control.Monad ( (>=>) )
11+import Data.Foldable ( foldl' )
12+import Data.List.NonEmpty ( NonEmpty( (:|) ), nonEmpty )
13+import Data.Monoid ( Any( Any ) )
14+import Prelude hiding ( undefined )
15+
16+-- opaleye
17+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
18+
19+-- rel8
20+import Rel8.Expr ( Expr )
21+import Rel8.Expr.Bool ( (&&.) )
22+import Rel8.Expr.Opaleye ( fromPrimExpr )
23+import Rel8.Query ( Query( Query ) )
24+import Rel8.Query.Rebind ( rebind )
25+import Rel8.Table ( Table )
26+import Rel8.Table.Bool ( case_ )
27+import Rel8.Table.Undefined ( undefined )
28+
29+
30+-- | 'evaluate' takes expressions that could potentially have side effects and
31+-- \"runs\" them in the 'Query' monad. The returned expressions have no side
32+-- effects and can safely be reused.
33+evaluate :: Table Expr a => a -> Query a
34+evaluate = laterally >=> rebind "eval"
35+
36+
37+laterally :: Table Expr a => a -> Query a
38+laterally a = Query $ \bindings -> pure $ (Any True,) $
39+ case nonEmpty bindings of
40+ Nothing -> a
41+ Just bindings' -> case_ [(condition, a)] undefined
42+ where
43+ condition = foldl1' (&&.) (fmap go bindings')
44+ where
45+ go = fromPrimExpr . Opaleye.UnExpr Opaleye.OpIsNotNull
46+
47+
48+foldl1' :: (a -> a -> a) -> NonEmpty a -> a
49+foldl1' f (a :| as) = foldl' f a as
src/Rel8/Query/Exists.hs+21−49
@@ -2,8 +2,8 @@
2
2
3module Rel8.Query.Exists
3module Rel8.Query.Exists
4 ( exists, inQuery
4 ( exists, inQuery
5− , whereExists, with, withBy
5+ , present, with, withBy
6− , whereNotExists, without, withoutBy
6+ , absent, without, withoutBy
7 )
7 )
8where
8where
9
9
@@ -11,84 +11,56 @@ where
11import Prelude hiding ( filter )
11import Prelude hiding ( filter )
12
12
13-- opaleye
13-- opaleye
14+import qualified Opaleye.Exists as Opaleye
14import qualified Opaleye.Operators as Opaleye
15import qualified Opaleye.Operators as Opaleye
15
16
16-- rel8
17-- rel8
17import Rel8.Expr ( Expr )
18import Rel8.Expr ( Expr )
19+import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )
18import Rel8.Query ( Query )
20import Rel8.Query ( Query )
19import Rel8.Query.Filter ( filter )
21import Rel8.Query.Filter ( filter )
20−import Rel8.Query.Maybe ( optional )
21import Rel8.Query.Opaleye ( mapOpaleye )
22import Rel8.Query.Opaleye ( mapOpaleye )
22import Rel8.Table.Eq ( EqTable, (==:) )
23import 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)
39exists :: Query a -> Query (Expr Bool)
27exists :: Query a -> Query (Expr Bool)
40−exists = fmap isJustTable . optional . whereExists
28+exists = fmap (fromPrimExpr . fromColumn) . mapOpaleye Opaleye.exists
41−-- FIXME: change this when b7aacc07c6392654cae439fc3b997620c3aa7a87 makes it
42−-- into a release of Opaleye
43
29
44
30
45inQuery :: EqTable a => a -> Query a -> Query (Expr Bool)
31inQuery :: EqTable a => a -> Query a -> Query (Expr Bool)
46inQuery a = exists . (>>= filter (a ==:))
32inQuery a = exists . (>>= filter (a ==:))
47
33
48
34
49−-- | Produce the empty query if the given query returns no rows. @whereExists@
35+-- | Produce the empty query if the given query returns no rows. @present@
50-- is equivalent to @WHERE EXISTS@ in SQL.
36-- is equivalent to @WHERE EXISTS@ in SQL.
51−--
52−-- >>> :{
53−-- select c do
54−-- author <- each authorSchema
55−-- whereExists do
56−-- project <- each projectSchema
57−-- where_ $ projectAuthorId project ==. authorId author
58−-- return $ authorName author
59−-- :}
60−-- ["Ollie","Bryan O'Sullivan"]
61−whereExists :: Query a -> Query ()
37+present :: Query a -> Query ()
62−whereExists = mapOpaleye Opaleye.restrictExists
38+present = mapOpaleye Opaleye.restrictExists
63−
39+
64−
40+
65−-- | Produce the empty query if the given query returns rows. @whereNotExists@
41+-- | Produce the empty query if the given query returns rows. @absent@
66-- is equivalent to @WHERE NOT EXISTS@ in SQL.
42-- is equivalent to @WHERE NOT EXISTS@ in SQL.
67−--
68−-- >>> :{
69−-- select c do
70−-- author <- each authorSchema
71−-- whereNotExists do
72−-- project <- each projectSchema
73−-- where_ $ projectAuthorId project ==. authorId author
74−-- return $ authorName author
75−-- :}
76−-- ["Emily Pillmore"]
77−whereNotExists :: Query a -> Query ()
43+absent :: Query a -> Query ()
78−whereNotExists = mapOpaleye Opaleye.restrictNotExists
44+absent = mapOpaleye Opaleye.restrictNotExists
79
45
80
46
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'.
81with :: (a -> Query b) -> a -> Query a
50with :: (a -> Query b) -> a -> Query a
82−with f a = a <$ whereExists (f a)
51+with f a = a <$ present (f a)
83
52
84
53
54+-- | Like @with@, but with a custom membership test.
85withBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a
55withBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a
86withBy predicate bs = with $ \a -> bs >>= filter (predicate a)
56withBy predicate bs = with $ \a -> bs >>= filter (predicate a)
87
57
88
58
59+-- | Filter rows where @a -> Query b@ yields no rows.
89without :: (a -> Query b) -> a -> Query a
60without :: (a -> Query b) -> a -> Query a
90−without f a = a <$ whereNotExists (f a)
61+without f a = a <$ absent (f a)
91
62
92
63
64+-- | Like @without@, but with a custom membership test.
93withoutBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a
65withoutBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a
94withoutBy predicate bs = without $ \a -> bs >>= filter (predicate a)
66withoutBy predicate bs = without $ \a -> bs >>= filter (predicate a)
src/Rel8/Query/Filter.hs−11
@@ -24,23 +24,12 @@ import Rel8.Query.Opaleye ( fromOpaleye )
24-- return @x@ unchanged when @f x@ is @True@. This is similar to
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,
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.
26-- it is easy to use in a pipeline of 'Query' transformations.
27−--
28−-- >>> select c $ values [ lit x | x <- [ 1..5 :: Int32 ] ] >>= filter (>. 3)
29−-- [4,5]
30filter :: (a -> Expr Bool) -> a -> Query a
27filter :: (a -> Expr Bool) -> a -> Query a
31filter f a = a <$ where_ (f a)
28filter f a = a <$ where_ (f a)
32
29
33
30
34-- | Drop any rows that don't match a predicate. @where_ expr@ is equivalent
31-- | Drop any rows that don't match a predicate. @where_ expr@ is equivalent
35-- to the SQL @WHERE expr@.
32-- to the SQL @WHERE expr@.
36−--
37−-- >>> :{
38−-- select c $ do
39−-- x <- values [ lit x | x <- [ 1..5 :: Int32 ] ]
40−-- where_ $ x >. lit 2
41−-- return x
42−-- :}
43−-- [3,4,5]
44where_ :: Expr Bool -> Query ()
33where_ :: Expr Bool -> Query ()
45where_ condition =
34where_ condition =
46 fromOpaleye $ lmap (\_ -> toColumn $ toPrimExpr condition) Opaleye.restrict
35 fromOpaleye $ lmap (\_ -> toColumn $ toPrimExpr condition) Opaleye.restrict
src/Rel8/Query/Indexed.hsnew file+21
@@ -0,0 +1,21 @@
1+module Rel8.Query.Indexed
2+ ( indexed
3+ )
4+where
5+
6+-- base
7+import Control.Applicative ( liftA2 )
8+import Data.Int ( Int64 )
9+import Prelude
10+
11+-- rel8
12+import Rel8.Expr ( Expr )
13+import Rel8.Expr.Window ( rowNumber )
14+import Rel8.Query ( Query )
15+import Rel8.Query.Window ( window )
16+import Rel8.Table.Window ( currentRow )
17+
18+
19+-- | Pair each row of a query with its index within the query.
20+indexed :: Query a -> Query (Expr Int64, a)
21+indexed = window (liftA2 (,) (subtract 1 <$> rowNumber) currentRow)
src/Rel8/Query/Limit.hs−6
@@ -17,17 +17,11 @@ import Rel8.Query.Opaleye ( mapOpaleye )
17
17
18-- | @limit n@ select at most @n@ rows from a query. @limit n@ is equivalent
18-- | @limit n@ select at most @n@ rows from a query. @limit n@ is equivalent
19-- to the SQL @LIMIT n@.
19-- to the SQL @LIMIT n@.
20−--
21−-- >>> select c $ limit 3 $ values [ lit x | x <- [ 1..5 :: Int32 ] ]
22−-- [1,2,3]
23limit :: Word -> Query a -> Query a
20limit :: Word -> Query a -> Query a
24limit = mapOpaleye . Opaleye.limit . fromIntegral
21limit = mapOpaleye . Opaleye.limit . fromIntegral
25
22
26
23
27-- | @offset n@ drops the first @n@ rows from a query. @offset n@ is equivalent
24-- | @offset n@ drops the first @n@ rows from a query. @offset n@ is equivalent
28-- to the SQL @OFFSET n@.
25-- to the SQL @OFFSET n@.
29−--
30−-- >>> select c $ offset 3 $ values [ lit x | x <- [ 1..5 :: Int32 ] ]
31−-- [4,5]
32offset :: Word -> Query a -> Query a
26offset :: Word -> Query a -> Query a
33offset = mapOpaleye . Opaleye.offset . fromIntegral
27offset = mapOpaleye . Opaleye.offset . fromIntegral
src/Rel8/Query/List.hs+93−14
@@ -1,23 +1,58 @@
1{-# language FlexibleContexts #-}
1{-# language FlexibleContexts #-}
2+{-# language GADTs #-}
3+{-# language NamedFieldPuns #-}
2
4
3module Rel8.Query.List
5module Rel8.Query.List
4 ( many, some
6 ( many, some
7+ , manyExpr, someExpr
8+ , catListTable, catNonEmptyTable
9+ , catList, catNonEmpty
5 )
10 )
6where
11where
7
12
8-- base
13-- base
14+import Data.Functor.Identity ( runIdentity )
15+import Data.List.NonEmpty ( NonEmpty )
9import Prelude
16import Prelude
10
17
18+-- opaleye
19+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
20+
11-- rel8
21-- rel8
12import Rel8.Expr ( Expr )
22import Rel8.Expr ( Expr )
23+import Rel8.Expr.Aggregate ( listAggExpr, nonEmptyAggExpr )
24+import Rel8.Expr.Opaleye ( mapPrimExpr )
13import Rel8.Query ( Query )
25import Rel8.Query ( Query )
14import Rel8.Query.Aggregate ( aggregate )
26import Rel8.Query.Aggregate ( aggregate )
15import Rel8.Query.Maybe ( optional )
27import Rel8.Query.Maybe ( optional )
16−import Rel8.Table ( Table )
28+import Rel8.Query.Rebind ( rebind )
29+import Rel8.Schema.HTable.Vectorize ( hunvectorize )
30+import Rel8.Schema.Null ( Sql, Unnullify )
31+import Rel8.Schema.Spec ( Spec( Spec, info ) )
32+import Rel8.Table ( Table, fromColumns )
33+import Rel8.Table.Cols ( toCols )
17import Rel8.Table.Aggregate ( listAgg, nonEmptyAgg )
34import Rel8.Table.Aggregate ( listAgg, nonEmptyAgg )
18−import Rel8.Table.List ( ListTable )
35+import Rel8.Table.List ( ListTable( ListTable ) )
19import Rel8.Table.Maybe ( maybeTable )
36import Rel8.Table.Maybe ( maybeTable )
20−import Rel8.Table.NonEmpty ( NonEmptyTable )
37+import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )
38+import Rel8.Type ( DBType, typeInformation )
39+import Rel8.Type.Array ( extractArrayElement )
40+import Rel8.Type.Information ( TypeInformation )
41+
42+
43+-- | Aggregate a 'Query' into a 'ListTable'. If the supplied query returns 0
44+-- rows, this function will produce a 'Query' that returns one row containing
45+-- the empty @ListTable@. If the supplied @Query@ does return rows, @many@ will
46+-- return exactly one row, with a @ListTable@ collecting all returned rows.
47+--
48+-- @many@ is analogous to 'Control.Applicative.many' from
49+-- @Control.Applicative@.
50+many :: Table Expr a => Query a -> Query (ListTable Expr a)
51+many =
52+ fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .
53+ optional .
54+ aggregate .
55+ fmap (listAgg . toCols)
21
56
22
57
23-- | Aggregate a 'Query' into a 'NonEmptyTable'. If the supplied query returns
58-- | Aggregate a 'Query' into a 'NonEmptyTable'. If the supplied query returns
@@ -28,16 +63,60 @@ import Rel8.Table.NonEmpty ( NonEmptyTable )
28--
63--
29-- @some@ is analogous to 'Control.Applicative.some' from
64-- @some@ is analogous to 'Control.Applicative.some' from
30-- @Control.Applicative@.
65-- @Control.Applicative@.
31−some :: Table Expr a => Query a -> Query (NonEmptyTable a)
66+some :: Table Expr a => Query a -> Query (NonEmptyTable Expr a)
67+some =
68+ fmap (\(NonEmptyTable a) -> NonEmptyTable a) .
69+ aggregate .
32−some = aggregate . fmap nonEmptyAgg
70+ fmap (nonEmptyAgg . toCols)
33
71
34
72
35−-- | Aggregate a 'Query' into a 'ListTable'. If the supplied query returns 0
73+-- | A version of 'many' specialised to single expressions.
36−-- rows, this function will produce a 'Query' that returns one row containing
74+manyExpr :: Sql DBType a => Query (Expr a) -> Query (Expr [a])
37−-- the empty @ListTable@. If the supplied @Query@ does return rows, @many@ will
38−-- return exactly one row, with a @ListTable@ collecting all returned rows.
39−--
40−-- @many@ is analogous to 'Control.Applicative.many' from
41−-- @Control.Applicative@.
42−many :: Table Expr a => Query a -> Query (ListTable a)
43−many = fmap (maybeTable mempty id) . optional . aggregate . fmap listAgg
75+manyExpr = fmap (maybeTable mempty id) . optional . aggregate . fmap listAggExpr
76+
77+
78+-- | A version of 'many' specialised to single expressions.
79+someExpr :: Sql DBType a => Query (Expr a) -> Query (Expr (NonEmpty a))
80+someExpr = aggregate . fmap nonEmptyAggExpr
81+
82+
83+-- | Expand a 'ListTable' into a 'Query', where each row in the query is an
84+-- element of the given @ListTable@.
85+--
86+-- @catListTable@ is an inverse to 'many'.
87+catListTable :: Table Expr a => ListTable Expr a -> Query a
88+catListTable (ListTable as) =
89+ rebind "unnest" $ fromColumns $ runIdentity $
90+ hunvectorize (\Spec {info} -> pure . sunnest info) as
91+
92+
93+-- | Expand a 'NonEmptyTable' into a 'Query', where each row in the query is an
94+-- element of the given @NonEmptyTable@.
95+--
96+-- @catNonEmptyTable@ is an inverse to 'some'.
97+catNonEmptyTable :: Table Expr a => NonEmptyTable Expr a -> Query a
98+catNonEmptyTable (NonEmptyTable as) =
99+ rebind "unnest" $ fromColumns $ runIdentity $
100+ hunvectorize (\Spec {info} -> pure . sunnest info) as
101+
102+
103+-- | Expand an expression that contains a list into a 'Query', where each row
104+-- in the query is an element of the given list.
105+--
106+-- @catList@ is an inverse to 'manyExpr'.
107+catList :: Sql DBType a => Expr [a] -> Query (Expr a)
108+catList = rebind "unnest" . sunnest typeInformation
109+
110+
111+-- | Expand an expression that contains a non-empty list into a 'Query', where
112+-- each row in the query is an element of the given list.
113+--
114+-- @catNonEmpty@ is an inverse to 'someExpr'.
115+catNonEmpty :: Sql DBType a => Expr (NonEmpty a) -> Query (Expr a)
116+catNonEmpty = rebind "unnest" . sunnest typeInformation
117+
118+
119+sunnest :: TypeInformation (Unnullify a) -> Expr (list a) -> Expr a
120+sunnest info = mapPrimExpr $
121+ extractArrayElement info .
122+ Opaleye.UnExpr (Opaleye.UnOpOther "UNNEST")
src/Rel8/Query/Maybe.hs+33−103
@@ -1,7 +1,10 @@
1+{-# language GADTs #-}
2+{-# language LambdaCase #-}
3+{-# language NamedFieldPuns #-}
4+
1module Rel8.Query.Maybe
5module Rel8.Query.Maybe
2 ( optional
6 ( optional
3 , catMaybeTable
7 , catMaybeTable
4− , bindMaybeTable
5 , traverseMaybeTable
8 , traverseMaybeTable
6 )
9 )
7where
10where
@@ -9,37 +12,32 @@ where
9-- base
12-- base
10import Prelude
13import Prelude
11
14
15+-- comonad
16+import Control.Comonad ( extract )
17+
12-- opaleye
18-- opaleye
13−import qualified Opaleye.Internal.PackMap as Opaleye
19+import qualified Opaleye.Internal.MaybeFields 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
18
20
19-- rel8
21-- rel8
20−import Rel8.Expr.Bool ( true )
22+import Rel8.Expr ( Expr )
21import Rel8.Expr.Eq ( (==.) )
23import Rel8.Expr.Eq ( (==.) )
22−import Rel8.Expr.Opaleye ( toPrimExpr )
24+import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )
23import Rel8.Query ( Query )
25import Rel8.Query ( Query )
24import Rel8.Query.Filter ( where_ )
26import Rel8.Query.Filter ( where_ )
25import Rel8.Query.Opaleye ( mapOpaleye )
27import Rel8.Query.Opaleye ( mapOpaleye )
26−import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
28+import Rel8.Table.Maybe ( MaybeTable(..), isJustTable )
27−import Rel8.Table.Opaleye ( unpackspec )
28−import Rel8.Table.Tag ( Tag(..), fromExpr )
29
29
30
30
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.
31−optional :: Query a -> Query (MaybeTable a)
36+optional :: Query a -> Query (MaybeTable Expr a)
32−optional = mapOpaleye $ Opaleye.QueryArr . go
37+optional = mapOpaleye $ Opaleye.optionalInternal $ \tag a -> MaybeTable
33− where
38+ { tag = fromPrimExpr $ fromColumn tag
34− go query (i, left, tag) =
39+ , just = pure a
35− (MaybeTable (fromExpr t') a, join, Opaleye.next tag')
40+ }
36− where
37− (MaybeTable Tag {expr = t} a, right, tag') =
38− Opaleye.runSimpleQueryArr (pure <$> query) (i, tag)
39− (t', bindings) = Opaleye.run $
40− Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr "maybe" tag') t
41− join = Opaleye.Join Opaleye.LeftJoin condition [] bindings left right
42− condition = toPrimExpr true
43
41
44
42
45-- | Filter out 'MaybeTable's, returning only the tables that are not-null.
43-- | Filter out 'MaybeTable's, returning only the tables that are not-null.
@@ -47,92 +45,24 @@ optional = mapOpaleye $ Opaleye.QueryArr . go
47-- This operation can be used to "undo" the effect of 'optional', which
45-- This operation can be used to "undo" the effect of 'optional', which
48-- operationally is like turning a @LEFT JOIN@ back into a full @JOIN@. You
46-- operationally is like turning a @LEFT JOIN@ back into a full @JOIN@. You
49-- can think of this as analogous to 'Data.Maybe.catMaybes'.
47-- can think of this as analogous to 'Data.Maybe.catMaybes'.
50−--
51−-- To see this in action, first consider the following 'optional' query:
52−--
53−-- >>> :{
54−-- select c $ do
55−-- author <- each authorSchema
56−-- maybeRel8 <- optional $
57−-- each projectSchema
58−-- >>= filter (\p -> projectAuthorId p ==. authorId author)
59−-- >>= filter (\p -> projectName p ==. "rel8")
60−-- return (authorName author, projectName <$> maybeRel8)
61−-- :}
62−-- [("Ollie",Just "rel8"),("Bryan O'Sullivan",Nothing),("Emily Pillmore",Nothing)]
63−--
64−-- Here @optional@ is acting as a @LEFT JOIN@. We can turn this into a proper
65−-- join by using @catMaybeTable@ to filter out rows where the join failed:
66−--
67−-- >>> :{
68−-- select c $ do
69−-- author <- each authorSchema
70−-- maybeRel8 <- optional $
71−-- each projectSchema
72−-- >>= filter (\p -> projectAuthorId p ==. authorId author)
73−-- >>= filter (\p -> projectName p ==. "rel8")
74−-- rel8 <- catMaybeTable maybeRel8
75−-- return (authorName author, projectName rel8)
76−-- :}
77−-- [("Ollie","rel8")]
78−catMaybeTable :: MaybeTable a -> Query a
48+catMaybeTable :: MaybeTable Expr a -> Query a
79catMaybeTable ma@(MaybeTable _ a) = do
49catMaybeTable ma@(MaybeTable _ a) = do
80 where_ $ isJustTable ma
50 where_ $ isJustTable ma
81− pure a
51+ pure (extract a)
82−
83−
84−-- | @bindMaybeTable f x@ is similar to the monadic bind (@>>=@) operation. It
85−-- allows you to "extend" an optional query with another query. If either the
86−-- input or output are 'noTable', then the result is 'noTable'.
87−--
88−-- This is similar to 'traverseMaybeTable', followed by a @join@ on the
89−-- resulting @MaybeTable@s.
90−--
91−-- >>> select c $ bindMaybeTable (optional . values . pure . not_) =<< optional (values [lit True])
92−-- [Just False]
93−--
94−-- >>> select c $ bindMaybeTable (\_ -> return (noTable :: MaybeTable (Expr Bool))) =<< optional (values [lit True])
95−-- [Nothing]
96−--
97−-- >>> select c $ bindMaybeTable (optional . values . pure . not_) =<< return (noTable :: MaybeTable (Expr Bool))
98−-- [Nothing]
99−bindMaybeTable :: Monad m
100− => (a -> m (MaybeTable b)) -> MaybeTable a -> m (MaybeTable b)
101−bindMaybeTable query (MaybeTable input a) = do
102− MaybeTable output b <- query a
103− pure $ MaybeTable (input <> output) b
104
52
105
53
106-- | Extend an optional query with another query. This is useful if you want
54-- | Extend an optional query with another query. This is useful if you want
107-- to step through multiple @LEFT JOINs@.
55-- to step through multiple @LEFT JOINs@.
108--
56--
109-- Note that @traverseMaybeTable@ takes a @a -> Query b@ function, which means
57-- Note that @traverseMaybeTable@ takes a @a -> Query b@ function, which means
110−-- you also have the ability to "expand" one row into multiple rows.
58+-- you also have the ability to "expand" one row into multiple rows. If the
111−--
112−-- >>> :{
113−-- duplicate :: Expr Bool -> Query (Expr Bool)
114−-- duplicate x = unionAll (return x) (return x)
115−-- :}
116−--
117−-- >>> select c $ traverseMaybeTable duplicate =<< optional (values [lit True])
118−-- [Just True,Just True]
119−--
120−-- Note that if the @a -> Query b@ function returns no rows, then the resulting
59+-- @a -> Query b@ function returns no rows, then the resulting query will also
121−-- query will also have no rows:
122−--
123−-- >>> select c $ traverseMaybeTable (limit 0 . pure) =<< optional (values [lit True])
124−-- []
125−--
126−-- However, regardless of the given @a -> Query b@ function, if the input is
60+-- have no rows. However, regardless of the given @a -> Query b@ function, if
127−-- @noTable@, you will always get exactly one @noTable@ back:
61+-- the input is @nothingTable@, you will always get exactly one @nothingTable@
128−--
62+-- back.
129−-- >>> select c $ traverseMaybeTable duplicate (noTable :: MaybeTable (Expr Bool))
130−-- [Nothing]
131−--
132−-- >>> select c $ traverseMaybeTable (limit 0 . pure) (noTable :: MaybeTable (Expr Bool))
133−-- [Nothing]
134−traverseMaybeTable :: (a -> Query b) -> MaybeTable a -> Query (MaybeTable b)
63+traverseMaybeTable :: (a -> Query b) -> MaybeTable Expr a -> Query (MaybeTable Expr b)
135traverseMaybeTable query ma@(MaybeTable input _) = do
64traverseMaybeTable query ma@(MaybeTable input _) = do
136− MaybeTable output b <- optional (query =<< catMaybeTable ma)
65+ optional (query =<< catMaybeTable ma) >>= \case
66+ MaybeTable output b -> do
137− where_ $ expr output ==. expr input
67+ where_ $ output ==. input
138− pure $ MaybeTable input b
68+ pure $ MaybeTable input b
src/Rel8/Query/Null.hs+18−18
@@ -1,5 +1,8 @@
1+{-# language FlexibleContexts #-}
2+
1module Rel8.Query.Null
3module Rel8.Query.Null
2− ( catNullable
4+ ( catNull
5+ , catNullTable
3 )
6 )
4where
7where
5
8
@@ -9,6 +12,8 @@ import Prelude
9-- rel8
12-- rel8
10import Rel8.Expr ( Expr )
13import Rel8.Expr ( Expr )
11import Rel8.Expr.Null ( isNonNull, unsafeUnnullify )
14import Rel8.Expr.Null ( isNonNull, unsafeUnnullify )
15+import Rel8.Table ( Table )
16+import Rel8.Table.Null ( NullTable, isNonNullTable, unsafeUnnullifyTable )
12import Rel8.Query ( Query )
17import Rel8.Query ( Query )
13import Rel8.Query.Filter ( where_ )
18import Rel8.Query.Filter ( where_ )
14
19
@@ -17,22 +22,17 @@ import Rel8.Query.Filter ( where_ )
17-- @null@s.
22-- @null@s.
18--
23--
19-- Corresponds to 'Data.Maybe.catMaybes'.
24-- 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)
35−catNullable :: Expr (Maybe a) -> Query (Expr a)
25+catNull :: Expr (Maybe a) -> Query (Expr a)
36−catNullable a = do
26+catNull a = do
37 where_ $ isNonNull a
27 where_ $ isNonNull a
38 pure $ unsafeUnnullify a
28 pure $ unsafeUnnullify a
29+
30+
31+-- | Filter a 'Query' that might return @nullTable@ to a 'Query' without any
32+-- @nullTable@s.
33+--
34+-- Corresponds to 'Data.Maybe.catMaybes'.
35+catNullTable :: Table Expr a => NullTable Expr a -> Query a
36+catNullTable a = do
37+ where_ $ isNonNullTable a
38+ pure $ unsafeUnnullifyTable a
src/Rel8/Query/Opaleye.hs+41−5
@@ -1,34 +1,70 @@
1+{-# language TupleSections #-}
2+
1module Rel8.Query.Opaleye
3module Rel8.Query.Opaleye
2 ( fromOpaleye
4 ( fromOpaleye
3 , toOpaleye
5 , toOpaleye
4 , mapOpaleye
6 , mapOpaleye
5 , zipOpaleyeWith
7 , zipOpaleyeWith
8+ , unsafePeekQuery
6 )
9 )
7where
10where
8
11
9-- base
12-- base
13+import Control.Applicative ( liftA2 )
10import Prelude
14import Prelude
11
15
12-- opaleye
16-- opaleye
13−import qualified Opaleye.Select as Opaleye
17+import qualified Opaleye.Internal.QueryArr as Opaleye
18+import qualified Opaleye.Internal.Tag as Opaleye
14
19
15-- rel8
20-- rel8
16import {-# SOURCE #-} Rel8.Query ( Query( Query ) )
21import {-# SOURCE #-} Rel8.Query ( Query( Query ) )
17
22
18
23
19fromOpaleye :: Opaleye.Select a -> Query a
24fromOpaleye :: Opaleye.Select a -> Query a
20−fromOpaleye = Query
25+fromOpaleye = Query . pure . fmap pure
21
26
22
27
23toOpaleye :: Query a -> Opaleye.Select a
28toOpaleye :: Query a -> Opaleye.Select a
24−toOpaleye (Query a) = a
29+toOpaleye (Query a) = snd <$> a mempty
25
30
26
31
27mapOpaleye :: (Opaleye.Select a -> Opaleye.Select b) -> Query a -> Query b
32mapOpaleye :: (Opaleye.Select a -> Opaleye.Select b) -> Query a -> Query b
28−mapOpaleye f = fromOpaleye . f . toOpaleye
33+mapOpaleye f (Query a) = Query (fmap (mapping f) a)
29
34
30
35
31zipOpaleyeWith :: ()
36zipOpaleyeWith :: ()
32 => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)
37 => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)
33 -> Query a -> Query b -> Query c
38 -> Query a -> Query b -> Query c
34−zipOpaleyeWith f a b = fromOpaleye $ f (toOpaleye a) (toOpaleye b)
39+zipOpaleyeWith f (Query a) (Query b) = Query $ liftA2 (zipping f) a b
40+
41+
42+unsafePeekQuery :: Query a -> a
43+unsafePeekQuery (Query q) = case q mempty of
44+ f -> case Opaleye.runStateQueryArr f () Opaleye.start of
45+ ((_, a), _, _) -> a
46+
47+
48+mapping :: ()
49+ => (Opaleye.Select a -> Opaleye.Select b)
50+ -> Opaleye.Select (m, a) -> Opaleye.Select (m, b)
51+mapping f q = Opaleye.stateQueryArr $ \_ tag ->
52+ let
53+ ((m, _), _, _) = Opaleye.runStateQueryArr q () tag
54+ q' = (m,) <$> f (snd <$> q)
55+ in
56+ Opaleye.runStateQueryArr q' () tag
57+
58+
59+zipping :: Semigroup m
60+ => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)
61+ -> Opaleye.Select (m, a) -> Opaleye.Select (m, b) -> Opaleye.Select (m, c)
62+zipping f q q' =
63+ Opaleye.stateQueryArr $ \_ tag ->
64+ let
65+ ((m, _), _, _) = Opaleye.runStateQueryArr q () tag
66+ ((m', _), _, _) = Opaleye.runStateQueryArr q' () tag
67+ m'' = m <> m'
68+ q'' = (m'',) <$> f (snd <$> q) (snd <$> q')
69+ in
70+ Opaleye.runStateQueryArr q'' () tag
src/Rel8/Query/Rebind.hsnew file+27
@@ -0,0 +1,27 @@
1+{-# language FlexibleContexts #-}
2+
3+module Rel8.Query.Rebind
4+ ( rebind
5+ )
6+where
7+
8+-- base
9+import Prelude
10+import Control.Arrow ((<<<))
11+
12+-- opaleye
13+import qualified Opaleye.Internal.Rebind as Opaleye
14+
15+-- rel8
16+import Rel8.Expr ( Expr )
17+import Rel8.Query ( Query )
18+import Rel8.Table ( Table )
19+import Rel8.Table.Opaleye ( unpackspec )
20+import Rel8.Query.Opaleye (fromOpaleye)
21+
22+
23+-- | 'rebind' takes a variable name, some expressions, and binds each of them
24+-- to a new variable in the SQL. The @a@ returned consists only of these
25+-- variables. It's essentially a @let@ binding for Postgres expressions.
26+rebind :: Table Expr a => String -> a -> Query a
27+rebind prefix a = fromOpaleye (Opaleye.rebindExplicitPrefix prefix unpackspec <<< pure a)
src/Rel8/Query/SQL.hs+6−58
@@ -1,73 +1,21 @@
1{-# language FlexibleContexts #-}
1{-# language FlexibleContexts #-}
2−{-# language TypeFamilies #-}
2+{-# language MonoLocalBinds #-}
3−{-# language ViewPatterns #-}
4
3
5module Rel8.Query.SQL
4module Rel8.Query.SQL
6 ( showQuery
5 ( showQuery
7− , sqlForQuery, sqlForQueryWithNames
8 )
6 )
9where
7where
10
8
11-- base
9-- base
12−import Data.Foldable ( fold )
13−import Data.Functor.Const ( Const( Const ), getConst )
14−import Data.Void ( Void )
15import Prelude
10import Prelude
16
11
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−
25-- rel8
12-- rel8
26−import Rel8.Expr ( Expr, Col(..) )
13+import Rel8.Expr ( Expr )
27−import Rel8.Expr.Opaleye ( toPrimExpr )
28import Rel8.Query ( Query )
14import Rel8.Query ( Query )
29−import Rel8.Query.Opaleye ( toOpaleye )
15+import Rel8.Statement.Select ( ppSelect )
30−import Rel8.Schema.Name ( Selects, Col(..) )
31−import Rel8.Schema.HTable ( htabulateA, hfield )
32−import Rel8.Table ( Table, toColumns )
16+import Rel8.Table ( Table )
33−import Rel8.Table.Name ( namesFromLabels )
34
17
35
18
36−-- | Convert a query to a 'String' containing the query as a @SELECT@
19+-- | Convert a 'Query' to a 'String' containing a @SELECT@ statement.
37−-- statement.
38showQuery :: Table Expr a => Query a -> String
20showQuery :: Table Expr a => Query a -> String
39−showQuery = fold . sqlForQuery
21+showQuery = show . ppSelect
40−
41−
42−sqlForQuery :: Table Expr a
43− => Query a -> Maybe String
44−sqlForQuery = sqlForQueryWithNames namesFromLabels . fmap toColumns
45−
46−
47−sqlForQueryWithNames :: Selects names exprs
48− => names -> Query exprs -> Maybe String
49−sqlForQueryWithNames names query =
50− show . Opaleye.ppSql . selectFrom names exprs <$> optimize primQuery
51− where
52− (exprs, primQuery, _) =
53− Opaleye.runSimpleQueryArrStart (toOpaleye query) ()
54−
55−
56−optimize :: Opaleye.PrimQuery' a -> Maybe (Opaleye.PrimQuery' Void)
57−optimize = Opaleye.removeEmpty . Opaleye.optimize
58−
59−
60−selectFrom :: Selects names exprs
61− => names -> exprs -> Opaleye.PrimQuery' Void -> Opaleye.Select
62−selectFrom (toColumns -> names) (toColumns -> exprs) query =
63− Opaleye.SelectFrom $ Opaleye.newSelect
64− { Opaleye.attrs = Opaleye.SelectAttrs attributes
65− , Opaleye.tables = Opaleye.oneTable select
66− }
67− where
68− select = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator query
69− attributes = getConst $ htabulateA $ \field -> case hfield names field of
70− NameCol name -> case hfield exprs field of
71− DB (toPrimExpr -> expr) -> Const (pure (makeAttr name expr))
72− makeAttr label expr =
73− (Opaleye.sqlExpr expr, Just (Opaleye.SqlColumn label))
src/Rel8/Query/Set.hs+6−24
@@ -23,54 +23,36 @@ import Rel8.Table.Opaleye ( binaryspec )
23
23
24
24
25-- | Combine the results of two queries of the same type, collapsing
25-- | Combine the results of two queries of the same type, collapsing
26−-- duplicates. @union a b@ is the same as the SQL statement @x UNION b@.
26+-- duplicates. @union a b@ is the same as the SQL statement @a UNION b@.
27−--
28−-- >>> select c $ values [lit True, lit True, lit False] `union` values [lit True]
29−-- [False,True]
30union :: EqTable a => Query a -> Query a -> Query a
27union :: EqTable a => Query a -> Query a -> Query a
31union = zipOpaleyeWith (Opaleye.unionExplicit binaryspec)
28union = zipOpaleyeWith (Opaleye.unionExplicit binaryspec)
32
29
33
30
34-- | Combine the results of two queries of the same type, retaining duplicates.
31-- | Combine the results of two queries of the same type, retaining duplicates.
35−-- @unionAll a b@ is the same as the SQL statement @x UNION ALL b@.
32+-- @unionAll a b@ is the same as the SQL statement @a UNION ALL b@.
36−--
37−-- >>> select c $ values [lit True, lit True, lit False] `unionAll` values [lit True]
38−-- [True,True,False,True]
39unionAll :: Table Expr a => Query a -> Query a -> Query a
33unionAll :: Table Expr a => Query a -> Query a -> Query a
40unionAll = zipOpaleyeWith (Opaleye.unionAllExplicit binaryspec)
34unionAll = zipOpaleyeWith (Opaleye.unionAllExplicit binaryspec)
41
35
42
36
43-- | Find the intersection of two queries, collapsing duplicates. @intersect a
37-- | Find the intersection of two queries, collapsing duplicates. @intersect a
44−-- b@ is the same as the SQL statement @x INTERSECT b@.
38+-- b@ is the same as the SQL statement @a INTERSECT b@.
45−--
46−-- >>> select c $ values [lit True, lit True, lit False] `intersect` values [lit True]
47−-- [True]
48intersect :: EqTable a => Query a -> Query a -> Query a
39intersect :: EqTable a => Query a -> Query a -> Query a
49intersect = zipOpaleyeWith (Opaleye.intersectExplicit binaryspec)
40intersect = zipOpaleyeWith (Opaleye.intersectExplicit binaryspec)
50
41
51
42
52-- | Find the intersection of two queries, retaining duplicates. @intersectAll
43-- | Find the intersection of two queries, retaining duplicates. @intersectAll
53−-- a b@ is the same as the SQL statement @x INTERSECT ALL b@.
44+-- a b@ is the same as the SQL statement @a INTERSECT ALL b@.
54−--
55−-- >>> select c $ values [lit True, lit True, lit False] `intersectAll` values [lit True, lit True]
56−-- [True,True]
57intersectAll :: EqTable a => Query a -> Query a -> Query a
45intersectAll :: EqTable a => Query a -> Query a -> Query a
58intersectAll = zipOpaleyeWith (Opaleye.intersectAllExplicit binaryspec)
46intersectAll = zipOpaleyeWith (Opaleye.intersectAllExplicit binaryspec)
59
47
60
48
61-- | Find the difference of two queries, collapsing duplicates @except a b@ is
49-- | Find the difference of two queries, collapsing duplicates @except a b@ is
62−-- the same as the SQL statement @x INTERSECT b@.
50+-- the same as the SQL statement @a EXCEPT b@.
63−--
64−-- >>> select c $ values [lit True, lit False, lit False] `except` values [lit True]
65−-- [False]
66except :: EqTable a => Query a -> Query a -> Query a
51except :: EqTable a => Query a -> Query a -> Query a
67except = zipOpaleyeWith (Opaleye.exceptExplicit binaryspec)
52except = zipOpaleyeWith (Opaleye.exceptExplicit binaryspec)
68
53
69
54
70-- | Find the difference of two queries, retaining duplicates. @exceptAll a b@
55-- | Find the difference of two queries, retaining duplicates. @exceptAll a b@
71−-- is the same as the SQL statement @x EXCEPT ALL b@.
56+-- is the same as the SQL statement @a EXCEPT ALL b@.
72−--
73−-- >>> select c $ values [lit True, lit False, lit False] `exceptAll` values [lit True]
74−-- [False,False]
75exceptAll :: EqTable a => Query a -> Query a -> Query a
57exceptAll :: EqTable a => Query a -> Query a -> Query a
76exceptAll = zipOpaleyeWith (Opaleye.exceptAllExplicit binaryspec)
58exceptAll = zipOpaleyeWith (Opaleye.exceptAllExplicit binaryspec)
src/Rel8/Query/These.hs+52−45
@@ -1,4 +1,5 @@
1{-# language FlexibleContexts #-}
1{-# language FlexibleContexts #-}
2+{-# language GADTs #-}
2
3
3module Rel8.Query.These
4module Rel8.Query.These
4 ( alignBy
5 ( alignBy
@@ -7,7 +8,6 @@ module Rel8.Query.These
7 , keepThisTable, loseThisTable
8 , keepThisTable, loseThisTable
8 , keepThatTable, loseThatTable
9 , keepThatTable, loseThatTable
9 , keepThoseTable, loseThoseTable
10 , keepThoseTable, loseThoseTable
10− , bindTheseTable
11 , bitraverseTheseTable
11 , bitraverseTheseTable
12 )
12 )
13where
13where
@@ -15,27 +15,29 @@ where
15-- base
15-- base
16import Prelude
16import Prelude
17
17
18+-- comonad
19+import Control.Comonad ( extract )
20+
18-- opaleye
21-- opaleye
19−import qualified Opaleye.Internal.Join as Opaleye
22+import qualified Opaleye.Internal.PackMap as Opaleye
20import qualified Opaleye.Internal.PrimQuery as Opaleye
23import qualified Opaleye.Internal.PrimQuery as Opaleye
24+import qualified Opaleye.Internal.QueryArr as Opaleye
25+import qualified Opaleye.Internal.Tag as Opaleye
21
26
22-- rel8
27-- rel8
23import Rel8.Expr ( Expr )
28import Rel8.Expr ( Expr )
24import Rel8.Expr.Bool ( boolExpr, not_ )
29import Rel8.Expr.Bool ( boolExpr, not_ )
25import Rel8.Expr.Eq ( (==.) )
30import Rel8.Expr.Eq ( (==.) )
26−import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
31+import Rel8.Expr.Opaleye ( toPrimExpr, traversePrimExpr )
27import Rel8.Expr.Serialize ( litExpr )
32import Rel8.Expr.Serialize ( litExpr )
28import Rel8.Query ( Query )
33import Rel8.Query ( Query )
29import Rel8.Query.Filter ( where_ )
34import Rel8.Query.Filter ( where_ )
30import Rel8.Query.Maybe ( optional )
35import Rel8.Query.Maybe ( optional )
31import Rel8.Query.Opaleye ( zipOpaleyeWith )
36import Rel8.Query.Opaleye ( zipOpaleyeWith )
32−import Rel8.Table ( Table )
33import Rel8.Table.Either ( EitherTable( EitherTable ) )
37import Rel8.Table.Either ( EitherTable( EitherTable ) )
34import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
38import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
35−import Rel8.Table.Opaleye ( unpackspec )
36−import Rel8.Table.Tag ( Tag(..) )
37import Rel8.Table.These
39import Rel8.Table.These
38− ( TheseTable( TheseTable )
40+ ( TheseTable( TheseTable, here, there )
39 , hasHereTable, hasThereTable
41 , hasHereTable, hasThereTable
40 , isThisTable, isThatTable, isThoseTable
42 , isThisTable, isThatTable, isThoseTable
41 )
43 )
@@ -43,86 +45,91 @@ import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) )
43
45
44
46
45-- | Corresponds to a @FULL OUTER JOIN@ between two queries.
47-- | Corresponds to a @FULL OUTER JOIN@ between two queries.
46−alignBy :: (Table Expr a, Table Expr b)
48+alignBy :: ()
47 => (a -> b -> Expr Bool)
49 => (a -> b -> Expr Bool)
48− -> Query a -> Query b -> Query (TheseTable a b)
50+ -> Query a -> Query b -> Query (TheseTable Expr a b)
49−alignBy condition as bs =
51+alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.stateQueryArr $ \_ t -> case t of
50− uncurry TheseTable <$> zipOpaleyeWith fullOuterJoin as bs
52+ tag -> (tab, join', tag''')
51− where
53+ where
52− fullOuterJoin a b =
54+ (ma, left', tag') = Opaleye.runStateQueryArr (pure <$> left) () tag
53− Opaleye.joinExplicit unpackspec unpackspec pure pure full a b on
55+ (mb, right', tag'') = Opaleye.runStateQueryArr (pure <$> right) () tag'
54− where
56+ MaybeTable hasHere a = ma
57+ MaybeTable hasThere b = mb
58+ (hasHere', lbindings) = Opaleye.run $ do
59+ traversePrimExpr (Opaleye.extractAttr "hasHere" tag'') hasHere
60+ (hasThere', rbindings) = Opaleye.run $ do
61+ traversePrimExpr (Opaleye.extractAttr "hasThere" tag'') hasThere
62+ tag''' = Opaleye.next tag''
55− full = Opaleye.FullJoin
63+ join = Opaleye.Join Opaleye.FullJoin on left'' right''
56− on = toColumn . toPrimExpr . uncurry condition
64+ where
57−
65+ on = toPrimExpr $ condition (extract a) (extract b)
58−
66+ left'' = (Opaleye.NonLateral, Opaleye.toPrimQuery (left' <> Opaleye.aRebind lbindings))
67+ right'' = (Opaleye.NonLateral, Opaleye.toPrimQuery (right' <> Opaleye.aRebind rbindings))
68+ ma' = MaybeTable hasHere' a
69+ mb' = MaybeTable hasThere' b
70+ tab = TheseTable {here = ma', there = mb'}
71+ join' = Opaleye.aProduct join
72+
73+
59−keepHereTable :: TheseTable a b -> Query (a, MaybeTable b)
74+keepHereTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)
60keepHereTable = loseThatTable
75keepHereTable = loseThatTable
61
76
62
77
63−loseHereTable :: TheseTable a b -> Query b
78+loseHereTable :: TheseTable Expr a b -> Query b
64loseHereTable = keepThatTable
79loseHereTable = keepThatTable
65
80
66
81
67−keepThereTable :: TheseTable a b -> Query (MaybeTable a, b)
82+keepThereTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)
68keepThereTable = loseThisTable
83keepThereTable = loseThisTable
69
84
70
85
71−loseThereTable :: TheseTable a b -> Query a
86+loseThereTable :: TheseTable Expr a b -> Query a
72loseThereTable = keepThisTable
87loseThereTable = keepThisTable
73
88
74
89
75−keepThisTable :: TheseTable a b -> Query a
90+keepThisTable :: TheseTable Expr a b -> Query a
76keepThisTable t@(TheseTable (MaybeTable _ a) _) = do
91keepThisTable t@(TheseTable (MaybeTable _ a) _) = do
77 where_ $ isThisTable t
92 where_ $ isThisTable t
78− pure a
93+ pure (extract a)
79
94
80
95
81−loseThisTable :: TheseTable a b -> Query (MaybeTable a, b)
96+loseThisTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)
82loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do
97loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do
83 where_ $ not_ $ isThisTable t
98 where_ $ not_ $ isThisTable t
84− pure (ma, b)
99+ pure (ma, extract b)
85
100
86
101
87−keepThatTable :: TheseTable a b -> Query b
102+keepThatTable :: TheseTable Expr a b -> Query b
88keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do
103keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do
89 where_ $ isThatTable t
104 where_ $ isThatTable t
90− pure b
105+ pure (extract b)
91
106
92
107
93−loseThatTable :: TheseTable a b -> Query (a, MaybeTable b)
108+loseThatTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)
94loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do
109loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do
95 where_ $ not_ $ isThatTable t
110 where_ $ not_ $ isThatTable t
96− pure (a, mb)
111+ pure (extract a, mb)
97
112
98
113
99−keepThoseTable :: TheseTable a b -> Query (a, b)
114+keepThoseTable :: TheseTable Expr a b -> Query (a, b)
100keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
115keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
101 where_ $ isThoseTable t
116 where_ $ isThoseTable t
102− pure (a, b)
117+ pure (extract a, extract b)
103
118
104
119
105−loseThoseTable :: TheseTable a b -> Query (EitherTable a b)
120+loseThoseTable :: TheseTable Expr a b -> Query (EitherTable Expr a b)
106loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
121loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
107 where_ $ not_ $ isThoseTable t
122 where_ $ not_ $ isThoseTable t
108− pure $ EitherTable result a b
123+ pure $ EitherTable tag a b
109 where
124 where
110 tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)
125 tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)
111− result = (mempty `asTypeOf` result) {expr = tag}
112−
113−
114−bindTheseTable :: (Table Expr a, Semigroup a, Monad m)
115− => (i -> m (TheseTable a b)) -> TheseTable a i -> m (TheseTable a b)
116−bindTheseTable query (TheseTable here (MaybeTable input i)) = do
117− TheseTable here' (MaybeTable output b) <- query i
118− pure $ TheseTable (here <> here') (MaybeTable (input <> output) b)
119
126
120
127
121bitraverseTheseTable :: ()
128bitraverseTheseTable :: ()
122 => (a -> Query c)
129 => (a -> Query c)
123 -> (b -> Query d)
130 -> (b -> Query d)
124− -> TheseTable a b
131+ -> TheseTable Expr a b
125− -> Query (TheseTable c d)
132+ -> Query (TheseTable Expr c d)
126bitraverseTheseTable f g t = do
133bitraverseTheseTable f g t = do
127 mc <- optional (f . fst =<< keepHereTable t)
134 mc <- optional (f . fst =<< keepHereTable t)
128 md <- optional (g . snd =<< keepThereTable t)
135 md <- optional (g . snd =<< keepThereTable t)
src/Rel8/Query/Values.hs+1−7
@@ -21,13 +21,7 @@ import Rel8.Table.Opaleye ( valuesspec )
21
21
22
22
23-- | Construct a query that returns the given input list of rows. This is like
23-- | Construct a query that returns the given input list of rows. This is like
24−-- folding a list of 'return' statements under 'union', but uses the SQL
24+-- folding a list of 'return' statements under 'Rel8.union', but uses the SQL
25-- @VALUES@ expression for efficiency.
25-- @VALUES@ expression for efficiency.
26−--
27−-- Typically @values@ will be used with 'lit':
28−--
29−-- >>> mapM_ Data.Text.IO.putStrLn =<< select c (values [ lit "Hello", lit "World!" ])
30−-- Hello
31−-- World!
32values :: (Table Expr a, Foldable f) => f a -> Query a
26values :: (Table Expr a, Foldable f) => f a -> Query a
33values = fromOpaleye . Opaleye.valuesExplicit valuesspec . toList
27values = fromOpaleye . Opaleye.valuesExplicit valuesspec . toList
src/Rel8/Query/Window.hsnew file+26
@@ -0,0 +1,26 @@
1+module Rel8.Query.Window
2+ ( window
3+ )
4+where
5+
6+-- base
7+import Prelude ()
8+
9+-- opaleye
10+import qualified Opaleye.Window as Opaleye
11+
12+-- rel8
13+import Rel8.Query ( Query )
14+import Rel8.Query.Opaleye ( mapOpaleye )
15+import Rel8.Window ( Window( Window ) )
16+
17+
18+-- | 'window' runs a query composed of expressions containing
19+-- [window functions](https://www.postgresql.org/docs/current/tutorial-window.html).
20+-- 'window' is similar to 'Rel8.aggregate', with the main difference being
21+-- that in a window query, each input row corresponds to one output row,
22+-- whereas aggregation queries fold the entire input query down into a single
23+-- row. To put this into a Haskell context, 'Rel8.aggregate' is to 'foldl' as
24+-- 'window' is to 'scanl'.
25+window :: Window a b -> Query a -> Query b
26+window (Window a) = mapOpaleye (Opaleye.runWindows a)
src/Rel8/Schema/Column.hsdeleted−168
@@ -1,168 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language TypeFamilies #-}
3−{-# language StandaloneKindSignatures #-}
4−
5−module Rel8.Schema.Column
6− ( Column, Default, Label
7− , HEither
8− , HList
9− , HMaybe
10− , HNonEmpty
11− , HThese
12− )
13−where
14−
15−-- base
16−import Data.Functor.Identity ( Identity )
17−import Data.Kind ( Type )
18−import Data.List.NonEmpty ( NonEmpty )
19−import GHC.TypeLits ( Symbol )
20−import Prelude
21−
22−-- rel8
23−import Rel8.Aggregate ( Aggregate )
24−import Rel8.Expr ( Expr )
25−import Rel8.Kind.Labels ( Labels )
26−import Rel8.Kind.Necessity ( Necessity( Required, Optional ) )
27−import Rel8.Schema.Field ( Field )
28−import Rel8.Schema.Insert ( Insert )
29−import qualified Rel8.Schema.Kind as K
30−import Rel8.Schema.Name ( Name )
31−import Rel8.Schema.Structure
32− ( Structure
33− , Shape( Either, List, Maybe, NonEmpty, These )
34− , Shape1
35− , Shape2
36− )
37−import Rel8.Table.Either ( EitherTable )
38−import Rel8.Table.List ( ListTable )
39−import Rel8.Table.Maybe ( MaybeTable )
40−import Rel8.Table.NonEmpty ( NonEmptyTable )
41−import Rel8.Table.These ( TheseTable )
42−
43−-- these
44−import Data.These ( These )
45−
46−
47−type Label :: Symbol -> Type -> Type
48−data Label label a
49−
50−
51−type Default :: Type -> Type
52−data Default a
53−
54−
55−type GetLabel :: Type -> Labels
56−type family GetLabel a where
57− GetLabel (Label label _) = '[label]
58− GetLabel _ = '[]
59−
60−
61−type UnwrapLabel :: Type -> Type
62−type family UnwrapLabel a where
63− UnwrapLabel (Label _ a) = a
64− UnwrapLabel a = a
65−
66−
67−type GetNecessity :: Type -> Necessity
68−type family GetNecessity a where
69− GetNecessity (Default _) = 'Optional
70− GetNecessity _ = 'Required
71−
72−
73−type UnwrapDefault :: Type -> Type
74−type family UnwrapDefault a where
75− UnwrapDefault (Default a) = a
76− UnwrapDefault a = a
77−
78−
79−-- | The @Column@ type family should be used to indicate which fields of your
80−-- data types are single columns in queries. This type family has special
81−-- support when a query is executed, allowing you to use a single data type for
82−-- both query data and rows decoded to Haskell.
83−--
84−-- To understand why this type family is special, let's consider a simple
85−-- higher-kinded data type of Haskell packages:
86−--
87−-- >>> :{
88−-- data Package f = Package
89−-- { packageName :: Column f Text
90−-- , packageAuthor :: Column f Text
91−-- }
92−-- :}
93−--
94−-- In queries, @f@ will be some type of 'Expr', and @Column Expr a@ reduces to
95−-- just @Expr a@:
96−--
97−-- >>> :t packageName (undefined :: Package Expr)
98−-- packageName (undefined :: Package Expr) :: Expr Text
99−--
100−-- When we 'select' queries of this type, @f@ will be instantiated as
101−-- @Identity@, at which point all wrapping entire disappears:
102−--
103−-- >>> :t packageName (undefined :: Package Identity)
104−-- packageName (undefined :: Package Identity) :: Text
105−--
106−-- In @rel8@ we try hard to always know what @f@ is, which means holes should
107−-- mention precise types, rather than the @Column@ type family. You should only
108−-- need to be aware of the type family when defining your table types.
109−type Column :: K.Context -> Type -> Type
110−type Column context a =
111− Field context (GetLabel a)
112− (GetNecessity (UnwrapLabel a))
113− (UnwrapDefault (UnwrapLabel a))
114−
115−
116−type HEither :: K.Context -> Type -> Type -> Type
117−type family HEither context where
118− HEither Structure = Shape2 'Either
119− HEither Aggregate = EitherTable
120− HEither Expr = EitherTable
121− HEither Identity = Either
122− HEither Insert = EitherTable
123− HEither Name = EitherTable
124− HEither _ = Either
125−
126−
127−type HList :: K.Context -> Type -> Type
128−type family HList context where
129− HList Structure = Shape1 'List
130− HList Aggregate = ListTable
131− HList Expr = ListTable
132− HList Identity = []
133− HList Insert = ListTable
134− HList Name = ListTable
135− HList _ = []
136−
137−
138−type HMaybe :: K.Context -> Type -> Type
139−type family HMaybe context where
140− HMaybe Structure = Shape1 'Maybe
141− HMaybe Aggregate = MaybeTable
142− HMaybe Expr = MaybeTable
143− HMaybe Identity = Maybe
144− HMaybe Insert = MaybeTable
145− HMaybe Name = MaybeTable
146− HMaybe _ = Maybe
147−
148−
149−type HNonEmpty :: K.Context -> Type -> Type
150−type family HNonEmpty context where
151− HNonEmpty Structure = Shape1 'NonEmpty
152− HNonEmpty Aggregate = NonEmptyTable
153− HNonEmpty Expr = NonEmptyTable
154− HNonEmpty Identity = NonEmpty
155− HNonEmpty Insert = NonEmptyTable
156− HNonEmpty Name = NonEmptyTable
157− HNonEmpty _ = NonEmpty
158−
159−
160−type HThese :: K.Context -> Type -> Type -> Type
161−type family HThese context where
162− HThese Structure = Shape2 'These
163− HThese Aggregate = TheseTable
164− HThese Expr = TheseTable
165− HThese Identity = These
166− HThese Insert = TheseTable
167− HThese Name = TheseTable
168− HThese _ = These
src/Rel8/Schema/Context.hsdeleted−28
@@ -1,28 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language GADTs #-}
3−{-# language StandaloneKindSignatures #-}
4−{-# language TypeFamilies #-}
5−
6−module Rel8.Schema.Context
7− ( Interpretation(..), Col( Result )
8− )
9−where
10−
11−-- base
12−import Data.Functor.Identity ( Identity )
13−import Data.Kind ( Constraint )
14−import Prelude ()
15−
16−-- rel8
17−import Rel8.Schema.Kind ( Context, HContext )
18−import Rel8.Schema.Spec ( Spec( Spec ) )
19−
20−
21−type Interpretation :: Context -> Constraint
22−class Interpretation context where
23− data Col context :: HContext
24−
25−
26−instance Interpretation Identity where
27− data Col Identity _spec where
28− Result :: a -> Col Identity ('Spec labels necessity a)
src/Rel8/Schema/Context/Identity.hsdeleted−199
@@ -1,199 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language DisambiguateRecordFields #-}
3−{-# language NamedFieldPuns #-}
4−{-# language TypeFamilies #-}
5−
6−module Rel8.Schema.Context.Identity
7− ( fromHEitherTable, toHEitherTable
8− , fromHListTable, toHListTable
9− , fromHMaybeTable, toHMaybeTable
10− , fromHNonEmptyTable, toHNonEmptyTable
11− , fromHTheseTable, toHTheseTable
12− )
13−where
14−
15−-- base
16−import Data.Functor ( ($>) )
17−import Data.Functor.Identity ( Identity )
18−import Data.List.NonEmpty ( NonEmpty )
19−import Prelude hiding ( null )
20−
21−-- rel8
22−import Rel8.Schema.Context ( Col( Result ) )
23−import Rel8.Schema.HTable ( HTable )
24−import Rel8.Schema.HTable.Either ( HEitherTable(..) )
25−import Rel8.Schema.HTable.Identity ( HIdentity(..) )
26−import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
27−import Rel8.Schema.HTable.List ( HListTable )
28−import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
29−import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify )
30−import Rel8.Schema.HTable.These ( HTheseTable(..) )
31−import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )
32−import Rel8.Schema.Nullability
33− ( Nullify
34− , Nullability( Nullable, NonNullable )
35− )
36−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
37−import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )
38−
39−-- these
40−import Data.These ( These( This, That, These ) )
41−import Data.These.Combinators ( justHere, justThere )
42−
43−
44−toHEitherTable :: (HTable t, HTable u)
45− => Either (t (Col Identity)) (u (Col Identity))
46− -> HEitherTable t u (Col Identity)
47−toHEitherTable = either hleft hright
48− where
49− hleft table = HEitherTable
50− { htag = HIdentity (Result IsLeft)
51− , hleft = hnullify nullifier table
52− , hright = hnulls null
53− }
54− hright table = HEitherTable
55− { htag = HIdentity (Result IsRight)
56− , hleft = hnulls null
57− , hright = hnullify nullifier table
58− }
59−{-# INLINABLE toHEitherTable #-}
60−
61−
62−fromHEitherTable :: (HTable t, HTable u)
63− => HEitherTable t u (Col Identity)
64− -> Either (t (Col Identity)) (u (Col Identity))
65−fromHEitherTable HEitherTable {htag, hleft, hright} = case htag of
66− HIdentity (Result tag) -> case tag of
67− IsLeft -> maybe err Left $ hunnullify unnullifier hleft
68− IsRight -> maybe err Right $ hunnullify unnullifier hright
69− where
70− err = error "fromHEitherTable: mismatch between tag and data"
71−{-# INLINABLE fromHEitherTable #-}
72−
73−
74−toHListTable :: HTable t => [t (Col Identity)] -> HListTable t (Col Identity)
75−toHListTable = hvectorize vectorizer
76−{-# INLINABLE toHListTable #-}
77−
78−
79−fromHListTable :: HTable t => HListTable t (Col Identity) -> [t (Col Identity)]
80−fromHListTable = hunvectorize unvectorizer
81−{-# INLINABLE fromHListTable #-}
82−
83−
84−toHMaybeTable :: HTable t => Maybe (t (Col Identity)) -> HMaybeTable t (Col Identity)
85−toHMaybeTable = maybe hnothing hjust
86− where
87− hnothing = HMaybeTable
88− { htag = HIdentity (Result Nothing)
89− , hjust = hnulls null
90− }
91− hjust table = HMaybeTable
92− { htag = HIdentity (Result (Just IsJust))
93− , hjust = hnullify nullifier table
94− }
95−{-# INLINABLE toHMaybeTable #-}
96−
97−
98−fromHMaybeTable :: HTable t => HMaybeTable t (Col Identity) -> Maybe (t (Col Identity))
99−fromHMaybeTable HMaybeTable {htag, hjust} = case htag of
100− HIdentity (Result tag) -> tag $>
101− case hunnullify unnullifier hjust of
102− Nothing -> error "fromHMaybeTable: mismatch between tag and data"
103− Just just -> just
104−{-# INLINABLE fromHMaybeTable #-}
105−
106−
107−toHNonEmptyTable :: HTable t => NonEmpty (t (Col Identity)) -> HNonEmptyTable t (Col Identity)
108−toHNonEmptyTable = hvectorize vectorizer
109−{-# INLINABLE toHNonEmptyTable #-}
110−
111−
112−fromHNonEmptyTable :: HTable t => HNonEmptyTable t (Col Identity) -> NonEmpty (t (Col Identity))
113−fromHNonEmptyTable = hunvectorize unvectorizer
114−{-# INLINABLE fromHNonEmptyTable #-}
115−
116−
117−toHTheseTable :: (HTable t, HTable u)
118− => These (t (Col Identity)) (u (Col Identity))
119− -> HTheseTable t u (Col Identity)
120−toHTheseTable tables = HTheseTable
121− { hhereTag = relabel hhereTag
122− , hhere
123− , hthereTag = relabel hthereTag
124− , hthere
125− }
126− where
127− HMaybeTable
128− { htag = hhereTag
129− , hjust = hhere
130− } = toHMaybeTable (justHere tables)
131− HMaybeTable
132− { htag = hthereTag
133− , hjust = hthere
134− } = toHMaybeTable (justThere tables)
135−{-# INLINABLE toHTheseTable #-}
136−
137−
138−fromHTheseTable :: (HTable t, HTable u)
139− => HTheseTable t u (Col Identity)
140− -> These (t (Col Identity)) (u (Col Identity))
141−fromHTheseTable HTheseTable {hhereTag, hhere, hthereTag, hthere} =
142− case (fromHMaybeTable mhere, fromHMaybeTable mthere) of
143− (Just a, Nothing) -> This a
144− (Nothing, Just b) -> That b
145− (Just a, Just b) -> These a b
146− _ -> error "fromHTheseTable: mismatch between tags and data"
147− where
148− mhere = HMaybeTable
149− { htag = relabel hhereTag
150− , hjust = hhere
151− }
152− mthere = HMaybeTable
153− { htag = relabel hthereTag
154− , hjust = hthere
155− }
156−{-# INLINABLE fromHTheseTable #-}
157−
158−
159−null :: Col Identity ('Spec labels necessity (Maybe a))
160−null = Result Nothing
161−
162−
163−nullifier :: ()
164− => SSpec ('Spec labels necessity a)
165− -> Col Identity ('Spec labels necessity a)
166− -> Col Identity ('Spec labels necessity (Nullify a))
167−nullifier SSpec {nullability} (Result a) = Result $ case nullability of
168− Nullable -> a
169− NonNullable -> Just a
170−
171−
172−unnullifier :: ()
173− => SSpec ('Spec labels necessity a)
174− -> Col Identity ('Spec labels necessity (Nullify a))
175− -> Maybe (Col Identity ('Spec labels necessity a))
176−unnullifier SSpec {nullability} (Result a) =
177− case nullability of
178− Nullable -> pure $ Result a
179− NonNullable -> Result <$> a
180−
181−
182−vectorizer :: Functor f
183− => SSpec ('Spec labels necessity a)
184− -> f (Col Identity ('Spec labels necessity a))
185− -> Col Identity ('Spec labels necessity (f a))
186−vectorizer _ = Result . fmap (\(Result a) -> a)
187−
188−
189−unvectorizer :: Functor f
190− => SSpec ('Spec labels necessity a)
191− -> Col Identity ('Spec labels necessity (f a))
192− -> f (Col Identity ('Spec labels necessity a))
193−unvectorizer _ (Result results) = Result <$> results
194−
195−
196−relabel :: ()
197− => HIdentity ('Spec labels necessity a) (Col Identity)
198− -> HIdentity ('Spec relabels necessity a) (Col Identity)
199−relabel (HIdentity (Result a)) = HIdentity (Result a)
src/Rel8/Schema/Context/Label.hsdeleted−60
@@ -1,60 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language FlexibleInstances #-}
3−{-# language StandaloneKindSignatures #-}
4−{-# language TypeFamilies #-}
5−{-# language TypeOperators #-}
6−
7−module Rel8.Schema.Context.Label
8− ( Labelable( labeler, unlabeler )
9− , HLabelable( hlabeler, hunlabeler )
10− )
11−where
12−
13−-- base
14−import Data.Functor.Identity ( Identity )
15−import Data.Kind ( Constraint )
16−import Prelude hiding ( null )
17−
18−-- rel8
19−import Rel8.Schema.Context ( Interpretation, Col(..) )
20−import Rel8.Schema.Dict ( Dict( Dict ) )
21−import Rel8.Schema.Kind ( Context, HContext )
22−import Rel8.Schema.Spec ( Spec( Spec ) )
23−import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
24−
25−
26−type Labelable :: Context -> Constraint
27−class Interpretation context => Labelable context where
28− labeler :: ()
29− => Col context ('Spec labels necessity a)
30− -> Col context ('Spec (label ': labels) necessity a)
31−
32− unlabeler :: ()
33− => Col context ('Spec (label ': labels) necessity a)
34− -> Col context ('Spec labels necessity a)
35−
36−
37−instance Labelable Identity where
38− labeler (Result a) = Result a
39− unlabeler (Result a) = Result a
40−
41−
42−type HLabelable :: HContext -> Constraint
43−class HLabelable context where
44− hlabeler :: ()
45− => context ('Spec labels necessity a)
46− -> context ('Spec (label ': labels) necessity a)
47−
48− hunlabeler :: ()
49− => context ('Spec (label ': labels) necessity a)
50− -> context ('Spec labels necessity a)
51−
52−
53−instance Labelable context => HLabelable (Col context) where
54− hlabeler = labeler
55− hunlabeler = unlabeler
56−
57−
58−instance HLabelable (Dict (ConstrainDBType constraint)) where
59− hlabeler Dict = Dict
60− hunlabeler Dict = Dict
src/Rel8/Schema/Context/Nullify.hs+105−166
@@ -1,205 +1,144 @@
1{-# language DataKinds #-}
1{-# language DataKinds #-}
2+{-# language EmptyCase #-}
2{-# language FlexibleContexts #-}
3{-# language FlexibleContexts #-}
3−{-# language FlexibleInstances #-}
4+{-# language GADTs #-}
4−{-# language InstanceSigs #-}
5{-# language LambdaCase #-}
5{-# language LambdaCase #-}
6−{-# language MultiParamTypeClasses #-}
7{-# language NamedFieldPuns #-}
6{-# language NamedFieldPuns #-}
8−{-# language ScopedTypeVariables #-}
9{-# language StandaloneKindSignatures #-}
7{-# language StandaloneKindSignatures #-}
10−{-# language TypeApplications #-}
11−{-# language TypeFamilies #-}
12
8
13module Rel8.Schema.Context.Nullify
9module Rel8.Schema.Context.Nullify
10+ ( Nullifiability(..), NonNullifiability(..), nullifiableOrNot, absurd
11+ , Nullifiable, nullifiability
14− ( Nullifiable( ConstrainTag, encodeTag, decodeTag, nullifier, unnullifier )
12+ , guarder, nullifier, unnullifier
15− , HNullifiable( HConstrainTag, hencodeTag, hdecodeTag, hnullifier, hunnullifier )
13+ , sguard, snullify
16− , runTag, unnull
17 )
14 )
18where
15where
19
16
20-- base
17-- base
18+import Data.Bool ( bool )
19+import Data.Functor.Identity ( Identity( Identity ) )
21import Data.Kind ( Constraint, Type )
20import Data.Kind ( Constraint, Type )
22−import GHC.TypeLits ( KnownSymbol )
23import Prelude hiding ( null )
21import Prelude hiding ( null )
24
22
25-- opaleye
23-- opaleye
26import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
24import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
27
25
28-- rel8
26-- rel8
29−import Rel8.Aggregate
27+import Rel8.Aggregate ( Aggregate(..), zipOutputs )
30− ( Aggregate, Col(..)
31− , mapInputs
32− , unsafeMakeAggregate
33− )
34−import Rel8.Expr ( Expr, Col(..) )
28+import Rel8.Expr ( Expr )
35import Rel8.Expr.Bool ( boolExpr )
29import Rel8.Expr.Bool ( boolExpr )
36import Rel8.Expr.Null ( nullify, unsafeUnnullify )
30import Rel8.Expr.Null ( nullify, unsafeUnnullify )
37−import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
31+import Rel8.Expr.Opaleye ( fromPrimExpr )
38−import Rel8.Kind.Necessity ( Necessity( Required ) )
32+import Rel8.Kind.Context ( SContext(..) )
39−import Rel8.Schema.Context ( Interpretation )
33+import Rel8.Schema.Field ( Field )
40import qualified Rel8.Schema.Kind as K
34import qualified Rel8.Schema.Kind as K
41−import Rel8.Schema.Name ( Name( Name ), Col(..) )
35+import Rel8.Schema.Name ( Name( Name ) )
42−import Rel8.Schema.Nullability
36+import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )
43− ( Nullify
44− , Nullability( Nullable, NonNullable )
45− , Sql
46− )
47−import Rel8.Schema.Dict ( Dict( Dict ) )
37+import Rel8.Schema.Result ( Result )
48−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
38+import Rel8.Schema.Spec ( Spec(..) )
49−import Rel8.Schema.Spec.ConstrainDBType
50− ( ConstrainDBType
51− , dbTypeDict, dbTypeNullability, fromNullabilityDict
52− )
53−import Rel8.Table.Tag ( Tag(..), Taggable, fromAggregate, fromExpr, fromName )
54
39
55
40
56−type Nullifiable :: K.Context -> Constraint
41+type Nullifiability :: K.Context -> Type
57−class Interpretation context => Nullifiable context where
42+data Nullifiability context where
58− type ConstrainTag context :: Type -> Constraint
43+ NAggregate :: Nullifiability Aggregate
59− type ConstrainTag _context = DefaultConstrainTag
44+ NExpr :: Nullifiability Expr
60−
45+ NName :: Nullifiability Name
61− encodeTag ::
62− ( Sql (ConstrainTag context) a
63− , KnownSymbol label
64− , Taggable a
65− )
66− => Tag label a
67− -> Col context ('Spec labels 'Required a)
68−
69− decodeTag ::
70− ( Sql (ConstrainTag context) a
71− , KnownSymbol label
72− , Taggable a
73− )
74− => Col context ('Spec labels 'Required a)
75− -> Tag label a
76−
77− nullifier :: ()
78− => Tag label a
79− -> (Expr a -> Expr Bool)
80− -> SSpec ('Spec labels necessity x)
81− -> Col context ('Spec labels necessity x)
82− -> Col context ('Spec labels necessity (Nullify x))
83−
84− unnullifier :: ()
85− => SSpec ('Spec labels necessity x)
86− -> Col context ('Spec labels necessity (Nullify x))
87− -> Col context ('Spec labels necessity x)
88−
89−
90−instance Nullifiable Aggregate where
91− encodeTag Tag {aggregator, expr} =
92− Aggregation $ unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr
93
46
94− decodeTag (Aggregation aggregate) = fromAggregate aggregate
95
47
96− nullifier Tag {expr} test SSpec {nullability} (Aggregation aggregate) =
48+type Nullifiable :: K.Context -> Constraint
97− Aggregation $
49+class Nullifiable context where
98− mapInputs (toPrimExpr . runTag nullability condition . fromPrimExpr) $
50+ nullifiability :: Nullifiability context
99− runTag nullability condition <$> aggregate
100− where
101− condition = test expr
102
51
103− unnullifier SSpec {nullability} (Aggregation aggregate) =
104− Aggregation $ unnull nullability <$> aggregate
105
52
106− {-# INLINABLE encodeTag #-}
53+instance Nullifiable Aggregate where
107− {-# INLINABLE decodeTag #-}
54+ nullifiability = NAggregate
108− {-# INLINABLE nullifier #-}
109− {-# INLINABLE unnullifier #-}
110
55
111
56
112instance Nullifiable Expr where
57instance Nullifiable Expr where
113− encodeTag Tag {expr} = DB expr
58+ nullifiability = NExpr
114− decodeTag (DB a) = fromExpr a
115− nullifier Tag {expr} test SSpec {nullability} (DB a) =
116− DB $ runTag nullability (test expr) a
117− unnullifier SSpec {nullability} (DB a) = DB $ unnull nullability a
118−
119− {-# INLINABLE encodeTag #-}
120− {-# INLINABLE decodeTag #-}
121− {-# INLINABLE nullifier #-}
122− {-# INLINABLE unnullifier #-}
123
59
124
60
125instance Nullifiable Name where
61instance Nullifiable Name where
126− encodeTag Tag {name = Name name} = NameCol name
62+ nullifiability = NName
127− decodeTag (NameCol name) = fromName (Name name)
63+
128− nullifier _ _ _ (NameCol name) = NameCol name
64+
129− unnullifier _ (NameCol name) = NameCol name
65+type NonNullifiability :: K.Context -> Type
130−
66+data NonNullifiability context where
131− {-# INLINABLE encodeTag #-}
67+ NField :: NonNullifiability (Field table)
132− {-# INLINABLE decodeTag #-}
68+ NResult :: NonNullifiability Result
133− {-# INLINABLE nullifier #-}
69+
134− {-# INLINABLE unnullifier #-}
70+
135−
71+nullifiableOrNot :: ()
136−
72+ => SContext context
137−runTag :: Nullability a -> Expr Bool -> Expr a -> Expr (Nullify a)
73+ -> Either (NonNullifiability context) (Nullifiability context)
138−runTag nullability tag a = case nullability of
74+nullifiableOrNot = \case
139− Nullable -> boolExpr null a tag
75+ SAggregate -> Right NAggregate
140− NonNullable -> boolExpr null (nullify a) tag
76+ SExpr -> Right NExpr
77+ SField -> Left NField
78+ SName -> Right NName
79+ SResult -> Left NResult
80+
81+
82+absurd :: Nullifiability context -> NonNullifiability context -> a
83+absurd = \case
84+ NAggregate -> \case
85+ NExpr -> \case
86+ NName -> \case
87+
88+
89+guarder :: ()
90+ => SContext context
91+ -> context tag
92+ -> (tag -> Bool)
93+ -> (Expr tag -> Expr Bool)
94+ -> context (Maybe a)
95+ -> context (Maybe a)
96+guarder = \case
97+ SAggregate -> \tag _ isNonNull -> zipOutputs (sguard . isNonNull) tag
98+ SExpr -> \tag _ isNonNull -> sguard (isNonNull tag)
99+ SField -> \_ _ _ -> id
100+ SName -> \_ _ _ -> id
101+ SResult -> \(Identity tag) isNonNull _ (Identity a) ->
102+ Identity (bool Nothing a (isNonNull tag))
103+
104+
105+nullifier :: ()
106+ => Nullifiability context
107+ -> Spec a
108+ -> context a
109+ -> context (Nullify a)
110+nullifier = \case
111+ NAggregate -> \Spec {nullity} (Aggregate a) ->
112+ Aggregate $ snullify nullity <$> a
113+ NExpr -> \Spec {nullity} a -> snullify nullity a
114+ NName -> \_ (Name a) -> Name a
115+
116+
117+unnullifier :: ()
118+ => Nullifiability context
119+ -> Spec a
120+ -> context (Nullify a)
121+ -> context a
122+unnullifier = \case
123+ NAggregate -> \Spec {nullity} (Aggregate a) ->
124+ Aggregate $ sunnullify nullity <$> a
125+ NExpr -> \Spec {nullity} a -> sunnullify nullity a
126+ NName -> \_ (Name a) -> Name a
127+
128+
129+sguard :: Expr Bool -> Expr (Maybe a) -> Expr (Maybe a)
130+sguard condition a = boolExpr null a condition
141 where
131 where
142 null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit
132 null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit
143
133
144
134
145−unnull :: Nullability a -> Expr (Nullify a) -> Expr a
135+snullify :: Nullity a -> Expr a -> Expr (Nullify a)
146−unnull nullability a = case nullability of
136+snullify nullity a = case nullity of
147− Nullable -> a
137+ Null -> a
148− NonNullable -> unsafeUnnullify a
138+ NotNull -> nullify a
149−
150−
151−type HNullifiable :: K.HContext -> Constraint
152−class HNullifiable context where
153− type HConstrainTag context :: Type -> Constraint
154− type HConstrainTag _context = DefaultConstrainTag
155−
156− hencodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)
157− => Tag label a
158− -> context ('Spec labels 'Required a)
159−
160− hdecodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)
161− => context ('Spec labels 'Required a)
162− -> Tag label a
163−
164− hnullifier :: ()
165− => Tag label a
166− -> (Expr a -> Expr Bool)
167− -> SSpec ('Spec labels necessity x)
168− -> context ('Spec labels necessity x)
169− -> context ('Spec labels necessity (Nullify x))
170−
171− hunnullifier :: ()
172− => SSpec ('Spec labels necessity x)
173− -> context ('Spec labels necessity (Nullify x))
174− -> context ('Spec labels necessity x)
175−
176−
177−instance Nullifiable context => HNullifiable (Col context) where
178− type HConstrainTag (Col context) = ConstrainTag context
179− hencodeTag = encodeTag
180− hdecodeTag = decodeTag
181− hnullifier = nullifier
182− hunnullifier = unnullifier
183−
184−
185−instance HNullifiable (Dict (ConstrainDBType constraint)) where
186− type HConstrainTag (Dict (ConstrainDBType constraint)) = constraint
187−
188− hencodeTag _ = Dict
189− hdecodeTag = mempty
190−
191− hnullifier _ _ SSpec {} dict = case dbTypeDict dict of
192− Dict -> case dbTypeNullability dict of
193− Nullable -> Dict
194− NonNullable -> Dict
195−
196− hunnullifier SSpec {nullability} dict = case dbTypeDict dict of
197− Dict -> case nullability of
198− Nullable -> Dict
199− NonNullable -> case dbTypeNullability dict of
200− Nullable -> fromNullabilityDict nullability Dict
201
139
202
140
203−type DefaultConstrainTag :: Type -> Constraint
141+sunnullify :: Nullity a -> Expr (Nullify a) -> Expr a
204−class DefaultConstrainTag a
142+sunnullify nullity a = case nullity of
205−instance DefaultConstrainTag a
143+ Null -> a
144+ NotNull -> unsafeUnnullify a
src/Rel8/Schema/Field.hs+37−21
@@ -1,34 +1,50 @@
1{-# language DataKinds #-}
1{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language MultiParamTypeClasses #-}
2{-# language StandaloneKindSignatures #-}
4{-# language StandaloneKindSignatures #-}
3{-# language TypeFamilies #-}
5{-# language TypeFamilies #-}
4
6
5module Rel8.Schema.Field
7module Rel8.Schema.Field
6− ( Field
8+ ( Field(..)
9+ , fields
7 )
10 )
8where
11where
9
12
10-- base
13-- base
11−import Data.Functor.Identity ( Identity )
14+import Data.Functor.Identity ( Identity( Identity ) )
12import Data.Kind ( Type )
15import Data.Kind ( Type )
13import Prelude
16import Prelude
14
17
15-- rel8
18-- rel8
16−import Rel8.Aggregate ( Aggregate )
19+import Rel8.Schema.HTable ( HField, htabulate )
17−import Rel8.Expr ( Expr )
20+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
18−import Rel8.Kind.Labels ( Labels )
19−import Rel8.Kind.Necessity ( Necessity( Required, Optional ) )
20−import Rel8.Schema.Insert ( Insert )
21−import qualified Rel8.Schema.Kind as K
21+import Rel8.Schema.Kind as K
22−import Rel8.Schema.Spec ( Spec( Spec ) )
22+import Rel8.Schema.Null ( Sql )
23−import Rel8.Schema.Structure ( Structure, Shape( Column ), Shape1 )
23+import Rel8.Table
24−
24+ ( Table, Columns, Context, fromColumns, toColumns
25−
25+ , FromExprs, fromResult, toResult
26+ , Transpose
27+ )
28+import Rel8.Table.Transpose ( Transposes )
29+import Rel8.Type ( DBType )
30+
31+
32+-- | A special context used in the construction of 'Rel8.Projection's.
26−type Field :: K.Context -> Labels -> Necessity -> Type -> Type
33+type Field :: Type -> K.Context
27−type family Field labels context necessity a where
34+newtype Field table a = Field (HField (Columns table) a)
28− Field Identity _labels _necessity a = a
35+
29− Field Expr _labels _necessity a = Expr a
36+
30− Field Insert _labels 'Required a = Expr a
37+instance Sql DBType a => Table (Field table) (Field table a) where
31− Field Insert _labels 'Optional a = Maybe (Expr a)
38+ type Columns (Field table a) = HIdentity a
32− Field Aggregate _labels _necessity a = Aggregate (Expr a)
39+ type Context (Field table a) = Field table
33− Field Structure labels necessity a = Shape1 'Column ('Spec labels necessity a)
40+ type FromExprs (Field table a) = a
34− Field context _labels _necessity a = context 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.hsdeleted−1049
@@ -1,1049 +0,0 @@
1−{-# language AllowAmbiguousTypes #-}
2−{-# language DataKinds #-}
3−{-# language DisambiguateRecordFields #-}
4−{-# language DefaultSignatures #-}
5−{-# language FlexibleContexts #-}
6−{-# language FlexibleInstances #-}
7−{-# language GADTs #-}
8−{-# language MultiParamTypeClasses #-}
9−{-# language ScopedTypeVariables #-}
10−{-# language StandaloneKindSignatures #-}
11−{-# language TypeApplications #-}
12−{-# language TypeFamilies #-}
13−{-# language TypeOperators #-}
14−{-# language UndecidableInstances #-}
15−{-# language ViewPatterns #-}
16−
17−{-# options_ghc -fno-warn-orphans #-}
18−
19−module Rel8.Schema.Generic
20− ( Rel8able
21− )
22−where
23−
24−-- base
25−import Data.Bifunctor ( bimap )
26−import Data.Functor.Identity ( Identity )
27−import Data.Kind ( Constraint, Type )
28−import Data.List.NonEmpty ( NonEmpty )
29−import GHC.Generics
30− ( Generic, Rep, from, to
31− , (:*:)( (:*:) ), K1( K1 ), M1( M1 )
32− , D, C, S
33− , Meta( MetaSel )
34− )
35−import GHC.TypeLits ( Symbol, KnownSymbol )
36−import Prelude
37−
38−-- rel8
39−import Rel8.Aggregate ( Aggregate, Col(..) )
40−import Rel8.Expr ( Expr, Col(..) )
41−import Rel8.Kind.Necessity
42− ( SNecessity( SRequired, SOptional )
43− , KnownNecessity, necessitySing
44− )
45−import Rel8.Schema.Context ( Col(..) )
46−import Rel8.Schema.Context.Identity
47− ( fromHEitherTable, toHEitherTable
48− , fromHListTable, toHListTable
49− , fromHMaybeTable, toHMaybeTable
50− , fromHNonEmptyTable, toHNonEmptyTable
51− , fromHTheseTable, toHTheseTable
52− )
53−import Rel8.Schema.Context.Label
54− ( Labelable, labeler, unlabeler
55− , hlabeler, hunlabeler
56− )
57−import Rel8.Schema.Field ( Field )
58−import Rel8.Schema.HTable ( HTable )
59−import Rel8.Schema.HTable.Either ( HEitherTable )
60−import Rel8.Schema.HTable.Identity ( HIdentity(..) )
61−import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
62−import Rel8.Schema.HTable.List ( HListTable )
63−import Rel8.Schema.HTable.Maybe ( HMaybeTable )
64−import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
65−import Rel8.Schema.HTable.Pair ( HPair(..) )
66−import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
67−import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
68−import Rel8.Schema.HTable.These ( HTheseTable )
69−import Rel8.Schema.HTable.Trio ( HTrio(..) )
70−import Rel8.Schema.HTable.Vectorize ( hrelabel )
71−import Rel8.Schema.Insert ( Insert, Col(..) )
72−import qualified Rel8.Schema.Kind as K
73−import Rel8.Schema.Name ( Name( Name ), Col(..) )
74−import Rel8.Schema.Spec ( Spec( Spec ), KTable )
75−import Rel8.Schema.Structure
76− ( IsStructure, Shape(..), Shape1, Shape2
77− , Structure
78− )
79−import Rel8.Table
80− ( Table, Columns, Context, fromColumns, toColumns
81− )
82−import Rel8.Table.Either ( EitherTable )
83−import Rel8.Table.Lifted
84− ( fromColumns1, toColumns1
85− , fromColumns2, toColumns2
86− )
87−import Rel8.Table.List ( ListTable )
88−import Rel8.Table.Maybe ( MaybeTable(..) )
89−import Rel8.Table.NonEmpty ( NonEmptyTable )
90−import Rel8.Table.These ( TheseTable )
91−
92−-- these
93−import Data.These ( These )
94−
95−
96−instance (Rel8able t, TableHelper context) => Table context (t context) where
97− type Columns (t context) = GRep t
98− type Context (t context) = context
99− fromColumns = gfromColumns
100− toColumns = gtoColumns
101−
102−
103−type TableHelper :: K.Context -> Constraint
104−class TableHelper context where
105− gfromColumns :: Rel8able t => GRep t (Col context) -> t context
106− gtoColumns :: Rel8able t => t context -> GRep t (Col context)
107−
108−
109−instance TableHelper Aggregate where
110− gfromColumns = fromAggregateColumns
111− gtoColumns = toAggregateColumns
112−
113−
114−instance TableHelper Expr where
115− gfromColumns = fromExprColumns
116− gtoColumns = toExprColumns
117−
118−
119−instance TableHelper Insert where
120− gfromColumns = fromInsertColumns
121− gtoColumns = toInsertColumns
122−
123−
124−instance TableHelper Identity where
125− gfromColumns = fromIdentityColumns
126− gtoColumns = toIdentityColumns
127−
128−
129−instance TableHelper Name where
130− gfromColumns = fromNameColumns
131− gtoColumns = toNameColumns
132−
133−
134−-- | This type class allows you to define custom 'Table's using higher-kinded
135−-- data types. Higher-kinded data types are data types of the pattern:
136−--
137−-- @
138−-- data MyType f =
139−-- MyType { field1 :: Column f T1 OR HK1 f
140−-- , field2 :: Column f T2 OR HK2 f
141−-- , ...
142−-- , fieldN :: Column f Tn OR HKn f
143−-- }
144−-- @
145−--
146−-- where @Tn@ is any Haskell type, and @HKn@ is any higher-kinded type.
147−--
148−-- That is, higher-kinded data are records where all fields in the record are
149−-- all either of the type @Column f T@ (for any @T@), or are themselves
150−-- higher-kinded data:
151−--
152−-- [Nested]
153−--
154−-- @
155−-- data Nested f =
156−-- Nested { nested1 :: MyType f
157−-- , nested2 :: MyType f
158−-- }
159−-- @
160−--
161−-- The @Rel8able@ type class is used to give us a special mapping operation
162−-- that lets us change the type parameter @f@.
163−--
164−-- [Supplying @Rel8able@ instances]
165−--
166−-- This type class should be derived generically for all table types in your
167−-- project. To do this, enable the @DeriveAnyType@ and @DeriveGeneric@ language
168−-- extensions:
169−--
170−-- @
171−-- \{\-\# LANGUAGE DeriveAnyClass, DeriveGeneric #-\}
172−--
173−-- data MyType f = MyType { fieldA :: Column f T }
174−-- deriving ( GHC.Generics.Generic, Rel8able )
175−-- @
176−type Rel8able :: KTable -> Constraint
177−class HTable (GRep t) => Rel8able t where
178− type GRep t :: K.HTable
179−
180− fromAggregateColumns :: GRep t (Col Aggregate) -> t Aggregate
181− toAggregateColumns :: t Aggregate -> GRep t (Col Aggregate)
182−
183− fromExprColumns :: GRep t (Col Expr) -> t Expr
184− toExprColumns :: t Expr -> GRep t (Col Expr)
185−
186− fromInsertColumns :: GRep t (Col Insert) -> t Insert
187− toInsertColumns :: t Insert -> GRep t (Col Insert)
188−
189− fromIdentityColumns :: GRep t (Col Identity) -> t Identity
190− toIdentityColumns :: t Identity -> GRep t (Col Identity)
191−
192− fromNameColumns :: GRep t (Col Name) -> t Name
193− toNameColumns :: t Name -> GRep t (Col Name)
194−
195− type GRep t = GColumns (Rep (t Structure))
196−
197− default fromAggregateColumns ::
198− ( Generic (t Aggregate)
199− , GColumns (Rep (t Structure)) ~ GRep t
200− , GRel8able Aggregate (Rep (t Structure)) (Rep (t Aggregate))
201− ) => GRep t (Col Aggregate) -> t Aggregate
202− fromAggregateColumns = to . fromGColumns @_ @(Rep (t Structure))
203−
204− default toAggregateColumns ::
205− ( Generic (t Aggregate)
206− , GColumns (Rep (t Structure)) ~ GRep t
207− , GRel8able Aggregate (Rep (t Structure)) (Rep (t Aggregate))
208− ) => t Aggregate -> GRep t (Col Aggregate)
209− toAggregateColumns = toGColumns @_ @(Rep (t Structure)) . from
210−
211− default fromExprColumns ::
212− ( Generic (t Expr)
213− , GColumns (Rep (t Structure)) ~ GRep t
214− , GRel8able Expr (Rep (t Structure)) (Rep (t Expr))
215− ) => GRep t (Col Expr) -> t Expr
216− fromExprColumns = to . fromGColumns @_ @(Rep (t Structure))
217−
218− default toExprColumns ::
219− ( Generic (t Expr)
220− , GColumns (Rep (t Structure)) ~ GRep t
221− , GRel8able Expr (Rep (t Structure)) (Rep (t Expr))
222− ) => t Expr -> GRep t (Col Expr)
223− toExprColumns = toGColumns @_ @(Rep (t Structure)) . from
224−
225− default fromInsertColumns ::
226− ( Generic (t Insert)
227− , GColumns (Rep (t Structure)) ~ GRep t
228− , GRel8able Insert (Rep (t Structure)) (Rep (t Insert))
229− ) => GRep t (Col Insert) -> t Insert
230− fromInsertColumns = to . fromGColumns @_ @(Rep (t Structure))
231−
232− default toInsertColumns ::
233− ( Generic (t Insert)
234− , GColumns (Rep (t Structure)) ~ GRep t
235− , GRel8able Insert (Rep (t Structure)) (Rep (t Insert))
236− ) => t Insert -> GRep t (Col Insert)
237− toInsertColumns = toGColumns @_ @(Rep (t Structure)) . from
238−
239− default fromIdentityColumns ::
240− ( Generic (t Identity)
241− , GColumns (Rep (t Structure)) ~ GRep t
242− , GRel8able Identity (Rep (t Structure)) (Rep (t Identity))
243− ) => GRep t (Col Identity) -> t Identity
244− fromIdentityColumns = to . fromGColumns @_ @(Rep (t Structure))
245−
246− default toIdentityColumns ::
247− ( Generic (t Identity)
248− , GColumns (Rep (t Structure)) ~ GRep t
249− , GRel8able Identity (Rep (t Structure)) (Rep (t Identity))
250− ) => t Identity -> GRep t (Col Identity)
251− toIdentityColumns = toGColumns @_ @(Rep (t Structure)) . from
252−
253− default fromNameColumns ::
254− ( Generic (t Name)
255− , GColumns (Rep (t Structure)) ~ GRep t
256− , GRel8able Name (Rep (t Structure)) (Rep (t Name))
257− ) => GRep t (Col Name) -> t Name
258− fromNameColumns = to . fromGColumns @_ @(Rep (t Structure))
259−
260− default toNameColumns ::
261− ( Generic (t Name)
262− , GColumns (Rep (t Structure)) ~ GRep t
263− , GRel8able Name (Rep (t Structure)) (Rep (t Name))
264− ) => t Name -> GRep t (Col Name)
265− toNameColumns = toGColumns @_ @(Rep (t Structure)) . from
266−
267−
268−type GColumns :: (Type -> Type) -> K.HTable
269−type family GColumns structure where
270− GColumns (M1 D _ structure) = GColumns structure
271− GColumns (M1 C _ structure) = GColumns structure
272− GColumns (a :*: b) = HPair (GColumns a) (GColumns b)
273− GColumns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ structure)) =
274− K1Columns label structure
275−
276−
277−type GRel8able :: K.Context -> (Type -> Type) -> (Type -> Type) -> Constraint
278−class GRel8able context structure rep where
279− fromGColumns :: GColumns structure (Col context) -> rep x
280− toGColumns :: rep x -> GColumns structure (Col context)
281−
282−
283−instance GRel8able context structure rep => GRel8able context (M1 D c structure) (M1 D c rep) where
284− fromGColumns = M1 . fromGColumns @context @structure @rep
285− toGColumns (M1 a) = toGColumns @context @structure @rep a
286−
287−
288−instance GRel8able context structure rep => GRel8able context (M1 C c structure) (M1 C c rep) where
289− fromGColumns = M1 . fromGColumns @context @structure @rep
290− toGColumns (M1 a) = toGColumns @context @structure @rep a
291−
292−
293−instance (GRel8able context structure1 rep1, GRel8able context structure2 rep2) =>
294− GRel8able context (structure1 :*: structure2) (rep1 :*: rep2)
295− where
296− fromGColumns (HPair a b) =
297− fromGColumns @context @structure1 @rep1 a :*:
298− fromGColumns @context @structure2 @rep2 b
299− toGColumns (a :*: b) =
300− HPair
301− (toGColumns @context @structure1 @rep1 a)
302− (toGColumns @context @structure2 @rep2 b)
303−
304−
305−instance
306− ( K1Table label context isStructure structure a
307− , meta ~ 'MetaSel ('Just label) _su _ss _ds
308− , structureK1 ~ K1 i structure
309− , k1 ~ K1 i a
310− ) => GRel8able context (M1 S meta structureK1) (M1 S meta k1)
311− where
312− fromGColumns = M1 . K1 . fromK1Columns @label @_ @_ @structure
313− toGColumns (M1 (K1 a)) = toK1Columns @label @_ @_ @structure a
314−
315−
316−type K1Columns :: Symbol -> Type -> K.HTable
317−type family K1Columns label structure where
318− K1Columns label (Shape1 'Column ('Spec '[] necessity a)) =
319− HIdentity ('Spec '[label] necessity a)
320− K1Columns _label (Shape1 'Column ('Spec (label ': labels) necessity a)) =
321− HIdentity ('Spec (label ': labels) necessity a)
322− K1Columns label (Shape2 'Either a b) =
323− HLabel label (HEitherTable (K1Columns "Left" a) (K1Columns "Right" b))
324− K1Columns label (Shape1 'List a) = HListTable (K1Columns label a)
325− K1Columns label (Shape1 'Maybe a) = HLabel label (HMaybeTable (K1Columns "Just" a))
326− K1Columns label (Shape1 'NonEmpty a) = HNonEmptyTable (K1Columns label a)
327− K1Columns label (Shape2 'These a b) =
328− HLabel label (HTheseTable (K1Columns "Here" a) (K1Columns "There" b))
329− K1Columns label (a, b) =
330− HLabel label
331− (HPair
332− (K1Columns "fst" a)
333− (K1Columns "snd" b))
334− K1Columns label (a, b, c) =
335− HLabel label
336− (HTrio
337− (K1Columns "fst" a)
338− (K1Columns "snd" b)
339− (K1Columns "trd" c))
340− K1Columns label (a, b, c, d) =
341− HLabel label
342− (HQuartet
343− (K1Columns "fst" a)
344− (K1Columns "snd" b)
345− (K1Columns "trd" c)
346− (K1Columns "frt" d))
347− K1Columns label (a, b, c, d, e) =
348− HLabel label
349− (HQuintet
350− (K1Columns "fst" a)
351− (K1Columns "snd" b)
352− (K1Columns "trd" c)
353− (K1Columns "frt" d)
354− (K1Columns "fft" e))
355− K1Columns label a = HLabel label (Columns a)
356−
357−
358−type K1Table :: Symbol -> K.Context -> Bool -> Type -> Type -> Constraint
359−class isStructure ~ IsStructure structure =>
360− K1Table label context isStructure structure a
361− where
362− fromK1Columns :: K1Columns label structure (Col context) -> a
363− toK1Columns :: a -> K1Columns label structure (Col context)
364−
365−
366−instance
367− ( x ~ Field Aggregate '[] necessity a
368− ) => K1Table label Aggregate 'True (Shape1 'Column ('Spec '[] necessity a)) x
369− where
370− fromK1Columns (HIdentity (Aggregation a)) = a
371− toK1Columns = HIdentity . Aggregation
372− {-# INLINABLE fromK1Columns #-}
373− {-# INLINABLE toK1Columns #-}
374−
375−
376−instance
377− ( x ~ Field Aggregate (label ': labels) necessity a
378− ) => K1Table _label Aggregate 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x
379− where
380− fromK1Columns (HIdentity (Aggregation a)) = a
381− toK1Columns = HIdentity . Aggregation
382− {-# INLINABLE fromK1Columns #-}
383− {-# INLINABLE toK1Columns #-}
384−
385−
386−instance
387− ( x ~ Field Expr '[] necessity a
388− ) => K1Table label Expr 'True (Shape1 'Column ('Spec '[] necessity a)) x
389− where
390− fromK1Columns (HIdentity (DB a)) = a
391− toK1Columns = HIdentity . DB
392− {-# INLINABLE fromK1Columns #-}
393− {-# INLINABLE toK1Columns #-}
394−
395−
396−instance
397− ( x ~ Field Expr (label ': labels) necessity a
398− ) => K1Table _label Expr 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x
399− where
400− fromK1Columns (HIdentity (DB a)) = a
401− toK1Columns = HIdentity . DB
402− {-# INLINABLE fromK1Columns #-}
403− {-# INLINABLE toK1Columns #-}
404−
405−
406−instance
407− ( x ~ Field Insert '[] necessity a
408− , KnownNecessity necessity
409− ) => K1Table label Insert 'True (Shape1 'Column ('Spec '[] necessity a)) x
410− where
411− fromK1Columns (HIdentity insert) = case insert of
412− RequiredInsert a -> a
413− OptionalInsert ma -> ma
414− toK1Columns a = HIdentity $ case necessitySing @necessity of
415− SRequired -> RequiredInsert a
416− SOptional -> OptionalInsert a
417− {-# INLINABLE fromK1Columns #-}
418− {-# INLINABLE toK1Columns #-}
419−
420−
421−instance
422− ( x ~ Field Insert (label ': labels) necessity a
423− , KnownNecessity necessity
424− ) => K1Table _label Insert 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x
425− where
426− fromK1Columns (HIdentity insert) = case insert of
427− RequiredInsert a -> a
428− OptionalInsert ma -> ma
429− toK1Columns a = HIdentity $ case necessitySing @necessity of
430− SRequired -> RequiredInsert a
431− SOptional -> OptionalInsert a
432− {-# INLINABLE fromK1Columns #-}
433− {-# INLINABLE toK1Columns #-}
434−
435−
436−instance
437− ( x ~ Field Identity '[] necessity a
438− ) => K1Table label Identity 'True (Shape1 'Column ('Spec '[] necessity a)) x
439− where
440− fromK1Columns (HIdentity (Result a)) = a
441− toK1Columns = HIdentity . Result
442− {-# INLINABLE fromK1Columns #-}
443− {-# INLINABLE toK1Columns #-}
444−
445−
446−instance
447− ( x ~ Field Identity (label ': labels) necessity a
448− ) => K1Table _label Identity 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x
449− where
450− fromK1Columns (HIdentity (Result a)) = a
451− toK1Columns = HIdentity . Result
452− {-# INLINABLE fromK1Columns #-}
453− {-# INLINABLE toK1Columns #-}
454−
455−
456−instance
457− ( x ~ Field Name '[] necessity a
458− ) => K1Table _label Name 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x
459− where
460− fromK1Columns (HIdentity (NameCol a)) = Name a
461− toK1Columns (Name a) = HIdentity (NameCol a)
462− {-# INLINABLE fromK1Columns #-}
463− {-# INLINABLE toK1Columns #-}
464−
465−
466−instance
467− ( x ~ Field Name (label ': labels) necessity a
468− ) => K1Table label Name 'True (Shape1 'Column ('Spec '[] necessity a)) x
469− where
470− fromK1Columns = Name . (\(NameCol a) -> a) . unlabeler . unHIdentity
471− toK1Columns = HIdentity . labeler . NameCol . (\(Name a) -> a)
472− {-# INLINABLE fromK1Columns #-}
473− {-# INLINABLE toK1Columns #-}
474−
475−
476−instance
477− ( HTable (K1Columns "Left" structure1)
478− , HTable (K1Columns "Right" structure2)
479− , K1Table "Left" Aggregate (IsStructure structure1) structure1 a
480− , K1Table "Right" Aggregate (IsStructure structure2) structure2 b
481− , e ~ EitherTable a b
482− , KnownSymbol label
483− ) => K1Table label Aggregate 'True (Shape2 'Either structure1 structure2) e
484− where
485− fromK1Columns =
486− fromColumns2
487− (fromK1Columns @"Left" @_ @_ @structure1)
488− (fromK1Columns @"Right" @_ @_ @structure2) .
489− hunlabel unlabeler
490− toK1Columns =
491− hlabel labeler .
492− toColumns2
493− (toK1Columns @"Left" @_ @_ @structure1)
494− (toK1Columns @"Right" @_ @_ @structure2)
495− {-# INLINABLE fromK1Columns #-}
496− {-# INLINABLE toK1Columns #-}
497−
498−
499−instance
500− ( HTable (K1Columns "Left" structure1)
501− , HTable (K1Columns "Right" structure2)
502− , K1Table "Left" Expr (IsStructure structure1) structure1 a
503− , K1Table "Right" Expr (IsStructure structure2) structure2 b
504− , e ~ EitherTable a b
505− , KnownSymbol label
506− ) => K1Table label Expr 'True (Shape2 'Either structure1 structure2) e
507− where
508− fromK1Columns =
509− fromColumns2
510− (fromK1Columns @"Left" @_ @_ @structure1)
511− (fromK1Columns @"Right" @_ @_ @structure2) .
512− hunlabel unlabeler
513− toK1Columns =
514− hlabel labeler .
515− toColumns2
516− (toK1Columns @"Left" @_ @_ @structure1)
517− (toK1Columns @"Right" @_ @_ @structure2)
518− {-# INLINABLE fromK1Columns #-}
519− {-# INLINABLE toK1Columns #-}
520−
521−
522−instance
523− ( HTable (K1Columns "Left" structure1)
524− , HTable (K1Columns "Right" structure2)
525− , K1Table "Left" Insert (IsStructure structure1) structure1 a
526− , K1Table "Right" Insert (IsStructure structure2) structure2 b
527− , e ~ EitherTable a b
528− , KnownSymbol label
529− ) => K1Table label Insert 'True (Shape2 'Either structure1 structure2) e
530− where
531− fromK1Columns =
532− fromColumns2
533− (fromK1Columns @"Left" @_ @_ @structure1)
534− (fromK1Columns @"Right" @_ @_ @structure2) .
535− hunlabel unlabeler
536− toK1Columns =
537− hlabel labeler .
538− toColumns2
539− (toK1Columns @"Left" @_ @_ @structure1)
540− (toK1Columns @"Right" @_ @_ @structure2)
541− {-# INLINABLE fromK1Columns #-}
542− {-# INLINABLE toK1Columns #-}
543−
544−
545−instance
546− ( HTable (K1Columns "Left" structure1)
547− , HTable (K1Columns "Right" structure2)
548− , K1Table "Left" Identity (IsStructure structure1) structure1 a
549− , K1Table "Right" Identity (IsStructure structure2) structure2 b
550− , e ~ Either a b
551− , KnownSymbol label
552− ) => K1Table label Identity 'True (Shape2 'Either structure1 structure2) e
553− where
554− fromK1Columns
555− = bimap
556− (fromK1Columns @"Left" @_ @_ @structure1)
557− (fromK1Columns @"Right" @_ @_ @structure2)
558− . fromHEitherTable
559− . hunlabel unlabeler
560− toK1Columns
561− = hlabel labeler
562− . toHEitherTable
563− . bimap
564− (toK1Columns @"Left" @_ @_ @structure1)
565− (toK1Columns @"Right" @_ @_ @structure2)
566− {-# INLINABLE fromK1Columns #-}
567− {-# INLINABLE toK1Columns #-}
568−
569−
570−instance
571− ( HTable (K1Columns "Left" structure1)
572− , HTable (K1Columns "Right" structure2)
573− , K1Table "Left" Name (IsStructure structure1) structure1 a
574− , K1Table "Right" Name (IsStructure structure2) structure2 b
575− , e ~ EitherTable a b
576− , KnownSymbol label
577− ) => K1Table label Name 'True (Shape2 'Either structure1 structure2) e
578− where
579− fromK1Columns =
580− fromColumns2
581− (fromK1Columns @"Left" @_ @_ @structure1)
582− (fromK1Columns @"Right" @_ @_ @structure2) .
583− hunlabel unlabeler
584− toK1Columns =
585− hlabel labeler .
586− toColumns2
587− (toK1Columns @"Left" @_ @_ @structure1)
588− (toK1Columns @"Right" @_ @_ @structure2)
589− {-# INLINABLE fromK1Columns #-}
590− {-# INLINABLE toK1Columns #-}
591−
592−
593−instance
594− ( Table Aggregate a
595− , K1Columns label structure ~ HLabel label (Columns a)
596− , as ~ ListTable a
597− , KnownSymbol label
598− ) => K1Table label Aggregate 'True (Shape1 'List structure) as
599− where
600− fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
601− toK1Columns = hrelabel (hlabel hlabeler) . toColumns
602− {-# INLINABLE fromK1Columns #-}
603− {-# INLINABLE toK1Columns #-}
604−
605−
606−instance
607− ( Table Expr a
608− , K1Columns label structure ~ HLabel label (Columns a)
609− , as ~ ListTable a
610− , KnownSymbol label
611− ) => K1Table label Expr 'True (Shape1 'List structure) as
612− where
613− fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
614− toK1Columns = hrelabel (hlabel hlabeler) . toColumns
615− {-# INLINABLE fromK1Columns #-}
616− {-# INLINABLE toK1Columns #-}
617−
618−
619−instance
620− ( Table Insert a
621− , K1Columns label structure ~ HLabel label (Columns a)
622− , as ~ ListTable a
623− , KnownSymbol label
624− ) => K1Table label Insert 'True (Shape1 'List structure) as
625− where
626− fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
627− toK1Columns = hrelabel (hlabel hlabeler) . toColumns
628− {-# INLINABLE fromK1Columns #-}
629− {-# INLINABLE toK1Columns #-}
630−
631−
632−instance
633− ( K1Table label Identity (IsStructure structure) structure a
634− , HTable (K1Columns label structure)
635− , as ~ [a]
636− ) => K1Table label Identity 'True (Shape1 'List structure) as
637− where
638− fromK1Columns = fmap (fromK1Columns @label @_ @_ @structure) . fromHListTable
639− toK1Columns = toHListTable . fmap (toK1Columns @label @_ @_ @structure)
640− {-# INLINABLE fromK1Columns #-}
641− {-# INLINABLE toK1Columns #-}
642−
643−
644−instance
645− ( Table Name a
646− , K1Columns label structure ~ HLabel label (Columns a)
647− , as ~ ListTable a
648− , KnownSymbol label
649− ) => K1Table label Name 'True (Shape1 'List structure) as
650− where
651− fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
652− toK1Columns = hrelabel (hlabel hlabeler) . toColumns
653− {-# INLINABLE fromK1Columns #-}
654− {-# INLINABLE toK1Columns #-}
655−
656−
657−instance
658− ( HTable (K1Columns "Just" structure)
659− , K1Table "Just" Aggregate (IsStructure structure) structure a
660− , ma ~ MaybeTable a
661− , KnownSymbol label
662− ) => K1Table label Aggregate 'True (Shape1 'Maybe structure) ma
663− where
664− fromK1Columns =
665− fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .
666− hunlabel unlabeler
667− toK1Columns =
668− hlabel labeler .
669− toColumns1 (toK1Columns @"Just" @_ @_ @structure)
670− {-# INLINABLE fromK1Columns #-}
671− {-# INLINABLE toK1Columns #-}
672−
673−
674−instance
675− ( HTable (K1Columns "Just" structure)
676− , K1Table "Just" Expr (IsStructure structure) structure a
677− , ma ~ MaybeTable a
678− , KnownSymbol label
679− ) => K1Table label Expr 'True (Shape1 'Maybe structure) ma
680− where
681− fromK1Columns =
682− fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .
683− hunlabel unlabeler
684− toK1Columns =
685− hlabel labeler .
686− toColumns1 (toK1Columns @"Just" @_ @_ @structure)
687− {-# INLINABLE fromK1Columns #-}
688− {-# INLINABLE toK1Columns #-}
689−
690−
691−instance
692− ( HTable (K1Columns "Just" structure)
693− , K1Table "Just" Insert (IsStructure structure) structure a
694− , ma ~ MaybeTable a
695− , KnownSymbol label
696− ) => K1Table label Insert 'True (Shape1 'Maybe structure) ma
697− where
698− fromK1Columns =
699− fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .
700− hunlabel unlabeler
701− toK1Columns =
702− hlabel labeler .
703− toColumns1 (toK1Columns @"Just" @_ @_ @structure)
704− {-# INLINABLE fromK1Columns #-}
705− {-# INLINABLE toK1Columns #-}
706−
707−
708−instance
709− ( HTable (K1Columns "Just" structure)
710− , K1Table "Just" Identity (IsStructure structure) structure a
711− , ma ~ Maybe a
712− , KnownSymbol label
713− ) => K1Table label Identity 'True (Shape1 'Maybe structure) ma
714− where
715− fromK1Columns
716− = fmap (fromK1Columns @"Just" @_ @_ @structure)
717− . fromHMaybeTable
718− . hunlabel unlabeler
719− toK1Columns
720− = hlabel labeler
721− . toHMaybeTable
722− . fmap (toK1Columns @"Just" @_ @_ @structure)
723− {-# INLINABLE fromK1Columns #-}
724− {-# INLINABLE toK1Columns #-}
725−
726−
727−instance
728− ( HTable (K1Columns "Just" structure)
729− , K1Table "Just" Name (IsStructure structure) structure a
730− , ma ~ MaybeTable a
731− , KnownSymbol label
732− ) => K1Table label Name 'True (Shape1 'Maybe structure) ma
733− where
734− fromK1Columns =
735− fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) .
736− hunlabel unlabeler
737− toK1Columns =
738− hlabel labeler .
739− toColumns1 (toK1Columns @"Just" @_ @_ @structure)
740− {-# INLINABLE fromK1Columns #-}
741− {-# INLINABLE toK1Columns #-}
742−
743−
744−instance
745− ( Table Aggregate a
746− , K1Columns label structure ~ HLabel label (Columns a)
747− , as ~ NonEmptyTable a
748− , KnownSymbol label
749− ) => K1Table label Aggregate 'True (Shape1 'NonEmpty structure) as
750− where
751− fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
752− toK1Columns = hrelabel (hlabel hlabeler) . toColumns
753− {-# INLINABLE fromK1Columns #-}
754− {-# INLINABLE toK1Columns #-}
755−
756−
757−instance
758− ( Table Expr a
759− , K1Columns label structure ~ HLabel label (Columns a)
760− , as ~ NonEmptyTable a
761− , KnownSymbol label
762− ) => K1Table label Expr 'True (Shape1 'NonEmpty structure) as
763− where
764− fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
765− toK1Columns = hrelabel (hlabel hlabeler) . toColumns
766− {-# INLINABLE fromK1Columns #-}
767− {-# INLINABLE toK1Columns #-}
768−
769−
770−instance
771− ( Table Insert a
772− , K1Columns label structure ~ HLabel label (Columns a)
773− , as ~ NonEmptyTable a
774− , KnownSymbol label
775− ) => K1Table label Insert 'True (Shape1 'NonEmpty structure) as
776− where
777− fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
778− toK1Columns = hrelabel (hlabel hlabeler) . toColumns
779− {-# INLINABLE fromK1Columns #-}
780− {-# INLINABLE toK1Columns #-}
781−
782−
783−instance
784− ( K1Table label Identity (IsStructure structure) structure a
785− , HTable (K1Columns label structure)
786− , as ~ NonEmpty a
787− ) => K1Table label Identity 'True (Shape1 'NonEmpty structure) as
788− where
789− fromK1Columns = fmap (fromK1Columns @label @_ @_ @structure) . fromHNonEmptyTable
790− toK1Columns = toHNonEmptyTable . fmap (toK1Columns @label @_ @_ @structure)
791− {-# INLINABLE fromK1Columns #-}
792− {-# INLINABLE toK1Columns #-}
793−
794−
795−instance
796− ( Table Name a
797− , K1Columns label structure ~ HLabel label (Columns a)
798− , as ~ NonEmptyTable a
799− , KnownSymbol label
800− ) => K1Table label Name 'True (Shape1 'NonEmpty structure) as
801− where
802− fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler)
803− toK1Columns = hrelabel (hlabel hlabeler) . toColumns
804− {-# INLINABLE fromK1Columns #-}
805− {-# INLINABLE toK1Columns #-}
806−
807−
808−instance
809− ( HTable (K1Columns "Here" structure1)
810− , HTable (K1Columns "There" structure2)
811− , K1Table "Here" Aggregate (IsStructure structure1) structure1 a
812− , K1Table "There" Aggregate (IsStructure structure2) structure2 b
813− , e ~ TheseTable a b
814− , KnownSymbol label
815− ) => K1Table label Aggregate 'True (Shape2 'These structure1 structure2) e
816− where
817− fromK1Columns =
818− fromColumns2
819− (fromK1Columns @"Here" @_ @_ @structure1)
820− (fromK1Columns @"There" @_ @_ @structure2) .
821− hunlabel unlabeler
822− toK1Columns =
823− hlabel labeler .
824− toColumns2
825− (toK1Columns @"Here" @_ @_ @structure1)
826− (toK1Columns @"There" @_ @_ @structure2)
827− {-# INLINABLE fromK1Columns #-}
828− {-# INLINABLE toK1Columns #-}
829−
830−
831−instance
832− ( HTable (K1Columns "Here" structure1)
833− , HTable (K1Columns "There" structure2)
834− , K1Table "Here" Expr (IsStructure structure1) structure1 a
835− , K1Table "There" Expr (IsStructure structure2) structure2 b
836− , e ~ TheseTable a b
837− , KnownSymbol label
838− ) => K1Table label Expr 'True (Shape2 'These structure1 structure2) e
839− where
840− fromK1Columns =
841− fromColumns2
842− (fromK1Columns @"Here" @_ @_ @structure1)
843− (fromK1Columns @"There" @_ @_ @structure2) .
844− hunlabel unlabeler
845− toK1Columns =
846− hlabel labeler .
847− toColumns2
848− (toK1Columns @"Here" @_ @_ @structure1)
849− (toK1Columns @"There" @_ @_ @structure2)
850− {-# INLINABLE fromK1Columns #-}
851− {-# INLINABLE toK1Columns #-}
852−
853−
854−instance
855− ( HTable (K1Columns "Here" structure1)
856− , HTable (K1Columns "There" structure2)
857− , K1Table "Here" Insert (IsStructure structure1) structure1 a
858− , K1Table "There" Insert (IsStructure structure2) structure2 b
859− , e ~ TheseTable a b
860− , KnownSymbol label
861− ) => K1Table label Insert 'True (Shape2 'These structure1 structure2) e
862− where
863− fromK1Columns =
864− fromColumns2
865− (fromK1Columns @"Here" @_ @_ @structure1)
866− (fromK1Columns @"There" @_ @_ @structure2) .
867− hunlabel unlabeler
868− toK1Columns =
869− hlabel labeler .
870− toColumns2
871− (toK1Columns @"Here" @_ @_ @structure1)
872− (toK1Columns @"There" @_ @_ @structure2)
873− {-# INLINABLE fromK1Columns #-}
874− {-# INLINABLE toK1Columns #-}
875−
876−
877−instance
878− ( HTable (K1Columns "Here" structure1)
879− , HTable (K1Columns "There" structure2)
880− , K1Table "Here" Identity (IsStructure structure1) structure1 a
881− , K1Table "There" Identity (IsStructure structure2) structure2 b
882− , e ~ These a b
883− , KnownSymbol label
884− ) => K1Table label Identity 'True (Shape2 'These structure1 structure2) e
885− where
886− fromK1Columns
887− = bimap
888− (fromK1Columns @"Here" @_ @_ @structure1)
889− (fromK1Columns @"There" @_ @_ @structure2)
890− . fromHTheseTable
891− . hunlabel unlabeler
892− toK1Columns
893− = hlabel labeler
894− . toHTheseTable
895− . bimap
896− (toK1Columns @"Here" @_ @_ @structure1)
897− (toK1Columns @"There" @_ @_ @structure2)
898− {-# INLINABLE fromK1Columns #-}
899− {-# INLINABLE toK1Columns #-}
900−
901−
902−instance
903− ( HTable (K1Columns "Here" structure1)
904− , HTable (K1Columns "There" structure2)
905− , K1Table "Here" Name (IsStructure structure1) structure1 a
906− , K1Table "There" Name (IsStructure structure2) structure2 b
907− , e ~ TheseTable a b
908− , KnownSymbol label
909− ) => K1Table label Name 'True (Shape2 'These structure1 structure2) e
910− where
911− fromK1Columns =
912− fromColumns2
913− (fromK1Columns @"Here" @_ @_ @structure1)
914− (fromK1Columns @"There" @_ @_ @structure2) .
915− hunlabel unlabeler
916− toK1Columns =
917− hlabel labeler .
918− toColumns2
919− (toK1Columns @"Here" @_ @_ @structure1)
920− (toK1Columns @"There" @_ @_ @structure2)
921− {-# INLINABLE fromK1Columns #-}
922− {-# INLINABLE toK1Columns #-}
923−
924−
925−instance
926− ( K1Table "fst" context (IsStructure structure1) structure1 a1
927− , K1Table "snd" context (IsStructure structure2) structure2 a2
928− , HTable (K1Columns "fst" structure1)
929− , HTable (K1Columns "snd" structure2)
930− , Labelable context
931− , a ~ (a1, a2)
932− , KnownSymbol label
933− ) => K1Table label context 'True (structure1, structure2) a
934− where
935− fromK1Columns (hunlabel unlabeler -> (HPair a b)) =
936− ( fromK1Columns @"fst" @_ @_ @structure1 a
937− , fromK1Columns @"snd" @_ @_ @structure2 b
938− )
939− toK1Columns (a, b) = hlabel labeler $ HPair
940− { hfst = toK1Columns @"fst" @_ @_ @structure1 a
941− , hsnd = toK1Columns @"snd" @_ @_ @structure2 b
942− }
943− {-# INLINABLE fromK1Columns #-}
944− {-# INLINABLE toK1Columns #-}
945−
946−
947−instance
948− ( K1Table "fst" context (IsStructure structure1) structure1 a1
949− , K1Table "snd" context (IsStructure structure2) structure2 a2
950− , K1Table "trd" context (IsStructure structure3) structure3 a3
951− , HTable (K1Columns "fst" structure1)
952− , HTable (K1Columns "snd" structure2)
953− , HTable (K1Columns "trd" structure3)
954− , Labelable context
955− , a ~ (a1, a2, a3)
956− , KnownSymbol label
957− ) => K1Table label context 'True (structure1, structure2, structure3) a
958− where
959− fromK1Columns (hunlabel unlabeler -> (HTrio a b c)) =
960− ( fromK1Columns @"fst" @_ @_ @structure1 a
961− , fromK1Columns @"snd" @_ @_ @structure2 b
962− , fromK1Columns @"trd" @_ @_ @structure3 c
963− )
964− toK1Columns (a, b, c) = hlabel labeler $ HTrio
965− { hfst = toK1Columns @"fst" @_ @_ @structure1 a
966− , hsnd = toK1Columns @"snd" @_ @_ @structure2 b
967− , htrd = toK1Columns @"trd" @_ @_ @structure3 c
968− }
969− {-# INLINABLE fromK1Columns #-}
970− {-# INLINABLE toK1Columns #-}
971−
972−
973−instance
974− ( K1Table "fst" context (IsStructure structure1) structure1 a1
975− , K1Table "snd" context (IsStructure structure2) structure2 a2
976− , K1Table "trd" context (IsStructure structure3) structure3 a3
977− , K1Table "frt" context (IsStructure structure3) structure4 a4
978− , HTable (K1Columns "fst" structure1)
979− , HTable (K1Columns "snd" structure2)
980− , HTable (K1Columns "trd" structure3)
981− , HTable (K1Columns "frt" structure4)
982− , Labelable context
983− , a ~ (a1, a2, a3, a4)
984− , KnownSymbol label
985− ) => K1Table label context 'True (structure1, structure2, structure3, structure4) a
986− where
987− fromK1Columns (hunlabel unlabeler -> (HQuartet a b c d)) =
988− ( fromK1Columns @"fst" @_ @_ @structure1 a
989− , fromK1Columns @"snd" @_ @_ @structure2 b
990− , fromK1Columns @"trd" @_ @_ @structure3 c
991− , fromK1Columns @"frt" @_ @_ @structure4 d
992− )
993− toK1Columns (a, b, c, d) = hlabel labeler $ HQuartet
994− { hfst = toK1Columns @"fst" @_ @_ @structure1 a
995− , hsnd = toK1Columns @"snd" @_ @_ @structure2 b
996− , htrd = toK1Columns @"trd" @_ @_ @structure3 c
997− , hfrt = toK1Columns @"frt" @_ @_ @structure4 d
998− }
999− {-# INLINABLE fromK1Columns #-}
1000− {-# INLINABLE toK1Columns #-}
1001−
1002−
1003−instance
1004− ( K1Table "fst" context (IsStructure structure1) structure1 a1
1005− , K1Table "snd" context (IsStructure structure2) structure2 a2
1006− , K1Table "trd" context (IsStructure structure3) structure3 a3
1007− , K1Table "frt" context (IsStructure structure3) structure4 a4
1008− , K1Table "fft" context (IsStructure structure3) structure5 a5
1009− , HTable (K1Columns "fst" structure1)
1010− , HTable (K1Columns "snd" structure2)
1011− , HTable (K1Columns "trd" structure3)
1012− , HTable (K1Columns "frt" structure4)
1013− , HTable (K1Columns "fft" structure5)
1014− , Labelable context
1015− , a ~ (a1, a2, a3, a4, a5)
1016− , KnownSymbol label
1017− ) => K1Table label context 'True (structure1, structure2, structure3, structure4, structure5) a
1018− where
1019− fromK1Columns (hunlabel unlabeler -> (HQuintet a b c d e)) =
1020− ( fromK1Columns @"fst" @_ @_ @structure1 a
1021− , fromK1Columns @"snd" @_ @_ @structure2 b
1022− , fromK1Columns @"trd" @_ @_ @structure3 c
1023− , fromK1Columns @"frt" @_ @_ @structure4 d
1024− , fromK1Columns @"fft" @_ @_ @structure5 e
1025− )
1026− toK1Columns (a, b, c, d, e) = hlabel labeler $ HQuintet
1027− { hfst = toK1Columns @"fst" @_ @_ @structure1 a
1028− , hsnd = toK1Columns @"snd" @_ @_ @structure2 b
1029− , htrd = toK1Columns @"trd" @_ @_ @structure3 c
1030− , hfrt = toK1Columns @"frt" @_ @_ @structure4 d
1031− , hfft = toK1Columns @"fft" @_ @_ @structure5 e
1032− }
1033− {-# INLINABLE fromK1Columns #-}
1034− {-# INLINABLE toK1Columns #-}
1035−
1036−
1037−instance
1038− ( IsStructure structure ~ 'False
1039− , K1Columns label structure ~ HLabel label (Columns structure)
1040− , Columns structure ~ Columns a
1041− , Labelable context
1042− , Table context a
1043− , KnownSymbol label
1044− ) => K1Table label context 'False structure a
1045− where
1046− fromK1Columns = fromColumns . hunlabel unlabeler
1047− toK1Columns = hlabel labeler . toColumns
1048− {-# INLINABLE fromK1Columns #-}
1049− {-# INLINABLE toK1Columns #-}
src/Rel8/Schema/Generic/Test.hsdeleted−79
@@ -1,79 +0,0 @@
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+68−36
@@ -16,11 +16,12 @@
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− , htabulateA
19+ , hfoldMap, hmap, htabulateA, htraverseP, htraversePWithField
20 )
20 )
21where
21where
22
22
23-- base
23-- base
24+import Data.Functor.Const ( Const( Const ), getConst )
24import Data.Kind ( Constraint, Type )
25import Data.Kind ( Constraint, Type )
25import Data.Functor.Compose ( Compose( Compose ), getCompose )
26import Data.Functor.Compose ( Compose( Compose ), getCompose )
26import Data.Proxy ( Proxy )
27import Data.Proxy ( Proxy )
@@ -32,16 +33,21 @@ import GHC.Generics
32 )
33 )
33import Prelude
34import Prelude
34
35
36+-- profunctors
37+import Data.Profunctor ( rmap, Profunctor (lmap) )
38+
39+-- product-profunctors
40+import Data.Profunctor.Product ( ProductProfunctor ((****)) )
41+
35-- rel8
42-- rel8
36import Rel8.Schema.Dict ( Dict )
43import Rel8.Schema.Dict ( Dict )
37−import Rel8.Schema.Spec ( Spec, SSpec )
44+import Rel8.Schema.Spec ( Spec )
38−import Rel8.Schema.HTable.Pair ( HPair( HPair ) )
45+import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
39import qualified Rel8.Schema.Kind as K
46import qualified Rel8.Schema.Kind as K
40
47
41-- semigroupoids
48-- semigroupoids
42import Data.Functor.Apply ( Apply, (<.>) )
49import Data.Functor.Apply ( Apply, (<.>) )
43
50
44−
45-- | A @HTable@ is a functor-indexed/higher-kinded data type that is
51-- | A @HTable@ is a functor-indexed/higher-kinded data type that is
46-- representable ('htabulate'/'hfield'), constrainable ('hdicts'), and
52-- representable ('htabulate'/'hfield'), constrainable ('hdicts'), and
47-- specified ('hspecs').
53-- specified ('hspecs').
@@ -50,14 +56,14 @@ import Data.Functor.Apply ( Apply, (<.>) )
50-- instances yourself or specify this constraint.
56-- instances yourself or specify this constraint.
51type HTable :: K.HTable -> Constraint
57type HTable :: K.HTable -> Constraint
52class HTable t where
58class HTable t where
53− type HField t = (field :: Spec -> Type) | field -> t
59+ type HField t = (field :: Type -> Type) | field -> t
54− type HConstrainTable t (c :: Spec -> Constraint) :: Constraint
60+ type HConstrainTable t (c :: Type -> Constraint) :: Constraint
55
61
56− hfield :: t context -> HField t spec -> context spec
62+ hfield :: t context -> HField t a -> context a
57− htabulate :: (forall spec. HField t spec -> context spec) -> t context
63+ htabulate :: (forall a. HField t a -> context a) -> t context
58− htraverse :: Apply m => (forall spec. f spec -> m (g spec)) -> t f -> m (t g)
64+ htraverse :: Apply m => (forall a. f a -> m (g a)) -> t f -> m (t g)
59 hdicts :: HConstrainTable t c => t (Dict c)
65 hdicts :: HConstrainTable t c => t (Dict c)
60− hspecs :: t SSpec
66+ hspecs :: t Spec
61
67
62 type HField t = GHField t
68 type HField t = GHField t
63 type HConstrainTable t c = HConstrainTable (GHColumns (Rep (t Proxy))) c
69 type HConstrainTable t c = HConstrainTable (GHColumns (Rep (t Proxy))) c
@@ -68,7 +74,7 @@ class HTable t where
68 , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))
74 , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))
69 , GHTable context (Rep (t context))
75 , GHTable context (Rep (t context))
70 )
76 )
71− => t context -> HField t spec -> context spec
77+ => t context -> HField t a -> context a
72 hfield table (GHField field) = hfield (toGHColumns (from table)) field
78 hfield table (GHField field) = hfield (toGHColumns (from table)) field
73
79
74 default htabulate ::
80 default htabulate ::
@@ -77,7 +83,7 @@ class HTable t where
77 , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))
83 , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))
78 , GHTable context (Rep (t context))
84 , GHTable context (Rep (t context))
79 )
85 )
80− => (forall spec. HField t spec -> context spec) -> t context
86+ => (forall a. HField t a -> context a) -> t context
81 htabulate f = to $ fromGHColumns $ htabulate (f . GHField)
87 htabulate f = to $ fromGHColumns $ htabulate (f . GHField)
82
88
83 default htraverse
89 default htraverse
@@ -87,7 +93,7 @@ class HTable t where
87 , Generic (t g), GHTable g (Rep (t g))
93 , Generic (t g), GHTable g (Rep (t g))
88 , GHColumns (Rep (t f)) ~ GHColumns (Rep (t g))
94 , GHColumns (Rep (t f)) ~ GHColumns (Rep (t g))
89 )
95 )
90− => (forall spec. f spec -> m (g spec)) -> t f -> m (t g)
96+ => (forall a. f a -> m (g a)) -> t f -> m (t g)
91 htraverse f = fmap (to . fromGHColumns) . htraverse f . toGHColumns . from
97 htraverse f = fmap (to . fromGHColumns) . htraverse f . toGHColumns . from
92
98
93 default hdicts
99 default hdicts
@@ -101,10 +107,10 @@ class HTable t where
101 hdicts = to $ fromGHColumns (hdicts @(GHColumns (Rep (t Proxy))) @c)
107 hdicts = to $ fromGHColumns (hdicts @(GHColumns (Rep (t Proxy))) @c)
102
108
103 default hspecs ::
109 default hspecs ::
104− ( Generic (t SSpec)
110+ ( Generic (t Spec)
105− , GHTable SSpec (Rep (t SSpec))
111+ , GHTable Spec (Rep (t Spec))
106 )
112 )
107− => t SSpec
113+ => t Spec
108 hspecs = to $ fromGHColumns hspecs
114 hspecs = to $ fromGHColumns hspecs
109
115
110 {-# INLINABLE hfield #-}
116 {-# INLINABLE hfield #-}
@@ -114,17 +120,43 @@ class HTable t where
114 {-# INLINABLE hspecs #-}
120 {-# INLINABLE hspecs #-}
115
121
116
122
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+
117htabulateA :: (HTable t, Apply m)
133htabulateA :: (HTable t, Apply m)
118− => (forall spec. HField t spec -> m (context spec)) -> m (t context)
134+ => (forall a. HField t a -> m (context a)) -> m (t context)
119htabulateA f = htraverse getCompose $ htabulate $ Compose . f
135htabulateA f = htraverse getCompose $ htabulate $ Compose . f
120{-# INLINABLE htabulateA #-}
136{-# INLINABLE htabulateA #-}
121
137
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)
122
154
123−type GHField :: K.HTable -> Spec -> Type
155+type GHField :: K.HTable -> Type -> Type
124−newtype GHField t spec = GHField (HField (GHColumns (Rep (t Proxy))) spec)
156+newtype GHField t a = GHField (HField (GHColumns (Rep (t Proxy))) a)
125
157
126
158
127−type GHTable :: K.HContext -> (Type -> Type) -> Constraint
159+type GHTable :: K.Context -> (Type -> Type) -> Constraint
128class HTable (GHColumns rep) => GHTable context rep | rep -> context where
160class HTable (GHColumns rep) => GHTable context rep | rep -> context where
129 type GHColumns rep :: K.HTable
161 type GHColumns rep :: K.HTable
130 toGHColumns :: rep x -> GHColumns rep context
162 toGHColumns :: rep x -> GHColumns rep context
@@ -144,30 +176,30 @@ instance HTable table => GHTable context (K1 i (table context)) where
144
176
145
177
146instance (GHTable context a, GHTable context b) => GHTable context (a :*: b) where
178instance (GHTable context a, GHTable context b) => GHTable context (a :*: b) where
147− type GHColumns (a :*: b) = HPair (GHColumns a) (GHColumns b)
179+ type GHColumns (a :*: b) = HProduct (GHColumns a) (GHColumns b)
148− toGHColumns (a :*: b) = HPair (toGHColumns a) (toGHColumns b)
180+ toGHColumns (a :*: b) = HProduct (toGHColumns a) (toGHColumns b)
149− fromGHColumns (HPair a b) = fromGHColumns a :*: fromGHColumns b
181+ fromGHColumns (HProduct a b) = fromGHColumns a :*: fromGHColumns b
150
182
151
183
152−-- | A HField type for indexing into HPair.
184+-- | A HField type for indexing into HProduct.
153−type HPairField :: K.HTable -> K.HTable -> Spec -> Type
185+type HProductField :: K.HTable -> K.HTable -> Type -> Type
154−data HPairField x y spec
186+data HProductField x y a
155− = HFst (HField x spec)
187+ = HFst (HField x a)
156− | HSnd (HField y spec)
188+ | HSnd (HField y a)
157
189
158
190
159−instance (HTable x, HTable y) => HTable (HPair x y) where
191+instance (HTable x, HTable y) => HTable (HProduct x y) where
160− type HConstrainTable (HPair x y) c = (HConstrainTable x c, HConstrainTable y c)
192+ type HConstrainTable (HProduct x y) c = (HConstrainTable x c, HConstrainTable y c)
161− type HField (HPair x y) = HPairField x y
193+ type HField (HProduct x y) = HProductField x y
162
194
163− hfield (HPair l r) = \case
195+ hfield (HProduct l r) = \case
164 HFst i -> hfield l i
196 HFst i -> hfield l i
165 HSnd i -> hfield r i
197 HSnd i -> hfield r i
166
198
167− htabulate f = HPair (htabulate (f . HFst)) (htabulate (f . HSnd))
199+ htabulate f = HProduct (htabulate (f . HFst)) (htabulate (f . HSnd))
168− htraverse f (HPair x y) = HPair <$> htraverse f x <.> htraverse f y
200+ htraverse f (HProduct x y) = HProduct <$> htraverse f x <.> htraverse f y
169− hdicts = HPair hdicts hdicts
201+ hdicts = HProduct hdicts hdicts
170− hspecs = HPair hspecs hspecs
202+ hspecs = HProduct hspecs hspecs
171
203
172 {-# INLINABLE hfield #-}
204 {-# INLINABLE hfield #-}
173 {-# INLINABLE htabulate #-}
205 {-# INLINABLE htabulate #-}
src/Rel8/Schema/HTable/Either.hs+5−17
@@ -2,43 +2,31 @@
2{-# language DeriveAnyClass #-}
2{-# language DeriveAnyClass #-}
3{-# language DeriveGeneric #-}
3{-# language DeriveGeneric #-}
4{-# language DerivingStrategies #-}
4{-# language DerivingStrategies #-}
5−{-# language FlexibleInstances #-}
6{-# language StandaloneKindSignatures #-}
5{-# language StandaloneKindSignatures #-}
7−{-# language UndecidableInstances #-}
8−{-# language UndecidableSuperClasses #-}
9
6
10module Rel8.Schema.HTable.Either
7module Rel8.Schema.HTable.Either
11 ( HEitherTable(..)
8 ( HEitherTable(..)
12− , HEitherNullifiable
13 )
9 )
14where
10where
15
11
16-- base
12-- base
17−import Data.Kind ( Constraint )
18import GHC.Generics ( Generic )
13import GHC.Generics ( Generic )
19import Prelude ()
14import Prelude ()
20
15
21-- rel8
16-- rel8
22−import Rel8.Kind.Necessity ( Necessity( Required ) )
23−import Rel8.Schema.Context.Nullify ( HNullifiable, HConstrainTag )
24import Rel8.Schema.HTable ( HTable )
17import Rel8.Schema.HTable ( HTable )
25−import Rel8.Schema.HTable.Identity ( HIdentity(..) )
18+import Rel8.Schema.HTable.Identity ( HIdentity )
19+import Rel8.Schema.HTable.Label ( HLabel )
26import Rel8.Schema.HTable.Nullify ( HNullify )
20import Rel8.Schema.HTable.Nullify ( HNullify )
27import qualified Rel8.Schema.Kind as K
21import qualified Rel8.Schema.Kind as K
28−import Rel8.Schema.Spec ( Spec( Spec ) )
29import Rel8.Type.Tag ( EitherTag )
22import Rel8.Type.Tag ( EitherTag )
30
23
31
24
32type HEitherTable :: K.HTable -> K.HTable -> K.HTable
25type HEitherTable :: K.HTable -> K.HTable -> K.HTable
33data HEitherTable left right context = HEitherTable
26data HEitherTable left right context = HEitherTable
34− { htag :: HIdentity ('Spec '["isRight"] 'Required EitherTag) context
27+ { htag :: HLabel "isRight" (HIdentity EitherTag) context
35− , hleft :: HNullify left context
28+ , hleft :: HLabel "Left" (HNullify left) context
36− , hright :: HNullify right context
29+ , hright :: HLabel "Right" (HNullify right) context
37 }
30 }
38 deriving stock Generic
31 deriving stock Generic
39 deriving anyclass HTable
32 deriving anyclass HTable
40−
41−
42−type HEitherNullifiable :: K.HContext -> Constraint
43−class (HNullifiable context, HConstrainTag context EitherTag) => HEitherNullifiable context
44−instance (HNullifiable context, HConstrainTag context EitherTag) => HEitherNullifiable context
src/Rel8/Schema/HTable/Identity.hs+16−17
@@ -1,15 +1,17 @@
1{-# language DataKinds #-}
1{-# language DataKinds #-}
2−{-# language GADTs #-}
2+{-# language FlexibleContexts #-}
3{-# language StandaloneKindSignatures #-}
3{-# language StandaloneKindSignatures #-}
4{-# language TypeFamilies #-}
4{-# language TypeFamilies #-}
5+{-# language UndecidableInstances #-}
5
6
6module Rel8.Schema.HTable.Identity
7module Rel8.Schema.HTable.Identity
7− ( HIdentity(..)
8+ ( HIdentity( HIdentity, unHIdentity )
8 )
9 )
9where
10where
10
11
11-- base
12-- base
12import Data.Kind ( Type )
13import Data.Kind ( Type )
14+import Data.Type.Equality ( (:~:)( Refl ) )
13import Prelude
15import Prelude
14
16
15-- rel8
17-- rel8
@@ -19,26 +21,23 @@ import Rel8.Schema.HTable
19 , hfield, htabulate, htraverse, hdicts, hspecs
21 , hfield, htabulate, htraverse, hdicts, hspecs
20 )
22 )
21import qualified Rel8.Schema.Kind as K
23import qualified Rel8.Schema.Kind as K
22−import Rel8.Schema.Spec ( Spec, KnownSpec, specSing )
24+import Rel8.Schema.Null ( Sql )
25+import Rel8.Schema.Spec ( specification )
26+import Rel8.Type ( DBType )
23
27
24
28
25−type HIdentity :: Spec -> K.HTable
29+type HIdentity :: Type -> K.HTable
26−newtype HIdentity spec context = HIdentity
30+newtype HIdentity a context = HIdentity
27− { unHIdentity :: context spec
31+ { unHIdentity :: context a
28 }
32 }
29
33
30
34
31−type HIdentityField :: Spec -> Spec -> Type
35+instance Sql DBType a => HTable (HIdentity a) where
32−data HIdentityField _spec spec where
36+ type HConstrainTable (HIdentity a) constraint = constraint a
33− HIdentityField :: HIdentityField spec spec
37+ type HField (HIdentity a) = (:~:) a
34
38
35−
36−instance KnownSpec spec => HTable (HIdentity spec) where
37− type HConstrainTable (HIdentity spec) c = c spec
38− type HField (HIdentity spec) = HIdentityField spec
39−
40− hfield (HIdentity a) HIdentityField = a
39+ hfield (HIdentity a) Refl = a
41− htabulate f = HIdentity $ f HIdentityField
40+ htabulate f = HIdentity $ f Refl
42 htraverse f (HIdentity a) = HIdentity <$> f a
41 htraverse f (HIdentity a) = HIdentity <$> f a
43 hdicts = HIdentity Dict
42 hdicts = HIdentity Dict
44− hspecs = HIdentity specSing
43+ hspecs = HIdentity specification
src/Rel8/Schema/HTable/Label.hs+36−51
@@ -1,85 +1,70 @@
1−{-# LANGUAGE DeriveAnyClass #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE DerivingStrategies #-}
4−{-# LANGUAGE LambdaCase #-}
5−{-# language ConstraintKinds #-}
6{-# language DataKinds #-}
1{-# language DataKinds #-}
7−{-# language FlexibleInstances #-}
8−{-# language GADTs #-}
9−{-# language InstanceSigs #-}
10−{-# language MultiParamTypeClasses #-}
11−{-# language QuantifiedConstraints #-}
12{-# language RankNTypes #-}
2{-# language RankNTypes #-}
13{-# language RecordWildCards #-}
3{-# language RecordWildCards #-}
14{-# language ScopedTypeVariables #-}
4{-# language ScopedTypeVariables #-}
15{-# language StandaloneKindSignatures #-}
5{-# language StandaloneKindSignatures #-}
16{-# language TypeApplications #-}
6{-# language TypeApplications #-}
17{-# language TypeFamilies #-}
7{-# language TypeFamilies #-}
18−{-# language TypeOperators #-}
19−{-# language UndecidableInstances #-}
20
8
21module Rel8.Schema.HTable.Label
9module Rel8.Schema.HTable.Label
22− ( HLabel, Label
23− , hlabel, hunlabel
10+ ( HLabel, hlabel, hrelabel, hunlabel
11+ , hproject
24 )
12 )
25where
13where
26
14
27-- base
15-- base
16+import Data.Kind ( Type )
28import Data.Proxy ( Proxy( Proxy ) )
17import Data.Proxy ( Proxy( Proxy ) )
29−import GHC.TypeLits ( KnownSymbol, Symbol )
18+import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
30import Prelude
19import Prelude
31
20
32-- rel8
21-- rel8
33−import Rel8.Kind.Labels ( SLabels( SLabels ) )
34import Rel8.Schema.HTable
22import Rel8.Schema.HTable
35− ( HTable
23+ ( HTable, HConstrainTable, HField
36− , hfield, htabulate, hspecs
24+ , htabulate, hfield, htraverse, hdicts, hspecs
37 )
25 )
38import qualified Rel8.Schema.Kind as K
26import qualified Rel8.Schema.Kind as K
39−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
27+import Rel8.Schema.Spec ( Spec(..) )
40−import Rel8.FCF
41−import Rel8.Schema.HTable.MapTable
42−import GHC.Generics (Generic)
43
28
44
29
45type HLabel :: Symbol -> K.HTable -> K.HTable
30type HLabel :: Symbol -> K.HTable -> K.HTable
46−newtype HLabel label table context = HLabel (HMapTable (Label label) table context)
31+newtype HLabel label table context = HLabel (table context)
47− deriving stock Generic
48− deriving anyclass HTable
49
32
50
33
51−data Label :: Symbol -> Spec -> Exp Spec
34+type HLabelField :: Symbol -> K.HTable -> Type -> Type
35+newtype HLabelField label table a = HLabelField (HField table a)
52
36
53
37
54−type instance Eval (Label label ('Spec labels necessity a)) = 'Spec (label : labels) necessity a
38+instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where
39+ type HField (HLabel label table) = HLabelField label table
40+ type HConstrainTable (HLabel label table) constraint =
41+ HConstrainTable table constraint
55
42
43+ hfield (HLabel a) (HLabelField field) = hfield a field
44+ htabulate f = HLabel (htabulate (f . HLabelField))
45+ htraverse f (HLabel a) = HLabel <$> htraverse f a
46+ hdicts = HLabel (hdicts @table)
47+ hspecs = HLabel $ htabulate $ \field -> case hfield (hspecs @table) field of
48+ Spec {..} -> Spec {labels = symbolVal (Proxy @label) : labels, ..}
49+ {-# INLINABLE hspecs #-}
56
50
57−instance KnownSymbol l => MapSpec (Label l) where
58− mapInfo = \case
59− SSpec {..} -> SSpec {labels = SLabels Proxy labels, ..}
60
51
61−
62−hlabel :: (HTable t, KnownSymbol label)
63− => (forall labels necessity a. ()
64− => context ('Spec labels necessity a)
65− -> context ('Spec (label ': labels) necessity a))
66− -> t context
67− -> HLabel label t context
52+hlabel :: forall label t context. t context -> HLabel label t context
68−hlabel labeler a = HLabel $ htabulate $ \(HMapTableField field) ->
53+hlabel = HLabel
69− case hfield hspecs field of
70− SSpec {} -> labeler (hfield a field)
71{-# INLINABLE hlabel #-}
54{-# INLINABLE hlabel #-}
72
55
73
56
74−hunlabel :: (HTable t, KnownSymbol label)
75− => (forall labels necessity a. ()
76− => context ('Spec (label ': labels) necessity a)
77− -> context ('Spec labels necessity a))
78− -> HLabel label t context
57+hrelabel :: forall label' label t context. HLabel label t context -> HLabel label' t context
79− -> t context
58+hrelabel = hlabel . hunlabel
80−hunlabel unlabler (HLabel as) =
59+{-# INLINABLE hrelabel #-}
81− htabulate $ \field ->
60+
82− case hfield hspecs field of
61+
83− SSpec {} -> case hfield as (HMapTableField field) of
62+hunlabel :: forall label t context. HLabel label t context -> t context
84− a -> unlabler a
63+hunlabel (HLabel a) = a
85{-# INLINABLE hunlabel #-}
64{-# INLINABLE hunlabel #-}
65+
66+
67+hproject :: ()
68+ => (forall ctx. t ctx -> t' ctx)
69+ -> HLabel label t context -> HLabel label t' context
70+hproject f (HLabel a) = HLabel (f a)
src/Rel8/Schema/HTable/MapTable.hs+28−14
@@ -6,7 +6,7 @@
6{-# language GADTs #-}
6{-# language GADTs #-}
7{-# language InstanceSigs #-}
7{-# language InstanceSigs #-}
8{-# language MultiParamTypeClasses #-}
8{-# language MultiParamTypeClasses #-}
9−{-# language PolyKinds #-}
9+{-# language RankNTypes #-}
10{-# language ScopedTypeVariables #-}
10{-# language ScopedTypeVariables #-}
11{-# language StandaloneKindSignatures #-}
11{-# language StandaloneKindSignatures #-}
12{-# language TypeApplications #-}
12{-# language TypeApplications #-}
@@ -19,32 +19,38 @@ module Rel8.Schema.HTable.MapTable
19 , MapSpec(..)
19 , MapSpec(..)
20 , Precompose(..)
20 , Precompose(..)
21 , HMapTableField(..)
21 , HMapTableField(..)
22+ , hproject
22 )
23 )
23where
24where
24
25
25-- base
26-- base
26import Data.Kind ( Constraint, Type )
27import Data.Kind ( Constraint, Type )
27−import Prelude ( ($), (.), (<$>), fmap )
28+import Prelude
28
29
29-- rel8
30-- rel8
30−import Rel8.FCF
31+import Rel8.FCF ( Exp, Eval )
31import Rel8.Schema.HTable
32import Rel8.Schema.HTable
33+ ( HTable, HConstrainTable, HField
34+ , hfield, htabulate, htraverse, hdicts, hspecs
35+ )
32−import Rel8.Schema.Spec ( Spec, SSpec )
36+import Rel8.Schema.Spec ( Spec )
33import qualified Rel8.Schema.Kind as K
37import qualified Rel8.Schema.Kind as K
34import Rel8.Schema.Dict ( Dict( Dict ) )
38import Rel8.Schema.Dict ( Dict( Dict ) )
35
39
36
40
37−type HMapTable :: (a -> Exp b) -> ((a -> Type) -> Type) -> (b -> Type) -> Type
41+type HMapTable :: (Type -> Exp Type) -> K.HTable -> K.HTable
38−data HMapTable f t g where
42+newtype HMapTable f t context = HMapTable
39− HMapTable :: { unHMapTable :: t (Precompose f g) } -> HMapTable f t g
43+ { unHMapTable :: t (Precompose f context)
44+ }
40
45
41
46
42−type Precompose :: (a -> Exp b) -> (b -> Type) -> a -> Type
47+type Precompose :: (Type -> Exp Type) -> K.Context -> K.Context
43−newtype Precompose f g x where
48+newtype Precompose f g x = Precompose
44− Precompose :: { precomposed :: g (Eval (f x)) } -> Precompose f g x
49+ { precomposed :: g (Eval (f x))
50+ }
45
51
46
52
47−type HMapTableField :: (Spec -> Exp a) -> K.HTable -> a -> Type
53+type HMapTableField :: (Type -> Exp Type) -> K.HTable -> K.Context
48data HMapTableField f t x where
54data HMapTableField f t x where
49 HMapTableField :: HField t a -> HMapTableField f t (Eval (f a))
55 HMapTableField :: HField t a -> HMapTableField f t (Eval (f a))
50
56
@@ -64,6 +70,7 @@ instance (HTable t, MapSpec f) => HTable (HMapTable f t) where
64
70
65 htraverse f (HMapTable x) =
71 htraverse f (HMapTable x) =
66 HMapTable <$> htraverse (fmap Precompose . f . precomposed) x
72 HMapTable <$> htraverse (fmap Precompose . f . precomposed) x
73+ {-# INLINABLE htraverse #-}
67
74
68 hdicts :: forall c. HConstrainTable (HMapTable f t) c => HMapTable f t (Dict c)
75 hdicts :: forall c. HConstrainTable (HMapTable f t) c => HMapTable f t (Dict c)
69 hdicts =
76 hdicts =
@@ -73,13 +80,20 @@ instance (HTable t, MapSpec f) => HTable (HMapTable f t) where
73
80
74 hspecs =
81 hspecs =
75 HMapTable $ htabulate $ Precompose . mapInfo @f . hfield hspecs
82 HMapTable $ htabulate $ Precompose . mapInfo @f . hfield hspecs
83+ {-# INLINABLE hspecs #-}
76
84
77
85
78−type MapSpec :: (Spec -> Exp Spec) -> Constraint
86+type MapSpec :: (Type -> Exp Type) -> Constraint
79class MapSpec f where
87class MapSpec f where
80− mapInfo :: SSpec x -> SSpec (Eval (f x))
88+ mapInfo :: Spec x -> Spec (Eval (f x))
81
89
82
90
83−type ComposeConstraint :: (a -> Exp b) -> (b -> Constraint) -> a -> Constraint
91+type ComposeConstraint :: (Type -> Exp Type) -> (Type -> Constraint) -> Type -> Constraint
84class c (Eval (f a)) => ComposeConstraint f c a
92class c (Eval (f a)) => ComposeConstraint f c a
85instance c (Eval (f a)) => ComposeConstraint f c a
93instance 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+5−17
@@ -2,42 +2,30 @@
2{-# language DeriveAnyClass #-}
2{-# language DeriveAnyClass #-}
3{-# language DeriveGeneric #-}
3{-# language DeriveGeneric #-}
4{-# language DerivingStrategies #-}
4{-# language DerivingStrategies #-}
5−{-# language FlexibleInstances #-}
6{-# language StandaloneKindSignatures #-}
5{-# language StandaloneKindSignatures #-}
7−{-# language UndecidableInstances #-}
8−{-# language UndecidableSuperClasses #-}
9
6
10module Rel8.Schema.HTable.Maybe
7module Rel8.Schema.HTable.Maybe
11 ( HMaybeTable(..)
8 ( HMaybeTable(..)
12− , HMaybeNullifiable
13 )
9 )
14where
10where
15
11
16-- base
12-- base
17−import Data.Kind ( Constraint )
18import GHC.Generics ( Generic )
13import GHC.Generics ( Generic )
19import Prelude
14import Prelude
20
15
21-- rel8
16-- rel8
22−import Rel8.Kind.Necessity ( Necessity( Required ) )
23−import Rel8.Schema.Context.Nullify ( HConstrainTag, HNullifiable )
24import Rel8.Schema.HTable ( HTable )
17import Rel8.Schema.HTable ( HTable )
25−import Rel8.Schema.HTable.Identity ( HIdentity(..) )
18+import Rel8.Schema.HTable.Identity ( HIdentity )
19+import Rel8.Schema.HTable.Label ( HLabel )
20+import Rel8.Schema.HTable.Nullify ( HNullify )
26import qualified Rel8.Schema.Kind as K
21import qualified Rel8.Schema.Kind as K
27−import Rel8.Schema.Spec ( Spec( Spec ) )
28import Rel8.Type.Tag ( MaybeTag )
22import Rel8.Type.Tag ( MaybeTag )
29−import Rel8.Schema.HTable.Nullify ( HNullify )
30
23
31
24
32type HMaybeTable :: K.HTable -> K.HTable
25type HMaybeTable :: K.HTable -> K.HTable
33data HMaybeTable table context = HMaybeTable
26data HMaybeTable table context = HMaybeTable
34− { htag :: HIdentity ('Spec '["isJust"] 'Required (Maybe MaybeTag)) context
27+ { htag :: HLabel "isJust" (HIdentity (Maybe MaybeTag)) context
35− , hjust :: HNullify table context
28+ , hjust :: HLabel "Just" (HNullify table) context
36 }
29 }
37 deriving stock Generic
30 deriving stock Generic
38 deriving anyclass HTable
31 deriving anyclass HTable
39−
40−
41−type HMaybeNullifiable :: K.HContext -> Constraint
42−class (HNullifiable context, HConstrainTag context MaybeTag) => HMaybeNullifiable context
43−instance (HNullifiable context, HConstrainTag context MaybeTag) => HMaybeNullifiable context
src/Rel8/Schema/HTable/Nullify.hs+55−46
@@ -1,48 +1,52 @@
1−{-# LANGUAGE DeriveAnyClass #-}
2−{-# LANGUAGE DerivingStrategies #-}
3−{-# LANGUAGE DeriveGeneric #-}
4−{-# LANGUAGE NamedFieldPuns #-}
5−{-# LANGUAGE LambdaCase #-}
6{-# language ConstraintKinds #-}
1{-# language ConstraintKinds #-}
7{-# language DataKinds #-}
2{-# language DataKinds #-}
3+{-# language DeriveAnyClass #-}
4+{-# language DerivingStrategies #-}
5+{-# language DeriveGeneric #-}
8{-# language FlexibleInstances #-}
6{-# language FlexibleInstances #-}
9{-# language GADTs #-}
7{-# language GADTs #-}
10−{-# language InstanceSigs #-}
8+{-# language LambdaCase #-}
11{-# language MultiParamTypeClasses #-}
9{-# language MultiParamTypeClasses #-}
10+{-# language NamedFieldPuns #-}
12{-# language QuantifiedConstraints #-}
11{-# language QuantifiedConstraints #-}
13{-# language RankNTypes #-}
12{-# language RankNTypes #-}
14{-# language RecordWildCards #-}
13{-# language RecordWildCards #-}
15{-# language ScopedTypeVariables #-}
14{-# language ScopedTypeVariables #-}
16{-# language StandaloneKindSignatures #-}
15{-# language StandaloneKindSignatures #-}
17−{-# language TypeApplications #-}
18{-# language TypeFamilies #-}
16{-# language TypeFamilies #-}
19{-# language UndecidableInstances #-}
17{-# language UndecidableInstances #-}
20
18
21module Rel8.Schema.HTable.Nullify
19module Rel8.Schema.HTable.Nullify
22 ( HNullify( HNullify )
20 ( HNullify( HNullify )
23 , Nullify
21 , Nullify
22+ , hguard
23+ , hnulls
24+ , hnullify
24− , hnulls, hnullify, hunnullify
25+ , hunnullify
26+ , hproject
25 )
27 )
26where
28where
27
29
28-- base
30-- base
31+import Data.Kind ( Type )
32+import GHC.Generics ( Generic )
29import Prelude hiding ( null )
33import Prelude hiding ( null )
30
34
31-- rel8
35-- rel8
32−import Rel8.Schema.HTable
36+import Rel8.FCF ( Eval, Exp )
33− ( HTable
34− , hfield, htabulate, htabulateA, hspecs
37+import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )
38+import Rel8.Schema.HTable.MapTable
39+ ( HMapTable, HMapTableField( HMapTableField )
40+ , MapSpec, mapInfo
35 )
41 )
42+import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )
36import qualified Rel8.Schema.Kind as K
43import qualified Rel8.Schema.Kind as K
37−import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
44+import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
38−import qualified Rel8.Schema.Nullability as Type ( Nullify )
45+import qualified Rel8.Schema.Null as Type ( Nullify )
39−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
46+import Rel8.Schema.Spec ( Spec(..) )
40
47
41-- semigroupoids
48-- semigroupoids
42import Data.Functor.Apply ( Apply )
49import Data.Functor.Apply ( Apply )
43−import Rel8.Schema.HTable.MapTable
44−import Rel8.FCF
45−import GHC.Generics (Generic)
46
50
47
51
48type HNullify :: K.HTable -> K.HTable
52type HNullify :: K.HTable -> K.HTable
@@ -51,58 +55,63 @@ newtype HNullify table context = HNullify (HMapTable Nullify table context)
51 deriving anyclass HTable
55 deriving anyclass HTable
52
56
53
57
54−
55−-- | Transform a 'Spec' by allowing it to be @null@.
58+-- | Transform a 'Type' by allowing it to be @null@.
56−data Nullify :: Spec -> Exp Spec
59+data Nullify :: Type -> Exp Type
57−
58−
59−type instance Eval (Nullify ('Spec labels necessity a)) =
60+type instance Eval (Nullify a) = Type.Nullify a
60− 'Spec labels necessity (Type.Nullify a)
61
61
62
62
63instance MapSpec Nullify where
63instance MapSpec Nullify where
64 mapInfo = \case
64 mapInfo = \case
65− SSpec{labels, necessity, info, nullability} -> SSpec
65+ Spec {nullity, ..} -> Spec
66− { labels
66+ { nullity = case nullity of
67− , necessity
67+ Null -> Null
68− , info
68+ NotNull -> Null
69− , nullability = case nullability of
69+ , ..
70− Nullable -> Nullable
70+ }
71− NonNullable -> Nullable
71+
72− }
72+
73+hguard :: HTable t
74+ => (forall a. context (Maybe a) -> context (Maybe a))
75+ -> HNullify t context -> HNullify t context
76+hguard guarder (HNullify as) = HNullify $ htabulate $ \(HMapTableField field) ->
77+ case hfield hspecs field of
78+ Spec {nullity} -> case hfield as (HMapTableField field) of
79+ a -> case nullity of
80+ Null -> guarder a
81+ NotNull -> guarder a
73
82
74
83
75hnulls :: HTable t
84hnulls :: HTable t
76− => (forall labels necessity a. ()
85+ => (forall a. Spec a -> context (Type.Nullify a))
77− => context ('Spec labels necessity (Maybe a)))
78 -> HNullify t context
86 -> HNullify t context
79−hnulls null = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
87+hnulls null = HNullify $ htabulate $ \(HMapTableField field) ->
80− SSpec {} -> null
88+ case hfield hspecs field of
89+ spec@Spec {} -> null spec
81{-# INLINABLE hnulls #-}
90{-# INLINABLE hnulls #-}
82
91
83
92
84hnullify :: HTable t
93hnullify :: HTable t
85− => (forall labels necessity a. ()
86− => SSpec ('Spec labels necessity a)
87− -> context ('Spec labels necessity a)
88− -> context ('Spec labels necessity (Type.Nullify a)))
94+ => (forall a. Spec a -> context a -> context (Type.Nullify a))
89 -> t context
95 -> t context
90 -> HNullify t context
96 -> HNullify t context
91hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->
97hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->
92 case hfield hspecs field of
98 case hfield hspecs field of
93− spec@SSpec {} -> nullifier spec (hfield a field)
99+ spec@Spec {} -> nullifier spec (hfield a field)
94{-# INLINABLE hnullify #-}
100{-# INLINABLE hnullify #-}
95
101
96
102
97hunnullify :: (HTable t, Apply m)
103hunnullify :: (HTable t, Apply m)
98− => (forall labels necessity a. ()
99− => SSpec ('Spec labels necessity a)
100− -> context ('Spec labels necessity (Type.Nullify a))
104+ => (forall a. Spec a -> context (Type.Nullify a) -> m (context a))
101− -> m (context ('Spec labels necessity a)))
102 -> HNullify t context
105 -> HNullify t context
103 -> m (t context)
106 -> m (t context)
104hunnullify unnullifier (HNullify as) =
107hunnullify unnullifier (HNullify as) =
105 htabulateA $ \field -> case hfield hspecs field of
108 htabulateA $ \field -> case hfield hspecs field of
106− spec@SSpec {} -> case hfield as (HMapTableField field) of
109+ spec@Spec {} -> case hfield as (HMapTableField field) of
107 a -> unnullifier spec a
110 a -> unnullifier spec a
108{-# INLINABLE hunnullify #-}
111{-# 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.hsdeleted−20
@@ -1,20 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language StandaloneKindSignatures #-}
3−
4−module Rel8.Schema.HTable.Pair
5− ( HPair(..)
6− )
7−where
8−
9−-- base
10−import Prelude ()
11−
12−-- rel8
13−import qualified Rel8.Schema.Kind as K
14−
15−
16−type HPair :: K.HTable -> K.HTable -> K.HTable
17−data HPair fst snd context = HPair
18− { hfst :: fst context
19− , hsnd :: snd context
20− }
src/Rel8/Schema/HTable/Product.hsnew file+17
@@ -0,0 +1,17 @@
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.hsdeleted−29
@@ -1,29 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language DeriveAnyClass #-}
3−{-# language DeriveGeneric #-}
4−{-# language DerivingStrategies #-}
5−{-# language StandaloneKindSignatures #-}
6−
7−module Rel8.Schema.HTable.Quartet
8− ( HQuartet(..)
9− )
10−where
11−
12−-- base
13−import GHC.Generics ( Generic )
14−import Prelude ()
15−
16−-- rel8
17−import Rel8.Schema.HTable ( HTable )
18−import qualified Rel8.Schema.Kind as K
19−
20−
21−type HQuartet :: K.HTable -> K.HTable -> K.HTable -> K.HTable -> K.HTable
22−data HQuartet w x y z context = HQuartet
23− { hfst :: w context
24− , hsnd :: x context
25− , htrd :: y context
26− , hfrt :: z context
27− }
28− deriving stock Generic
29− deriving anyclass HTable
src/Rel8/Schema/HTable/Quintet.hsdeleted−30
@@ -1,30 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language DeriveAnyClass #-}
3−{-# language DeriveGeneric #-}
4−{-# language DerivingStrategies #-}
5−{-# language StandaloneKindSignatures #-}
6−
7−module Rel8.Schema.HTable.Quintet
8− ( HQuintet(..)
9− )
10−where
11−
12−-- base
13−import GHC.Generics ( Generic )
14−import Prelude ()
15−
16−-- rel8
17−import Rel8.Schema.HTable ( HTable )
18−import qualified Rel8.Schema.Kind as K
19−
20−
21−type HQuintet :: K.HTable -> K.HTable -> K.HTable -> K.HTable -> K.HTable -> K.HTable
22−data HQuintet v w x y z context = HQuintet
23− { hfst :: v context
24− , hsnd :: w context
25− , htrd :: x context
26− , hfrt :: y context
27− , hfft :: z context
28− }
29− deriving stock Generic
30− deriving anyclass HTable
src/Rel8/Schema/HTable/These.hs+5−6
@@ -14,21 +14,20 @@ import GHC.Generics ( Generic )
14import Prelude
14import Prelude
15
15
16-- rel8
16-- rel8
17−import Rel8.Kind.Necessity ( Necessity( Required ) )
18import Rel8.Schema.HTable ( HTable )
17import Rel8.Schema.HTable ( HTable )
19import Rel8.Schema.HTable.Identity ( HIdentity )
18import Rel8.Schema.HTable.Identity ( HIdentity )
19+import Rel8.Schema.HTable.Label ( HLabel )
20import Rel8.Schema.HTable.Nullify ( HNullify )
20import Rel8.Schema.HTable.Nullify ( HNullify )
21import qualified Rel8.Schema.Kind as K
21import qualified Rel8.Schema.Kind as K
22−import Rel8.Schema.Spec ( Spec( Spec ) )
23import Rel8.Type.Tag ( MaybeTag )
22import Rel8.Type.Tag ( MaybeTag )
24
23
25
24
26type HTheseTable :: K.HTable -> K.HTable -> K.HTable
25type HTheseTable :: K.HTable -> K.HTable -> K.HTable
27data HTheseTable here there context = HTheseTable
26data HTheseTable here there context = HTheseTable
28− { hhereTag :: HIdentity ('Spec '["hasHere"] 'Required (Maybe MaybeTag)) context
27+ { hhereTag :: HLabel "hereTag" (HIdentity (Maybe MaybeTag)) context
29− , hhere :: HNullify here context
28+ , hhere :: HLabel "Here" (HNullify here) context
30− , hthereTag :: HIdentity ('Spec '["hasThere"] 'Required (Maybe MaybeTag)) context
29+ , hthereTag :: HLabel "thereTag" (HIdentity (Maybe MaybeTag)) context
31− , hthere :: HNullify there context
30+ , hthere :: HLabel "There" (HNullify there) context
32 }
31 }
33 deriving stock Generic
32 deriving stock Generic
34 deriving anyclass HTable
33 deriving anyclass HTable
src/Rel8/Schema/HTable/Trio.hsdeleted−28
@@ -1,28 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language DeriveAnyClass #-}
3−{-# language DeriveGeneric #-}
4−{-# language DerivingStrategies #-}
5−{-# language StandaloneKindSignatures #-}
6−
7−module Rel8.Schema.HTable.Trio
8− ( HTrio(..)
9− )
10−where
11−
12−-- base
13−import GHC.Generics ( Generic )
14−import Prelude ()
15−
16−-- rel8
17−import Rel8.Schema.HTable ( HTable )
18−import qualified Rel8.Schema.Kind as K
19−
20−
21−type HTrio :: K.HTable -> K.HTable -> K.HTable -> K.HTable
22−data HTrio x y z context = HTrio
23− { hfst :: x context
24− , hsnd :: y context
25− , htrd :: z context
26− }
27− deriving stock Generic
28− deriving anyclass HTable
src/Rel8/Schema/HTable/Type.hsdeleted−61
@@ -1,61 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language GADTs #-}
3−{-# language StandaloneKindSignatures #-}
4−{-# language TypeFamilies #-}
5−{-# language UndecidableInstances #-}
6−
7−module Rel8.Schema.HTable.Type
8− ( HType(..)
9− )
10−where
11−
12−-- base
13−import Data.Kind ( Type )
14−import Data.Proxy ( Proxy( Proxy ) )
15−import Prelude
16−
17−-- rel8
18−import Rel8.Kind.Labels ( SLabels( SLabel ) )
19−import Rel8.Kind.Necessity ( Necessity( Required ), SNecessity( SRequired ) )
20−import Rel8.Schema.Dict ( Dict( Dict ) )
21−import Rel8.Schema.HTable
22− ( HTable, HConstrainTable, HField
23− , hfield, htabulate, htraverse, hdicts, hspecs
24− )
25−import qualified Rel8.Schema.Kind as K
26−import Rel8.Schema.Nullability ( Sql, nullabilization )
27−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
28−import Rel8.Type ( DBType, typeInformation )
29−
30−
31−type HType :: Type -> K.HTable
32−newtype HType a context = HType
33− { unHType :: context ('Spec '[""] 'Required a)
34− }
35−
36−
37−type HTypeField :: Type -> Spec -> Type
38−data HTypeField a spec where
39− HTypeField :: HTypeField a ('Spec '[""] 'Required a)
40−
41−
42−instance Sql DBType a => HTable (HType a) where
43− type HConstrainTable (HType a) c = c ('Spec '[""] 'Required a)
44− type HField (HType a) = HTypeField a
45−
46− hfield (HType a) HTypeField = a
47− htabulate f = HType $ f HTypeField
48− htraverse f (HType a) = HType <$> f a
49− hdicts = HType Dict
50− hspecs = HType SSpec
51− { labels = SLabel Proxy
52− , necessity = SRequired
53− , info = typeInformation
54− , nullability = nullabilization
55− }
56−
57− {-# INLINABLE hfield #-}
58− {-# INLINABLE htabulate #-}
59− {-# INLINABLE htraverse #-}
60− {-# INLINABLE hdicts #-}
61− {-# INLINABLE hspecs #-}
src/Rel8/Schema/HTable/Vectorize.hs+45−67
@@ -1,67 +1,63 @@
1−{-# LANGUAGE DeriveAnyClass #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE DerivingStrategies #-}
4−{-# LANGUAGE LambdaCase #-}
5{-# language AllowAmbiguousTypes #-}
1{-# language AllowAmbiguousTypes #-}
6{-# language ConstraintKinds #-}
2{-# language ConstraintKinds #-}
7{-# language DataKinds #-}
3{-# language DataKinds #-}
4+{-# language DeriveAnyClass #-}
5+{-# language DeriveGeneric #-}
6+{-# language DerivingStrategies #-}
8{-# language FlexibleContexts #-}
7{-# language FlexibleContexts #-}
9{-# language FlexibleInstances #-}
8{-# language FlexibleInstances #-}
10{-# language GADTs #-}
9{-# language GADTs #-}
11−{-# language InstanceSigs #-}
10+{-# language LambdaCase #-}
12{-# language MultiParamTypeClasses #-}
11{-# language MultiParamTypeClasses #-}
13−{-# language NamedFieldPuns #-}
14−{-# language QuantifiedConstraints #-}
15{-# language RankNTypes #-}
12{-# language RankNTypes #-}
16{-# language RecordWildCards #-}
13{-# language RecordWildCards #-}
17{-# language ScopedTypeVariables #-}
14{-# language ScopedTypeVariables #-}
18{-# language StandaloneKindSignatures #-}
15{-# language StandaloneKindSignatures #-}
19{-# language TypeApplications #-}
16{-# language TypeApplications #-}
20{-# language TypeFamilies #-}
17{-# language TypeFamilies #-}
21−{-# language TypeOperators #-}
22{-# language UndecidableInstances #-}
18{-# language UndecidableInstances #-}
23
19
24module Rel8.Schema.HTable.Vectorize
20module Rel8.Schema.HTable.Vectorize
25 ( HVectorize
21 ( HVectorize
26 , hvectorize, hunvectorize
22 , hvectorize, hunvectorize
27 , happend, hempty
23 , happend, hempty
28− , hrelabel
24+ , hproject
25+ , hcolumn
29 )
26 )
30where
27where
31
28
32-- base
29-- base
33−import Data.Kind ( Type )
30+import Data.Kind ( Constraint, Type )
34import Data.List.NonEmpty ( NonEmpty )
31import Data.List.NonEmpty ( NonEmpty )
32+import GHC.Generics (Generic)
35import Prelude
33import Prelude
36
34
37-- rel8
35-- rel8
38−import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )
36+import Rel8.FCF ( Eval, Exp )
39import Rel8.Schema.Dict ( Dict( Dict ) )
37import Rel8.Schema.Dict ( Dict( Dict ) )
40import qualified Rel8.Schema.Kind as K
38import qualified Rel8.Schema.Kind as K
41−import Rel8.Schema.HTable
42− ( HTable
43− , hfield, htabulate, htabulateA, hspecs
39+import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )
44− )
40+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
45−import Rel8.Schema.Nullability
41+import Rel8.Schema.HTable.MapTable
46− ( Unnullify
42+ ( HMapTable( HMapTable ), HMapTableField( HMapTableField )
47− , NotNull
43+ , MapSpec, mapInfo
48− , Nullability( NonNullable )
44+ , Precompose( Precompose )
49 )
45 )
50−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
46+import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )
47+import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )
48+import Rel8.Schema.Spec ( Spec(..) )
51import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
49import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
52import Rel8.Type.Information ( TypeInformation )
50import Rel8.Type.Information ( TypeInformation )
53
51
54-- semialign
52-- semialign
55−import Data.Zip ( Unzip, Repeat, Zippy(..) )
53+import Data.Zip ( Unzip, Zip, Zippy(..) )
56−import Rel8.FCF
57−import Rel8.Schema.HTable.MapTable
58−import GHC.Generics (Generic)
59
54
60
55
56+type Vector :: (Type -> Type) -> Constraint
61class Vector list where
57class Vector list where
62 listNotNull :: proxy a -> Dict NotNull (list a)
58 listNotNull :: proxy a -> Dict NotNull (list a)
63 vectorTypeInformation :: ()
59 vectorTypeInformation :: ()
64− => Nullability a
60+ => Nullity a
65 -> TypeInformation (Unnullify a)
61 -> TypeInformation (Unnullify a)
66 -> TypeInformation (list a)
62 -> TypeInformation (list a)
67
63
@@ -82,84 +78,66 @@ newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) t
82 deriving anyclass HTable
78 deriving anyclass HTable
83
79
84
80
85−data Vectorize :: (Type -> Type) -> Spec -> Exp Spec
81+data Vectorize :: (Type -> Type) -> Type -> Exp Type
86
82
87
83
88−type instance Eval (Vectorize list ('Spec labels necessity a)) = 'Spec labels necessity (list a)
84+type instance Eval (Vectorize list a) = list a
89
85
90
86
91instance Vector list => MapSpec (Vectorize list) where
87instance Vector list => MapSpec (Vectorize list) where
92 mapInfo = \case
88 mapInfo = \case
93− SSpec {..} -> case listNotNull @list nullability of
89+ Spec {..} -> case listNotNull @list nullity of
94− Dict -> SSpec
90+ Dict -> Spec
95− { nullability = NonNullable
91+ { nullity = NotNull
96− , info = vectorTypeInformation nullability info
92+ , info = vectorTypeInformation nullity info
97 , ..
93 , ..
98 }
94 }
99
95
100
96
101hvectorize :: (HTable t, Unzip f, Vector list)
97hvectorize :: (HTable t, Unzip f, Vector list)
102− => (forall labels necessity a. ()
98+ => (forall a. Spec a -> f (context a) -> context' (list a))
103− => SSpec ('Spec labels necessity a)
104− -> f (context ('Spec labels necessity a))
105− -> context' ('Spec labels necessity (list a)))
106 -> f (t context)
99 -> f (t context)
107 -> HVectorize list t context'
100 -> HVectorize list t context'
108hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->
101hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->
109 case hfield hspecs field of
102 case hfield hspecs field of
110− spec@SSpec {} -> vectorizer spec (fmap (`hfield` field) as)
103+ spec -> vectorizer spec (fmap (`hfield` field) as)
111{-# INLINABLE hvectorize #-}
104{-# INLINABLE hvectorize #-}
112
105
113
106
114−hunvectorize :: (HTable t, Repeat f, Vector list)
107+hunvectorize :: (HTable t, Zip f, Vector list)
115− => (forall labels necessity a. ()
108+ => (forall a. Spec a -> context (list a) -> f (context' a))
116− => SSpec ('Spec labels necessity a)
117− -> context ('Spec labels necessity (list a))
118− -> f (context' ('Spec labels necessity a)))
119 -> HVectorize list t context
109 -> HVectorize list t context
120 -> f (t context')
110 -> f (t context')
121hunvectorize unvectorizer (HVectorize table) =
111hunvectorize unvectorizer (HVectorize table) =
122 getZippy $ htabulateA $ \field -> case hfield hspecs field of
112 getZippy $ htabulateA $ \field -> case hfield hspecs field of
123− spec@SSpec{} -> case hfield table (HMapTableField field) of
113+ spec -> case hfield table (HMapTableField field) of
124 a -> Zippy (unvectorizer spec a)
114 a -> Zippy (unvectorizer spec a)
125{-# INLINABLE hunvectorize #-}
115{-# INLINABLE hunvectorize #-}
126
116
127
117
128−happend :: (HTable t, Vector list) =>
118+happend :: (HTable t, Vector list)
129− ( forall labels necessity a. ()
119+ => (forall a. Spec a -> context (list a) -> context (list a) -> context (list a))
130− => Nullability a
131− -> TypeInformation (Unnullify a)
132− -> context ('Spec labels necessity (list a))
133− -> context ('Spec labels necessity (list a))
134− -> context ('Spec labels necessity (list a))
135− )
136 -> HVectorize list t context
120 -> HVectorize list t context
137 -> HVectorize list t context
121 -> HVectorize list t context
138 -> HVectorize list t context
122 -> HVectorize list t context
139happend append (HVectorize as) (HVectorize bs) = HVectorize $
123happend append (HVectorize as) (HVectorize bs) = HVectorize $
140 htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of
124 htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of
141 (a, b) -> case hfield hspecs j of
125 (a, b) -> case hfield hspecs j of
142− SSpec {nullability, info} -> append nullability info a b
126+ spec -> append spec a b
143
127
144
128
145−hempty :: HTable t =>
129+hempty :: HTable t
146− ( forall labels necessity a. ()
130+ => (forall a. Spec a -> context [a])
147− => Nullability a
148− -> TypeInformation (Unnullify a)
149− -> context ('Spec labels necessity [a])
150− )
151 -> HVectorize [] t context
131 -> HVectorize [] t context
152−hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
132+hempty empty = HVectorize $ htabulate $ \(HMapTableField field) ->
153− SSpec {nullability, info} -> empty nullability info
133+ empty (hfield hspecs field)
154
134
155
135
156−instance HLabelable g => HLabelable (Precompose (Vectorize list) g) where
136+hproject :: ()
157− hlabeler = Precompose . hlabeler . precomposed
137+ => (forall ctx. t ctx -> t' ctx)
158− hunlabeler = Precompose . hunlabeler . precomposed
138+ -> HVectorize list t context -> HVectorize list t' context
139+hproject f (HVectorize a) = HVectorize (HMapTable.hproject f a)
159
140
160
141
161−hrelabel :: HLabelable context
142+hcolumn :: HVectorize list (HIdentity a) context -> context (list a)
162− => (forall ctx. HLabelable ctx => t ctx -> u ctx)
143+hcolumn (HVectorize (HMapTable (HIdentity (Precompose a)))) = a
163− -> HVectorize list t context
164− -> HVectorize list u context
165−hrelabel f (HVectorize (HMapTable table)) = HVectorize (HMapTable (f table))
src/Rel8/Schema/Insert.hsdeleted−164
@@ -1,164 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language DuplicateRecordFields #-}
3−{-# language FlexibleContexts #-}
4−{-# language FlexibleInstances #-}
5−{-# language GADTs #-}
6−{-# language LambdaCase #-}
7−{-# language MultiParamTypeClasses #-}
8−{-# language NamedFieldPuns #-}
9−{-# language ScopedTypeVariables #-}
10−{-# language StandaloneKindSignatures #-}
11−{-# language TypeApplications #-}
12−{-# language TypeFamilies #-}
13−{-# language UndecidableInstances #-}
14−{-# language UndecidableSuperClasses #-}
15−
16−module Rel8.Schema.Insert
17− ( Insert(..)
18− , OnConflict(..)
19− , Col( RequiredInsert, OptionalInsert )
20− , Insertion(..)
21− , Inserts
22− )
23−where
24−
25−-- base
26−import Data.Functor.Identity ( Identity )
27−import Data.Kind ( Constraint, Type )
28−import Prelude
29−
30−-- rel8
31−import Rel8.Aggregate ( Aggregate )
32−import Rel8.Expr ( Expr )
33−import Rel8.Kind.Necessity ( Necessity(Optional, Required) )
34−import Rel8.Opaque ( Opaque )
35−import Rel8.Schema.Context ( Interpretation(..) )
36−import Rel8.Schema.Context.Label ( Labelable(..) )
37−import Rel8.Schema.Context.Nullify
38− ( Nullifiable, encodeTag, decodeTag, nullifier, unnullifier
39− , runTag, unnull
40− )
41−import Rel8.Schema.HTable.Type ( HType(HType) )
42−import qualified Rel8.Schema.Kind as K
43−import Rel8.Schema.Name ( Name, Selects )
44−import Rel8.Schema.Nullability ( Sql )
45−import Rel8.Schema.Spec ( SSpec(SSpec, nullability), Spec(Spec) )
46−import Rel8.Schema.Table ( TableSchema )
47−import Rel8.Statement.Returning ( Returning )
48−import Rel8.Table ( Table(..) )
49−import Rel8.Table.Recontextualize ( Recontextualize )
50−import Rel8.Table.Tag ( Tag(..), fromExpr )
51−import Rel8.Type ( DBType )
52−
53−
54−-- | @OnConflict@ allows you to add an @ON CONFLICT@ clause to an @INSERT@
55−-- statement.
56−data OnConflict
57− = Abort -- ^ @ON CONFLICT ABORT@
58− | DoNothing -- ^ @ON CONFLICT DO NOTHING@
59−
60−
61−-- | The constituent parts of a SQL @INSERT@ statement.
62−type Insert :: K.Context
63−data Insert a where
64− Insert :: (Selects names exprs, Inserts exprs inserts) =>
65− { into :: TableSchema names
66− -- ^ Which table to insert into.
67− , rows :: [inserts]
68− -- ^ The rows to insert.
69− , onConflict :: OnConflict
70− -- ^ What to do if the inserted rows conflict with data already in the
71− -- table.
72− , returning :: Returning names a
73− -- ^ What information to return on completion.
74− }
75− -> Insert a
76−
77−
78−instance Interpretation Insert where
79− data Col Insert _spec where
80− RequiredInsert :: Expr a -> Col Insert ('Spec labels 'Required a)
81− OptionalInsert :: Maybe (Expr a) -> Col Insert ('Spec labels 'Optional a)
82−
83−
84−type Insertion :: K.Context
85−newtype Insertion a = Insertion (Expr a)
86−
87−
88−instance Sql DBType a => Table Insert (Insertion a) where
89− type Columns (Insertion a) = HType a
90− type Context (Insertion a) = Insert
91−
92− toColumns (Insertion a) = HType (RequiredInsert a)
93− fromColumns (HType (RequiredInsert a)) = Insertion a
94−
95−
96−instance Sql DBType a =>
97− Recontextualize Aggregate Insert (Aggregate (Expr a)) (Insertion a)
98−
99−
100−instance Sql DBType a => Recontextualize Expr Insert (Expr a) (Insertion a)
101−
102−
103−instance Sql DBType a =>
104− Recontextualize Identity Insert (Identity a) (Insertion a)
105−
106−
107−instance Sql DBType a =>
108− Recontextualize Insert Aggregate (Insertion a) (Aggregate (Expr a))
109−
110−
111−instance Sql DBType a => Recontextualize Insert Expr (Insertion a) (Expr a)
112−
113−
114−instance Sql DBType a =>
115− Recontextualize Insert Identity (Insertion a) (Identity a)
116−
117−
118−instance Sql DBType a => Recontextualize Insert Insert (Insertion a) (Insertion a)
119−
120−
121−instance Sql DBType a => Recontextualize Insert Name (Insertion a) (Name a)
122−
123−
124−instance Sql DBType a => Recontextualize Name Insert (Name a) (Insertion a)
125−
126−
127−instance Labelable Insert where
128− labeler = \case
129− RequiredInsert a -> RequiredInsert a
130− OptionalInsert ma -> OptionalInsert ma
131−
132− unlabeler = \case
133− RequiredInsert a -> RequiredInsert a
134− OptionalInsert ma -> OptionalInsert ma
135−
136−
137−instance Nullifiable Insert where
138− encodeTag = RequiredInsert . expr
139− decodeTag (RequiredInsert a) = fromExpr a
140−
141− nullifier Tag {expr} test SSpec {nullability} = \case
142− RequiredInsert a ->
143− RequiredInsert $ runTag nullability condition a
144− OptionalInsert ma ->
145− OptionalInsert $ runTag nullability condition <$> ma
146− where
147− condition = test expr
148−
149− unnullifier SSpec {nullability} = \case
150− RequiredInsert a -> RequiredInsert $ unnull nullability a
151− OptionalInsert ma -> OptionalInsert $ unnull nullability <$> ma
152−
153− {-# INLINABLE encodeTag #-}
154− {-# INLINABLE decodeTag #-}
155− {-# INLINABLE nullifier #-}
156− {-# INLINABLE unnullifier #-}
157−
158−
159−-- | @Inserts a b@ means that the columns in @a@ are compatible for inserting
160−-- with the table @b@.
161−type Inserts :: Type -> Type -> Constraint
162−class Recontextualize Expr Insert exprs inserts => Inserts exprs inserts
163−instance Recontextualize Expr Insert exprs inserts => Inserts exprs inserts
164−instance {-# OVERLAPPING #-} Inserts (Opaque Expr Opaque) (Opaque Insert Opaque)
src/Rel8/Schema/Kind.hs+8−14
@@ -1,8 +1,9 @@
1{-# language StandaloneKindSignatures #-}
1{-# language StandaloneKindSignatures #-}
2
2
3module Rel8.Schema.Kind
3module Rel8.Schema.Kind
4+ ( Rel8able
4− ( Context, Table
5+ , Context
5− , HContext, HTable
6+ , HTable
6 )
7 )
7where
8where
8
9
@@ -10,21 +11,14 @@ where
10import Data.Kind ( Type )
11import Data.Kind ( Type )
11import Prelude ()
12import Prelude ()
12
13
13−-- rel8
14−import Rel8.Schema.Spec ( Spec )
15
14
16−
17−type HContext :: Type
15+type Context :: Type
18−type HContext = Spec -> Type
16+type Context = Type -> Type
19
17
20
18
21type HTable :: Type
19type HTable :: Type
22−type HTable = HContext -> Type
23−
24−
25−type Context :: Type
26−type Context = Type -> Type
20+type HTable = Context -> Type
27
21
28
22
29−type Table :: Type
23+type Rel8able :: Type
30−type Table = Context -> Type
24+type Rel8able = Context -> Type
src/Rel8/Schema/Name.hs+32−43
@@ -2,39 +2,45 @@
2{-# language DerivingStrategies #-}
2{-# language DerivingStrategies #-}
3{-# language FlexibleContexts #-}
3{-# language FlexibleContexts #-}
4{-# language FlexibleInstances #-}
4{-# language FlexibleInstances #-}
5+{-# language GADTs #-}
5{-# language GeneralizedNewtypeDeriving #-}
6{-# language GeneralizedNewtypeDeriving #-}
6{-# language MultiParamTypeClasses #-}
7{-# language MultiParamTypeClasses #-}
7{-# language RankNTypes #-}
8{-# language RankNTypes #-}
8−{-# language ScopedTypeVariables #-}
9{-# language StandaloneKindSignatures #-}
9{-# language StandaloneKindSignatures #-}
10−{-# language TypeApplications #-}
11{-# language TypeFamilies #-}
10{-# language TypeFamilies #-}
12{-# language UndecidableInstances #-}
11{-# language UndecidableInstances #-}
13−{-# language UndecidableSuperClasses #-}
14
12
15module Rel8.Schema.Name
13module Rel8.Schema.Name
16 ( Name(..)
14 ( Name(..)
17− , Col( NameCol )
18 , Selects
15 , Selects
16+ , ppColumn
19 )
17 )
20where
18where
21
19
22-- base
20-- base
23−import Data.Functor.Identity ( Identity )
21+import Data.Functor.Identity ( Identity( Identity ) )
24import Data.Kind ( Constraint, Type )
22import Data.Kind ( Constraint, Type )
25import Data.String ( IsString )
23import Data.String ( IsString )
26import Prelude
24import Prelude
27
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+
28-- rel8
33-- rel8
29import Rel8.Expr ( Expr )
34import Rel8.Expr ( Expr )
30−import Rel8.Opaque ( Opaque )
31−import Rel8.Schema.Context ( Interpretation, Col )
32−import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
33−import Rel8.Schema.HTable.Type ( HType( HType ) )
34import qualified Rel8.Schema.Kind as K
35import qualified Rel8.Schema.Kind as K
35−import Rel8.Schema.Nullability ( Sql )
36+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
37+import Rel8.Schema.Null ( Sql )
38+import Rel8.Table
36−import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
39+ ( Table, Columns, Context, fromColumns, toColumns
37−import Rel8.Table.Recontextualize ( Recontextualize )
40+ , FromExprs, fromResult, toResult
41+ , Transpose
42+ )
43+import Rel8.Table.Transpose ( Transposes )
38import Rel8.Type ( DBType )
44import Rel8.Type ( DBType )
39
45
40
46
@@ -45,44 +51,27 @@ import Rel8.Type ( DBType )
45type Name :: K.Context
51type Name :: K.Context
46newtype Name a = Name String
52newtype Name a = Name String
47 deriving stock Show
53 deriving stock Show
48− deriving newtype (IsString, Monoid, Semigroup)
54+ deriving newtype IsString
49
55
50
56
51instance Sql DBType a => Table Name (Name a) where
57instance Sql DBType a => Table Name (Name a) where
52− type Columns (Name a) = HType a
58+ type Columns (Name a) = HIdentity a
53 type Context (Name a) = Name
59 type Context (Name a) = Name
60+ type FromExprs (Name a) = a
61+ type Transpose to (Name a) = to a
54
62
55− toColumns (Name a) = HType (NameCol a)
63+ toColumns a = HIdentity a
56− fromColumns (HType (NameCol a)) = Name a
64+ fromColumns (HIdentity a) = a
57−
65+ toResult a = HIdentity (Identity a)
58−
66+ fromResult (HIdentity (Identity a)) = a
59−instance Sql DBType a => Recontextualize Expr Name (Expr a) (Name a)
60−
61−
62−instance Sql DBType a => Recontextualize Identity Name (Identity a) (Name a)
63−
64−
65−instance Sql DBType a => Recontextualize Name Expr (Name a) (Expr a)
66−
67−
68−instance Sql DBType a => Recontextualize Name Identity (Name a) (Identity a)
69−
70−
71−instance Sql DBType a => Recontextualize Name Name (Name a) (Name a)
72−
73−
74−instance Interpretation Name where
75− newtype Col Name _spec = NameCol String
76−
77−
78−instance Labelable Name where
79− labeler (NameCol a) = NameCol a
80− unlabeler (NameCol a) = NameCol a
81
67
82
68
83-- | @Selects a b@ means that @a@ is a schema (i.e., a 'Table' of 'Name's) for
69-- | @Selects a b@ means that @a@ is a schema (i.e., a 'Table' of 'Name's) for
84-- the 'Expr' columns in @b@.
70-- the 'Expr' columns in @b@.
85type Selects :: Type -> Type -> Constraint
71type Selects :: Type -> Type -> Constraint
86−class Recontextualize Name Expr names exprs => Selects names exprs
72+class Transposes Name Expr names exprs => Selects names exprs
87−instance Recontextualize Name Expr names exprs => Selects names exprs
73+instance Transposes Name Expr names exprs => Selects names exprs
88−instance {-# OVERLAPPING #-} Selects (Opaque Name Opaque) (Opaque Expr Opaque)
74+
75+
76+ppColumn :: String -> Doc
77+ppColumn = Opaleye.ppSqlExpr . Opaleye.ColumnSqlExpr . Opaleye.SqlColumn
src/Rel8/Schema/Null.hsnew file+110
@@ -0,0 +1,110 @@
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.hsdeleted−22
@@ -1,22 +0,0 @@
1−{-# language ConstraintKinds #-}
2−{-# language FlexibleInstances #-}
3−{-# language MonoLocalBinds #-}
4−{-# language MultiParamTypeClasses #-}
5−{-# language UndecidableInstances #-}
6−
7−{-# options_ghc -fno-warn-orphans #-}
8−
9−module Rel8.Schema.Nullability
10− ( module Rel8.Schema.Nullability.Internal
11− )
12−where
13−
14−-- base
15−import Prelude ()
16−
17−-- rel8
18−import Rel8.Opaque ( Opaque )
19−import Rel8.Schema.Nullability.Internal
20−
21−
22−instance {-# OVERLAPPING #-} (c Opaque, Sql c Opaque) => Sql c Opaque
src/Rel8/Schema/Nullability/Internal.hsdeleted−137
@@ -1,137 +0,0 @@
1−{-# language ConstraintKinds #-}
2−{-# language DataKinds #-}
3−{-# language FlexibleContexts #-}
4−{-# language FlexibleInstances #-}
5−{-# language FunctionalDependencies #-}
6−{-# language GADTs #-}
7−{-# language MultiParamTypeClasses #-}
8−{-# language RankNTypes #-}
9−{-# language QuantifiedConstraints #-}
10−{-# language StandaloneKindSignatures #-}
11−{-# language TypeFamilies #-}
12−{-# language UndecidableInstances #-}
13−{-# language UndecidableSuperClasses #-}
14−
15−module Rel8.Schema.Nullability.Internal
16− ( Nullify, Unnullify
17− , NotNull
18− , Homonullable
19− , Nullability( Nullable, NonNullable )
20− , HasNullability, nullabilization
21− , Sql, fromSql, mapSql, toSql
22− )
23−where
24−
25−-- base
26−import Data.Kind ( Constraint, Type )
27−import Prelude
28−
29−-- rel8
30−import Rel8.Opaque ( Opaque )
31−import Rel8.Schema.Dict ( Dict( Dict ) )
32−
33−
34−type IsMaybe :: Type -> Bool
35−type family IsMaybe a where
36− IsMaybe (Maybe _) = 'True
37− IsMaybe _ = 'False
38−
39−
40−type Unnullify' :: Bool -> Type -> Type
41−type family Unnullify' isMaybe ma where
42− Unnullify' 'False a = a
43− Unnullify' 'True (Maybe a) = a
44−
45−
46−type Unnullify :: Type -> Type
47−type Unnullify a = Unnullify' (IsMaybe a) a
48−
49−
50−type Nullify' :: Bool -> Type -> Type
51−type family Nullify' isMaybe a where
52− Nullify' 'False a = a
53− Nullify' 'True a = Maybe a
54−
55−
56−type Nullify :: Type -> Type
57−type Nullify a = Maybe (Unnullify a)
58−
59−
60−type NotNull :: Type -> Constraint
61−class (HasNullability a, IsMaybe a ~ 'False) => NotNull a
62−instance (HasNullability a, IsMaybe a ~ 'False) => NotNull a
63−instance {-# OVERLAPPING #-} NotNull Opaque
64−
65−
66−type Homonullable :: Type -> Type -> Constraint
67−class IsMaybe a ~ IsMaybe b => Homonullable a b
68−instance IsMaybe a ~ IsMaybe b => Homonullable a b
69−instance {-# OVERLAPPING #-} Homonullable Opaque Opaque
70−
71−
72−type Nullability :: Type -> Type
73−data Nullability a where
74− NonNullable :: NotNull a => Nullability a
75− Nullable :: NotNull a => Nullability (Maybe a)
76−
77−
78−type HasNullability' :: Bool -> Type -> Constraint
79−class
80− ( IsMaybe a ~ isMaybe
81− , IsMaybe (Unnullify a) ~ 'False
82− , Nullify' isMaybe (Unnullify a) ~ a
83− ) => HasNullability' isMaybe a
84− where
85− nullabilization' :: Nullability a
86−
87−
88−instance IsMaybe a ~ 'False => HasNullability' 'False a where
89− nullabilization' = NonNullable
90−
91−
92−instance IsMaybe a ~ 'False => HasNullability' 'True (Maybe a) where
93− nullabilization' = Nullable
94−
95−
96−type HasNullability :: Type -> Constraint
97−class HasNullability' (IsMaybe a) a => HasNullability a
98−instance HasNullability' (IsMaybe a) a => HasNullability a
99−instance {-# OVERLAPPING #-} HasNullability Opaque
100−
101−
102−nullabilization :: HasNullability a => Nullability a
103−nullabilization = nullabilization'
104−
105−
106−-- | The @Sql@ type class describes both null and not null database values,
107−-- constrained by a specific class.
108−--
109−-- For example, if you see @Sql DBEq a@, this means any database type that
110−-- supports equality, and @a@ can either be exactly an @a@, or it could also be
111−-- @Maybe a@.
112−type Sql :: (Type -> Constraint) -> Type -> Constraint
113−class
114− ( (forall c. (forall x. (constraint x => c x)) => Sql c a)
115− , HasNullability a
116− , constraint (Unnullify a)
117− )
118− => Sql constraint a
119−instance (constraint (Unnullify a), HasNullability a) => Sql constraint a
120−
121−
122−fromSql :: Dict (Sql constraint) a -> (Nullability a, Dict constraint (Unnullify a))
123−fromSql Dict = (nullabilization, Dict)
124−{-# INLINABLE fromSql #-}
125−
126−
127−mapSql :: ()
128− => (forall x. Dict constraint x -> Dict constraint' x)
129− -> Dict (Sql constraint) a -> Dict (Sql constraint') a
130−mapSql f dict = case fromSql dict of
131− (nullability, dict') -> toSql nullability (f dict')
132−
133−
134−toSql :: Nullability a -> Dict constraint (Unnullify a) -> Dict (Sql constraint) a
135−toSql NonNullable Dict = Dict
136−toSql Nullable Dict = Dict
137−{-# INLINABLE toSql #-}
src/Rel8/Schema/Result.hsnew file+54
@@ -0,0 +1,54 @@
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+18−60
@@ -1,76 +1,34 @@
1−{-# language DataKinds #-}
2{-# language FlexibleContexts #-}
1{-# language FlexibleContexts #-}
3−{-# language GADTs #-}
2+{-# language MonoLocalBinds #-}
4{-# language StandaloneKindSignatures #-}
3{-# language StandaloneKindSignatures #-}
5−{-# language UndecidableInstances #-}
6
4
7module Rel8.Schema.Spec
5module Rel8.Schema.Spec
8− ( Spec( Spec )
6+ ( Spec( Spec, labels, info, nullity )
9− , SSpec( SSpec, labels, necessity, info, nullability )
7+ , specification
10− , KnownSpec( specSing )
11− , KContext, HKTable
12− , KTable
13 )
8 )
14where
9where
15
10
16-- base
11-- base
17−import Data.Kind ( Constraint, Type )
12+import Data.Kind ( Type )
18−import Prelude ()
13+import Prelude
19
14
20-- rel8
15-- rel8
21−import Rel8.Kind.Labels ( Labels, SLabels, KnownLabels, labelsSing )
16+import Rel8.Schema.Null ( Nullity, Sql, Unnullify, nullable )
22−import Rel8.Kind.Necessity
23− ( Necessity
24− , SNecessity
25− , KnownNecessity, necessitySing
26− )
27−import Rel8.Schema.Nullability ( Nullability, Sql, Unnullify, nullabilization )
28import Rel8.Type ( DBType, typeInformation )
17import Rel8.Type ( DBType, typeInformation )
29import Rel8.Type.Information ( TypeInformation )
18import Rel8.Type.Information ( TypeInformation )
30
19
31
20
32−type Spec :: Type
21+type Spec :: Type -> Type
33−data Spec = Spec Labels Necessity Type
22+data Spec a = Spec
34−
23+ { labels :: [String]
35−
36−type SSpec :: Spec -> Type
37−data SSpec spec where
38− SSpec ::
39− { labels :: SLabels labels
40− , necessity :: SNecessity necessity
41− , info :: TypeInformation (Unnullify a)
24+ , info :: TypeInformation (Unnullify a)
42− , nullability :: Nullability a
25+ , nullity :: Nullity a
43− }
44− -> SSpec ('Spec labels necessity a)
45−
46−
47−type KnownSpec :: Spec -> Constraint
48−class KnownSpec spec where
49− specSing :: SSpec spec
50−
51−
52−instance
53− ( KnownLabels labels
54− , KnownNecessity necessity
55− , Sql DBType a
56− )
57− => KnownSpec ('Spec labels necessity a)
58− where
59− specSing = SSpec
60− { labels = labelsSing
61− , necessity = necessitySing
62− , info = typeInformation
63− , nullability = nullabilization
64− }
26+ }
65−
66−
67−type KContext :: Type
68−type KContext = Spec -> Type
69−
70−
71−type HKTable :: Type
72−type HKTable = KContext -> Type
73
27
74
28
75−type KTable :: Type
29+specification :: Sql DBType a => Spec a
76−type KTable = (Type -> Type) -> Type
30+specification = Spec
31+ { labels = []
32+ , info = typeInformation
33+ , nullity = nullable
34+ }
src/Rel8/Schema/Spec/ConstrainDBType.hsdeleted−70
@@ -1,70 +0,0 @@
1−{-# language ConstraintKinds #-}
2−{-# language DataKinds #-}
3−{-# language FlexibleInstances #-}
4−{-# language MultiParamTypeClasses #-}
5−{-# language QuantifiedConstraints #-}
6−{-# language StandaloneKindSignatures #-}
7−{-# language TypeFamilies #-}
8−{-# language UndecidableInstances #-}
9−
10−module Rel8.Schema.Spec.ConstrainDBType
11− ( ConstrainDBType
12− , dbTypeNullability
13− , dbTypeDict
14− , fromNullabilityDict
15− )
16−where
17−
18−-- base
19−import Data.Kind ( Constraint, Type )
20−import Prelude
21−
22−-- rel8
23−import Rel8.Schema.Dict ( Dict( Dict ) )
24−import Rel8.Schema.Nullability
25− ( Unnullify
26− , Nullability
27− , Sql, nullabilization, toSql
28− )
29−import Rel8.Schema.Spec ( Spec( Spec ) )
30−
31−
32−type ConstrainDBType :: (Type -> Constraint) -> Spec -> Constraint
33−class
34− ( forall c labels necessity a. ()
35− => (spec ~ 'Spec labels necessity a)
36− => (forall x. (constraint x => c x)) => Sql c a
37− )
38− => ConstrainDBType constraint spec
39−instance
40− ( spec ~ 'Spec labels necessity a
41− , Sql constraint a
42− )
43− => ConstrainDBType constraint spec
44−
45−
46−dbTypeNullability :: Dict (ConstrainDBType c) ('Spec l n a) -> Nullability a
47−dbTypeNullability = step2 . step1
48− where
49− step1 :: Dict (ConstrainDBType c) ('Spec l n a) -> Dict (Sql c) a
50− step1 Dict = Dict
51−
52− step2 :: Dict (Sql c) a -> Nullability a
53− step2 Dict = nullabilization
54−
55−
56−dbTypeDict :: Dict (ConstrainDBType c) ('Spec l n a) -> Dict c (Unnullify a)
57−dbTypeDict = step2 . step1
58− where
59− step1 :: Dict (ConstrainDBType c) ('Spec l n a) -> Dict (Sql c) a
60− step1 Dict = Dict
61−
62− step2 :: Dict (Sql c) a -> Dict c (Unnullify a)
63− step2 Dict = Dict
64−
65−
66−fromNullabilityDict :: Nullability a -> Dict c (Unnullify a) -> Dict (ConstrainDBType c) ('Spec l n a)
67−fromNullabilityDict nullability = step2 . toSql nullability
68− where
69− step2 :: Dict (Sql c) a -> Dict (ConstrainDBType c) ('Spec l n a)
70− step2 Dict = Dict
src/Rel8/Schema/Spec/ConstrainType.hsdeleted−31
@@ -1,31 +0,0 @@
1−{-# language ConstraintKinds #-}
2−{-# language DataKinds #-}
3−{-# language FlexibleInstances #-}
4−{-# language MultiParamTypeClasses #-}
5−{-# language QuantifiedConstraints #-}
6−{-# language StandaloneKindSignatures #-}
7−{-# language TypeFamilies #-}
8−{-# language UndecidableInstances #-}
9−
10−module Rel8.Schema.Spec.ConstrainType
11− ( ConstrainType
12− )
13−where
14−
15−-- base
16−import Data.Kind ( Constraint, Type )
17−import Prelude ()
18−
19−-- rel8
20−import Rel8.Schema.Spec ( Spec( Spec ) )
21−
22−
23−type ConstrainType :: (Type -> Constraint) -> Spec -> Constraint
24−class
25− ( forall labels necessity a. ()
26− => (spec ~ 'Spec labels necessity a)
27− => constraint a
28− ) =>
29− ConstrainType constraint spec
30−instance (spec ~ 'Spec labels necessity a, constraint a) =>
31− ConstrainType constraint spec
src/Rel8/Schema/Structure.hsdeleted−54
@@ -1,54 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language StandaloneKindSignatures #-}
3−{-# language PolyKinds #-}
4−{-# language TypeFamilies #-}
5−
6−module Rel8.Schema.Structure
7− ( Structure
8− , Shape( Column, Either, List, Maybe, NonEmpty, These )
9− , Shape1
10− , Shape2
11− , IsStructure
12− )
13−where
14−
15−-- base
16−import Data.Kind ( Type )
17−import Prelude
18−
19−-- rel8
20−import qualified Rel8.Schema.Kind as K
21−import Rel8.Schema.Spec ( Spec )
22−
23−
24−type Structure :: K.Context
25−data Structure a
26−
27−
28−type Shape :: Type
29−data Shape
30− = Column Spec
31− | Either Type Type
32− | List Type
33− | Maybe Type
34− | NonEmpty Type
35− | These Type Type
36−
37−
38−type Shape1 :: (a -> Shape) -> a -> Type
39−data Shape1 shape a
40−
41−
42−type Shape2 :: (a -> b -> Shape) -> a -> b -> Type
43−data Shape2 shape a b
44−
45−
46−type IsStructure :: Type -> Bool
47−type family IsStructure a where
48− IsStructure (Shape1 _ _) = 'True
49− IsStructure (Shape2 _ _ _) = 'True
50− IsStructure (_, _) = 'True
51− IsStructure (_, _, _) = 'True
52− IsStructure (_, _, _, _) = 'True
53− IsStructure (_, _, _, _, _) = 'True
54− IsStructure _ = 'False
src/Rel8/Schema/Table.hs+21−14
@@ -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 #-}
3
6
4module Rel8.Schema.Table
7module Rel8.Schema.Table
5 ( TableSchema(..)
8 ( TableSchema(..)
9+ , ppTable
6 )
10 )
7where
11where
8
12
9-- base
13-- base
14+import Data.Kind ( Type )
10import Prelude
15import Prelude
11
16
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+
12
24
13-- | The schema for a table. This is used to specify the name and schema that a
25-- | The schema for a table. This is used to specify the name and schema that a
14-- table belongs to (the @FROM@ part of a SQL query), along with the schema of
26-- table belongs to (the @FROM@ part of a SQL query), along with the schema of
15-- the columns within this table.
27-- the columns within this table.
16--
28--
17-- For each selectable table in your database, you should provide a
29-- For each selectable table in your database, you should provide a
18−-- @TableSchema@ in order to interact with the table via Rel8. For a table
30+-- @TableSchema@ in order to interact with the table via Rel8.
19−-- storing a list of projects (as defined in the introduction):
31+type TableSchema :: Type -> Type
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,3 +40,10 @@ 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+35−66
@@ -1,40 +1,37 @@
1{-# language DuplicateRecordFields #-}
1{-# language DuplicateRecordFields #-}
2{-# language GADTs #-}
2{-# language GADTs #-}
3{-# language NamedFieldPuns #-}
3{-# language NamedFieldPuns #-}
4−{-# language ScopedTypeVariables #-}
4+{-# language RankNTypes #-}
5+{-# language RecordWildCards #-}
5{-# language StandaloneKindSignatures #-}
6{-# language StandaloneKindSignatures #-}
6−{-# language TypeApplications #-}
7+{-# language StrictData #-}
7
8
8module Rel8.Statement.Delete
9module Rel8.Statement.Delete
9 ( Delete(..)
10 ( Delete(..)
10 , delete
11 , delete
12+ , ppDelete
11 )
13 )
12where
14where
13
15
14-- base
16-- base
15−import Control.Exception ( throwIO )
16import Data.Kind ( Type )
17import Data.Kind ( Type )
17import Prelude
18import Prelude
18
19
19-- hasql
20-- hasql
20−import Hasql.Connection ( Connection )
21−import qualified Hasql.Decoders as Hasql
22import qualified Hasql.Encoders as Hasql
21import qualified Hasql.Encoders as Hasql
23−import qualified Hasql.Session as Hasql
24import qualified Hasql.Statement as Hasql
22import qualified Hasql.Statement as Hasql
25
23
26−-- opaleye
24+-- pretty
27−import qualified Opaleye.Internal.Manipulation as Opaleye
25+import Text.PrettyPrint ( Doc, (<+>), ($$), text )
28
26
29-- rel8
27-- rel8
30import Rel8.Expr ( Expr )
28import Rel8.Expr ( Expr )
31−import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
29+import Rel8.Query ( Query )
32import Rel8.Schema.Name ( Selects )
30import 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.Serialize ( Serializable, parse )
38
35
39-- text
36-- text
40import qualified Data.Text as Text
37import qualified Data.Text as Text
@@ -47,7 +44,10 @@ data Delete a where
47 Delete :: Selects names exprs =>
44 Delete :: Selects names exprs =>
48 { from :: TableSchema names
45 { from :: TableSchema names
49 -- ^ Which table to delete from.
46 -- ^ Which table to delete from.
47+ , using :: Query using
48+ -- ^ @USING@ clause — this can be used to join against other tables,
49+ -- and its results can be referenced in the @WHERE@ clause
50− , deleteWhere :: exprs -> Expr Bool
50+ , deleteWhere :: using -> exprs -> Expr Bool
51 -- ^ Which rows should be selected for deletion.
51 -- ^ Which rows should be selected for deletion.
52 , returning :: Returning names a
52 , returning :: Returning names a
53 -- ^ What to return from the @DELETE@ statement.
53 -- ^ What to return from the @DELETE@ statement.
@@ -55,56 +55,25 @@ data Delete a where
55 -> Delete a
55 -> Delete a
56
56
57
57
58−-- | Run a @DELETE@ statement.
58+ppDelete :: Delete a -> Doc
59−--
59+ppDelete Delete {..} = case ppUsing using of
60−-- >>> mapM_ print =<< select c (each projectSchema)
60+ Nothing ->
61−-- Project {projectAuthorId = 1, projectName = "rel8"}
61+ text "DELETE FROM" <+> ppTable from $$
62−-- Project {projectAuthorId = 2, projectName = "aeson"}
62+ text "WHERE false"
63−-- Project {projectAuthorId = 2, projectName = "text"}
63+ Just (usingDoc, i) ->
64−--
64+ text "DELETE FROM" <+> ppTable from $$
65−-- >>> :{
65+ usingDoc $$
66−-- delete c Delete
66+ ppWhere from (deleteWhere i) $$
67−-- { from = projectSchema
67+ ppReturning from returning
68−-- , deleteWhere = \p -> projectName p ==. lit "rel8"
69−-- , returning = Projection projectName
70−-- }
71−-- :}
72−-- ["rel8"]
73−--
74−-- >>> mapM_ print =<< select c (each projectSchema)
75−-- Project {projectAuthorId = 2, projectName = "aeson"}
76−-- Project {projectAuthorId = 2, projectName = "text"}
77−delete :: Connection -> Delete a -> IO a
78−delete c Delete {from, deleteWhere, returning} =
79− case returning of
80− NumberOfRowsAffected -> Hasql.run session c >>= either throwIO pure
81− where
82− session = Hasql.statement () statement
83− statement = Hasql.Statement bytes params decode prepare
84− bytes = encodeUtf8 $ Text.pack sql
85− params = Hasql.noParams
86− decode = Hasql.rowsAffected
87− prepare = False
88− sql = Opaleye.arrangeDeleteSql from' where'
89− where
90− from' = table $ toColumns <$> from
91− where' = toColumn . toPrimExpr . deleteWhere . fromColumns
92
68
93− Projection project -> Hasql.run session c >>= either throwIO pure
69+
94− where
70+-- | Run a 'Delete' statement.
95− session = Hasql.statement () statement
71+delete :: Delete a -> Hasql.Statement () a
96− statement = Hasql.Statement bytes params decode prepare
72+delete d@Delete {returning} = Hasql.Statement bytes params decode prepare
97− bytes = encodeUtf8 $ Text.pack sql
98− params = Hasql.noParams
99− decode = decoder project
100− prepare = False
101− sql =
102− Opaleye.arrangeDeleteReturningSql unpackspec from' where' project'
103− where
104− from' = table $ toColumns <$> from
105− where' = toColumn . toPrimExpr . deleteWhere . fromColumns
106− project' = toColumns . project . fromColumns
107 where
73 where
108− decoder :: forall exprs projection a. Serializable projection a
74+ bytes = encodeUtf8 $ Text.pack sql
109− => (exprs -> projection) -> Hasql.Result [a]
75+ params = Hasql.noParams
110− decoder _ = Hasql.rowList (parse @projection @a)
76+ decode = decodeReturning returning
77+ prepare = False
78+ sql = show doc
79+ doc = ppDelete d
src/Rel8/Statement/Insert.hs+60−70
@@ -1,99 +1,89 @@
1+{-# language DuplicateRecordFields #-}
2+{-# language FlexibleContexts #-}
1{-# language GADTs #-}
3{-# language GADTs #-}
2{-# language NamedFieldPuns #-}
4{-# language NamedFieldPuns #-}
3−{-# language ScopedTypeVariables #-}
5+{-# language RecordWildCards #-}
4−{-# language TypeApplications #-}
6+{-# language StandaloneKindSignatures #-}
7+{-# language StrictData #-}
5
8
6module Rel8.Statement.Insert
9module Rel8.Statement.Insert
7 ( Insert(..)
10 ( Insert(..)
8− , OnConflict(..)
9 , insert
11 , insert
12+ , ppInsert
13+ , ppInto
10 )
14 )
11where
15where
12
16
13-- base
17-- base
14−import Control.Exception ( throwIO )
18+import Data.Foldable ( toList )
15−import Data.List.NonEmpty ( NonEmpty( (:|) ) )
19+import Data.Kind ( Type )
16import Prelude
20import Prelude
17
21
18-- hasql
22-- hasql
19−import Hasql.Connection ( Connection )
20−import qualified Hasql.Decoders as Hasql
21import qualified Hasql.Encoders as Hasql
23import qualified Hasql.Encoders as Hasql
22−import qualified Hasql.Session as Hasql
23import qualified Hasql.Statement as Hasql
24import qualified Hasql.Statement as Hasql
24
25
25-- opaleye
26-- opaleye
26−import qualified Opaleye.Internal.Manipulation as Opaleye
27+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye
27−import qualified Opaleye.Manipulation as Opaleye
28+
29+-- pretty
30+import Text.PrettyPrint ( Doc, (<+>), ($$), parens, text )
28
31
29-- rel8
32-- rel8
30−import Rel8.Schema.Insert ( Insert(..), OnConflict(..) )
33+import Rel8.Query ( Query )
34+import Rel8.Schema.Name ( Name, Selects, ppColumn )
35+import Rel8.Schema.Table ( TableSchema(..), ppTable )
36+import Rel8.Statement.OnConflict ( OnConflict, ppOnConflict )
31−import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) )
37+import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )
32−import Rel8.Table ( fromColumns, toColumns )
38+import Rel8.Statement.Select ( ppRows )
33−import Rel8.Table.Opaleye ( table, unpackspec )
39+import Rel8.Table ( Table )
34−import Rel8.Table.Serialize ( Serializable, parse )
40+import Rel8.Table.Name ( showNames )
35
41
36-- text
42-- text
37import qualified Data.Text as Text ( pack )
43import qualified Data.Text as Text ( pack )
38import Data.Text.Encoding ( encodeUtf8 )
44import Data.Text.Encoding ( encodeUtf8 )
39
45
40
46
41−-- | Run an @INSERT@ statement
47+-- | The constituent parts of a SQL @INSERT@ statement.
42−--
48+type Insert :: Type -> Type
43−-- >>> :{
49+data Insert a where
44−-- insert c Insert
50+ Insert :: Selects names exprs =>
45−-- { into = authorSchema
51+ { into :: TableSchema names
46−-- , rows = [ lit Author{ authorName = "Gabriel Gonzales", authorId = AuthorId 4, authorUrl = Just "https://haskellforall.com" } ]
52+ -- ^ Which table to insert into.
47−-- , onConflict = Abort
53+ , rows :: Query exprs
48−-- , returning = NumberOfRowsAffected
54+ -- ^ The rows to insert. This can be an arbitrary query — use
49−-- }
55+ -- 'Rel8.values' insert a static list of rows.
50−-- :}
56+ , onConflict :: OnConflict names
51−-- 1
57+ -- ^ What to do if the inserted rows conflict with data already in the
52−insert :: Connection -> Insert a -> IO a
58+ -- table.
53−insert c Insert {into, rows, onConflict, returning} =
59+ , returning :: Returning names a
54− case (rows, returning) of
60+ -- ^ What information to return on completion.
55− ([], NumberOfRowsAffected) -> pure 0
61+ }
56− ([], Projection _) -> pure []
62+ -> Insert a
57
63
58− (x:xs, NumberOfRowsAffected) -> Hasql.run session c >>= either throwIO pure
59− where
60− session = Hasql.statement () statement
61− statement = Hasql.Statement bytes params decode prepare
62− bytes = encodeUtf8 $ Text.pack sql
63− params = Hasql.noParams
64− decode = Hasql.rowsAffected
65− prepare = False
66− sql = Opaleye.arrangeInsertManySql into' rows' onConflict'
67− where
68− into' = table $ toColumns <$> into
69− rows' = toColumns <$> x :| xs
70
64
71− (x:xs, Projection project) -> Hasql.run session c >>= either throwIO pure
65+ppInsert :: Insert a -> Doc
72− where
66+ppInsert Insert {..} =
73− session = Hasql.statement () statement
67+ text "INSERT INTO" <+>
74− statement = Hasql.Statement bytes params decode prepare
68+ ppInto into $$
75− bytes = encodeUtf8 $ Text.pack sql
69+ ppRows rows $$
76− params = Hasql.noParams
77− decode = decoder project
78− prepare = False
79− sql =
80− Opaleye.arrangeInsertManyReturningSql
81− unpackspec
82− into'
83− rows'
84− project'
85− onConflict'
70+ ppOnConflict into onConflict $$
86− where
71+ ppReturning into returning
87− into' = table $ toColumns <$> into
88− rows' = toColumns <$> x :| xs
89− project' = toColumns . project . fromColumns
90
72
91− where
92− onConflict' =
93− case onConflict of
94− DoNothing -> Just Opaleye.DoNothing
95− Abort -> Nothing
96
73
97− decoder :: forall exprs projection a. Serializable projection a
74+ppInto :: Table Name a => TableSchema a -> Doc
98− => (exprs -> projection) -> Hasql.Result [a]
75+ppInto table@TableSchema {columns} =
99− decoder _ = Hasql.rowList (parse @projection @a)
76+ ppTable table <+>
77+ parens (Opaleye.commaV ppColumn (toList (showNames columns)))
78+
79+
80+-- | Run an 'Insert' statement.
81+insert :: Insert a -> Hasql.Statement () a
82+insert i@Insert {returning} = Hasql.Statement bytes params decode prepare
83+ where
84+ bytes = encodeUtf8 $ Text.pack sql
85+ params = Hasql.noParams
86+ decode = decodeReturning returning
87+ prepare = False
88+ sql = show doc
89+ doc = ppInsert i
src/Rel8/Statement/OnConflict.hsnew file+106
@@ -0,0 +1,106 @@
1+{-# language DuplicateRecordFields #-}
2+{-# language FlexibleContexts #-}
3+{-# language GADTs #-}
4+{-# language LambdaCase #-}
5+{-# language NamedFieldPuns #-}
6+{-# language RecordWildCards #-}
7+{-# language StandaloneKindSignatures #-}
8+{-# language StrictData #-}
9+
10+module Rel8.Statement.OnConflict
11+ ( OnConflict(..)
12+ , Upsert(..)
13+ , ppOnConflict
14+ )
15+where
16+
17+-- base
18+import Data.Foldable ( toList )
19+import Data.Kind ( Type )
20+import Prelude
21+
22+-- opaleye
23+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye
24+
25+-- pretty
26+import Text.PrettyPrint ( Doc, (<+>), ($$), parens, text )
27+
28+-- rel8
29+import Rel8.Expr ( Expr )
30+import Rel8.Schema.Name ( Name, Selects, ppColumn )
31+import Rel8.Schema.Table ( TableSchema(..) )
32+import Rel8.Statement.Set ( ppSet )
33+import Rel8.Statement.Where ( ppWhere )
34+import Rel8.Table ( Table, toColumns )
35+import Rel8.Table.Cols ( Cols( Cols ) )
36+import Rel8.Table.Name ( showNames )
37+import Rel8.Table.Opaleye ( attributes )
38+import Rel8.Table.Projection ( Projecting, Projection, apply )
39+
40+
41+-- | 'OnConflict' represents the @ON CONFLICT@ clause of an @INSERT@
42+-- statement. This specifies what ought to happen when one or more of the
43+-- rows proposed for insertion conflict with an existing row in the table.
44+type OnConflict :: Type -> Type
45+data OnConflict names
46+ = Abort
47+ -- ^ Abort the transaction if there are conflicting rows (Postgres' default)
48+ | DoNothing
49+ -- ^ @ON CONFLICT DO NOTHING@
50+ | DoUpdate (Upsert names)
51+ -- ^ @ON CONFLICT DO UPDATE@
52+
53+
54+-- | The @ON CONFLICT (...) DO UPDATE@ clause of an @INSERT@ statement, also
55+-- known as \"upsert\".
56+--
57+-- When an existing row conflicts with a row proposed for insertion,
58+-- @ON CONFLICT DO UPDATE@ allows you to instead update this existing row. The
59+-- conflicting row proposed for insertion is then \"excluded\", but its values
60+-- can still be referenced from the @SET@ and @WHERE@ clauses of the @UPDATE@
61+-- statement.
62+--
63+-- Upsert in Postgres requires an explicit set of \"conflict targets\" — the
64+-- set of columns comprising the @UNIQUE@ index from conflicts with which we
65+-- would like to recover.
66+type Upsert :: Type -> Type
67+data Upsert names where
68+ Upsert :: (Selects names exprs, Projecting names index, excluded ~ exprs) =>
69+ { index :: Projection names index
70+ -- ^ The set of conflict targets, projected from the set of columns for
71+ -- the whole table
72+ , set :: excluded -> exprs -> exprs
73+ -- ^ How to update each selected row.
74+ , updateWhere :: excluded -> exprs -> Expr Bool
75+ -- ^ Which rows to select for update.
76+ }
77+ -> Upsert names
78+
79+
80+ppOnConflict :: TableSchema names -> OnConflict names -> Doc
81+ppOnConflict schema = \case
82+ Abort -> mempty
83+ DoNothing -> text "ON CONFLICT DO NOTHING"
84+ DoUpdate upsert -> ppUpsert schema upsert
85+
86+
87+ppUpsert :: TableSchema names -> Upsert names -> Doc
88+ppUpsert schema@TableSchema {columns} Upsert {..} =
89+ text "ON CONFLICT" <+>
90+ ppIndex schema index <+>
91+ text "DO UPDATE" $$
92+ ppSet schema (set excluded) $$
93+ ppWhere schema (updateWhere excluded)
94+ where
95+ excluded = attributes TableSchema
96+ { schema = Nothing
97+ , name = "excluded"
98+ , columns
99+ }
100+
101+
102+ppIndex :: (Table Name names, Projecting names index)
103+ => TableSchema names -> Projection names index -> Doc
104+ppIndex TableSchema {columns} index =
105+ parens $ Opaleye.commaV ppColumn $ toList $
106+ showNames $ Cols $ apply index $ toColumns columns
src/Rel8/Statement/Returning.hs+114−10
@@ -1,29 +1,133 @@
1{-# language GADTs #-}
1{-# language GADTs #-}
2+{-# language LambdaCase #-}
3+{-# language NamedFieldPuns #-}
4+{-# language RankNTypes #-}
5+{-# language ScopedTypeVariables #-}
2{-# language StandaloneKindSignatures #-}
6{-# language StandaloneKindSignatures #-}
7+{-# language StrictData #-}
8+{-# language TypeApplications #-}
3
9
4module Rel8.Statement.Returning
10module Rel8.Statement.Returning
5− ( Returning(..)
11+ ( Returning( NumberOfRowsAffected, Projection )
12+ , decodeReturning
13+ , ppReturning
6 )
14 )
7where
15where
8
16
9-- base
17-- base
18+import Control.Applicative ( liftA2 )
19+import Data.Foldable ( toList )
10import Data.Int ( Int64 )
20import Data.Int ( Int64 )
11import Data.Kind ( Type )
21import 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 )
13
35
14-- rel8
36-- rel8
15import Rel8.Schema.Name ( Selects )
37import Rel8.Schema.Name ( Selects )
38+import Rel8.Schema.Table ( TableSchema(..) )
39+import Rel8.Table.Opaleye ( castTable, exprs, view )
16−import Rel8.Table.Serialize ( Serializable )
40+import Rel8.Table.Serialize ( Serializable, parse )
17
41
42+-- semigropuoids
43+import Data.Functor.Apply ( Apply, (<.>) )
18
44
45+
19−-- | @INSERT@, @UPDATE@ and @DELETE@ all support returning either the number of
46+-- | 'Rel8.Insert', 'Rel8.Update' and 'Rel8.Delete' all support returning either
20−-- rows affected, or the actual rows modified. 'Projection' allows you to
47+-- the number of rows affected, or the actual rows modified.
21−-- project out of these returned rows, which can be useful if you want to log
22−-- exactly which rows were deleted, or to view a generated id (for example, if
23−-- using a column with an autoincrementing counter as a default value).
24type Returning :: Type -> Type -> Type
48type Returning :: Type -> Type -> Type
25data Returning names a where
49data 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.
26 NumberOfRowsAffected :: Returning names Int64
54 NumberOfRowsAffected :: Returning names Int64
55+
56+ -- | 'Projection' allows you to project out of the affected rows, which can
57+ -- be useful if you want to log exactly which rows were deleted, or to view
58+ -- a generated id (for example, if using a column with an autoincrementing
59+ -- counter via 'Rel8.nextval').
27− Projection :: (Selects names exprs, Serializable projection a)
60+ Projection :: (Selects names exprs, Serializable returning a)
28− => (exprs -> projection)
61+ => (exprs -> returning)
29 -> Returning names [a]
62 -> Returning names [a]
63+
64+
65+instance Functor (Returning names) where
66+ fmap f = \case
67+ Pure a -> Pure (f a)
68+ Ap g a -> Ap (fmap (f .) g) a
69+ m -> Ap (Pure f) m
70+
71+
72+instance Apply (Returning names) where
73+ (<.>) = Ap
74+
75+
76+instance Applicative (Returning names) where
77+ pure = Pure
78+ (<*>) = Ap
79+
80+
81+projections :: ()
82+ => TableSchema names -> Returning names a -> Maybe (NonEmpty Opaleye.PrimExpr)
83+projections schema@TableSchema {columns} = \case
84+ Pure _ -> Nothing
85+ Ap f a -> projections schema f <> projections schema a
86+ NumberOfRowsAffected -> Nothing
87+ Projection f -> Just (exprs (castTable (f (view columns))))
88+
89+
90+runReturning :: ()
91+ => ((Int64 -> a) -> r)
92+ -> (forall x. Hasql.Row x -> ([x] -> a) -> r)
93+ -> Returning names a
94+ -> r
95+runReturning rowCount rowList = \case
96+ Pure a -> rowCount (const a)
97+ Ap fs as ->
98+ runReturning
99+ (\withCount ->
100+ runReturning
101+ (\withCount' -> rowCount (withCount <*> withCount'))
102+ (\decoder -> rowList decoder . liftA2 withCount length64)
103+ as)
104+ (\decoder withRows ->
105+ runReturning
106+ (\withCount -> rowList decoder $ withRows <*> withCount . length64)
107+ (\decoder' withRows' ->
108+ rowList (liftA2 (,) decoder decoder') $
109+ withRows <$> fmap fst <*> withRows' . fmap snd)
110+ as)
111+ fs
112+ NumberOfRowsAffected -> rowCount id
113+ Projection (_ :: exprs -> returning) -> rowList decoder' id
114+ where
115+ decoder' = parse @returning
116+ where
117+ length64 :: Foldable f => f x -> Int64
118+ length64 = fromIntegral . length
119+
120+
121+decodeReturning :: Returning names a -> Hasql.Result a
122+decodeReturning = runReturning
123+ (<$> Hasql.rowsAffected)
124+ (\decoder withRows -> withRows <$> Hasql.rowList decoder)
125+
126+
127+ppReturning :: TableSchema names -> Returning names a -> Doc
128+ppReturning schema returning = case projections schema returning of
129+ Nothing -> mempty
130+ Just columns ->
131+ text "RETURNING" <+> Opaleye.commaV Opaleye.ppSqlExpr (toList sqlExprs)
132+ where
133+ sqlExprs = Opaleye.sqlExpr <$> columns
src/Rel8/Statement/SQL.hsnew file+29
@@ -0,0 +1,29 @@
1+module Rel8.Statement.SQL
2+ ( showDelete
3+ , showInsert
4+ , showUpdate
5+ )
6+where
7+
8+-- base
9+import Prelude
10+
11+-- rel8
12+import Rel8.Statement.Delete ( Delete, ppDelete )
13+import Rel8.Statement.Insert ( Insert, ppInsert )
14+import Rel8.Statement.Update ( Update, ppUpdate )
15+
16+
17+-- | Convert a 'Delete' to a 'String' containing a @DELETE@ statement.
18+showDelete :: Delete a -> String
19+showDelete = show . ppDelete
20+
21+
22+-- | Convert an 'Insert' to a 'String' containing an @INSERT@ statement.
23+showInsert :: Insert a -> String
24+showInsert = show . ppInsert
25+
26+
27+-- | Convert an 'Update' to a 'String' containing an @UPDATE@ statement.
28+showUpdate :: Update a -> String
29+showUpdate = show . ppUpdate
src/Rel8/Statement/Select.hs+121−35
@@ -1,61 +1,147 @@
1+{-# language DeriveTraversable #-}
2+{-# language DerivingStrategies #-}
3+{-# language FlexibleContexts #-}
4+{-# language MonoLocalBinds #-}
1{-# language ScopedTypeVariables #-}
5{-# language ScopedTypeVariables #-}
6+{-# language StandaloneKindSignatures #-}
2{-# language TypeApplications #-}
7{-# language TypeApplications #-}
3
8
4module Rel8.Statement.Select
9module Rel8.Statement.Select
5 ( select
10 ( select
6− , selectWithNames
11+ , ppSelect
12+
13+ , Optimized(..)
14+ , ppPrimSelect
15+ , ppRows
7 )
16 )
8where
17where
9
18
10-- base
19-- base
11−import Control.Exception ( throwIO )
20+import Data.Foldable ( toList )
21+import Data.Kind ( Type )
22+import Data.Void ( Void )
12−import Prelude
23+import Prelude hiding ( undefined )
13
24
14-- hasql
25-- hasql
15−import Hasql.Connection ( Connection )
16import qualified Hasql.Decoders as Hasql
26import qualified Hasql.Decoders as Hasql
17import qualified Hasql.Encoders as Hasql
27import qualified Hasql.Encoders as Hasql
18−import qualified Hasql.Session as Hasql
19import qualified Hasql.Statement as Hasql
28import qualified Hasql.Statement as Hasql
20
29
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+
21-- rel8
44-- rel8
45+import Rel8.Expr ( Expr )
46+import Rel8.Expr.Bool ( false )
47+import Rel8.Expr.Opaleye ( toPrimExpr )
22import Rel8.Query ( Query )
48import Rel8.Query ( Query )
23−import Rel8.Query.SQL ( sqlForQuery, sqlForQueryWithNames )
49+import Rel8.Query.Opaleye ( toOpaleye )
24import Rel8.Schema.Name ( Selects )
50import Rel8.Schema.Name ( Selects )
51+import Rel8.Table ( Table )
52+import Rel8.Table.Cols ( toCols )
53+import Rel8.Table.Name ( namesFromLabels )
54+import Rel8.Table.Opaleye ( castTable, exprsWithNames )
55+import qualified Rel8.Table.Opaleye as T
25import Rel8.Table.Serialize ( Serializable, parse )
56import Rel8.Table.Serialize ( Serializable, parse )
57+import Rel8.Table.Undefined ( undefined )
26
58
27-- text
59-- text
28import qualified Data.Text as Text
60import qualified Data.Text as Text
29import Data.Text.Encoding ( encodeUtf8 )
61import Data.Text.Encoding ( encodeUtf8 )
30
62
31
63
32−-- | Run a @SELECT@ query, returning all rows.
64+-- | Run a @SELECT@ statement, returning all rows.
33select :: forall exprs a. Serializable exprs a
65select :: forall exprs a. Serializable exprs a
34− => Connection -> Query exprs -> IO [a]
66+ => Query exprs -> Hasql.Statement () [a]
35−select c query = case sqlForQuery query of
67+select query = Hasql.Statement bytes params decode prepare
36− Nothing -> pure []
68+ where
37− Just sql -> Hasql.run session c >>= either throwIO pure
69+ bytes = encodeUtf8 (Text.pack sql)
38− where
70+ params = Hasql.noParams
39− session = Hasql.statement () statement
71+ decode = Hasql.rowList (parse @exprs @a)
40− statement = Hasql.Statement bytes params decode prepare
72+ prepare = False
41− bytes = encodeUtf8 (Text.pack sql)
73+ sql = show doc
42− params = Hasql.noParams
74+ doc = ppSelect query
43− decode = Hasql.rowList (parse @exprs @a)
75+
44− prepare = False
76+
45−
77+ppSelect :: Table Expr a => Query a -> Doc
46−
78+ppSelect query =
47−selectWithNames :: forall exprs a names.
79+ Opaleye.ppSql $ primSelectWith names (toCols exprs') primQuery'
48− ( Selects names exprs
80+ where
49− , Serializable exprs a
81+ names = namesFromLabels
50− )
82+ (exprs, primQuery, _) =
51− => Connection -> names -> Query exprs -> IO [a]
83+ Opaleye.runSimpleQueryArrStart (toOpaleye query) ()
52−selectWithNames c names query = case sqlForQueryWithNames names query of
84+ (exprs', primQuery') = case optimize primQuery of
53− Nothing -> pure []
85+ Empty -> (undefined, Opaleye.Product (pure (pure Opaleye.Unit)) never)
54− Just sql -> Hasql.run session c >>= either throwIO pure
86+ Unit -> (exprs, Opaleye.Unit)
55− where
87+ Optimized pq -> (exprs, pq)
56− session = Hasql.statement () statement
88+ never = pure (toPrimExpr false)
57− statement = Hasql.Statement bytes params decode prepare
89+
58− bytes = encodeUtf8 (Text.pack sql)
90+
59− params = Hasql.noParams
91+ppRows :: Table Expr a => Query a -> Doc
60− decode = Hasql.rowList (parse @exprs @a)
92+ppRows query = case optimize primQuery of
61− prepare = False
93+ -- Special case VALUES because we can't use DEFAULT inside a SELECT
94+ Optimized (Opaleye.Values symbols rows)
95+ | eqSymbols symbols (toList (T.exprs a)) ->
96+ Opaleye.ppValues_ (map Opaleye.sqlExpr <$> toList rows)
97+ _ -> ppSelect query
98+ where
99+ (a, primQuery, _) = Opaleye.runSimpleQueryArrStart (toOpaleye query) ()
100+
101+ eqSymbols (symbol : symbols) (Opaleye.AttrExpr symbol' : exprs)
102+ | eqSymbol symbol symbol' = eqSymbols symbols exprs
103+ | otherwise = False
104+ eqSymbols [] [] = True
105+ eqSymbols _ _ = False
106+
107+ eqSymbol
108+ (Opaleye.Symbol name (Opaleye.UnsafeTag tag))
109+ (Opaleye.Symbol name' (Opaleye.UnsafeTag tag'))
110+ = name == name' && tag == tag'
111+
112+
113+ppPrimSelect :: Query a -> (Optimized Doc, a)
114+ppPrimSelect query =
115+ (Opaleye.ppSql . primSelect <$> optimize primQuery, a)
116+ where
117+ (a, primQuery, _) = Opaleye.runSimpleQueryArrStart (toOpaleye query) ()
118+
119+
120+type Optimized :: Type -> Type
121+data Optimized a = Empty | Unit | Optimized a
122+ deriving stock (Functor, Foldable, Traversable, Show)
123+
124+
125+optimize :: Opaleye.PrimQuery' a -> Optimized (Opaleye.PrimQuery' Void)
126+optimize query = case Opaleye.removeEmpty (Opaleye.optimize query) of
127+ Nothing -> Empty
128+ Just Opaleye.Unit -> Unit
129+ Just query' -> Optimized query'
130+
131+
132+primSelect :: Opaleye.PrimQuery' Void -> Opaleye.Select
133+primSelect = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator
134+
135+
136+primSelectWith :: Selects names exprs
137+ => names -> exprs -> Opaleye.PrimQuery' Void -> Opaleye.Select
138+primSelectWith names exprs query =
139+ Opaleye.SelectFrom $ Opaleye.newSelect
140+ { Opaleye.attrs = Opaleye.SelectAttrs attrs
141+ , Opaleye.tables = Opaleye.oneTable (primSelect query)
142+ }
143+ where
144+ attrs = makeAttr <$> exprsWithNames names (castTable exprs)
145+ where
146+ makeAttr (label, expr) =
147+ (Opaleye.sqlExpr expr, Just (Opaleye.SqlColumn label))
src/Rel8/Statement/Set.hsnew file+33
@@ -0,0 +1,33 @@
1+{-# language MonoLocalBinds #-}
2+{-# language NamedFieldPuns #-}
3+
4+module Rel8.Statement.Set
5+ ( ppSet
6+ )
7+where
8+
9+-- base
10+import Data.Foldable ( toList )
11+import Prelude ()
12+
13+-- opaleye
14+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye
15+import qualified Opaleye.Internal.Sql as Opaleye
16+
17+-- pretty
18+import Text.PrettyPrint ( Doc, (<+>), equals, text )
19+
20+-- rel8
21+import Rel8.Schema.Name ( Selects, ppColumn )
22+import Rel8.Schema.Table ( TableSchema(..) )
23+import Rel8.Table.Opaleye ( attributes, exprsWithNames )
24+
25+
26+ppSet :: Selects names exprs
27+ => TableSchema names -> (exprs -> exprs) -> Doc
28+ppSet schema@TableSchema {columns} f =
29+ text "SET" <+> Opaleye.commaV ppAssign (toList assigns)
30+ where
31+ assigns = exprsWithNames columns (f (attributes schema))
32+ ppAssign (column, expr) =
33+ ppColumn column <+> equals <+> Opaleye.ppSqlExpr (Opaleye.sqlExpr expr)
src/Rel8/Statement/Update.hs+38−80
@@ -1,43 +1,37 @@
1+{-# language DuplicateRecordFields #-}
1{-# language GADTs #-}
2{-# language GADTs #-}
2{-# language NamedFieldPuns #-}
3{-# language NamedFieldPuns #-}
3−{-# language ScopedTypeVariables #-}
4+{-# language RecordWildCards #-}
4{-# language StandaloneKindSignatures #-}
5{-# language StandaloneKindSignatures #-}
5−{-# language TypeApplications #-}
6+{-# language StrictData #-}
6
7
7module Rel8.Statement.Update
8module Rel8.Statement.Update
8 ( Update(..)
9 ( Update(..)
9 , update
10 , update
11+ , ppUpdate
10 )
12 )
11where
13where
12
14
13-- base
15-- base
14−import Control.Exception ( throwIO )
15import Data.Kind ( Type )
16import Data.Kind ( Type )
16import Prelude
17import Prelude
17
18
18-- hasql
19-- hasql
19−import Hasql.Connection ( Connection )
20−import qualified Hasql.Decoders as Hasql
21import qualified Hasql.Encoders as Hasql
20import qualified Hasql.Encoders as Hasql
22−import qualified Hasql.Session as Hasql
23import qualified Hasql.Statement as Hasql
21import qualified Hasql.Statement as Hasql
24
22
25−-- opaleye
23+-- pretty
26−import qualified Opaleye.Internal.Manipulation as Opaleye
24+import Text.PrettyPrint ( Doc, (<+>), ($$), text )
27−
28−-- profunctors
29−import Data.Profunctor ( lmap )
30
25
31-- rel8
26-- rel8
32import Rel8.Expr ( Expr )
27import Rel8.Expr ( Expr )
33−import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
28+import Rel8.Query ( Query )
34import Rel8.Schema.Name ( Selects )
29import 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.Serialize ( Serializable, parse )
41
35
42-- text
36-- text
43import qualified Data.Text as Text
37import qualified Data.Text as Text
@@ -50,9 +44,12 @@ data Update a where
50 Update :: Selects names exprs =>
44 Update :: Selects names exprs =>
51 { target :: TableSchema names
45 { target :: TableSchema names
52 -- ^ Which table to update.
46 -- ^ Which table to update.
53− , set :: exprs -> exprs
47+ , from :: Query from
48+ -- ^ @FROM@ clause — this can be used to join against other tables,
49+ -- and its results can be referenced in the @SET@ and @WHERE@ clauses.
50+ , set :: from -> exprs -> exprs
54 -- ^ How to update each selected row.
51 -- ^ How to update each selected row.
55− , updateWhere :: exprs -> Expr Bool
52+ , updateWhere :: from -> exprs -> Expr Bool
56 -- ^ Which rows to select for update.
53 -- ^ Which rows to select for update.
57 , returning :: Returning names a
54 , returning :: Returning names a
58 -- ^ What to return from the @UPDATE@ statement.
55 -- ^ What to return from the @UPDATE@ statement.
@@ -60,66 +57,27 @@ data Update a where
60 -> Update a
57 -> Update a
61
58
62
59
63−-- | Run an @UPDATE@ statement.
60+ppUpdate :: Update a -> Doc
64−--
61+ppUpdate Update {..} = case ppFrom from of
65−-- >>> mapM_ print =<< select c (each projectSchema)
62+ Nothing ->
66−-- Project {projectAuthorId = 1, projectName = "rel8"}
63+ text "UPDATE" <+> ppTable target $$
67−-- Project {projectAuthorId = 2, projectName = "aeson"}
64+ ppSet target id $$
68−-- Project {projectAuthorId = 2, projectName = "text"}
65+ text "WHERE false"
69−--
66+ Just (fromDoc, i) ->
70−-- >>> :{
67+ text "UPDATE" <+> ppTable target $$
71−-- update c Update
68+ ppSet target (set i) $$
72−-- { target = projectSchema
69+ fromDoc $$
73−-- , set = \p -> p { projectName = "Rel8!" }
70+ ppWhere target (updateWhere i) $$
74−-- , updateWhere = \p -> projectName p ==. lit "rel8"
71+ ppReturning target returning
75−-- , returning = NumberOfRowsAffected
76−-- }
77−-- :}
78−-- 1
79−--
80−-- >>> mapM_ print =<< select c (each projectSchema)
81−-- Project {projectAuthorId = 2, projectName = "aeson"}
82−-- Project {projectAuthorId = 2, projectName = "text"}
83−-- Project {projectAuthorId = 1, projectName = "Rel8!"}
84−update :: Connection -> Update a -> IO a
85−update c Update {target, set, updateWhere, returning} =
86− case returning of
87− NumberOfRowsAffected -> Hasql.run session c >>= either throwIO pure
88− where
89− session = Hasql.statement () statement
90− statement = Hasql.Statement bytes params decode prepare
91− bytes = encodeUtf8 $ Text.pack sql
92− params = Hasql.noParams
93− decode = Hasql.rowsAffected
94− prepare = False
95− sql = Opaleye.arrangeUpdateSql target' set' where'
96− where
97− target' = lmap toInsert $ table $ toColumns <$> target
98− set' = toColumns . set . fromColumns
99− where' = toColumn . toPrimExpr . updateWhere . fromColumns
100
72
101− Projection project -> Hasql.run session c >>= either throwIO pure
102− where
103− session = Hasql.statement () statement
104− statement = Hasql.Statement bytes params decode prepare
105− bytes = encodeUtf8 $ Text.pack sql
106− params = Hasql.noParams
107− decode = decoder project
108− prepare = False
109− sql =
110− Opaleye.arrangeUpdateReturningSql
111− unpackspec
112− target'
113− set'
114− where'
115− project'
116− where
117− target' = lmap toInsert $ table $ toColumns <$> target
118− set' = toColumns . set . fromColumns
119− where' = toColumn . toPrimExpr . updateWhere . fromColumns
120− project' = toColumns . project . fromColumns
121
73
74+-- | Run an @UPDATE@ statement.
75+update :: Update a -> Hasql.Statement () a
76+update u@Update {returning} = Hasql.Statement bytes params decode prepare
122 where
77 where
123− decoder :: forall exprs projection a. Serializable projection a
78+ bytes = encodeUtf8 $ Text.pack sql
124− => (exprs -> projection) -> Hasql.Result [a]
79+ params = Hasql.noParams
125− decoder _ = Hasql.rowList (parse @projection @a)
80+ decode = decodeReturning returning
81+ prepare = False
82+ sql = show doc
83+ doc = ppUpdate u
src/Rel8/Statement/Using.hsnew file+36
@@ -0,0 +1,36 @@
1+module Rel8.Statement.Using
2+ ( ppFrom
3+ , ppUsing
4+ )
5+where
6+
7+-- base
8+import Prelude
9+
10+-- pretty
11+import Text.PrettyPrint ( Doc, (<+>), parens, text )
12+
13+-- rel8
14+import Rel8.Query ( Query )
15+import Rel8.Schema.Table ( TableSchema(..), ppTable )
16+import Rel8.Statement.Select ( Optimized(..), ppPrimSelect )
17+
18+
19+ppFrom :: Query a -> Maybe (Doc, a)
20+ppFrom = ppJoin "FROM"
21+
22+
23+ppUsing :: Query a -> Maybe (Doc, a)
24+ppUsing = ppJoin "USING"
25+
26+
27+ppJoin :: String -> Query a -> Maybe (Doc, a)
28+ppJoin clause join = do
29+ doc <- case ofrom of
30+ Empty -> Nothing
31+ Unit -> Just mempty
32+ Optimized doc -> Just $ text clause <+> parens doc <+> ppTable alias
33+ pure (doc, a)
34+ where
35+ alias = TableSchema {name = "T1", schema = Nothing, columns = ()}
36+ (ofrom, a) = ppPrimSelect join
src/Rel8/Statement/View.hs+47−28
@@ -1,59 +1,78 @@
1{-# language FlexibleContexts #-}
1{-# language FlexibleContexts #-}
2+{-# language MonoLocalBinds #-}
2
3
3module Rel8.Statement.View
4module Rel8.Statement.View
4 ( createView
5 ( createView
6+ , createOrReplaceView
5 )
7 )
6where
8where
7
9
8-- base
10-- base
9−import Control.Exception ( throwIO )
10−import Control.Monad ( (>=>) )
11−import Data.Foldable ( fold )
12−import Data.Maybe ( fromMaybe )
13import Prelude
11import Prelude
14
12
15-- hasql
13-- hasql
16−import Hasql.Connection ( Connection )
17import qualified Hasql.Decoders as Hasql
14import qualified Hasql.Decoders as Hasql
18import qualified Hasql.Encoders as Hasql
15import qualified Hasql.Encoders as Hasql
19−import qualified Hasql.Session as Hasql
20import qualified Hasql.Statement as Hasql
16import qualified Hasql.Statement as Hasql
21
17
22-- rel8
18-- rel8
23import Rel8.Query ( Query )
19import Rel8.Query ( Query )
24−import Rel8.Query.SQL ( sqlForQueryWithNames )
25import Rel8.Schema.Name ( Selects )
20import Rel8.Schema.Name ( Selects )
26−import Rel8.Schema.Table ( TableSchema( TableSchema ) )
21+import Rel8.Schema.Table ( TableSchema )
27−import Rel8.Table.Alternative ( emptyTable )
22+import Rel8.Statement.Insert ( ppInto )
23+import Rel8.Statement.Select ( ppSelect )
24+
25+-- pretty
26+import Text.PrettyPrint ( Doc, (<+>), ($$), text )
28
27
29-- text
28-- text
30import qualified Data.Text as Text
29import qualified Data.Text as Text
31import Data.Text.Encoding ( encodeUtf8 )
30import Data.Text.Encoding ( encodeUtf8 )
32
31
33
32
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.
34createView :: Selects names exprs
39createView :: Selects names exprs
35− => TableSchema names -> Query exprs -> Connection -> IO ()
40+ => TableSchema names -> Query exprs -> Hasql.Statement () ()
36−createView (TableSchema name mschema names) query =
41+createView =
37− Hasql.run session >=> either throwIO pure
42+ createViewGeneric Create
43+
44+
45+-- | Given a 'TableSchema' and 'Query', @createOrReplaceView@ runs a
46+-- @CREATE OR REPLACE VIEW@ statement that will save the given query
47+-- as a view, replacing the current view definition if it exists and
48+-- adheres to the restrictions in place for replacing a view in
49+-- PostgreSQL.
50+createOrReplaceView :: Selects names exprs
51+ => TableSchema names -> Query exprs -> Hasql.Statement () ()
52+createOrReplaceView =
53+ createViewGeneric CreateOrReplace
54+
55+
56+createViewGeneric :: Selects names exprs
57+ => CreateView -> TableSchema names -> Query exprs -> Hasql.Statement () ()
58+createViewGeneric replace schema query =
59+ Hasql.Statement bytes params decode prepare
38 where
60 where
39− session = Hasql.statement () statement
40− statement = Hasql.Statement bytes params decode prepare
41 bytes = encodeUtf8 (Text.pack sql)
61 bytes = encodeUtf8 (Text.pack sql)
42 params = Hasql.noParams
62 params = Hasql.noParams
43 decode = Hasql.noResult
63 decode = Hasql.noResult
44 prepare = False
64 prepare = False
45− sql = "CREATE VIEW " <> title <> " WITH " <> select
65+ sql = show doc
46− where
66+ doc = ppCreateView schema query replace
47− title = case mschema of
67+
48− Nothing -> quote name
68+
49− Just schema -> quote schema <> "." <> quote name
69+ppCreateView :: Selects names exprs
50− select = fromMaybe fallback $ sqlForQueryWithNames names query
70+ => TableSchema names -> Query exprs -> CreateView -> Doc
51− where
71+ppCreateView schema query replace =
52− fallback = fold $ sqlForQueryWithNames names emptyTable
72+ createOrReplace replace <+>
53−
73+ ppInto schema $$
54−
74+ text "AS" <+>
55−quote :: String -> String
75+ ppSelect query
56−quote string = "\"" <> concatMap go string <> "\""
57 where
76 where
58− go '"' = "\"\""
77+ createOrReplace Create = text "CREATE VIEW"
59− go c = [c]
78+ createOrReplace CreateOrReplace = text "CREATE OR REPLACE VIEW"
src/Rel8/Statement/Where.hsnew file+31
@@ -0,0 +1,31 @@
1+{-# language MonoLocalBinds #-}
2+
3+module Rel8.Statement.Where
4+ ( ppWhere
5+ )
6+where
7+
8+-- base
9+import Prelude
10+
11+-- opaleye
12+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye
13+import qualified Opaleye.Internal.Sql as Opaleye
14+
15+-- pretty
16+import Text.PrettyPrint ( Doc, (<+>), text )
17+
18+-- rel8
19+import Rel8.Expr ( Expr )
20+import Rel8.Expr.Opaleye ( toPrimExpr )
21+import Rel8.Schema.Name ( Selects )
22+import Rel8.Schema.Table ( TableSchema )
23+import Rel8.Table.Opaleye ( attributes )
24+
25+
26+ppWhere :: Selects names exprs
27+ => TableSchema names -> (exprs -> Expr Bool) -> Doc
28+ppWhere schema where_ = text "WHERE" <+> ppExpr condition
29+ where
30+ ppExpr = Opaleye.ppSqlExpr . Opaleye.sqlExpr . toPrimExpr
31+ condition = where_ (attributes schema)
src/Rel8/Table.hs+149−147
@@ -1,40 +1,46 @@
1+{-# language AllowAmbiguousTypes #-}
1{-# language DataKinds #-}
2{-# language DataKinds #-}
2−{-# language DisambiguateRecordFields #-}
3+{-# language DefaultSignatures #-}
3{-# language FlexibleContexts #-}
4{-# language FlexibleContexts #-}
4{-# language FlexibleInstances #-}
5{-# language FlexibleInstances #-}
5{-# language FunctionalDependencies #-}
6{-# language FunctionalDependencies #-}
7+{-# language ScopedTypeVariables #-}
6{-# language StandaloneKindSignatures #-}
8{-# language StandaloneKindSignatures #-}
9+{-# language TypeApplications #-}
7{-# language TypeFamilies #-}
10{-# language TypeFamilies #-}
8{-# language UndecidableInstances #-}
11{-# language UndecidableInstances #-}
9
12
10module Rel8.Table
13module Rel8.Table
11− ( Table (Columns, Context)
14+ ( Table
12− , toColumns, fromColumns
15+ ( Columns, Context, fromColumns, toColumns
16+ , FromExprs, fromResult, toResult
17+ , Transpose
18+ )
13 , Congruent
19 , Congruent
20+ , TTable, TColumns, TContext, TFromExprs, TTranspose
21+ , TSerialize
14 )
22 )
15where
23where
16
24
17-- base
25-- base
18import Data.Functor.Identity ( Identity( Identity ) )
26import Data.Functor.Identity ( Identity( Identity ) )
19import Data.Kind ( Constraint, Type )
27import Data.Kind ( Constraint, Type )
20−import Prelude
28+import GHC.Generics ( Generic, Rep, from, to )
29+import Prelude hiding ( null )
21
30
22-- rel8
31-- rel8
23−import {-# SOURCE #-} Rel8.Expr ( Expr )
32+import Rel8.FCF ( Eval, Exp )
24−import Rel8.Opaque ( Opaque )
33+import Rel8.Generic.Map ( Map )
25−import Rel8.Schema.Context ( Col(..) )
34+import Rel8.Generic.Table.Record
26−import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
35+ ( GTable, GColumns, GContext, gfromColumns, gtoColumns
36+ , GSerialize, gfromResult, gtoResult
37+ )
38+import Rel8.Generic.Record ( Record(..) )
27import Rel8.Schema.HTable ( HTable )
39import Rel8.Schema.HTable ( HTable )
28−import Rel8.Schema.HTable.Identity ( HIdentity(..) )
40+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
29−import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
30−import Rel8.Schema.HTable.Pair ( HPair(..) )
31−import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
32−import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
33−import Rel8.Schema.HTable.Trio ( HTrio(..) )
34−import Rel8.Schema.HTable.Type ( HType( HType ) )
35import qualified Rel8.Schema.Kind as K
41import qualified Rel8.Schema.Kind as K
36−import Rel8.Schema.Nullability ( Sql )
42+import Rel8.Schema.Null ( Sql )
37−import Rel8.Schema.Spec ( KnownSpec )
43+import Rel8.Schema.Result ( Result )
38import Rel8.Type ( DBType )
44import Rel8.Type ( DBType )
39
45
40
46
@@ -42,177 +48,173 @@ import Rel8.Type ( DBType )
42-- types that have a finite number of columns. Each of these columns contains
48-- types that have a finite number of columns. Each of these columns contains
43-- data under a shared context, and contexts describe how to interpret the
49-- data under a shared context, and contexts describe how to interpret the
44-- metadata about a column to a particular Haskell type. In Rel8, we have
50-- metadata about a column to a particular Haskell type. In Rel8, we have
45−-- contexts for expressions (the 'Expr' context), aggregations (the 'Aggregate'
51+-- contexts for expressions (the 'Rel8.Expr' context), aggregations (the
46−-- context), insert values (the 'Insert' contex), among others.
52+-- 'Rel8.Aggregate' context), insert values (the 'Rel8.Insert' contex), among
53+-- others.
47--
54--
48-- In typical usage of Rel8 you don't need to derive instances of 'Table'
55-- In typical usage of Rel8 you don't need to derive instances of 'Table'
49−-- yourself, as anything that's an instance of 'Rel8able' is always a 'Table'.
56+-- yourself, as anything that's an instance of 'Rel8.Rel8able' is always a
57+-- 'Table'.
50type Table :: K.Context -> Type -> Constraint
58type Table :: K.Context -> Type -> Constraint
51−class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where
59+class
60+ ( HTable (Columns a)
61+ , context ~ Context a
62+ , a ~ Transpose context a
63+ )
64+ => Table context a | a -> context
65+ where
52 -- | The 'HTable' functor that describes the schema of this table.
66 -- | The 'HTable' functor that describes the schema of this table.
53 type Columns a :: K.HTable
67 type Columns a :: K.HTable
54
68
55 -- | The common context that all columns use as an interpretation.
69 -- | The common context that all columns use as an interpretation.
56 type Context a :: K.Context
70 type Context a :: K.Context
57
71
58− toColumns :: a -> Columns a (Col (Context a))
72+ -- | The @FromExprs@ type family maps a type in the @Expr@ context to the
59− fromColumns :: Columns a (Col (Context a)) -> a
73+ -- corresponding Haskell type.
74+ type FromExprs a :: Type
60
75
76+ type Transpose (context' :: K.Context) a :: Type
61
77
62−-- | Any 'HTable' is also a 'Table'.
63−instance HTable t => Table context (t (Col context)) where
64− type Columns (t (Col context)) = t
65− type Context (t (Col context)) = context
66
78
67− toColumns = id
79+ toColumns :: a -> Columns a context
68− fromColumns = id
80+ fromColumns :: Columns a context -> a
69
81
82+ fromResult :: Columns a Result -> FromExprs a
83+ toResult :: FromExprs a -> Columns a Result
70
84
71−-- | Any context is trivially a table.
85+ type Columns a = GColumns TColumns (Rep (Record a))
72−instance KnownSpec spec => Table context (Col context spec) where
86+ type Context a = GContext TContext (Rep (Record a))
73− type Columns (Col context spec) = HIdentity spec
87+ type FromExprs a = Map TFromExprs a
74− type Context (Col context spec) = context
88+ type Transpose context a = Map (TTranspose context) a
89+
90+ default toColumns ::
91+ ( Generic (Record a)
92+ , GTable (TTable context) TColumns (Rep (Record a))
93+ , Columns a ~ GColumns TColumns (Rep (Record a))
94+ )
95+ => a -> Columns a context
96+ toColumns =
97+ gtoColumns @(TTable context) @TColumns toColumns .
98+ from .
99+ Record
100+
101+ default fromColumns ::
102+ ( Generic (Record a)
103+ , GTable (TTable context) TColumns (Rep (Record a))
104+ , Columns a ~ GColumns TColumns (Rep (Record a))
105+ )
106+ => Columns a context -> a
107+ fromColumns =
108+ unrecord .
109+ to .
110+ gfromColumns @(TTable context) @TColumns fromColumns
111+
112+ default toResult ::
113+ ( Generic (Record (FromExprs a))
114+ , GSerialize TSerialize TColumns (Rep (Record a)) (Rep (Record (FromExprs a)))
115+ , Columns a ~ GColumns TColumns (Rep (Record a))
116+ )
117+ => FromExprs a -> Columns a Result
118+ toResult =
119+ gtoResult
120+ @TSerialize
121+ @TColumns
122+ @(Rep (Record a))
123+ @(Rep (Record (FromExprs a)))
124+ (\(_ :: proxy x) -> toResult @(Context x) @x) .
125+ from .
126+ Record
127+
128+ default fromResult ::
129+ ( Generic (Record (FromExprs a))
130+ , GSerialize TSerialize TColumns (Rep (Record a)) (Rep (Record (FromExprs a)))
131+ , Columns a ~ GColumns TColumns (Rep (Record a))
132+ )
133+ => Columns a Result -> FromExprs a
134+ fromResult =
135+ unrecord .
136+ to .
137+ gfromResult
138+ @TSerialize
139+ @TColumns
140+ @(Rep (Record a))
141+ @(Rep (Record (FromExprs a)))
142+ (\(_ :: proxy x) -> fromResult @(Context x) @x)
143+
144+
145+instance Sql DBType a => Table Result (Identity a) where
146+ type Columns (Identity a) = HIdentity a
147+ type Context (Identity a) = Result
148+ type FromExprs (Identity a) = a
149+ type Transpose to (Identity a) = to a
75
150
76 toColumns = HIdentity
151 toColumns = HIdentity
77− fromColumns = unHIdentity
152+ fromColumns (HIdentity a) = a
153+ toResult a = HIdentity (Identity a)
154+ fromResult (HIdentity (Identity a)) = a
78
155
79
156
80−instance Sql DBType a => Table Identity (Identity a) where
157+data TTable :: K.Context -> Type -> Exp Constraint
81− type Columns (Identity a) = HType a
158+type instance Eval (TTable context a) = Table context a
82− type Context (Identity a) = Identity
83
159
84− toColumns (Identity a) = HType (Result a)
85− fromColumns (HType (Result a)) = Identity a
86
160
161+data TColumns :: Type -> Exp K.HTable
162+type instance Eval (TColumns a) = Columns a
87
163
88−{-}
89−instance Sql DBType a => Table Insertion (Insertion a) where
90− type Columns (Insertion a) = HType a
91− type Context (Insertion a) = Insertion
92
164
93− toColumns (Insertion a) = HType (RequiredInsert a)
165+data TContext :: Type -> Exp K.Context
94− fromColumns (HType (RequiredInsert a)) = Insertion a
166+type instance Eval (TContext a) = Context a
95−-}
96
167
97
168
98−instance
169+data TFromExprs :: Type -> Exp Type
99− ( Table context a, Table context b
170+type instance Eval (TFromExprs a) = FromExprs a
100− , Labelable context
171+
101− ) =>
172+
102− Table context (a, b)
173+data TTranspose :: K.Context -> Type -> Exp Type
103− where
174+type instance Eval (TTranspose context a) = Transpose context a
104− type Columns (a, b) =
175+
105− HPair
176+
106− (HLabel "fst" (Columns a))
177+data TSerialize :: Type -> Type -> Exp Constraint
107− (HLabel "snd" (Columns b))
178+type instance Eval (TSerialize expr a) =
108− type Context (a, b) = Context a
179+ ( Table (Context expr) expr
109−
180+ , a ~ FromExprs expr
110− toColumns (a, b) = HPair
181+ )
111− { hfst = hlabel labeler $ toColumns a
182+
112− , hsnd = hlabel labeler $ toColumns b
183+
113− }
184+instance (Table context a, Table context b) => Table context (a, b)
114− fromColumns (HPair a b) =
115− ( fromColumns $ hunlabel unlabeler a
116− , fromColumns $ hunlabel unlabeler b
117− )
118
185
119
186
120instance
187instance
121 ( Table context a, Table context b, Table context c
188 ( Table context a, Table context b, Table context c
122− , Labelable context
189+ )
123− ) => Table context (a, b, c)
190+ => Table context (a, b, c)
124− where
125− type Columns (a, b, c) =
126− HTrio
127− (HLabel "fst" (Columns a))
128− (HLabel "snd" (Columns b))
129− (HLabel "trd" (Columns c))
130− type Context (a, b, c) = Context a
131−
132− toColumns (a, b, c) = HTrio
133− { hfst = hlabel labeler $ toColumns a
134− , hsnd = hlabel labeler $ toColumns b
135− , htrd = hlabel labeler $ toColumns c
136− }
137− fromColumns (HTrio a b c) =
138− ( fromColumns $ hunlabel unlabeler a
139− , fromColumns $ hunlabel unlabeler b
140− , fromColumns $ hunlabel unlabeler c
141− )
142
191
143
192
144instance
193instance
145 ( Table context a, Table context b, Table context c, Table context d
194 ( Table context a, Table context b, Table context c, Table context d
146− , Labelable context
195+ )
147− ) => Table context (a, b, c, d)
196+ => Table context (a, b, c, d)
148− where
149− type Columns (a, b, c, d) =
150− HQuartet
151− (HLabel "fst" (Columns a))
152− (HLabel "snd" (Columns b))
153− (HLabel "trd" (Columns c))
154− (HLabel "frt" (Columns d))
155− type Context (a, b, c, d) = Context a
156−
157− toColumns (a, b, c, d) = HQuartet
158− { hfst = hlabel labeler $ toColumns a
159− , hsnd = hlabel labeler $ toColumns b
160− , htrd = hlabel labeler $ toColumns c
161− , hfrt = hlabel labeler $ toColumns d
162− }
163− fromColumns (HQuartet a b c d) =
164− ( fromColumns $ hunlabel unlabeler a
165− , fromColumns $ hunlabel unlabeler b
166− , fromColumns $ hunlabel unlabeler c
167− , fromColumns $ hunlabel unlabeler d
168− )
169
197
170
198
171instance
199instance
172 ( Table context a, Table context b, Table context c, Table context d
200 ( Table context a, Table context b, Table context c, Table context d
173 , Table context e
201 , Table context e
174− , Labelable context
202+ )
175− ) => Table context (a, b, c, d, e)
203+ => Table context (a, b, c, d, e)
176− where
177− type Columns (a, b, c, d, e) =
178− HQuintet
179− (HLabel "fst" (Columns a))
180− (HLabel "snd" (Columns b))
181− (HLabel "trd" (Columns c))
182− (HLabel "frt" (Columns d))
183− (HLabel "fft" (Columns e))
184− type Context (a, b, c, d, e) = Context a
185−
186− toColumns (a, b, c, d, e) = HQuintet
187− { hfst = hlabel labeler $ toColumns a
188− , hsnd = hlabel labeler $ toColumns b
189− , htrd = hlabel labeler $ toColumns c
190− , hfrt = hlabel labeler $ toColumns d
191− , hfft = hlabel labeler $ toColumns e
192− }
193− fromColumns (HQuintet a b c d e) =
194− ( fromColumns $ hunlabel unlabeler a
195− , fromColumns $ hunlabel unlabeler b
196− , fromColumns $ hunlabel unlabeler c
197− , fromColumns $ hunlabel unlabeler d
198− , fromColumns $ hunlabel unlabeler e
199− )
200−
201−
202−instance Table Expr Opaque where
203− type Columns Opaque = HType Opaque
204− type Context Opaque = Expr
205
204
206− fromColumns = error "opaque"
207− toColumns = error "opaque"
208
205
206+instance
207+ ( Table context a, Table context b, Table context c, Table context d
208+ , Table context e, Table context f
209+ )
210+ => Table context (a, b, c, d, e, f)
209
211
210−instance Table context (Opaque context a) where
211− type Columns (Opaque context a) = HType Opaque
212− type Context (Opaque context a) = context
213
212
214− fromColumns = error "opaque"
213+instance
215− toColumns = error "opaque"
214+ ( Table context a, Table context b, Table context c, Table context d
215+ , Table context e, Table context f, Table context g
216+ )
217+ => Table context (a, b, c, d, e, f, g)
216
218
217
219
218type Congruent :: Type -> Type -> Constraint
220type Congruent :: Type -> Type -> Constraint
src/Rel8/Table/ADT.hsnew file+173
@@ -0,0 +1,173 @@
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+40−17
@@ -6,9 +6,8 @@
6{-# language ViewPatterns #-}
6{-# language ViewPatterns #-}
7
7
8module Rel8.Table.Aggregate
8module Rel8.Table.Aggregate
9− ( groupBy
9+ ( groupBy, hgroupBy
10− , listAgg
10+ , listAgg, nonEmptyAgg
11− , nonEmptyAgg
12 )
11 )
13where
12where
14
13
@@ -17,25 +16,49 @@ import Data.Functor.Identity ( Identity( Identity ) )
17import Prelude
16import Prelude
18
17
19-- rel8
18-- rel8
20−import Rel8.Aggregate ( Aggregate, Col(..) )
19+import Rel8.Aggregate ( Aggregate, Aggregates )
21−import Rel8.Expr ( Expr, Col(..) )
20+import Rel8.Expr ( Expr )
22−import Rel8.Expr.Aggregate ( groupByExpr, listAggExpr, nonEmptyAggExpr )
21+import Rel8.Expr.Aggregate
22+ ( groupByExpr
23+ , slistAggExpr
24+ , snonEmptyAggExpr
25+ )
23import Rel8.Schema.Dict ( Dict( Dict ) )
26import Rel8.Schema.Dict ( Dict( Dict ) )
24−import Rel8.Schema.HTable ( htabulate, hfield )
27+import Rel8.Schema.HTable ( HTable, hfield, htabulate )
25import Rel8.Schema.HTable.Vectorize ( hvectorize )
28import Rel8.Schema.HTable.Vectorize ( hvectorize )
26−import Rel8.Table ( Table, toColumns, fromColumns )
29+import Rel8.Schema.Null ( Sql )
30+import Rel8.Schema.Spec ( Spec( Spec, info ) )
31+import Rel8.Table ( toColumns, fromColumns )
27import Rel8.Table.Eq ( EqTable, eqTable )
32import Rel8.Table.Eq ( EqTable, eqTable )
28import Rel8.Table.List ( ListTable )
33import Rel8.Table.List ( ListTable )
29import Rel8.Table.NonEmpty ( NonEmptyTable )
34import Rel8.Table.NonEmpty ( NonEmptyTable )
35+import Rel8.Type.Eq ( DBEq )
30
36
31
37
32-- | Group equal tables together. This works by aggregating each column in the
38-- | Group equal tables together. This works by aggregating each column in the
33-- given table with 'groupByExpr'.
39-- given table with 'groupByExpr'.
34−groupBy :: forall exprs. EqTable exprs => exprs -> Aggregate exprs
40+--
35−groupBy (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
41+-- For example, if we have a table of items, we could group the items by the
36− case hfield (eqTable @exprs) field of
42+-- order they belong to:
43+--
44+-- @
45+-- itemsByOrder :: Query (OrderId Expr, ListTable Expr (Item Expr))
46+-- itemsByOrder = aggregate $ do
47+-- item <- each itemSchema
48+-- let orderId = groupBy (itemOrderId item)
49+-- let orderItems = listAgg item
50+-- pure (orderId, orderItems)
51+-- @
52+groupBy :: forall exprs aggregates. (EqTable exprs, Aggregates aggregates exprs)
53+ => exprs -> aggregates
54+groupBy = fromColumns . hgroupBy (eqTable @exprs) . toColumns
55+
56+
57+hgroupBy :: HTable t => t (Dict (Sql DBEq)) -> t Expr -> t Aggregate
58+hgroupBy eqs exprs = htabulate $ \field ->
59+ case hfield eqs field of
37 Dict -> case hfield exprs field of
60 Dict -> case hfield exprs field of
38− DB expr -> Aggregation $ groupByExpr expr
61+ expr -> groupByExpr expr
39
62
40
63
41-- | Aggregate rows into a single row containing an array of all aggregated
64-- | Aggregate rows into a single row containing an array of all aggregated
@@ -48,22 +71,22 @@ groupBy (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
48-- items:
71-- items:
49--
72--
50-- @
73-- @
51−-- ordersWithItems :: Query (Order Expr, ListTable (Item Expr))
74+-- ordersWithItems :: Query (Order Expr, ListTable Expr (Item Expr))
52-- ordersWithItems = do
75-- ordersWithItems = do
53-- order <- each orderSchema
76-- order <- each orderSchema
54-- items <- aggregate $ listAgg <$> itemsFromOrder order
77-- items <- aggregate $ listAgg <$> itemsFromOrder order
55-- return (order, items)
78-- return (order, items)
56-- @
79-- @
57−listAgg :: Table Expr exprs => exprs -> Aggregate (ListTable exprs)
80+listAgg :: Aggregates aggregates exprs => exprs -> ListTable Aggregate aggregates
58listAgg (toColumns -> exprs) = fromColumns $
81listAgg (toColumns -> exprs) = fromColumns $
59 hvectorize
82 hvectorize
60− (\_ (Identity (DB a)) -> Aggregation $ listAggExpr a)
83+ (\Spec {info} (Identity a) -> slistAggExpr info a)
61 (pure exprs)
84 (pure exprs)
62
85
63
86
64-- | Like 'listAgg', but the result is guaranteed to be a non-empty list.
87-- | Like 'listAgg', but the result is guaranteed to be a non-empty list.
65−nonEmptyAgg :: Table Expr exprs => exprs -> Aggregate (NonEmptyTable exprs)
88+nonEmptyAgg :: Aggregates aggregates exprs => exprs -> NonEmptyTable Aggregate aggregates
66nonEmptyAgg (toColumns -> exprs) = fromColumns $
89nonEmptyAgg (toColumns -> exprs) = fromColumns $
67 hvectorize
90 hvectorize
68− (\_ (Identity (DB a)) -> Aggregation $ nonEmptyAggExpr a)
91+ (\Spec {info} (Identity a) -> snonEmptyAggExpr info a)
69 (pure exprs)
92 (pure exprs)
src/Rel8/Table/Alternative.hs+2−2
@@ -20,8 +20,8 @@ import Rel8.Table ( Table )
20-- | Like 'Alt' in Haskell. This class is purely a Rel8 concept, and allows you
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'.
21-- to take a choice between two tables. See also 'AlternativeTable'.
22--
22--
23−-- For example, using '<|>:' on 'MaybeTable' allows you to combine two tables
23+-- For example, using '<|>:' on 'Rel8.MaybeTable' allows you to combine two
24−-- and to return the first one that is a "just" MaybeTable.
24+-- tables and to return the first one that is a "just" MaybeTable.
25type AltTable :: (Type -> Type) -> Constraint
25type AltTable :: (Type -> Type) -> Constraint
26class AltTable f where
26class AltTable f where
27 -- | An associative binary operation on 'Table's.
27 -- | An associative binary operation on 'Table's.
src/Rel8/Table/Bool.hs+19−6
@@ -5,6 +5,7 @@
5module Rel8.Table.Bool
5module Rel8.Table.Bool
6 ( bool
6 ( bool
7 , case_
7 , case_
8+ , nullable
8 )
9 )
9where
10where
10
11
@@ -12,24 +13,36 @@ where
12import Prelude
13import Prelude
13
14
14-- rel8
15-- rel8
15−import Rel8.Expr ( Expr, Col(..) )
16+import Rel8.Expr ( Expr )
16import Rel8.Expr.Bool ( boolExpr, caseExpr )
17import Rel8.Expr.Bool ( boolExpr, caseExpr )
18+import Rel8.Expr.Null ( isNull, unsafeUnnullify )
17import Rel8.Schema.HTable ( htabulate, hfield )
19import Rel8.Schema.HTable ( htabulate, hfield )
18import Rel8.Table ( Table, fromColumns, toColumns )
20import Rel8.Table ( Table, fromColumns, toColumns )
19
21
20
22
23+-- | An if-then-else expression on tables.
24+--
25+-- @bool x y p@ returns @x@ if @p@ is @False@, and returns @y@ if @p@ is
26+-- @True@.
21bool :: Table Expr a => a -> a -> Expr Bool -> a
27bool :: Table Expr a => a -> a -> Expr Bool -> a
22bool (toColumns -> false) (toColumns -> true) condition =
28bool (toColumns -> false) (toColumns -> true) condition =
23 fromColumns $ htabulate $ \field ->
29 fromColumns $ htabulate $ \field ->
24 case (hfield false field, hfield true field) of
30 case (hfield false field, hfield true field) of
25− (DB falseExpr, DB trueExpr) ->
31+ (falseExpr, trueExpr) -> boolExpr falseExpr trueExpr condition
26− DB (boolExpr falseExpr trueExpr condition)
27{-# INLINABLE bool #-}
32{-# INLINABLE bool #-}
28
33
29
34
35+-- | Produce a table expression from a list of alternatives. Returns the first
36+-- table where the @Expr Bool@ expression is @True@. If no alternatives are
37+-- true, the given default is returned.
30case_ :: Table Expr a => [(Expr Bool, a)] -> a -> a
38case_ :: Table Expr a => [(Expr Bool, a)] -> a -> a
31case_ (map (fmap toColumns) -> branches) (toColumns -> fallback) =
39case_ (map (fmap toColumns) -> branches) (toColumns -> fallback) =
32 fromColumns $ htabulate $ \field -> case hfield fallback field of
40 fromColumns $ htabulate $ \field -> case hfield fallback field of
33− DB fallbackExpr ->
41+ fallbackExpr ->
34− case map (fmap (unDB . (`hfield` field))) branches of
42+ case map (fmap (`hfield` field)) branches of
35− branchExprs -> DB (caseExpr branchExprs fallbackExpr)
43+ branchExprs -> caseExpr branchExprs fallbackExpr
44+
45+
46+-- | Like 'maybe', but to eliminate @null@.
47+nullable :: Table Expr b => b -> (Expr a -> b) -> Expr (Maybe a) -> b
48+nullable b f ma = bool (f (unsafeUnnullify ma)) b (isNull ma)
src/Rel8/Table/Cols.hsnew file+50
@@ -0,0 +1,50 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleInstances #-}
3+{-# language MultiParamTypeClasses #-}
4+{-# language StandaloneKindSignatures #-}
5+{-# language TypeFamilies #-}
6+{-# language UndecidableInstances #-}
7+
8+module Rel8.Table.Cols
9+ ( Cols( Cols )
10+ , fromCols
11+ , toCols
12+ )
13+where
14+
15+-- base
16+import Data.Kind ( Type )
17+import Prelude
18+
19+-- rel8
20+import qualified Rel8.Schema.Kind as K
21+import Rel8.Schema.HTable ( HTable )
22+import Rel8.Schema.Result ( Result )
23+import Rel8.Table ( Table(..) )
24+
25+
26+type Cols :: K.Context -> K.HTable -> Type
27+newtype Cols context columns = Cols (columns context)
28+
29+
30+instance (HTable columns, context ~ context') =>
31+ Table context' (Cols context columns)
32+ where
33+ type Columns (Cols context columns) = columns
34+ type Context (Cols context columns) = context
35+ type FromExprs (Cols context columns) = Cols Result columns
36+ type Transpose to (Cols context columns) = Cols to columns
37+
38+ toColumns (Cols a) = a
39+ fromColumns = Cols
40+
41+ toResult (Cols a) = a
42+ fromResult = Cols
43+
44+
45+fromCols :: Table context a => Cols context (Columns a) -> a
46+fromCols (Cols a) = fromColumns a
47+
48+
49+toCols :: Table context a => a -> Cols context (Columns a)
50+toCols = Cols . toColumns
src/Rel8/Table/Either.hs+154−116
@@ -3,6 +3,7 @@
3{-# language DerivingStrategies #-}
3{-# language DerivingStrategies #-}
4{-# language FlexibleContexts #-}
4{-# language FlexibleContexts #-}
5{-# language FlexibleInstances #-}
5{-# language FlexibleInstances #-}
6+{-# language LambdaCase #-}
6{-# language MultiParamTypeClasses #-}
7{-# language MultiParamTypeClasses #-}
7{-# language NamedFieldPuns #-}
8{-# language NamedFieldPuns #-}
8{-# language ScopedTypeVariables #-}
9{-# language ScopedTypeVariables #-}
@@ -11,195 +12,232 @@
11{-# language TypeFamilies #-}
12{-# language TypeFamilies #-}
12{-# language UndecidableInstances #-}
13{-# language UndecidableInstances #-}
13
14
15+{-# options_ghc -fno-warn-orphans #-}
16+
14module Rel8.Table.Either
17module Rel8.Table.Either
15 ( EitherTable(..)
18 ( EitherTable(..)
16 , eitherTable, leftTable, rightTable
19 , eitherTable, leftTable, rightTable
17 , isLeftTable, isRightTable
20 , isLeftTable, isRightTable
18− , aggregateEitherTable, nameEitherTable
21+ , aggregateEitherTable
22+ , nameEitherTable
19 )
23 )
20where
24where
21
25
22-- base
26-- base
23import Data.Bifunctor ( Bifunctor, bimap )
27import Data.Bifunctor ( Bifunctor, bimap )
24−import Data.Functor.Identity ( runIdentity )
28+import Data.Functor.Identity ( Identity( Identity ) )
25import Data.Kind ( Type )
29import Data.Kind ( Type )
26import Prelude hiding ( undefined )
30import Prelude hiding ( undefined )
27
31
32+-- comonad
33+import Control.Comonad ( extract )
34+
28-- rel8
35-- rel8
29−import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )
36+import Rel8.Aggregate ( Aggregate )
30import Rel8.Expr ( Expr )
37import Rel8.Expr ( Expr )
31−import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
38+import Rel8.Expr.Aggregate ( groupByExpr )
32import Rel8.Expr.Serialize ( litExpr )
39import Rel8.Expr.Serialize ( litExpr )
33−import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler, hlabeler )
40+import Rel8.Kind.Context ( Reifiable )
34−import Rel8.Schema.Context.Nullify
41+import Rel8.Schema.Context.Nullify ( Nullifiable )
35− ( Nullifiable, ConstrainTag
42+import Rel8.Schema.Dict ( Dict( Dict ) )
36− , hencodeTag, hdecodeTag
43+import Rel8.Schema.HTable.Either ( HEitherTable(..) )
37− , hnullifier, hunnullifier
38− )
39−import Rel8.Schema.HTable.Either ( HEitherTable(..), HEitherNullifiable )
40import Rel8.Schema.HTable.Identity ( HIdentity(..) )
44import Rel8.Schema.HTable.Identity ( HIdentity(..) )
41−import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
45+import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
42−import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
46+import qualified Rel8.Schema.Kind as K
43import Rel8.Schema.Name ( Name )
47import Rel8.Schema.Name ( Name )
44−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+ )
45import Rel8.Table.Bool ( bool )
53import Rel8.Table.Bool ( bool )
46import Rel8.Table.Eq ( EqTable, eqTable )
54import Rel8.Table.Eq ( EqTable, eqTable )
47−import Rel8.Table.Lifted
55+import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )
48− ( Table2, Columns2, ConstrainHContext2, fromColumns2, toColumns2
49− )
50import Rel8.Table.Ord ( OrdTable, ordTable )
56import Rel8.Table.Ord ( OrdTable, ordTable )
51−import Rel8.Table.Recontextualize ( Recontextualize )
57+import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )
52−import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )
58+import Rel8.Table.Serialize ( ToExprs )
53import Rel8.Table.Undefined ( undefined )
59import Rel8.Table.Undefined ( undefined )
54import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
60import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
55
61
56-- semigroupoids
62-- semigroupoids
57−import Data.Functor.Apply ( Apply, (<.>), liftF3 )
63+import Data.Functor.Apply ( Apply, (<.>) )
58import Data.Functor.Bind ( Bind, (>>-) )
64import Data.Functor.Bind ( Bind, (>>-) )
59
65
60
66
61−type EitherTable :: Type -> Type -> Type
67+-- | An @EitherTable a b@ is a Rel8 table that contains either the table @a@ or
62−data EitherTable a b = EitherTable
68+-- the table @b@. You can construct an @EitherTable@ using 'leftTable' and
63− { tag :: Tag "isRight" EitherTag
69+-- 'rightTable', and eliminate/pattern match using 'eitherTable'.
64− , left :: a
70+--
65− , right :: b
71+-- An @EitherTable@ is operationally the same as Haskell's 'Either' type, but
72+-- adapted to work with Rel8.
73+type EitherTable :: K.Context -> Type -> Type -> Type
74+data EitherTable context a b = EitherTable
75+ { tag :: context EitherTag
76+ , left :: Nullify context a
77+ , right :: Nullify context b
66 }
78 }
67 deriving stock Functor
79 deriving stock Functor
68
80
69
81
70−instance Bifunctor EitherTable where
82+instance Biprojectable (EitherTable context) where
71− bimap f g (EitherTable tag a b) = EitherTable tag (f a) (g b)
83+ biproject f g (EitherTable tag a b) =
84+ EitherTable tag (project f a) (project g b)
85+
86+
87+instance Nullifiable context => Bifunctor (EitherTable context) where
88+ bimap f g (EitherTable tag a b) = EitherTable tag (fmap f a) (fmap g b)
89+
72
90
91+instance Projectable (EitherTable context a) where
92+ project f (EitherTable tag a b) = EitherTable tag a (project f b)
73
93
74−instance Table Expr a => Apply (EitherTable a) where
94+
95+instance (context ~ Expr, Table Expr a) => Apply (EitherTable context a) where
75 EitherTable tag l1 f <.> EitherTable tag' l2 a =
96 EitherTable tag l1 f <.> EitherTable tag' l2 a =
76− EitherTable (tag <> tag') (bool l1 l2 (isLeft (expr tag))) (f a)
97+ EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f <.> a)
77
98
78
99
79−instance Table Expr a => Applicative (EitherTable a) where
100+instance (context ~ Expr, Table Expr a) => Applicative (EitherTable context a) where
80 pure = rightTable
101 pure = rightTable
81 (<*>) = (<.>)
102 (<*>) = (<.>)
82
103
83
104
84−instance Table Expr a => Bind (EitherTable a) where
105+instance (context ~ Expr, Table Expr a) => Bind (EitherTable context a) where
85− EitherTable tag l1 a >>- f = case f a of
106+ EitherTable tag l1 a >>- f = case f (extract a) of
86 EitherTable tag' l2 b ->
107 EitherTable tag' l2 b ->
87− EitherTable (tag <> tag') (bool l1 l2 (isRight (expr tag))) b
108+ EitherTable (tag <> tag') (bool l1 l2 (isRight tag)) b
88
109
89
110
90−instance Table Expr a => Monad (EitherTable a) where
111+instance (context ~ Expr, Table Expr a) => Monad (EitherTable context a) where
91 (>>=) = (>>-)
112 (>>=) = (>>-)
92
113
93
114
94−instance (Table Expr a, Table Expr b) => Semigroup (EitherTable a b) where
115+instance (context ~ Expr, Table Expr a, Table Expr b) =>
116+ Semigroup (EitherTable context a b)
117+ where
95 a <> b = bool a b (isRightTable a)
118 a <> b = bool a b (isRightTable a)
96
119
97
120
98−instance Table2 EitherTable where
121+instance
99− type Columns2 EitherTable = HEitherTable
122+ ( Table context a, Table context b
100− type ConstrainHContext2 EitherTable = HEitherNullifiable
123+ , Reifiable context, context ~ context'
124+ )
125+ => Table context' (EitherTable context a b)
126+ where
127+ type Columns (EitherTable context a b) = HEitherTable (Columns a) (Columns b)
128+ type Context (EitherTable context a b) = Context a
129+ type FromExprs (EitherTable context a b) = Either (FromExprs a) (FromExprs b)
130+ type Transpose to (EitherTable context a b) =
131+ EitherTable to (Transpose to a) (Transpose to b)
132+
133+ toColumns EitherTable {tag, left, right} = HEitherTable
134+ { htag = hlabel $ HIdentity tag
135+ , hleft = hlabel $ guard tag (== IsLeft) isLeft $ toColumns left
136+ , hright = hlabel $ guard tag (== IsRight) isRight $ toColumns right
137+ }
101
138
102− toColumns2 f g EitherTable {tag, left, right} = HEitherTable
139+ fromColumns HEitherTable {htag, hleft, hright} = EitherTable
103− { htag
140+ { tag = unHIdentity $ hunlabel htag
104− , hleft = hnullify (hnullifier tag isLeft) $ f left
141+ , left = fromColumns $ hunlabel hleft
105− , hright = hnullify (hnullifier tag isRight) $ g right
142+ , right = fromColumns $ hunlabel hright
106 }
143 }
107− where
144+
108− htag = HIdentity (hencodeTag tag)
145+ toResult = \case
109−
146+ Left table -> HEitherTable
110− fromColumns2 f g HEitherTable {htag = htag, hleft, hright} =
147+ { htag = hlabel (HIdentity (Identity IsLeft))
111− EitherTable
148+ , hleft = hlabel (toResult @_ @(Nullify context a) (Just table))
112− { tag
149+ , hright = hlabel (toResult @_ @(Nullify context b) Nothing)
113− , left = f $ runIdentity $
150+ }
114− hunnullify (\a -> pure . hunnullifier a) hleft
151+ Right table -> HEitherTable
115− , right = g $ runIdentity $
152+ { htag = hlabel (HIdentity (Identity IsRight))
116− hunnullify (\a -> pure . hunnullifier a) hright
153+ , hleft = hlabel (toResult @_ @(Nullify context a) Nothing)
154+ , hright = hlabel (toResult @_ @(Nullify context b) (Just table))
117 }
155 }
118− where
119− tag = hdecodeTag $ unHIdentity htag
120
156
121− {-# INLINABLE fromColumns2 #-}
157+ fromResult HEitherTable {htag, hleft, hright} = case hunlabel htag of
122− {-# INLINABLE toColumns2 #-}
158+ HIdentity (Identity tag) -> case tag of
159+ IsLeft -> maybe err Left $ fromResult @_ @(Nullify context a) (hunlabel hleft)
160+ IsRight -> maybe err Right $ fromResult @_ @(Nullify context b) (hunlabel hright)
161+ where
162+ err = error "Either.fromColumns: mismatch between tag and data"
123
163
124
164
125−instance
165+instance (EqTable a, EqTable b, context ~ Expr) =>
126− ( Table context a, Table context b
166+ EqTable (EitherTable context a b)
127− , Labelable context, Nullifiable context, ConstrainTag context EitherTag
128− ) =>
129− Table context (EitherTable a b)
130 where
167 where
131− type Columns (EitherTable a b) =
168+ eqTable = HEitherTable
132− HEitherTable (HLabel "Left" (Columns a)) (HLabel "Right" (Columns b))
169+ { htag = hlabel (HIdentity Dict)
133− type Context (EitherTable a b) = Context a
170+ , hleft = hlabel (eqTable @(Nullify context a))
134−
171+ , hright = hlabel (eqTable @(Nullify context b))
135− toColumns =
172+ }
136− toColumns2
137− (hlabel labeler . toColumns)
138− (hlabel labeler . toColumns)
139− fromColumns =
140− fromColumns2
141− (fromColumns . hunlabel unlabeler)
142− (fromColumns . hunlabel unlabeler)
143−
144−
145−instance
146− ( Nullifiable from, Labelable from, ConstrainTag from EitherTag
147− , Nullifiable to, Labelable to, ConstrainTag to EitherTag
148− , Recontextualize from to a1 b1
149− , Recontextualize from to a2 b2
150− ) =>
151− Recontextualize from to (EitherTable a1 a2) (EitherTable b1 b2)
152
173
153
174
154−instance (EqTable a, EqTable b) => EqTable (EitherTable a b) where
175+instance (OrdTable a, OrdTable b, context ~ Expr) =>
155− eqTable =
176+ OrdTable (EitherTable context a b)
156− toColumns2 (hlabel hlabeler) (hlabel hlabeler)
177+ where
157− (rightTableWith (eqTable @a) (eqTable @b))
178+ ordTable = HEitherTable
179+ { htag = hlabel (HIdentity Dict)
180+ , hleft = hlabel (ordTable @(Nullify context a))
181+ , hright = hlabel (ordTable @(Nullify context b))
182+ }
158
183
159
184
160−instance (OrdTable a, OrdTable b) => OrdTable (EitherTable a b) where
185+instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable Expr exprs1 exprs2) =>
161− ordTable =
186+ ToExprs x (Either a b)
162− toColumns2 (hlabel hlabeler) (hlabel hlabeler)
163− (rightTableWith (ordTable @a) (ordTable @b))
164
187
165
188
166−isLeftTable :: EitherTable a b -> Expr Bool
189+-- | Test if an 'EitherTable' is a 'leftTable'.
167−isLeftTable = isLeft . expr . tag
190+isLeftTable :: EitherTable Expr a b -> Expr Bool
191+isLeftTable EitherTable {tag} = isLeft tag
168
192
169
193
170−isRightTable :: EitherTable a b -> Expr Bool
194+-- | Test if an 'EitherTable' is a 'rightTable'.
171−isRightTable = isRight . expr . tag
195+isRightTable :: EitherTable Expr a b -> Expr Bool
196+isRightTable EitherTable {tag} = isRight tag
172
197
173
198
199+-- | Pattern match/eliminate an 'EitherTable', by providing mappings from a
200+-- 'leftTable' and 'rightTable'.
174eitherTable :: Table Expr c
201eitherTable :: Table Expr c
175− => (a -> c) -> (b -> c) -> EitherTable a b -> c
202+ => (a -> c) -> (b -> c) -> EitherTable Expr a b -> c
176eitherTable f g EitherTable {tag, left, right} =
203eitherTable f g EitherTable {tag, left, right} =
177− bool (f left) (g right) (isRight (expr tag))
204+ bool (f (extract left)) (g (extract right)) (isRight tag)
178
205
179
206
180−leftTable :: Table Expr b => a -> EitherTable a b
207+-- | Construct a left 'EitherTable'. Like 'Left'.
181−leftTable a = EitherTable (fromExpr (litExpr IsLeft)) a undefined
208+leftTable :: Table Expr b => a -> EitherTable Expr a b
209+leftTable a = EitherTable (litExpr IsLeft) (pure a) undefined
182
210
183
211
184−rightTable :: Table Expr a => b -> EitherTable a b
212+-- | Construct a right 'EitherTable'. Like 'Right'.
185−rightTable = rightTableWith undefined
213+rightTable :: Table Expr a => b -> EitherTable Expr a b
214+rightTable = EitherTable (litExpr IsRight) undefined . pure
186
215
187
216
188−rightTableWith :: a -> b -> EitherTable a b
217+-- | Lift a pair of aggregating functions to operate on an 'EitherTable'.
189−rightTableWith = EitherTable (fromExpr (litExpr IsRight))
218+-- @leftTable@s and @rightTable@s are grouped separately.
219+aggregateEitherTable :: ()
220+ => (exprs -> aggregates)
221+ -> (exprs' -> aggregates')
222+ -> EitherTable Expr exprs exprs'
223+ -> EitherTable Aggregate aggregates aggregates'
224+aggregateEitherTable f g (EitherTable tag a b) = EitherTable
225+ { tag = groupByExpr tag
226+ , left = aggregateNullify f a
227+ , right = aggregateNullify g b
228+ }
190
229
191
230
192−aggregateEitherTable :: ()
231+-- | Construct a 'EitherTable' in the 'Name' context. This can be useful if you
193− => (a -> Aggregate c)
232+-- have a 'EitherTable' that you are storing in a table and need to construct a
194− -> (b -> Aggregate d)
233+-- 'TableSchema'.
195− -> EitherTable a b
234+nameEitherTable
196− -> Aggregate (EitherTable c d)
235+ :: Name EitherTag
197−aggregateEitherTable f g EitherTable {tag, left, right} =
236+ -- ^ The name of the column to track whether a row is a 'leftTable' or
198− liftF3 EitherTable (tag <$ aggregate) (f left) (g right)
237+ -- 'rightTable'.
199− where
238+ -> a
200− Tag {aggregator, expr} = tag
239+ -- ^ Names of the columns in the @a@ table.
201− aggregate = unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr
240+ -> b
202−
241+ -- ^ Names of the columns in the @b@ table.
203−
242+ -> EitherTable Name a b
204−nameEitherTable :: Name EitherTag -> a -> b -> EitherTable a b
243+nameEitherTable tag left right = EitherTable tag (pure left) (pure right)
205−nameEitherTable = EitherTable . fromName
src/Rel8/Table/Eq.hs+41−69
@@ -5,14 +5,12 @@
5{-# language DisambiguateRecordFields #-}
5{-# language DisambiguateRecordFields #-}
6{-# language FlexibleContexts #-}
6{-# language FlexibleContexts #-}
7{-# language FlexibleInstances #-}
7{-# language FlexibleInstances #-}
8−{-# language LambdaCase #-}
9−{-# language NamedFieldPuns #-}
10{-# language ScopedTypeVariables #-}
8{-# language ScopedTypeVariables #-}
11{-# language StandaloneKindSignatures #-}
9{-# language StandaloneKindSignatures #-}
12{-# language TypeApplications #-}
10{-# language TypeApplications #-}
13{-# language TypeFamilies #-}
11{-# language TypeFamilies #-}
12+{-# language TypeOperators #-}
14{-# language UndecidableInstances #-}
13{-# language UndecidableInstances #-}
15−{-# language UndecidableSuperClasses #-}
16{-# language ViewPatterns #-}
14{-# language ViewPatterns #-}
17
15
18module Rel8.Table.Eq
16module Rel8.Table.Eq
@@ -25,97 +23,71 @@ import Data.Foldable ( foldl' )
25import Data.Functor.Const ( Const( Const ), getConst )
23import Data.Functor.Const ( Const( Const ), getConst )
26import Data.Kind ( Constraint, Type )
24import Data.Kind ( Constraint, Type )
27import Data.List.NonEmpty ( NonEmpty( (:|) ) )
25import Data.List.NonEmpty ( NonEmpty( (:|) ) )
26+import GHC.Generics ( Rep )
28import Prelude
27import Prelude
29
28
30-- rel8
29-- rel8
31−import Rel8.Expr ( Expr, Col(..) )
30+import Rel8.Expr ( Expr )
32import Rel8.Expr.Bool ( (||.), (&&.) )
31import Rel8.Expr.Bool ( (||.), (&&.) )
33import Rel8.Expr.Eq ( (==.), (/=.) )
32import Rel8.Expr.Eq ( (==.), (/=.) )
34−import Rel8.Schema.Context.Label ( hlabeler )
33+import Rel8.FCF ( Eval, Exp )
34+import Rel8.Generic.Record ( Record )
35+import Rel8.Generic.Table.Record ( GTable, GColumns, gtable )
35import Rel8.Schema.Dict ( Dict( Dict ) )
36import Rel8.Schema.Dict ( Dict( Dict ) )
36−import Rel8.Schema.HTable
37+import Rel8.Schema.HTable ( htabulateA, hfield )
37− ( HTable, HConstrainTable
38+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
38− , htabulateA, hfield, hdicts
39+import Rel8.Schema.Null ( Sql )
39− )
40+import Rel8.Table ( Table, Columns, toColumns, TColumns )
40−import Rel8.Schema.HTable.Label ( hlabel )
41−import Rel8.Schema.HTable.Pair ( HPair(..) )
42−import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
43−import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
44−import Rel8.Schema.HTable.Trio ( HTrio(..) )
45−import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
46−import Rel8.Table ( Table, Columns, toColumns )
47import Rel8.Type.Eq ( DBEq )
41import Rel8.Type.Eq ( DBEq )
48−import Rel8.Schema.Nullability ( Sql )
49
42
50
43
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'".
51type EqTable :: Type -> Constraint
47type EqTable :: Type -> Constraint
52class Table Expr a => EqTable a where
48class Table Expr a => EqTable a where
53− eqTable :: Columns a (Dict (ConstrainDBType DBEq))
49+ eqTable :: Columns a (Dict (Sql DBEq))
54−
55− default eqTable :: ()
56− => HConstrainTable (Columns a) (ConstrainDBType DBEq)
57− => Columns a (Dict (ConstrainDBType DBEq))
58− eqTable = hdicts @(Columns a) @(ConstrainDBType DBEq)
59
50
51+ default eqTable ::
52+ ( GTable TEqTable TColumns (Rep (Record a))
53+ , Columns a ~ GColumns TColumns (Rep (Record a))
54+ )
55+ => Columns a (Dict (Sql DBEq))
56+ eqTable = gtable @TEqTable @TColumns @(Rep (Record a)) table
57+ where
58+ table (_ :: proxy x) = eqTable @x
60
59
61−instance
62− ( Table Expr (t Expr)
63− , f ~ Expr
64− , HConstrainTable (Columns (t Expr)) (ConstrainDBType DBEq)
65− )
66− => EqTable (t f)
67
60
68−
61+data TEqTable :: Type -> Exp Constraint
69−instance
62+type instance Eval (TEqTable a) = EqTable a
70− ( HTable t
71− , f ~ Col Expr
72− , HConstrainTable t (ConstrainDBType DBEq)
73− )
74− => EqTable (t f)
75
63
76
64
77−instance Sql DBEq a => EqTable (Expr a)
65+instance Sql DBEq a => EqTable (Expr a) where
66+ eqTable = HIdentity Dict
78
67
79
68
80−instance (EqTable a, EqTable b) => EqTable (a, b) where
69+instance (EqTable a, EqTable b) => EqTable (a, b)
81− eqTable =
82− HPair
83− { hfst = hlabel hlabeler (eqTable @a)
84− , hsnd = hlabel hlabeler (eqTable @b)
85− }
86
70
87
71
88−instance (EqTable a, EqTable b, EqTable c) => EqTable (a, b, c) where
72+instance (EqTable a, EqTable b, EqTable c) => EqTable (a, b, c)
89− eqTable =
90− HTrio
91− { hfst = hlabel hlabeler (eqTable @a)
92− , hsnd = hlabel hlabeler (eqTable @b)
93− , htrd = hlabel hlabeler (eqTable @c)
94− }
95
73
96
74
97instance (EqTable a, EqTable b, EqTable c, EqTable d) => EqTable (a, b, c, d)
75instance (EqTable a, EqTable b, EqTable c, EqTable d) => EqTable (a, b, c, d)
98− where
99− eqTable =
100− HQuartet
101− { hfst = hlabel hlabeler (eqTable @a)
102− , hsnd = hlabel hlabeler (eqTable @b)
103− , htrd = hlabel hlabeler (eqTable @c)
104− , hfrt = hlabel hlabeler (eqTable @d)
105− }
106
76
107
77
108instance (EqTable a, EqTable b, EqTable c, EqTable d, EqTable e) =>
78instance (EqTable a, EqTable b, EqTable c, EqTable d, EqTable e) =>
109 EqTable (a, b, c, d, e)
79 EqTable (a, b, c, d, e)
110− where
80+
111− eqTable =
81+
112− HQuintet
82+instance (EqTable a, EqTable b, EqTable c, EqTable d, EqTable e, EqTable f) =>
113− { hfst = hlabel hlabeler (eqTable @a)
83+ EqTable (a, b, c, d, e, f)
114− , hsnd = hlabel hlabeler (eqTable @b)
84+
115− , htrd = hlabel hlabeler (eqTable @c)
85+
116− , hfrt = hlabel hlabeler (eqTable @d)
86+instance
117− , hfft = hlabel hlabeler (eqTable @e)
87+ ( EqTable a, EqTable b, EqTable c, EqTable d, EqTable e, EqTable f
118− }
88+ , EqTable g
89+ )
90+ => EqTable (a, b, c, d, e, f, g)
119
91
120
92
121-- | Compare two 'Table's for equality. This corresponds to comparing all
93-- | Compare two 'Table's for equality. This corresponds to comparing all
@@ -125,7 +97,7 @@ instance (EqTable a, EqTable b, EqTable c, EqTable d, EqTable e) =>
125(toColumns -> as) ==: (toColumns -> bs) =
97(toColumns -> as) ==: (toColumns -> bs) =
126 foldl1' (&&.) $ getConst $ htabulateA $ \field ->
98 foldl1' (&&.) $ getConst $ htabulateA $ \field ->
127 case (hfield as field, hfield bs field) of
99 case (hfield as field, hfield bs field) of
128− (DB a, DB b) -> case hfield (eqTable @a) field of
100+ (a, b) -> case hfield (eqTable @a) field of
129 Dict -> Const (pure (a ==. b))
101 Dict -> Const (pure (a ==. b))
130infix 4 ==:
102infix 4 ==:
131
103
@@ -137,7 +109,7 @@ infix 4 ==:
137(toColumns -> as) /=: (toColumns -> bs) =
109(toColumns -> as) /=: (toColumns -> bs) =
138 foldl1' (||.) $ getConst $ htabulateA $ \field ->
110 foldl1' (||.) $ getConst $ htabulateA $ \field ->
139 case (hfield as field, hfield bs field) of
111 case (hfield as field, hfield bs field) of
140− (DB a, DB b) -> case hfield (eqTable @a) field of
112+ (a, b) -> case hfield (eqTable @a) field of
141 Dict -> Const (pure (a /=. b))
113 Dict -> Const (pure (a /=. b))
142infix 4 /=:
114infix 4 /=:
143
115
src/Rel8/Table/HKD.hsnew file+228
@@ -0,0 +1,228 @@
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.hsdeleted−51
@@ -1,51 +0,0 @@
1−{-# language FlexibleContexts #-}
2−{-# language NamedFieldPuns #-}
3−{-# language TypeFamilies #-}
4−{-# language ViewPatterns #-}
5−
6−module Rel8.Table.Insert
7− ( toInsert
8− , toInsertDefaults
9− )
10−where
11−
12−-- base
13−import Prelude
14−
15−-- rel8
16−import Rel8.Expr ( Col(..) )
17−import Rel8.Kind.Necessity ( SNecessity( SOptional, SRequired ) )
18−import Rel8.Schema.HTable ( hfield, htabulate, hspecs )
19−import Rel8.Schema.Insert ( Inserts, Col(..) )
20−import Rel8.Schema.Spec ( SSpec(..) )
21−import Rel8.Table ( fromColumns, toColumns )
22−
23−
24−-- | @toInsert@ converts a 'Table' of 'Expr's into a 'Table' that can be used
25−-- with 'insert'. This will override any columns that have default values to
26−-- use exactly what is given. If you want to use default values, you can either
27−-- override the result of @toInsert@, or use 'toInsertDefaults'.
28−toInsert :: Inserts exprs inserts => exprs -> inserts
29−toInsert (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
30− case hfield hspecs field of
31− SSpec {necessity} -> case hfield exprs field of
32− DB expr -> case necessity of
33− SRequired -> RequiredInsert expr
34− SOptional -> OptionalInsert (Just expr)
35−
36−
37−-- | @toInsertDefaults@ converts a 'Table' of 'Expr's into a 'Table' that can
38−-- be used with 'insert'. Any columns that have a default value will override
39−-- whatever is in the input expression.
40−--
41−-- One example where this is useful is for any table that has a special @id@
42−-- column, which has a default value to draw a new value from a sequence. If we
43−-- use 'toInsertDefaults', we can provide a dummy value that will be replaced
44−-- with a call to @DEFAULT@.
45−toInsertDefaults :: Inserts exprs inserts => exprs -> inserts
46−toInsertDefaults (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
47− case hfield hspecs field of
48− SSpec {necessity} -> case hfield exprs field of
49− DB expr -> case necessity of
50− SRequired -> RequiredInsert expr
51− SOptional -> OptionalInsert Nothing
src/Rel8/Table/Lifted.hsdeleted−82
@@ -1,82 +0,0 @@
1−{-# language ConstrainedClassMethods #-}
2−{-# language ConstraintKinds #-}
3−{-# language DataKinds #-}
4−{-# language FlexibleContexts #-}
5−{-# language FlexibleInstances #-}
6−{-# language MultiParamTypeClasses #-}
7−{-# language QuantifiedConstraints #-}
8−{-# language StandaloneKindSignatures #-}
9−{-# language TypeFamilies #-}
10−{-# language UndecidableInstances #-}
11−
12−module Rel8.Table.Lifted
13− ( Table1( Columns1, ConstrainHContext1, toColumns1, fromColumns1 )
14− , Table2( Columns2, ConstrainHContext2, toColumns2, fromColumns2 )
15− , ConstrainContext
16− )
17−where
18−
19−-- base
20−import Data.Kind ( Constraint, Type )
21−import Prelude ()
22−
23−-- rel8
24−import Rel8.Schema.Context ( Col )
25−import Rel8.Schema.HTable ( HTable )
26−import Rel8.Schema.HTable.Pair
27−import qualified Rel8.Schema.Kind as K
28−
29−
30−type Table1 :: (Type -> Type) -> Constraint
31−class Table1 f where
32− type Columns1 f :: K.HTable -> K.HTable
33− type ConstrainHContext1 f :: K.HContext -> Constraint
34− type ConstrainHContext1 _ = DefaultConstrainContext
35−
36− toColumns1 :: (ConstrainHContext1 f context, HTable t)
37− => (a -> t context)
38− -> f a
39− -> Columns1 f t context
40−
41− fromColumns1 :: (ConstrainHContext1 f context, HTable t)
42− => (t context -> a)
43− -> Columns1 f t context
44− -> f a
45−
46−
47−type Table2 :: (Type -> Type -> Type) -> Constraint
48−class Table2 p where
49− type Columns2 p :: K.HTable -> K.HTable -> K.HTable
50− type ConstrainHContext2 p :: K.HContext -> Constraint
51− type ConstrainHContext2 _ = DefaultConstrainContext
52−
53− toColumns2 :: (ConstrainHContext2 p context, HTable t, HTable u)
54− => (a -> t context)
55− -> (b -> u context)
56− -> p a b
57− -> Columns2 p t u context
58−
59− fromColumns2 :: (ConstrainHContext2 p context, HTable t, HTable u)
60− => (t context -> a)
61− -> (u context -> b)
62− -> Columns2 p t u context
63− -> p a b
64−
65−
66−instance Table2 (,) where
67− type Columns2 (,) = HPair
68−
69− toColumns2 f g (a, b) = HPair (f a) (g b)
70− fromColumns2 f g (HPair a b) = (f a, g b)
71−
72−
73−type DefaultConstrainContext :: K.HContext -> Constraint
74−class DefaultConstrainContext context
75−instance DefaultConstrainContext context
76−
77−
78−type ConstrainContext :: (K.Context -> Constraint) -> K.HContext -> Constraint
79−class (forall context. hcontext ~ Col context => constraint context)
80− => ConstrainContext constraint hcontext
81−instance (hcontext ~ Col context, constraint context) =>
82− ConstrainContext constraint hcontext
src/Rel8/Table/List.hs+85−37
@@ -1,3 +1,4 @@
1+{-# language DataKinds #-}
1{-# language FlexibleContexts #-}
2{-# language FlexibleContexts #-}
2{-# language FlexibleInstances #-}
3{-# language FlexibleInstances #-}
3{-# language MultiParamTypeClasses #-}
4{-# language MultiParamTypeClasses #-}
@@ -10,7 +11,9 @@
10
11
11module Rel8.Table.List
12module Rel8.Table.List
12 ( ListTable(..)
13 ( ListTable(..)
14+ , ($*)
13 , listTable
15 , listTable
16+ , nameListTable
14 )
17 )
15where
18where
16
19
@@ -20,82 +23,127 @@ import Data.Kind ( Type )
20import Prelude
23import Prelude
21
24
22-- rel8
25-- rel8
23−import Rel8.Expr ( Expr, Col(..) )
26+import Rel8.Expr ( Expr )
24import Rel8.Expr.Array ( sappend, sempty, slistOf )
27import Rel8.Expr.Array ( sappend, sempty, slistOf )
25import Rel8.Schema.Dict ( Dict( Dict ) )
28import Rel8.Schema.Dict ( Dict( Dict ) )
26import Rel8.Schema.HTable.List ( HListTable )
29import Rel8.Schema.HTable.List ( HListTable )
27−import Rel8.Schema.HTable.Vectorize ( happend, hempty, hvectorize )
30+import Rel8.Schema.HTable.Vectorize
28−import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
31+ ( hvectorize, hunvectorize
29−import Rel8.Schema.Spec ( SSpec(..) )
32+ , happend, hempty
30−import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullability )
33+ , hproject, hcolumn
31−import Rel8.Table ( Table, Context, Columns, fromColumns, toColumns )
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+ )
32import Rel8.Table.Alternative
45import Rel8.Table.Alternative
33 ( AltTable, (<|>:)
46 ( AltTable, (<|>:)
34 , AlternativeTable, emptyTable
47 , AlternativeTable, emptyTable
35 )
48 )
36import Rel8.Table.Eq ( EqTable, eqTable )
49import Rel8.Table.Eq ( EqTable, eqTable )
37import Rel8.Table.Ord ( OrdTable, ordTable )
50import Rel8.Table.Ord ( OrdTable, ordTable )
38−import Rel8.Table.Recontextualize ( Recontextualize )
51+import Rel8.Table.Projection
52+ ( Projectable, Projecting, Projection, project, apply
53+ )
54+import Rel8.Table.Serialize ( ToExprs )
39
55
40
56
41-- | A @ListTable@ value contains zero or more instances of @a@. You construct
57-- | A @ListTable@ value contains zero or more instances of @a@. You construct
42−-- @ListTable@s with 'many' or 'listAgg'.
58+-- @ListTable@s with 'Rel8.many' or 'Rel8.listAgg'.
43−type ListTable :: Type -> Type
59+type ListTable :: K.Context -> Type -> Type
44−newtype ListTable a = ListTable (HListTable (Columns a) (Col (Context a)))
60+newtype ListTable context a =
61+ ListTable (HListTable (Columns a) (Context a))
45
62
46
63
47−instance Table context a => Table context (ListTable a) where
64+instance Projectable (ListTable context) where
48− type Columns (ListTable a) = HListTable (Columns a)
65+ project f (ListTable a) = ListTable (hproject (apply f) a)
49− type Context (ListTable a) = Context a
50
66
51− fromColumns = ListTable
52− toColumns (ListTable a) = a
53
67
68+instance (Table context a, context ~ context') =>
69+ Table context' (ListTable context a)
70+ where
71+ type Columns (ListTable context a) = HListTable (Columns a)
72+ type Context (ListTable context a) = Context a
73+ type FromExprs (ListTable context a) = [FromExprs a]
74+ type Transpose to (ListTable context a) = ListTable to (Transpose to a)
54
75
55−instance Recontextualize from to a b =>
76+ fromColumns = ListTable
56− Recontextualize from to (ListTable a) (ListTable b)
77+ toColumns (ListTable a) = a
78+ fromResult = fmap (fromResult @_ @a) . hunvectorize unvectorizer
79+ toResult = hvectorize vectorizer . fmap (toResult @_ @a)
57
80
58
81
59−instance EqTable a => EqTable (ListTable a) where
82+instance (EqTable a, context ~ Expr) => EqTable (ListTable context a) where
60 eqTable =
83 eqTable =
61 hvectorize
84 hvectorize
62− (\SSpec {} (Identity dict) -> case dbTypeDict dict of
85+ (\Spec {nullity} (Identity Dict) -> case nullity of
63− Dict -> case dbTypeNullability dict of
86+ Null -> Dict
64− Nullable -> Dict
87+ NotNull -> Dict)
65− NonNullable -> Dict)
66 (Identity (eqTable @a))
88 (Identity (eqTable @a))
67
89
68
90
69−instance OrdTable a => OrdTable (ListTable a) where
91+instance (OrdTable a, context ~ Expr) => OrdTable (ListTable context a) where
70 ordTable =
92 ordTable =
71 hvectorize
93 hvectorize
72− (\SSpec {} (Identity dict) -> case dbTypeDict dict of
94+ (\Spec {nullity} (Identity Dict) -> case nullity of
73− Dict -> case dbTypeNullability dict of
95+ Null -> Dict
74− Nullable -> Dict
96+ NotNull -> Dict)
75− NonNullable -> Dict)
76 (Identity (ordTable @a))
97 (Identity (ordTable @a))
77
98
78
99
79−instance AltTable ListTable where
100+instance (ToExprs exprs a, context ~ Expr) =>
101+ ToExprs (ListTable context exprs) [a]
102+
103+
104+instance context ~ Expr => AltTable (ListTable context) where
80 (<|>:) = (<>)
105 (<|>:) = (<>)
81
106
82
107
83−instance AlternativeTable ListTable where
108+instance context ~ Expr => AlternativeTable (ListTable context) where
84 emptyTable = mempty
109 emptyTable = mempty
85
110
86
111
87−instance Table Expr a => Semigroup (ListTable a) where
112+instance (context ~ Expr, Table Expr a) => Semigroup (ListTable context a)
88− ListTable as <> ListTable bs = ListTable $
113+ where
89− happend (\_ _ (DB a) (DB b) -> DB (sappend a b)) as bs
114+ ListTable as <> ListTable bs = ListTable $ happend (const sappend) as bs
115+
116+
117+instance (context ~ Expr, Table Expr a) =>
118+ Monoid (ListTable context a)
119+ where
120+ mempty = ListTable $ hempty $ \Spec {info} -> sempty info
90
121
91
122
92−instance Table Expr a => Monoid (ListTable a) where
123+-- | Project a single expression out of a 'ListTable'.
93− mempty = ListTable $ hempty $ \nullability info ->
124+($*) :: Projecting a (Expr b)
94− DB (sempty nullability info)
125+ => Projection a (Expr b) -> ListTable Expr a -> Expr [b]
126+f $* ListTable a = hcolumn $ hproject (apply f) a
127+infixl 4 $*
95
128
96
129
97−listTable :: Table Expr a => [a] -> ListTable a
130+-- | Construct a @ListTable@ from a list of expressions.
131+listTable :: Table Expr a => [a] -> ListTable Expr a
98listTable =
132listTable =
99 ListTable .
133 ListTable .
100− hvectorize (\SSpec {info} -> DB . slistOf info . fmap unDB) .
134+ hvectorize (\Spec {info} -> slistOf info) .
101 fmap toColumns
135 fmap toColumns
136+
137+
138+-- | Construct a 'ListTable' in the 'Name' context. This can be useful if you
139+-- have a 'ListTable' that you are storing in a table and need to construct a
140+-- 'TableSchema'.
141+nameListTable
142+ :: Table Name a
143+ => a -- ^ The names of the columns of elements of the list.
144+ -> ListTable Name a
145+nameListTable =
146+ ListTable .
147+ hvectorize (\_ (Identity (Name a)) -> Name a) .
148+ pure .
149+ toColumns
src/Rel8/Table/Maybe.hs+127−116
@@ -15,6 +15,7 @@ module Rel8.Table.Maybe
15 ( MaybeTable(..)
15 ( MaybeTable(..)
16 , maybeTable, nothingTable, justTable
16 , maybeTable, nothingTable, justTable
17 , isNothingTable, isJustTable
17 , isNothingTable, isJustTable
18+ , fromMaybeTable
18 , ($?)
19 , ($?)
19 , aggregateMaybeTable
20 , aggregateMaybeTable
20 , nameMaybeTable
21 , nameMaybeTable
@@ -22,51 +23,51 @@ module Rel8.Table.Maybe
22where
23where
23
24
24-- base
25-- base
25−import Data.Functor.Identity ( runIdentity )
26+import Data.Functor ( ($>) )
27+import Data.Functor.Identity ( Identity( Identity ) )
26import Data.Kind ( Type )
28import Data.Kind ( Type )
27−import Prelude hiding ( null, repeat, undefined, zipWith )
29+import Data.Maybe ( fromMaybe, isJust )
30+import Prelude hiding ( null, undefined )
31+
32+-- comonad
33+import Control.Comonad ( extract )
28
34
29-- rel8
35-- rel8
30−import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )
36+import Rel8.Aggregate ( Aggregate )
31import Rel8.Expr ( Expr )
37import Rel8.Expr ( Expr )
38+import Rel8.Expr.Aggregate ( groupByExpr )
32import Rel8.Expr.Bool ( boolExpr )
39import Rel8.Expr.Bool ( boolExpr )
33import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )
40import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )
34−import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
41+import Rel8.Kind.Context ( Reifiable )
35−import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler, hlabeler )
42+import Rel8.Schema.Dict ( Dict( Dict ) )
36−import Rel8.Schema.Context.Nullify
43+import qualified Rel8.Schema.Kind as K
37− ( Nullifiable, ConstrainTag
38− , hencodeTag, hdecodeTag
39− , hnullifier, hunnullifier
40− )
41import Rel8.Schema.HTable.Identity ( HIdentity(..) )
44import Rel8.Schema.HTable.Identity ( HIdentity(..) )
42−import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
45+import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
43−import Rel8.Schema.HTable.Maybe ( HMaybeTable(..), HMaybeNullifiable )
46+import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
44−import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
45import Rel8.Schema.Name ( Name )
47import Rel8.Schema.Name ( Name )
46−import Rel8.Schema.Nullability
48+import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
47− ( Nullify
49+import qualified Rel8.Schema.Null as N
48− , Nullability( Nullable, NonNullable )
50+import Rel8.Table
49− , Sql, nullabilization
51+ ( Table, Columns, Context, fromColumns, toColumns
52+ , FromExprs, fromResult, toResult
53+ , Transpose
50 )
54 )
51−import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
52import Rel8.Table.Alternative
55import Rel8.Table.Alternative
53 ( AltTable, (<|>:)
56 ( AltTable, (<|>:)
54 , AlternativeTable, emptyTable
57 , AlternativeTable, emptyTable
55 )
58 )
56import Rel8.Table.Bool ( bool )
59import Rel8.Table.Bool ( bool )
57import Rel8.Table.Eq ( EqTable, eqTable )
60import Rel8.Table.Eq ( EqTable, eqTable )
58−import Rel8.Table.Lifted
59− ( Table1, Columns1, ConstrainHContext1, fromColumns1, toColumns1
60− )
61import Rel8.Table.Ord ( OrdTable, ordTable )
61import Rel8.Table.Ord ( OrdTable, ordTable )
62−import Rel8.Table.Recontextualize ( Recontextualize )
62+import Rel8.Table.Projection ( Projectable, project )
63−import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )
63+import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )
64+import Rel8.Table.Serialize ( ToExprs )
64import Rel8.Table.Undefined ( undefined )
65import Rel8.Table.Undefined ( undefined )
65import Rel8.Type ( DBType )
66import Rel8.Type ( DBType )
66−import Rel8.Type.Tag ( MaybeTag )
67+import Rel8.Type.Tag ( MaybeTag( IsJust ) )
67
68
68-- semigroupoids
69-- semigroupoids
69−import Data.Functor.Apply ( Apply, (<.>), liftF2 )
70+import Data.Functor.Apply ( Apply, (<.>) )
70import Data.Functor.Bind ( Bind, (>>-) )
71import Data.Functor.Bind ( Bind, (>>-) )
71
72
72
73
@@ -78,158 +79,168 @@ import Data.Functor.Bind ( Bind, (>>-) )
78-- entirely of nulls, you can't distinguish if you matched an all null row, or
79-- entirely of nulls, you can't distinguish if you matched an all null row, or
79-- if the match failed. For this reason @MaybeTable@ contains an extra field -
80-- if the match failed. For this reason @MaybeTable@ contains an extra field -
80-- a "nullTag" - to track whether or not the outer join produced any rows.
81-- a "nullTag" - to track whether or not the outer join produced any rows.
81−type MaybeTable :: Type -> Type
82+type MaybeTable :: K.Context -> Type -> Type
82−data MaybeTable a = MaybeTable
83+data MaybeTable context a = MaybeTable
83− { tag :: Tag "isJust" (Maybe MaybeTag)
84+ { tag :: context (Maybe MaybeTag)
84− , just :: a
85+ , just :: Nullify context a
85 }
86 }
86 deriving stock Functor
87 deriving stock Functor
87
88
88
89
89−instance Apply MaybeTable where
90+instance Projectable (MaybeTable context) where
90− MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f a)
91+ project f (MaybeTable tag a) = MaybeTable tag (project f a)
92+
93+
94+instance context ~ Expr => Apply (MaybeTable context) where
95+ MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f <.> a)
91
96
92
97
93-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:
98-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:
94−-- 'traverseMaybeTable'.
99+-- 'Rel8.traverseMaybeTable'.
95−instance Applicative MaybeTable where
100+instance context ~ Expr => Applicative (MaybeTable context) where
96 (<*>) = (<.>)
101 (<*>) = (<.>)
97 pure = justTable
102 pure = justTable
98
103
99
104
100−instance Bind MaybeTable where
105+instance context ~ Expr => Bind (MaybeTable context) where
101− MaybeTable tag a >>- f = case f a of
106+ MaybeTable tag a >>- f = case f (extract a) of
102 MaybeTable tag' b -> MaybeTable (tag <> tag') b
107 MaybeTable tag' b -> MaybeTable (tag <> tag') b
103
108
104
109
105−-- | Has the same behavior as the @Monad@ instance for @Maybe@. See also:
110+-- | Has the same behavior as the @Monad@ instance for @Maybe@.
106−-- 'bindMaybeTable'.
111+instance context ~ Expr => Monad (MaybeTable context) where
107−instance Monad MaybeTable where
108 (>>=) = (>>-)
112 (>>=) = (>>-)
109
113
110
114
111−instance AltTable MaybeTable where
115+instance context ~ Expr => AltTable (MaybeTable context) where
112− ma@(MaybeTable tag a) <|>: MaybeTable tag' b = MaybeTable
116+ ma <|>: mb = bool ma mb (isNothingTable ma)
113− { tag = (tag <> tag')
114− { expr = boolExpr (expr tag) (expr tag') condition
115− }
116− , just = bool a b condition
117− }
118− where
119− condition = isNothingTable ma
120
117
121
118
122−instance AlternativeTable MaybeTable where
119+instance context ~ Expr => AlternativeTable (MaybeTable context) where
123 emptyTable = nothingTable
120 emptyTable = nothingTable
124
121
125
122
126−instance (Table Expr a, Semigroup a) => Semigroup (MaybeTable a) where
123+instance (context ~ Expr, Table Expr a, Semigroup a) =>
124+ Semigroup (MaybeTable context a)
125+ where
127 ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma
126 ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma
128
127
129
128
130−instance (Table Expr a, Semigroup a) => Monoid (MaybeTable a) where
129+instance (context ~ Expr, Table Expr a, Semigroup a) =>
130+ Monoid (MaybeTable context a)
131+ where
131 mempty = nothingTable
132 mempty = nothingTable
132
133
133
134
134−instance Table1 MaybeTable where
135+instance (Table context a, Reifiable context, context ~ context') =>
135− type Columns1 MaybeTable = HMaybeTable
136+ Table context' (MaybeTable context a)
136− type ConstrainHContext1 MaybeTable = HMaybeNullifiable
137+ where
137−
138+ type Columns (MaybeTable context a) = HMaybeTable (Columns a)
138− toColumns1 f MaybeTable {tag, just} = HMaybeTable
139+ type Context (MaybeTable context a) = Context a
139− { htag
140+ type FromExprs (MaybeTable context a) = Maybe (FromExprs a)
140− , hjust = hnullify (hnullifier tag isNonNull) $ f just
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
141 }
146 }
142− where
143− htag = HIdentity (hencodeTag tag)
144
147
145− fromColumns1 f HMaybeTable {htag = HIdentity htag, hjust} = MaybeTable
148+ fromColumns HMaybeTable {htag, hjust} = MaybeTable
146− { tag
149+ { tag = unHIdentity $ hunlabel htag
147− , just = f $ runIdentity $
150+ , just = fromColumns $ hunlabel hjust
148− hunnullify (\a -> pure . hunnullifier a) hjust
149 }
151 }
150− where
151− tag = hdecodeTag htag
152−
153− {-# INLINABLE fromColumns1 #-}
154− {-# INLINABLE toColumns1 #-}
155−
156
152
157−instance
153+ toResult ma = HMaybeTable
158− ( Table context a
154+ { htag = hlabel (HIdentity (Identity (IsJust <$ ma)))
159− , Labelable context, Nullifiable context
155+ , hjust = hlabel (toResult @_ @(Nullify context a) ma)
160− , ConstrainTag context MaybeTag
156+ }
161− ) => Table context (MaybeTable a)
162− where
163− type Columns (MaybeTable a) = HMaybeTable (HLabel "Just" (Columns a))
164− type Context (MaybeTable a) = Context a
165
157
166− toColumns = toColumns1 (hlabel labeler . toColumns)
158+ fromResult HMaybeTable {htag, hjust} = case hunlabel htag of
167− fromColumns = fromColumns1 (fromColumns . hunlabel unlabeler)
159+ HIdentity (Identity tag) -> tag $>
160+ fromMaybe err (fromResult @_ @(Nullify context a) (hunlabel hjust))
161+ where
162+ err = error "Maybe.fromColumns: mismatch between tag and data"
168
163
169
164
170−instance
165+instance (EqTable a, context ~ Expr) => EqTable (MaybeTable context a) where
171− ( Labelable from, Nullifiable from, ConstrainTag from MaybeTag
166+ eqTable = HMaybeTable
172− , Labelable to, Nullifiable to, ConstrainTag to MaybeTag
167+ { htag = hlabel (HIdentity Dict)
173− , Recontextualize from to a b
168+ , hjust = hlabel (eqTable @(Nullify context a))
174− ) => Recontextualize from to (MaybeTable a) (MaybeTable b)
169+ }
175
170
176
171
177−instance EqTable a => EqTable (MaybeTable a) where
172+instance (OrdTable a, context ~ Expr) => OrdTable (MaybeTable context a) where
178− eqTable = toColumns1 (hlabel hlabeler) (justTable (eqTable @a))
173+ ordTable = HMaybeTable
174+ { htag = hlabel (HIdentity Dict)
175+ , hjust = hlabel (ordTable @(Nullify context a))
176+ }
179
177
180
178
181−instance OrdTable a => OrdTable (MaybeTable a) where
179+instance (ToExprs exprs a, context ~ Expr) =>
182− ordTable = toColumns1 (hlabel hlabeler) (justTable (ordTable @a))
180+ ToExprs (MaybeTable context exprs) (Maybe a)
183
181
184
182
185−-- | Check if a @MaybeTable@ is absent of any row.. Like 'isNothing'.
183+-- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.
186−isNothingTable :: MaybeTable a -> Expr Bool
184+isNothingTable :: MaybeTable Expr a -> Expr Bool
187−isNothingTable (MaybeTable tag _) = isNull (expr tag)
185+isNothingTable (MaybeTable tag _) = isNull tag
188
186
189
187
190−-- | Check if a @MaybeTable@ contains a row. Like 'isJust'.
188+-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.
191−isJustTable :: MaybeTable a -> Expr Bool
189+isJustTable :: MaybeTable Expr a -> Expr Bool
192−isJustTable (MaybeTable tag _) = isNonNull (expr tag)
190+isJustTable (MaybeTable tag _) = isNonNull tag
193
191
194
192
195-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.
193-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.
196−maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable a -> b
194+maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable Expr a -> b
197−maybeTable b f ma@(MaybeTable _ a) = bool (f a) b (isNothingTable ma)
195+maybeTable b f ma@(MaybeTable _ a) = bool (f (extract a)) b (isNothingTable ma)
198{-# INLINABLE maybeTable #-}
196{-# INLINABLE maybeTable #-}
199
197
200
198
201-- | The null table. Like 'Nothing'.
199-- | The null table. Like 'Nothing'.
202−nothingTable :: Table Expr a => MaybeTable a
200+nothingTable :: Table Expr a => MaybeTable Expr a
203−nothingTable = MaybeTable (fromExpr null) undefined
201+nothingTable = MaybeTable null (pure undefined)
204
202
205
203
206-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use
204-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use
207-- 'pure'.
205-- 'pure'.
208−justTable :: a -> MaybeTable a
206+justTable :: a -> MaybeTable Expr a
209−justTable = MaybeTable (fromExpr mempty)
207+justTable = MaybeTable mempty . pure
208+
209+
210+-- | 'Data.Maybe.fromMaybe' for 'MaybeTable's.
211+fromMaybeTable :: Table Expr a => a -> MaybeTable Expr a -> a
212+fromMaybeTable fallback = maybeTable fallback id
210
213
211
214
212-- | Project a single expression out of a 'MaybeTable'. You can think of this
215-- | Project a single expression out of a 'MaybeTable'. You can think of this
213-- operator like the '$' operator, but it also has the ability to return
216-- operator like the '$' operator, but it also has the ability to return
214-- @null@.
217-- @null@.
215−--
216−-- >>> select c $ fmap (fst $?) (optional (values [lit (True, False)]))
217−-- [Just True]
218($?) :: forall a b. Sql DBType b
218($?) :: forall a b. Sql DBType b
219− => (a -> Expr b) -> MaybeTable a -> Expr (Nullify b)
219+ => (a -> Expr b) -> MaybeTable Expr a -> Expr (N.Nullify b)
220−f $? ma@(MaybeTable _ a) = case nullabilization @b of
220+f $? ma@(MaybeTable _ a) = case nullable @b of
221− Nullable -> boolExpr (f a) null (isNothingTable ma)
221+ Null -> boolExpr (f (extract a)) null (isNothingTable ma)
222− NonNullable -> boolExpr (nullify (f a)) null (isNothingTable ma)
222+ NotNull -> boolExpr (nullify (f (extract a))) null (isNothingTable ma)
223infixl 4 $?
223infixl 4 $?
224
224
225
225
226+-- | Lift an aggregating function to operate on a 'MaybeTable'.
227+-- @nothingTable@s and @justTable@s are grouped separately.
226aggregateMaybeTable :: ()
228aggregateMaybeTable :: ()
227− => (a -> Aggregate b) -> MaybeTable a -> Aggregate (MaybeTable b)
229+ => (exprs -> aggregates)
228−aggregateMaybeTable f MaybeTable {tag = tag@Tag {aggregator, expr}, just} =
230+ -> MaybeTable Expr exprs
229− liftF2 MaybeTable (tag <$ aggregate) (f just)
231+ -> MaybeTable Aggregate aggregates
230− where
232+aggregateMaybeTable f (MaybeTable tag a) =
231− aggregate = unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr
233+ MaybeTable (groupByExpr tag) (aggregateNullify f a)
232−
234+
233−
235+
234−nameMaybeTable :: Name (Maybe MaybeTag) -> a -> MaybeTable a
236+-- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you
235−nameMaybeTable = MaybeTable . fromName
237+-- have a 'MaybeTable' that you are storing in a table and need to construct a
238+-- 'TableSchema'.
239+nameMaybeTable
240+ :: Name (Maybe MaybeTag)
241+ -- ^ The name of the column to track whether a row is a 'justTable' or
242+ -- 'nothingTable'.
243+ -> a
244+ -- ^ Names of the columns in @a@.
245+ -> MaybeTable Name a
246+nameMaybeTable tag = MaybeTable tag . pure
src/Rel8/Table/Name.hs+37−22
@@ -1,14 +1,17 @@
1+{-# language DataKinds #-}
1{-# language FlexibleContexts #-}
2{-# language FlexibleContexts #-}
3+{-# language FlexibleInstances #-}
4+{-# language MultiParamTypeClasses #-}
2{-# language NamedFieldPuns #-}
5{-# language NamedFieldPuns #-}
3{-# language ScopedTypeVariables #-}
6{-# language ScopedTypeVariables #-}
4{-# language TypeApplications #-}
7{-# language TypeApplications #-}
5{-# language TypeFamilies #-}
8{-# language TypeFamilies #-}
9+{-# language UndecidableInstances #-}
6{-# language ViewPatterns #-}
10{-# language ViewPatterns #-}
7
11
8module Rel8.Table.Name
12module Rel8.Table.Name
9 ( namesFromLabels
13 ( namesFromLabels
10 , namesFromLabelsWith
14 , namesFromLabelsWith
11− , showExprs
12 , showLabels
15 , showLabels
13 , showNames
16 , showNames
14 )
17 )
@@ -17,48 +20,60 @@ where
17-- base
20-- base
18import Data.Foldable ( fold )
21import Data.Foldable ( fold )
19import Data.Functor.Const ( Const( Const ), getConst )
22import Data.Functor.Const ( Const( Const ), getConst )
20−import Data.List.NonEmpty ( NonEmpty, intersperse )
23+import Data.List.NonEmpty ( NonEmpty, intersperse, nonEmpty )
24+import Data.Maybe ( fromMaybe )
21import Prelude
25import Prelude
22
26
23−-- casing
24−import Text.Casing ( quietSnake )
25−
26-- rel8
27-- rel8
27−import Rel8.Expr ( Expr, Col(..) )
28−import Rel8.Kind.Labels ( renderLabels )
29import Rel8.Schema.HTable ( htabulate, htabulateA, hfield, hspecs )
28import Rel8.Schema.HTable ( htabulate, htabulateA, hfield, hspecs )
30−import Rel8.Schema.Name ( Name, Col(..) )
29+import Rel8.Schema.Name ( Name( Name ) )
31−import Rel8.Schema.Spec ( SSpec(..) )
30+import Rel8.Schema.Spec ( Spec(..) )
32−import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
31+import Rel8.Table ( Table(..) )
33
32
34
33
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'.
35namesFromLabels :: Table Name a => a
38namesFromLabels :: Table Name a => a
36namesFromLabels = namesFromLabelsWith go
39namesFromLabels = namesFromLabelsWith go
37 where
40 where
38− go = fold . intersperse "/" . fmap quietSnake
41+ go = fold . intersperse "/"
39
42
40
43
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.
41namesFromLabelsWith :: Table Name a
59namesFromLabelsWith :: Table Name a
42 => (NonEmpty String -> String) -> a
60 => (NonEmpty String -> String) -> a
43namesFromLabelsWith f = fromColumns $ htabulate $ \field ->
61namesFromLabelsWith f = fromColumns $ htabulate $ \field ->
44 case hfield hspecs field of
62 case hfield hspecs field of
45− SSpec {labels} -> NameCol (f (renderLabels labels))
63+ Spec {labels} -> Name (f (renderLabels labels))
46−
47−
48−showExprs :: Table Expr a => a -> [(String, String)]
49−showExprs as = case (namesFromLabels, toColumns as) of
50− (names, exprs) -> getConst $ htabulateA $ \field ->
51− case (hfield names field, hfield exprs field) of
52− (NameCol name, DB expr) -> Const [(name, show expr)]
53
64
54
65
55showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]
66showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]
56showLabels _ = getConst $
67showLabels _ = getConst $
57 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
68 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
58− SSpec {labels} -> Const [renderLabels labels]
69+ Spec {labels} -> Const (pure (renderLabels labels))
59
70
60
71
61−showNames :: forall a. Table Name a => a -> [String]
72+showNames :: forall a. Table Name a => a -> NonEmpty String
62showNames (toColumns -> names) = getConst $
73showNames (toColumns -> names) = getConst $
63 htabulateA @(Columns a) $ \field -> case hfield names field of
74 htabulateA @(Columns a) $ \field -> case hfield names field of
64− NameCol name -> Const [name]
75+ Name name -> Const (pure name)
76+
77+
78+renderLabels :: [String] -> NonEmpty String
79+renderLabels labels = fromMaybe (pure "anon") (nonEmpty labels )
src/Rel8/Table/NonEmpty.hs+86−35
@@ -1,3 +1,4 @@
1+{-# language DataKinds #-}
1{-# language FlexibleContexts #-}
2{-# language FlexibleContexts #-}
2{-# language FlexibleInstances #-}
3{-# language FlexibleInstances #-}
3{-# language MultiParamTypeClasses #-}
4{-# language MultiParamTypeClasses #-}
@@ -10,8 +11,9 @@
10
11
11module Rel8.Table.NonEmpty
12module Rel8.Table.NonEmpty
12 ( NonEmptyTable(..)
13 ( NonEmptyTable(..)
13− , HNonEmptyTable
14+ , ($+)
14 , nonEmptyTable
15 , nonEmptyTable
16+ , nameNonEmptyTable
15 )
17 )
16where
18where
17
19
@@ -19,74 +21,123 @@ where
19import Data.Functor.Identity ( Identity( Identity ) )
21import Data.Functor.Identity ( Identity( Identity ) )
20import Data.Kind ( Type )
22import Data.Kind ( Type )
21import Data.List.NonEmpty ( NonEmpty )
23import Data.List.NonEmpty ( NonEmpty )
22−import Prelude
24+import Prelude hiding ( id )
23
25
24-- rel8
26-- rel8
25−import Rel8.Expr ( Expr, Col(..) )
27+import Rel8.Expr ( Expr )
26import Rel8.Expr.Array ( sappend1, snonEmptyOf )
28import Rel8.Expr.Array ( sappend1, snonEmptyOf )
27import Rel8.Schema.Dict ( Dict( Dict ) )
29import Rel8.Schema.Dict ( Dict( Dict ) )
28import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
30import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
29−import Rel8.Schema.HTable.Vectorize ( happend, hvectorize )
31+import Rel8.Schema.HTable.Vectorize
30−import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
32+ ( hvectorize, hunvectorize
31−import Rel8.Schema.Spec ( SSpec(..) )
33+ , happend
32−import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullability )
34+ , hproject, hcolumn
33−import Rel8.Table ( Table, Context, Columns, fromColumns, toColumns )
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+ )
34import Rel8.Table.Alternative ( AltTable, (<|>:) )
46import Rel8.Table.Alternative ( AltTable, (<|>:) )
35import Rel8.Table.Eq ( EqTable, eqTable )
47import Rel8.Table.Eq ( EqTable, eqTable )
36import Rel8.Table.Ord ( OrdTable, ordTable )
48import Rel8.Table.Ord ( OrdTable, ordTable )
37−import Rel8.Table.Recontextualize ( Recontextualize )
49+import Rel8.Table.Projection
50+ ( Projectable, Projecting, Projection, project, apply
51+ )
52+import Rel8.Table.Serialize ( ToExprs )
38
53
39
54
40-- | A @NonEmptyTable@ value contains one or more instances of @a@. You
55-- | A @NonEmptyTable@ value contains one or more instances of @a@. You
41−-- construct @NonEmptyTable@s with 'some' or 'nonEmptyAgg'.
56+-- construct @NonEmptyTable@s with 'Rel8.some' or 'nonEmptyAgg'.
42−type NonEmptyTable :: Type -> Type
57+type NonEmptyTable :: K.Context -> Type -> Type
43−newtype NonEmptyTable a =
58+newtype NonEmptyTable context a =
44− NonEmptyTable (HNonEmptyTable (Columns a) (Col (Context a)))
59+ NonEmptyTable (HNonEmptyTable (Columns a) (Context a))
45
60
46
61
47−instance Table context a => Table context (NonEmptyTable a) where
62+instance Projectable (NonEmptyTable context) where
48− type Columns (NonEmptyTable a) = HNonEmptyTable (Columns a)
63+ project f (NonEmptyTable a) = NonEmptyTable (hproject (apply f) a)
49− type Context (NonEmptyTable a) = Context a
50
64
51− fromColumns = NonEmptyTable
52− toColumns (NonEmptyTable a) = a
53
65
66+instance (Table context a, context ~ context') =>
67+ Table context' (NonEmptyTable context a)
68+ where
69+ type Columns (NonEmptyTable context a) = HNonEmptyTable (Columns a)
70+ type Context (NonEmptyTable context a) = Context a
71+ type FromExprs (NonEmptyTable context a) = NonEmpty (FromExprs a)
72+ type Transpose to (NonEmptyTable context a) =
73+ NonEmptyTable to (Transpose to a)
54
74
55−instance Recontextualize from to a b =>
75+ fromColumns = NonEmptyTable
56− Recontextualize from to (NonEmptyTable a) (NonEmptyTable b)
76+ toColumns (NonEmptyTable a) = a
77+ fromResult = fmap (fromResult @_ @a) . hunvectorize unvectorizer
78+ toResult = hvectorize vectorizer . fmap (toResult @_ @a)
57
79
58
80
59−instance EqTable a => EqTable (NonEmptyTable a) where
81+instance (EqTable a, context ~ Expr) =>
82+ EqTable (NonEmptyTable context a)
83+ where
60 eqTable =
84 eqTable =
61 hvectorize
85 hvectorize
62− (\SSpec {} (Identity dict) -> case dbTypeDict dict of
86+ (\Spec {nullity} (Identity Dict) -> case nullity of
63− Dict -> case dbTypeNullability dict of
87+ Null -> Dict
64− Nullable -> Dict
88+ NotNull -> Dict)
65− NonNullable -> Dict)
66 (Identity (eqTable @a))
89 (Identity (eqTable @a))
67
90
68
91
69−instance OrdTable a => OrdTable (NonEmptyTable a) where
92+instance (OrdTable a, context ~ Expr) =>
93+ OrdTable (NonEmptyTable context a)
94+ where
70 ordTable =
95 ordTable =
71 hvectorize
96 hvectorize
72− (\SSpec {} (Identity dict) -> case dbTypeDict dict of
97+ (\Spec {nullity} (Identity Dict) -> case nullity of
73− Dict -> case dbTypeNullability dict of
98+ Null -> Dict
74− Nullable -> Dict
99+ NotNull -> Dict)
75− NonNullable -> Dict)
76 (Identity (ordTable @a))
100 (Identity (ordTable @a))
77
101
78
102
79−instance AltTable NonEmptyTable where
103+instance (ToExprs exprs a, context ~ Expr) =>
104+ ToExprs (NonEmptyTable context exprs) (NonEmpty a)
105+
106+
107+instance context ~ Expr => AltTable (NonEmptyTable context) where
80 (<|>:) = (<>)
108 (<|>:) = (<>)
81
109
82
110
83−instance Table Expr a => Semigroup (NonEmptyTable a) where
111+instance (Table Expr a, context ~ Expr) => Semigroup (NonEmptyTable context a)
112+ where
84 NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $
113 NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $
85− happend (\_ _ (DB a) (DB b) -> DB (sappend1 a b)) as bs
114+ happend (const sappend1) as bs
115+
116+
117+-- | Project a single expression out of a 'NonEmptyTable'.
118+($+) :: Projecting a (Expr b)
119+ => Projection a (Expr b) -> NonEmptyTable Expr a -> Expr (NonEmpty b)
120+f $+ NonEmptyTable a = hcolumn $ hproject (apply f) a
121+infixl 4 $+
86
122
87
123
88−nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable a
124+-- | Construct a @NonEmptyTable@ from a non-empty list of expressions.
125+nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable Expr a
89nonEmptyTable =
126nonEmptyTable =
90 NonEmptyTable .
127 NonEmptyTable .
91− hvectorize (\SSpec {info} -> DB . snonEmptyOf info . fmap unDB) .
128+ hvectorize (\Spec {info} -> snonEmptyOf info) .
92 fmap toColumns
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.hsnew file+147
@@ -0,0 +1,147 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language FlexibleInstances #-}
4+{-# language MultiParamTypeClasses #-}
5+{-# language ScopedTypeVariables #-}
6+{-# language StandaloneKindSignatures #-}
7+{-# language TypeApplications #-}
8+{-# language TypeFamilies #-}
9+{-# language UndecidableInstances #-}
10+
11+module Rel8.Table.Null
12+ ( NullTable(..)
13+ , nullableTable, nullTable, nullifyTable, unsafeUnnullifyTable
14+ , isNullTable, isNonNullTable
15+ , nameNullTable
16+ , toMaybeTable, toNullTable
17+ )
18+where
19+
20+-- base
21+import Data.Kind ( Type )
22+import Prelude hiding ( null, undefined )
23+
24+-- comonad
25+import Control.Comonad ( extract )
26+
27+-- rel8
28+import Rel8.Expr ( Expr )
29+import Rel8.Expr.Bool ( not_ )
30+import Rel8.Kind.Context ( Reifiable )
31+import qualified Rel8.Schema.Kind as K
32+import Rel8.Schema.Name ( Name )
33+import Rel8.Table
34+ ( Table, Columns, Context, fromColumns, toColumns
35+ , FromExprs, fromResult, toResult
36+ , Transpose
37+ )
38+import Rel8.Table.Alternative
39+ ( AltTable, (<|>:)
40+ , AlternativeTable, emptyTable
41+ )
42+import Rel8.Table.Bool ( bool )
43+import Rel8.Table.Eq ( EqTable, eqTable )
44+import Rel8.Table.Maybe ( MaybeTable, justTable, maybeTable, nothingTable )
45+import Rel8.Table.Nullify ( Nullify, isNull )
46+import Rel8.Table.Ord ( OrdTable, ordTable )
47+import Rel8.Table.Projection ( Projectable, project )
48+import Rel8.Table.Serialize ( ToExprs )
49+import Rel8.Table.Undefined ( undefined )
50+
51+
52+-- | @NullTable t@ is the table @t@, but where all the columns in @t@ have the
53+-- possibility of being 'Rel8.null'. This is very similar to
54+-- 'Rel8.MaybeTable', except that it does not use an extra tag field, so it
55+-- cannot distinguish between @Nothing@ and @Just Nothing@ if nested. In other
56+-- words, if all of the columns of the @t@ passed to @NullTable@ are already
57+-- nullable, then @NullTable@ has no effect.
58+type NullTable :: K.Context -> Type -> Type
59+newtype NullTable context a = NullTable (Nullify context a)
60+
61+
62+instance Projectable (NullTable context) where
63+ project f (NullTable a) = NullTable (project f a)
64+
65+
66+instance context ~ Expr => AltTable (NullTable context) where
67+ ma <|>: mb = bool ma mb (isNullTable ma)
68+
69+
70+instance context ~ Expr => AlternativeTable (NullTable context) where
71+ emptyTable = nullTable
72+
73+
74+instance (Table context a, Reifiable context, context ~ context') =>
75+ Table context' (NullTable context a)
76+ where
77+ type Columns (NullTable context a) = Columns (Nullify context a)
78+ type Context (NullTable context a) = Context (Nullify context a)
79+ type FromExprs (NullTable context a) = FromExprs (Nullify context a)
80+ type Transpose to (NullTable context a) = NullTable to (Transpose to a)
81+
82+ toColumns (NullTable a) = toColumns a
83+ fromColumns = NullTable . fromColumns
84+
85+ toResult = toResult @_ @(Nullify context a)
86+ fromResult = fromResult @_ @(Nullify context a)
87+
88+
89+instance (EqTable a, context ~ Expr) => EqTable (NullTable context a) where
90+ eqTable = eqTable @(Nullify context a)
91+
92+
93+instance (OrdTable a, context ~ Expr) => OrdTable (NullTable context a) where
94+ ordTable = ordTable @(Nullify context a)
95+
96+
97+instance (ToExprs exprs a, context ~ Expr) =>
98+ ToExprs (NullTable context exprs) (Maybe a)
99+
100+
101+-- | Check if any of the non-nullable fields of @a@ are 'Rel8.null' under the
102+-- 'NullTable'. Returns 'Rel8.false' if @a@ has no non-nullable fields.
103+isNullTable :: Table Expr a => NullTable Expr a -> Expr Bool
104+isNullTable (NullTable a) = isNull a
105+
106+
107+-- | The inverse of 'isNullTable'.
108+isNonNullTable :: Table Expr a => NullTable Expr a -> Expr Bool
109+isNonNullTable = not_ . isNullTable
110+
111+
112+-- | Like 'Rel8.nullable'.
113+nullableTable :: (Table Expr a, Table Expr b)
114+ => b -> (a -> b) -> NullTable Expr a -> b
115+nullableTable b f ma@(NullTable a) = bool (f (extract a)) b (isNullTable ma)
116+
117+
118+-- | The null table. Like 'Rel8.null'.
119+nullTable :: Table Expr a => NullTable Expr a
120+nullTable = NullTable (pure undefined)
121+
122+
123+-- | Lift any table into 'NullTable'. Like 'Rel8.nullify'.
124+nullifyTable :: a -> NullTable Expr a
125+nullifyTable = NullTable . pure
126+
127+
128+unsafeUnnullifyTable :: NullTable Expr a -> a
129+unsafeUnnullifyTable (NullTable a) = extract a
130+
131+
132+-- | Construct a 'NullTable' in the 'Name' context. This can be useful if you
133+-- have a 'NullTable' that you are storing in a table and need to construct a
134+-- 'TableSchema'.
135+nameNullTable :: a -> NullTable Name a
136+nameNullTable = NullTable . pure
137+
138+
139+-- | Convert a 'NullTable' to a 'MaybeTable'.
140+toMaybeTable :: Table Expr a => NullTable Expr a -> MaybeTable Expr a
141+toMaybeTable = nullableTable nothingTable justTable
142+
143+
144+-- | Convert a 'MaybeTable' to a 'NullTable'. Note that if the underlying @a@
145+-- has no non-nullable fields, this is a lossy conversion.
146+toNullTable :: Table Expr a => MaybeTable Expr a -> NullTable Expr a
147+toNullTable = maybeTable nullTable nullifyTable
src/Rel8/Table/Nullify.hsnew file+211
@@ -0,0 +1,211 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language FlexibleInstances #-}
4+{-# language LambdaCase #-}
5+{-# language MultiParamTypeClasses #-}
6+{-# language NamedFieldPuns #-}
7+{-# language ScopedTypeVariables #-}
8+{-# language StandaloneKindSignatures #-}
9+{-# language TypeApplications #-}
10+{-# language TypeFamilies #-}
11+{-# language UndecidableInstances #-}
12+
13+module Rel8.Table.Nullify
14+ ( Nullify
15+ , aggregateNullify
16+ , guard
17+ , isNull
18+ )
19+where
20+
21+-- base
22+import Control.Applicative ( liftA2 )
23+import Data.Functor.Const ( Const( Const ), getConst )
24+import Data.Functor.Identity ( runIdentity )
25+import Data.Kind ( Type )
26+import Prelude
27+
28+-- comonad
29+import Control.Comonad ( Comonad, duplicate, extract, ComonadApply, (<@>) )
30+
31+-- rel8
32+import Rel8.Aggregate ( Aggregate )
33+import Rel8.Expr ( Expr )
34+import Rel8.Expr.Bool ( (||.), false )
35+import qualified Rel8.Expr.Null as Expr
36+import Rel8.Kind.Context ( Reifiable, contextSing )
37+import Rel8.Schema.Context.Nullify
38+ ( Nullifiability( NAggregate, NExpr )
39+ , NonNullifiability
40+ , Nullifiable, nullifiability
41+ , nullifiableOrNot, absurd
42+ , guarder
43+ , nullifier
44+ , unnullifier
45+ )
46+import Rel8.Schema.Dict ( Dict( Dict ) )
47+import Rel8.Schema.HTable ( HTable )
48+import Rel8.Schema.HTable.Nullify
49+ ( HNullify, hnulls, hnullify, hunnullify
50+ , hguard
51+ , hproject
52+ )
53+import qualified Rel8.Schema.Kind as K
54+import Rel8.Schema.Null ( Nullity( NotNull, Null ) )
55+import qualified Rel8.Schema.Result as R
56+import Rel8.Table
57+ ( Table, Columns, Context, toColumns, fromColumns
58+ , FromExprs, fromResult, toResult
59+ , Transpose
60+ )
61+import Rel8.Schema.Spec ( Spec( Spec, nullity ) )
62+import Rel8.Table.Eq ( EqTable, eqTable )
63+import Rel8.Table.Ord ( OrdTable, ordTable )
64+import Rel8.Table.Projection ( Projectable, apply, project )
65+
66+-- semigroupoids
67+import Data.Functor.Apply ( Apply, (<.>), liftF2 )
68+import Data.Functor.Bind ( Bind, (>>-) )
69+import Data.Functor.Extend ( Extend, duplicated )
70+
71+
72+type Nullify :: K.Context -> Type -> Type
73+data Nullify context a
74+ = Table (Nullifiability context) a
75+ | Fields (NonNullifiability context) (HNullify (Columns a) (Context a))
76+
77+
78+instance Projectable (Nullify context) where
79+ project f = \case
80+ Table nullifiable a -> Table nullifiable (fromColumns (apply f (toColumns a)))
81+ Fields nonNullifiable a -> Fields nonNullifiable (hproject (apply f) a)
82+
83+
84+instance Nullifiable context => Functor (Nullify context) where
85+ fmap f = \case
86+ Table nullifiable a -> Table nullifiable (f a)
87+ Fields notNullifiable _ -> absurd nullifiability notNullifiable
88+
89+
90+instance Nullifiable context => Foldable (Nullify context) where
91+ foldMap f = \case
92+ Table _ a -> f a
93+ Fields notNullifiable _ -> absurd nullifiability notNullifiable
94+
95+
96+instance Nullifiable context => Traversable (Nullify context) where
97+ traverse f = \case
98+ Table nullifiable a -> Table nullifiable <$> f a
99+ Fields notNullifiable _ -> absurd nullifiability notNullifiable
100+
101+
102+instance Nullifiable context => Apply (Nullify context) where
103+ liftF2 f = \case
104+ Table nullifiable a -> \case
105+ Table _ b -> Table nullifiable (f a b)
106+ Fields notNullifiable _ -> absurd nullifiable notNullifiable
107+ Fields notNullifiable _ -> absurd nullifiability notNullifiable
108+
109+
110+instance Nullifiable context => Applicative (Nullify context) where
111+ pure = Table nullifiability
112+ liftA2 = liftF2
113+
114+
115+instance Nullifiable context => Bind (Nullify context) where
116+ Table _ a >>- f = f a
117+ Fields notNullifiable _ >>- _ = absurd nullifiability notNullifiable
118+
119+
120+instance Nullifiable context => Monad (Nullify context) where
121+ (>>=) = (>>-)
122+
123+
124+instance Nullifiable context => Extend (Nullify context) where
125+ duplicated = \case
126+ Table nullifiable a -> Table nullifiable (Table nullifiable a)
127+ Fields notNullifiable _ -> absurd nullifiability notNullifiable
128+
129+
130+instance Nullifiable context => Comonad (Nullify context) where
131+ extract = \case
132+ Table _ a -> a
133+ Fields notNullifiable _ -> absurd nullifiability notNullifiable
134+ duplicate = duplicated
135+
136+
137+instance Nullifiable context => ComonadApply (Nullify context) where
138+ (<@>) = (<.>)
139+
140+
141+instance (Table context a, Reifiable context, context ~ context') =>
142+ Table context' (Nullify context a)
143+ where
144+ type Columns (Nullify context a) = HNullify (Columns a)
145+ type Context (Nullify context a) = Context a
146+ type FromExprs (Nullify context a) = Maybe (FromExprs a)
147+ type Transpose to (Nullify context a) = Nullify to (Transpose to a)
148+
149+ fromColumns = case nullifiableOrNot contextSing of
150+ Left notNullifiable -> Fields notNullifiable
151+ Right nullifiable ->
152+ Table nullifiable .
153+ fromColumns .
154+ runIdentity .
155+ hunnullify (\spec -> pure . unnullifier nullifiable spec)
156+
157+ toColumns = \case
158+ Table nullifiable a -> hnullify (nullifier nullifiable) (toColumns a)
159+ Fields _ a -> a
160+
161+ fromResult = fmap (fromResult @_ @a) . hunnullify R.unnullifier
162+
163+ toResult =
164+ maybe (hnulls (const R.null)) (hnullify R.nullifier) .
165+ fmap (toResult @_ @a)
166+
167+
168+instance (EqTable a, context ~ Expr) => EqTable (Nullify context a) where
169+ eqTable = hnullify (\_ Dict -> Dict) (eqTable @a)
170+
171+
172+instance (OrdTable a, context ~ Expr) => OrdTable (Nullify context a) where
173+ ordTable = hnullify (\_ Dict -> Dict) (ordTable @a)
174+
175+
176+aggregateNullify :: ()
177+ => (exprs -> aggregates)
178+ -> Nullify Expr exprs
179+ -> Nullify Aggregate aggregates
180+aggregateNullify f = \case
181+ Table _ a -> Table NAggregate (f a)
182+ Fields notNullifiable _ -> absurd NExpr notNullifiable
183+
184+
185+guard :: (Reifiable context, HTable t)
186+ => context tag
187+ -> (tag -> Bool)
188+ -> (Expr tag -> Expr Bool)
189+ -> HNullify t context
190+ -> HNullify t context
191+guard tag isNonNull isNonNullExpr =
192+ hguard (guarder contextSing tag isNonNull isNonNullExpr)
193+
194+
195+isNull :: forall a. Table Expr a => Nullify Expr a -> Expr Bool
196+isNull =
197+ maybe false getAny .
198+ getConst .
199+ hunnullify (\Spec {nullity} a -> Const $ case nullity of
200+ NotNull -> Just $ Any $ Expr.isNull a
201+ Null -> Nothing) .
202+ toColumns
203+
204+
205+newtype Any = Any
206+ { getAny :: Expr Bool
207+ }
208+
209+
210+instance Semigroup Any where
211+ Any a <> Any b = Any (a ||. b)
src/Rel8/Table/Opaleye.hs+92−68
@@ -1,126 +1,150 @@
1+{-# language BlockArguments #-}
2+{-# language DataKinds #-}
1{-# language DisambiguateRecordFields #-}
3{-# language DisambiguateRecordFields #-}
2{-# language FlexibleContexts #-}
4{-# language FlexibleContexts #-}
3{-# language NamedFieldPuns #-}
5{-# language NamedFieldPuns #-}
6+{-# language RankNTypes #-}
4{-# language TypeFamilies #-}
7{-# language TypeFamilies #-}
5{-# language ViewPatterns #-}
8{-# language ViewPatterns #-}
6
9
10+{-# options_ghc -Wno-deprecations #-}
11+
7module Rel8.Table.Opaleye
12module Rel8.Table.Opaleye
8 ( aggregator
13 ( aggregator
14+ , attributes
9 , binaryspec
15 , binaryspec
10 , distinctspec
16 , distinctspec
17+ , exprs
18+ , exprsWithNames
11 , table
19 , table
12 , tableFields
20 , tableFields
13 , unpackspec
21 , unpackspec
14 , valuesspec
22 , valuesspec
23+ , view
24+ , castTable
15 )
25 )
16where
26where
17
27
18-- base
28-- base
19−import Prelude hiding ( undefined )
29+import Data.Functor.Const ( Const( Const ), getConst )
30+import Data.List.NonEmpty ( NonEmpty )
31+import Prelude
20
32
21-- opaleye
33-- opaleye
34+import qualified Opaleye.Adaptors as Opaleye
35+import qualified Opaleye.Field as Opaleye ( Field_ )
22import qualified Opaleye.Internal.Aggregate as Opaleye
36import qualified Opaleye.Internal.Aggregate as Opaleye
23−import qualified Opaleye.Internal.Binary as Opaleye
24−import qualified Opaleye.Internal.Distinct as Opaleye
25import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
37import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
26−import qualified Opaleye.Internal.PackMap as Opaleye
27−import qualified Opaleye.Internal.Unpackspec as Opaleye
28import qualified Opaleye.Internal.Values as Opaleye
38import qualified Opaleye.Internal.Values as Opaleye
29−import qualified Opaleye.Internal.Table as Opaleye
39+import qualified Opaleye.Table as Opaleye
30
40
31-- profunctors
41-- profunctors
32import Data.Profunctor ( dimap, lmap )
42import Data.Profunctor ( dimap, lmap )
33
43
34-- rel8
44-- rel8
35−import Rel8.Aggregate ( Aggregate( Aggregate ) )
45+import Rel8.Aggregate ( Aggregate( Aggregate ), Aggregates )
36−import Rel8.Expr ( Expr, Col(..) )
46+import Rel8.Expr ( Expr )
37import Rel8.Expr.Opaleye
47import Rel8.Expr.Opaleye
38 ( fromPrimExpr, toPrimExpr
48 ( fromPrimExpr, toPrimExpr
39− , traversePrimExpr
49+ , scastExpr, traverseFieldP
40− , fromColumn, toColumn
41 )
50 )
42−import Rel8.Kind.Necessity ( SNecessity( SRequired, SOptional ) )
51+import Rel8.Schema.HTable ( htabulateA, hfield, hspecs, htabulate,
43−import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs )
52+ htraverseP, htraversePWithField )
44−import Rel8.Schema.Insert ( Insert, Inserts, Col(..) )
53+import Rel8.Schema.Name ( Name( Name ), Selects, ppColumn )
45−import Rel8.Schema.Name ( Name, Selects, Col(..) )
54+import Rel8.Schema.Spec ( Spec(..) )
46−import Rel8.Schema.Spec ( SSpec(..) )
55+import Rel8.Schema.Table ( TableSchema(..), ppTable )
47−import Rel8.Schema.Table ( TableSchema(..) )
48import Rel8.Table ( Table, fromColumns, toColumns )
56import Rel8.Table ( Table, fromColumns, toColumns )
49−import Rel8.Table.Undefined ( undefined )
57+import Rel8.Type.Information ( typeName )
50
58
51-- semigroupoids
59-- semigroupoids
52import Data.Functor.Apply ( WrappedApplicative(..) )
60import 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+
53
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)
54
76
55−aggregator :: Opaleye.Aggregator (Aggregate exprs) exprs
77+
56−aggregator = Opaleye.Aggregator $ Opaleye.PackMap $
78+fromOpaleyespec :: (ProductProfunctor p, Table Expr a)
57− \f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner))) -> inner f ()
79+ => p (Opaleye.Field_ n x) (Opaleye.Field_ n x)
80+ -> p a a
81+fromOpaleyespec x =
82+ dimap toColumns fromColumns (htraverseP (traverseFieldP x))
58
83
59
84
60binaryspec :: Table Expr a => Opaleye.Binaryspec a a
85binaryspec :: Table Expr a => Opaleye.Binaryspec a a
61−binaryspec = Opaleye.Binaryspec $ Opaleye.PackMap $ \f (as, bs) ->
86+binaryspec = fromOpaleyespec Opaleye.binaryspecField
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)
66
87
67
88
68distinctspec :: Table Expr a => Opaleye.Distinctspec a a
89distinctspec :: Table Expr a => Opaleye.Distinctspec a a
69−distinctspec =
90+distinctspec = fromOpaleyespec Opaleye.distinctspecField
70− Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap $ \f ->
91+
71− fmap fromColumns .
92+
72− unwrapApplicative .
93+exprs :: Table Expr a => a -> NonEmpty Opaleye.PrimExpr
73− htraverse
94+exprs (toColumns -> as) = getConst $ htabulateA $ \field ->
74− (\(DB a) ->
95+ case hfield as field of
75− WrapApplicative $ DB . fromPrimExpr <$> f (Nothing, toPrimExpr a)) .
96+ expr -> Const (pure (toPrimExpr expr))
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
81table (TableSchema name schema columns) =
107table (TableSchema name schema columns) =
82 case schema of
108 case schema of
83− Nothing -> Opaleye.Table name (tableFields columns)
109+ Nothing -> Opaleye.table name (tableFields columns)
84− Just schemaName -> Opaleye.TableWithSchema schemaName name (tableFields columns)
110+ Just schemaName -> Opaleye.tableWithSchema schemaName name (tableFields columns)
85
111
86
112
87−tableFields :: (Selects names exprs, Inserts exprs inserts)
113+tableFields :: Selects names exprs
88− => names -> Opaleye.TableFields inserts exprs
114+ => names -> Opaleye.TableFields exprs exprs
89tableFields (toColumns -> names) = dimap toColumns fromColumns $
115tableFields (toColumns -> names) = dimap toColumns fromColumns $
90 unwrapApplicative $ htabulateA $ \field -> WrapApplicative $
116 unwrapApplicative $ htabulateA $ \field -> WrapApplicative $
91− case hfield hspecs field of
117+ case hfield names field of
92− specs -> case hfield names field of
118+ name -> lmap (`hfield` field) (go name)
93− name -> lmap (`hfield` field) (go specs name)
94 where
119 where
95− go :: SSpec spec -> Col Name spec -> Opaleye.TableFields (Col Insert spec) (Col Expr spec)
120+ go :: Name a -> Opaleye.TableFields (Expr a) (Expr a)
96− go SSpec {necessity} (NameCol name) = case necessity of
121+ go (Name name) =
97− SRequired ->
122+ traverseFieldP $
98− lmap (\(RequiredInsert a) -> toColumn $ toPrimExpr a) $
123+ Opaleye.requiredTableField name
99− DB . fromPrimExpr . fromColumn <$>
100− Opaleye.requiredTableField name
101− SOptional ->
102− lmap (\(OptionalInsert ma) -> toColumn . toPrimExpr <$> ma) $
103− DB . fromPrimExpr . fromColumn <$>
104− Opaleye.optionalTableField name
105
124
106
125
107unpackspec :: Table Expr a => Opaleye.Unpackspec a a
126unpackspec :: Table Expr a => Opaleye.Unpackspec a a
108−unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->
127+unpackspec = fromOpaleyespec Opaleye.unpackspecField
109− fmap fromColumns .
110− unwrapApplicative .
111− htraverse (\(DB a) -> WrapApplicative $ DB <$> traversePrimExpr f a) .
112− toColumns
113{-# INLINABLE unpackspec #-}
128{-# INLINABLE unpackspec #-}
114
129
115
130
116−valuesspec :: Table Expr a => Opaleye.ValuesspecSafe a a
131+valuesspec :: Table Expr a => Opaleye.Valuesspec a a
117−valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec
132+valuesspec = dimap toColumns fromColumns $
133+ htraversePWithField (traverseFieldP . Opaleye.valuesspecFieldType . typeName)
134+ where typeName = Rel8.Type.Information.typeName . info . hfield hspecs
135+
136+
137+view :: Selects names exprs => names -> exprs
138+view columns = fromColumns $ htabulate $ \field ->
139+ case hfield (toColumns columns) field of
140+ Name column -> fromPrimExpr $ Opaleye.BaseTableAttrExpr column
118
141
119
142
120−toPackMap :: Table Expr a
143+-- | Transform a table by adding 'CAST' to all columns. This is most useful for
121− => a -> Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () a
144+-- finalising a SELECT or RETURNING statement, guaranteed that the output
122−toPackMap as = Opaleye.PackMap $ \f () ->
145+-- matches what is encoded in each columns TypeInformation.
123− fmap fromColumns $
146+castTable :: Table Expr a => a -> a
124− unwrapApplicative .
147+castTable (toColumns -> as) = fromColumns $ htabulate \field ->
125− htraverse (\(DB a) -> WrapApplicative $ DB <$> traversePrimExpr f a) $
148+ case hfield hspecs field of
126− toColumns as
149+ Spec {info} -> case hfield as field of
150+ expr -> scastExpr info expr
src/Rel8/Table/Ord.hs+45−73
@@ -2,14 +2,14 @@
2{-# language DataKinds #-}
2{-# language DataKinds #-}
3{-# language DefaultSignatures #-}
3{-# language DefaultSignatures #-}
4{-# language DisambiguateRecordFields #-}
4{-# language DisambiguateRecordFields #-}
5+{-# language FlexibleContexts #-}
5{-# language FlexibleInstances #-}
6{-# language FlexibleInstances #-}
6−{-# language NamedFieldPuns #-}
7{-# language ScopedTypeVariables #-}
7{-# language ScopedTypeVariables #-}
8{-# language StandaloneKindSignatures #-}
8{-# language StandaloneKindSignatures #-}
9{-# language TypeApplications #-}
9{-# language TypeApplications #-}
10{-# language TypeFamilies #-}
10{-# language TypeFamilies #-}
11+{-# language TypeOperators #-}
11{-# language UndecidableInstances #-}
12{-# language UndecidableInstances #-}
12−{-# language UndecidableSuperClasses #-}
13{-# language ViewPatterns #-}
13{-# language ViewPatterns #-}
14
14
15module Rel8.Table.Ord
15module Rel8.Table.Ord
@@ -20,31 +20,25 @@ where
20-- base
20-- base
21import Data.Functor.Const ( Const( Const ), getConst )
21import Data.Functor.Const ( Const( Const ), getConst )
22import Data.Kind ( Constraint, Type )
22import Data.Kind ( Constraint, Type )
23+import GHC.Generics ( Rep )
23import Prelude hiding ( seq )
24import Prelude hiding ( seq )
24
25
25-- rel8
26-- rel8
26−import Rel8.Expr ( Expr, Col(..) )
27+import Rel8.Expr ( Expr )
27import Rel8.Expr.Bool ( (||.), (&&.), false, true )
28import Rel8.Expr.Bool ( (||.), (&&.), false, true )
28import Rel8.Expr.Eq ( (==.) )
29import Rel8.Expr.Eq ( (==.) )
29import Rel8.Expr.Ord ( (<.), (>.) )
30import Rel8.Expr.Ord ( (<.), (>.) )
30−import Rel8.Schema.Context.Label ( hlabeler )
31+import Rel8.FCF ( Eval, Exp )
32+import Rel8.Generic.Record ( Record )
33+import Rel8.Generic.Table.Record ( GTable, GColumns, gtable )
31import Rel8.Schema.Dict ( Dict( Dict ) )
34import Rel8.Schema.Dict ( Dict( Dict ) )
32−import Rel8.Schema.HTable
35+import Rel8.Schema.HTable ( htabulateA, hfield )
33− ( HTable, HConstrainTable
36+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
34− , htabulateA, hfield, hdicts
37+import Rel8.Schema.Null (Sql)
35− )
38+import Rel8.Table ( Columns, toColumns, TColumns )
36−import Rel8.Schema.HTable.Label ( hlabel )
37−import Rel8.Schema.HTable.Pair ( HPair(..) )
38−import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
39−import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
40−import Rel8.Schema.HTable.Trio ( HTrio(..) )
41−import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
42−import Rel8.Table ( Table, Columns, toColumns )
43import Rel8.Table.Bool ( bool )
39import Rel8.Table.Bool ( bool )
44import Rel8.Table.Eq ( EqTable )
40import Rel8.Table.Eq ( EqTable )
45−import Rel8.Type.Eq ( DBEq )
46import Rel8.Type.Ord ( DBOrd )
41import Rel8.Type.Ord ( DBOrd )
47−import Rel8.Schema.Nullability (Sql)
48
42
49
43
50-- | The class of 'Table's that can be ordered. Ordering on tables is defined
44-- | The class of 'Table's that can be ordered. Ordering on tables is defined
@@ -52,72 +46,50 @@ import Rel8.Schema.Nullability (Sql)
52-- columns in a 'Table' have an instance of 'DBOrd'".
46-- columns in a 'Table' have an instance of 'DBOrd'".
53type OrdTable :: Type -> Constraint
47type OrdTable :: Type -> Constraint
54class EqTable a => OrdTable a where
48class EqTable a => OrdTable a where
55− ordTable :: Columns a (Dict (ConstrainDBType DBOrd))
49+ ordTable :: Columns a (Dict (Sql DBOrd))
56−
57− default ordTable :: HConstrainTable (Columns a) (ConstrainDBType DBOrd) => Columns a (Dict (ConstrainDBType DBOrd))
58− ordTable = hdicts @(Columns a) @(ConstrainDBType DBOrd)
59
50
60−
51+ default ordTable ::
61−instance
52+ ( GTable TOrdTable TColumns (Rep (Record a))
62− ( Table Expr (t Expr)
53+ , Columns a ~ GColumns TColumns (Rep (Record a))
63− , f ~ Expr
54+ )
64− , HConstrainTable (Columns (t Expr)) (ConstrainDBType DBEq)
55+ => Columns a (Dict (Sql DBOrd))
65− , HConstrainTable (Columns (t Expr)) (ConstrainDBType DBOrd)
56+ ordTable = gtable @TOrdTable @TColumns @(Rep (Record a)) table
66− )
57+ where
67− => OrdTable (t f)
58+ table (_ :: proxy x) = ordTable @x
68
59
69
60
70−instance
61+data TOrdTable :: Type -> Exp Constraint
71− ( HTable t
62+type instance Eval (TOrdTable a) = OrdTable a
72− , f ~ Col Expr
73− , HConstrainTable t (ConstrainDBType DBEq)
74− , HConstrainTable t (ConstrainDBType DBOrd)
75− )
76− => OrdTable (t f)
77
63
78
64
79−instance Sql DBOrd a => OrdTable (Expr a)
65+instance Sql DBOrd a => OrdTable (Expr a) where
66+ ordTable = HIdentity Dict
80
67
81
68
82−instance (OrdTable a, OrdTable b) => OrdTable (a, b) where
69+instance (OrdTable a, OrdTable b) => OrdTable (a, b)
83− ordTable =
84− HPair
85− { hfst = hlabel hlabeler (ordTable @a)
86− , hsnd = hlabel hlabeler (ordTable @b)
87− }
88
70
89
71
90−instance (OrdTable a, OrdTable b, OrdTable c) => OrdTable (a, b, c) where
72+instance (OrdTable a, OrdTable b, OrdTable c) => OrdTable (a, b, c)
91− ordTable =
92− HTrio
93− { hfst = hlabel hlabeler (ordTable @a)
94− , hsnd = hlabel hlabeler (ordTable @b)
95− , htrd = hlabel hlabeler (ordTable @c)
96− }
97
73
98
74
99instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d) => OrdTable (a, b, c, d)
75instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d) => OrdTable (a, b, c, d)
100− where
101− ordTable =
102− HQuartet
103− { hfst = hlabel hlabeler (ordTable @a)
104− , hsnd = hlabel hlabeler (ordTable @b)
105− , htrd = hlabel hlabeler (ordTable @c)
106− , hfrt = hlabel hlabeler (ordTable @d)
107− }
108
76
109
77
110instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e) =>
78instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e) =>
111 OrdTable (a, b, c, d, e)
79 OrdTable (a, b, c, d, e)
112− where
80+
113− ordTable =
81+
114− HQuintet
82+instance
115− { hfst = hlabel hlabeler (ordTable @a)
83+ ( OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e, OrdTable f
116− , hsnd = hlabel hlabeler (ordTable @b)
84+ )
117− , htrd = hlabel hlabeler (ordTable @c)
85+ => OrdTable (a, b, c, d, e, f)
118− , hfrt = hlabel hlabeler (ordTable @d)
86+
119− , hfft = hlabel hlabeler (ordTable @e)
87+
120− }
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)
121
93
122
94
123-- | Test if one 'Table' sorts before another. Corresponds to comparing all
95-- | Test if one 'Table' sorts before another. Corresponds to comparing all
@@ -126,7 +98,7 @@ instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e) =>
126(toColumns -> as) <: (toColumns -> bs) =
98(toColumns -> as) <: (toColumns -> bs) =
127 foldr @[] go false $ getConst $ htabulateA $ \field ->
99 foldr @[] go false $ getConst $ htabulateA $ \field ->
128 case (hfield as field, hfield bs field) of
100 case (hfield as field, hfield bs field) of
129− (DB a, DB b) -> case hfield (ordTable @a) field of
101+ (a, b) -> case hfield (ordTable @a) field of
130 Dict -> Const [(a <. b, a ==. b)]
102 Dict -> Const [(a <. b, a ==. b)]
131 where
103 where
132 go (lt, eq) a = lt ||. (eq &&. a)
104 go (lt, eq) a = lt ||. (eq &&. a)
@@ -139,7 +111,7 @@ infix 4 <:
139(toColumns -> as) <=: (toColumns -> bs) =
111(toColumns -> as) <=: (toColumns -> bs) =
140 foldr @[] go true $ getConst $ htabulateA $ \field ->
112 foldr @[] go true $ getConst $ htabulateA $ \field ->
141 case (hfield as field, hfield bs field) of
113 case (hfield as field, hfield bs field) of
142− (DB a, DB b) -> case hfield (ordTable @a) field of
114+ (a, b) -> case hfield (ordTable @a) field of
143 Dict -> Const [(a <. b, a ==. b)]
115 Dict -> Const [(a <. b, a ==. b)]
144 where
116 where
145 go (lt, eq) a = lt ||. (eq &&. a)
117 go (lt, eq) a = lt ||. (eq &&. a)
@@ -152,7 +124,7 @@ infix 4 <=:
152(toColumns -> as) >: (toColumns -> bs) =
124(toColumns -> as) >: (toColumns -> bs) =
153 foldr @[] go false $ getConst $ htabulateA $ \field ->
125 foldr @[] go false $ getConst $ htabulateA $ \field ->
154 case (hfield as field, hfield bs field) of
126 case (hfield as field, hfield bs field) of
155− (DB a, DB b) -> case hfield (ordTable @a) field of
127+ (a, b) -> case hfield (ordTable @a) field of
156 Dict -> Const [(a >. b, a ==. b)]
128 Dict -> Const [(a >. b, a ==. b)]
157 where
129 where
158 go (gt, eq) a = gt ||. (eq &&. a)
130 go (gt, eq) a = gt ||. (eq &&. a)
@@ -165,7 +137,7 @@ infix 4 >:
165(toColumns -> as) >=: (toColumns -> bs) =
137(toColumns -> as) >=: (toColumns -> bs) =
166 foldr @[] go true $ getConst $ htabulateA $ \field ->
138 foldr @[] go true $ getConst $ htabulateA $ \field ->
167 case (hfield as field, hfield bs field) of
139 case (hfield as field, hfield bs field) of
168− (DB a, DB b) -> case hfield (ordTable @a) field of
140+ (a, b) -> case hfield (ordTable @a) field of
169 Dict -> Const [(a >. b, a ==. b)]
141 Dict -> Const [(a >. b, a ==. b)]
170 where
142 where
171 go (gt, eq) a = gt ||. (eq &&. a)
143 go (gt, eq) a = gt ||. (eq &&. a)
@@ -174,9 +146,9 @@ infix 4 >=:
174
146
175-- | Given two 'Table's, return the table that sorts before the other.
147-- | Given two 'Table's, return the table that sorts before the other.
176least :: OrdTable a => a -> a -> a
148least :: OrdTable a => a -> a -> a
177−least a b = bool a b (a <: b)
149+least a b = bool b a (a <: b)
178
150
179
151
180-- | Given two 'Table's, return the table that sorts after the other.
152-- | Given two 'Table's, return the table that sorts after the other.
181greatest :: OrdTable a => a -> a -> a
153greatest :: OrdTable a => a -> a -> a
182−greatest a b = bool a b (a >: b)
154+greatest a b = bool b a (a >: b)
src/Rel8/Table/Order.hs+14−18
@@ -16,16 +16,14 @@ import Data.Functor.Contravariant ( (>$<), contramap )
16import Prelude
16import Prelude
17
17
18-- rel8
18-- rel8
19−import Rel8.Expr ( unDB )
20import Rel8.Expr.Order ( asc, desc, nullsFirst, nullsLast )
19import Rel8.Expr.Order ( asc, desc, nullsFirst, nullsLast )
21import Rel8.Order ( Order )
20import Rel8.Order ( Order )
22import Rel8.Schema.Dict ( Dict( Dict ) )
21import Rel8.Schema.Dict ( Dict( Dict ) )
23import Rel8.Schema.HTable (htabulateA, hfield, hspecs)
22import Rel8.Schema.HTable (htabulateA, hfield, hspecs)
24−import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
23+import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
25−import Rel8.Schema.Spec ( SSpec( SSpec ) )
24+import Rel8.Schema.Spec ( Spec( Spec, nullity ) )
26−import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullability )
25+import Rel8.Table ( Columns, toColumns )
27−import Rel8.Table
26+import Rel8.Table.Ord ( OrdTable, ordTable )
28−import Rel8.Table.Ord
29
27
30
28
31-- | Construct an 'Order' for a 'Table' by sorting all columns into ascending
29-- | Construct an 'Order' for a 'Table' by sorting all columns into ascending
@@ -33,12 +31,11 @@ import Rel8.Table.Ord
33ascTable :: forall a. OrdTable a => Order a
31ascTable :: forall a. OrdTable a => Order a
34ascTable = contramap toColumns $ getConst $
32ascTable = contramap toColumns $ getConst $
35 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
33 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
36− SSpec {} -> case hfield (ordTable @a) field of
34+ Spec {nullity} -> case hfield (ordTable @a) field of
37− dict@Dict -> case dbTypeDict dict of
35+ Dict -> Const $ (`hfield` field) >$<
38− Dict -> Const $ unDB . (`hfield` field) >$<
36+ case nullity of
39− case dbTypeNullability dict of
37+ Null -> nullsFirst asc
40− Nullable -> nullsFirst asc
38+ NotNull -> asc
41− NonNullable -> asc
42
39
43
40
44-- | Construct an 'Order' for a 'Table' by sorting all columns into descending
41-- | Construct an 'Order' for a 'Table' by sorting all columns into descending
@@ -46,9 +43,8 @@ ascTable = contramap toColumns $ getConst $
46descTable :: forall a. OrdTable a => Order a
43descTable :: forall a. OrdTable a => Order a
47descTable = contramap toColumns $ getConst $
44descTable = contramap toColumns $ getConst $
48 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
45 htabulateA @(Columns a) $ \field -> case hfield hspecs field of
49− SSpec {} -> case hfield (ordTable @a) field of
46+ Spec {nullity} -> case hfield (ordTable @a) field of
50− dict@Dict -> case dbTypeDict dict of
47+ Dict -> Const $ (`hfield` field) >$<
51− Dict -> Const $ unDB . (`hfield` field) >$<
48+ case nullity of
52− case dbTypeNullability dict of
49+ Null -> nullsLast desc
53− Nullable -> nullsLast desc
50+ NotNull -> desc
54− NonNullable -> desc
src/Rel8/Table/Projection.hsnew file+73
@@ -0,0 +1,73 @@
1+{-# language FlexibleContexts #-}
2+{-# language FlexibleInstances #-}
3+{-# language MonoLocalBinds #-}
4+{-# language MultiParamTypeClasses #-}
5+{-# language StandaloneKindSignatures #-}
6+{-# language UndecidableInstances #-}
7+
8+module Rel8.Table.Projection
9+ ( Projection
10+ , Projectable( project )
11+ , Biprojectable( biproject )
12+ , Projecting
13+ , apply
14+ )
15+where
16+
17+-- base
18+import Data.Kind ( Constraint, Type )
19+import Prelude
20+
21+-- rel8
22+import Rel8.Schema.Field ( Field( Field ), fields )
23+import Rel8.Schema.HTable ( hfield, htabulate )
24+import Rel8.Table ( Columns, Context, Transpose, toColumns )
25+import Rel8.Table.Transpose ( Transposes )
26+
27+
28+-- | The constraint @'Projecting' a b@ ensures that @'Projection' a b@ is a
29+-- usable 'Projection'.
30+type Projecting :: Type -> Type -> Constraint
31+class
32+ ( Transposes (Context a) (Field a) a (Transpose (Field a) a)
33+ , Transposes (Context a) (Field a) b (Transpose (Field a) b)
34+ )
35+ => Projecting a b
36+instance
37+ ( Transposes (Context a) (Field a) a (Transpose (Field a) a)
38+ , Transposes (Context a) (Field a) b (Transpose (Field a) b)
39+ )
40+ => Projecting a b
41+
42+
43+-- | A @'Projection' a b@s is a special type of function @a -> b@ whereby the
44+-- resulting @b@ is guaranteed to be composed only from columns contained in
45+-- @a@.
46+type Projection :: Type -> Type -> Type
47+type Projection a b = Transpose (Field a) a -> Transpose (Field a) b
48+
49+
50+-- | @'Projectable' f@ means that @f@ is a kind of functor on 'Rel8.Table's
51+-- that allows the mapping of a 'Projection' over its underlying columns.
52+type Projectable :: (Type -> Type) -> Constraint
53+class Projectable f where
54+ -- | Map a 'Projection' over @f@.
55+ project :: Projecting a b
56+ => Projection a b -> f a -> f b
57+
58+
59+-- | @'Biprojectable' p@ means that @p@ is a kind of bifunctor on
60+-- 'Rel8.Table's that allows the mapping of a pair of 'Projection's over its
61+-- underlying columns.
62+type Biprojectable :: (Type -> Type -> Type) -> Constraint
63+class Biprojectable p where
64+ -- | Map a pair of 'Projection's over @p@.
65+ biproject :: (Projecting a b, Projecting c d)
66+ => Projection a b -> Projection c d -> p a c -> p b d
67+
68+
69+apply :: Projecting a b
70+ => Projection a b -> Columns a context -> Columns b context
71+apply f a = case toColumns (f fields) of
72+ bs -> htabulate $ \field -> case hfield bs field of
73+ Field field' -> hfield a field'
src/Rel8/Table/Recontextualize.hsdeleted−133
@@ -1,133 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language FlexibleInstances #-}
3−{-# language FunctionalDependencies #-}
4−{-# language StandaloneKindSignatures #-}
5−{-# language TypeFamilies #-}
6−{-# language UndecidableInstances #-}
7−{-# language UndecidableSuperClasses #-}
8−
9−module Rel8.Table.Recontextualize
10− ( Recontextualize
11− )
12−where
13−
14−-- base
15−import Data.Functor.Identity ( Identity )
16−import Data.Kind ( Constraint, Type )
17−import Prelude ()
18−
19−-- rel8
20−import Rel8.Opaque ( Opaque )
21−import Rel8.Schema.Context ( Col )
22−import Rel8.Schema.Context.Label ( Labelable )
23−import Rel8.Schema.HTable ( HTable )
24−import qualified Rel8.Schema.Kind as K
25−import Rel8.Schema.Nullability ( Sql )
26−import Rel8.Schema.Spec ( KnownSpec )
27−import Rel8.Table ( Table, Congruent )
28−import Rel8.Type ( DBType )
29−
30−
31−type Recontextualize :: K.Context -> K.Context -> Type -> Type -> Constraint
32−class
33− ( Table from a
34− , Table to b
35− , Congruent a b
36− , Recontextualize from from a a
37− , Recontextualize to to b b
38− , Recontextualize to from b a
39− ) => Recontextualize from to a b
40− | a -> from
41− , b -> to
42− , a to -> b
43− , b from -> a
44−
45−
46−instance KnownSpec spec =>
47− Recontextualize from to (Col from spec) (Col to spec)
48−
49−
50−{-
51−instance Sql DBType a =>
52− Recontextualize Aggregate Insertion (Aggregate (Expr a)) (Insertion a)
53−
54−
55−instance Sql DBType a => Recontextualize Expr Insertion (Expr a) (Insertion a)
56−-}
57−
58−
59−instance Sql DBType a => Recontextualize Identity Identity (Identity a) (Identity a)
60−
61−
62−{-
63−instance Sql DBType a =>
64− Recontextualize Identity Insertion (Identity a) (Insertion a)
65−
66−
67−instance Sql DBType a =>
68− Recontextualize Insertion Aggregate (Insertion a) (Aggregate (Expr a))
69−
70−
71−instance Sql DBType a => Recontextualize Insertion Expr (Insertion a) (Expr a)
72−
73−
74−instance Sql DBType a =>
75− Recontextualize Insertion Identity (Insertion a) (Identity a)
76−
77−
78−instance Sql DBType a => Recontextualize Insertion Insertion (Insertion a) (Insertion a)
79−
80−
81−instance Sql DBType a => Recontextualize Insertion Name (Insertion a) (Name a)
82−
83−
84−instance Sql DBType a => Recontextualize Name Insertion (Name a) (Insertion a)
85−-}
86−
87−
88−instance Recontextualize from to (Opaque from a) (Opaque to a)
89−
90−
91−instance HTable t => Recontextualize from to (t (Col from)) (t (Col to))
92−
93−
94−instance
95− ( Table from (t from)
96− , Table to (t to)
97− , Congruent (t from) (t to)
98− ) => Recontextualize from to (t from) (t to)
99−
100−
101−instance
102− ( Recontextualize from to a1 b1
103− , Recontextualize from to a2 b2
104− , Labelable from
105− , Labelable to
106− ) => Recontextualize from to (a1, a2) (b1, b2)
107−
108−
109−instance
110− ( Recontextualize from to a1 b1
111− , Recontextualize from to a2 b2
112− , Recontextualize from to a3 b3
113− , Labelable from, Labelable to
114− ) => Recontextualize from to (a1, a2, a3) (b1, b2, b3)
115−
116−
117−instance
118− ( Recontextualize from to a1 b1
119− , Recontextualize from to a2 b2
120− , Recontextualize from to a3 b3
121− , Recontextualize from to a4 b4
122− , Labelable from, Labelable to
123− ) => Recontextualize from to (a1, a2, a3, a4) (b1, b2, b3, b4)
124−
125−
126−instance
127− ( Recontextualize from to a1 b1
128− , Recontextualize from to a2 b2
129− , Recontextualize from to a3 b3
130− , Recontextualize from to a4 b4
131− , Recontextualize from to a5 b5
132− , Labelable from, Labelable to
133− ) => Recontextualize from to (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5)
src/Rel8/Table/Rel8able.hsnew file+92
@@ -0,0 +1,92 @@
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+71−270
@@ -1,6 +1,4 @@
1{-# language AllowAmbiguousTypes #-}
1{-# language AllowAmbiguousTypes #-}
2−{-# language DataKinds #-}
3−{-# language DisambiguateRecordFields #-}
4{-# language FlexibleContexts #-}
2{-# language FlexibleContexts #-}
5{-# language FlexibleInstances #-}
3{-# language FlexibleInstances #-}
6{-# language FunctionalDependencies #-}
4{-# language FunctionalDependencies #-}
@@ -9,18 +7,16 @@
9{-# language StandaloneKindSignatures #-}
7{-# language StandaloneKindSignatures #-}
10{-# language TypeApplications #-}
8{-# language TypeApplications #-}
11{-# language TypeFamilies #-}
9{-# language TypeFamilies #-}
12−{-# language ViewPatterns #-}
13{-# language UndecidableInstances #-}
10{-# language UndecidableInstances #-}
14
11
15module Rel8.Table.Serialize
12module Rel8.Table.Serialize
16− ( Serializable, lit, parse
13+ ( Serializable, lit, litHTable, parse
17− , Encodes, litTable
14+ , ToExprs
18 )
15 )
19where
16where
20
17
21-- base
18-- base
22−import Data.Bifunctor ( bimap )
19+import Data.Functor.Identity ( Identity( Identity ) )
23−import Data.Functor.Identity ( Identity )
24import Data.Kind ( Constraint, Type )
20import Data.Kind ( Constraint, Type )
25import Data.List.NonEmpty ( NonEmpty )
21import Data.List.NonEmpty ( NonEmpty )
26import Prelude
22import Prelude
@@ -29,319 +25,124 @@ import Prelude
29import qualified Hasql.Decoders as Hasql
25import qualified Hasql.Decoders as Hasql
30
26
31-- rel8
27-- rel8
32−import Rel8.Expr ( Expr, Col(..) )
28+import Rel8.Expr ( Expr )
33import Rel8.Expr.Serialize ( slitExpr, sparseValue )
29import Rel8.Expr.Serialize ( slitExpr, sparseValue )
34−import Rel8.Schema.Context ( Col(..) )
35−import Rel8.Schema.Context.Identity
36− ( fromHEitherTable, toHEitherTable
37− , fromHListTable, toHListTable
38− , fromHMaybeTable, toHMaybeTable
39− , fromHNonEmptyTable, toHNonEmptyTable
40− , fromHTheseTable, toHTheseTable
41− )
42−import Rel8.Schema.Context.Label ( labeler, unlabeler )
43import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )
30import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )
44−import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
31+import Rel8.Schema.Null ( NotNull, Sql )
45−import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
32+import Rel8.Schema.Result ( Result )
46−import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
33+import Rel8.Schema.Spec ( Spec(..) )
47−import Rel8.Schema.HTable.Pair ( HPair(..) )
34+import Rel8.Table ( Table, fromColumns, FromExprs, fromResult, toResult )
48−import Rel8.Schema.HTable.Trio ( HTrio(..) )
49−import Rel8.Schema.HTable.Type ( HType(..) )
50−import Rel8.Schema.Nullability ( NotNull, Sql )
51−import Rel8.Schema.Spec ( SSpec(..), KnownSpec )
52−import Rel8.Table ( Table, Columns, fromColumns, toColumns )
53−import Rel8.Table.Either ( EitherTable )
54−import Rel8.Table.List ( ListTable )
55−import Rel8.Table.Maybe ( MaybeTable )
56−import Rel8.Table.NonEmpty ( NonEmptyTable )
57−import Rel8.Table.Recontextualize ( Recontextualize )
58−import Rel8.Table.These ( TheseTable )
59import Rel8.Type ( DBType )
35import Rel8.Type ( DBType )
60
36
61-- semigroupoids
37-- semigroupoids
62import Data.Functor.Apply ( WrappedApplicative(..) )
38import Data.Functor.Apply ( WrappedApplicative(..) )
63
39
64−-- these
65−import Data.These ( These )
66−
67−
68−fromIdentity' :: forall exprs a. ToExprs a exprs => Columns exprs (Col Identity) -> a
69−fromIdentity' = fromIdentity @_ @exprs
70−
71−
72−toIdentity' :: forall exprs a. ToExprs a exprs => a -> Columns exprs (Col Identity)
73−toIdentity' = toIdentity @_ @exprs
74−
75
40
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.
76type ToExprs :: Type -> Type -> Constraint
44type ToExprs :: Type -> Type -> Constraint
77−class Table Expr exprs => ToExprs a exprs where
45+class Table Expr exprs => ToExprs exprs a
78− fromIdentity :: Columns exprs (Col Identity) -> a
79− toIdentity :: a -> Columns exprs (Col Identity)
80−
81
46
82−instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs a x where
83− fromIdentity (HType (Result a)) = a
84− toIdentity = HType . Result
85
47
48+instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a
86
49
87−instance (Sql DBType a, x ~ [a]) => ToExprs [a] (Expr x) where
88− fromIdentity (HType (Result a)) = a
89− toIdentity = HType . Result
90
50
51+instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a]
91
52
92−instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Maybe a) (Expr x)
93− where
94− fromIdentity (HType (Result a)) = a
95− toIdentity = HType . Result
96
53
54+instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a)
97
55
98−instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (NonEmpty a) (Expr x)
99− where
100− fromIdentity (HType (Result a)) = a
101− toIdentity = HType . Result
102
56
57+instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a)
103
58
104−instance (ToExprs a exprs1, ToExprs b exprs2, x ~ EitherTable exprs1 exprs2) =>
105− ToExprs (Either a b) x
106− where
107− fromIdentity =
108− bimap
109− (fromIdentity' @exprs1 . hunlabel unlabeler)
110− (fromIdentity' @exprs2 . hunlabel unlabeler) .
111− fromHEitherTable
112− toIdentity =
113− toHEitherTable .
114− bimap
115− (hlabel labeler . toIdentity' @exprs1)
116− (hlabel labeler . toIdentity' @exprs2)
117
59
60+instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>
61+ ToExprs x (a, b)
118
62
119−instance ToExprs a exprs => ToExprs [a] (ListTable exprs) where
120− fromIdentity = fmap (fromIdentity' @exprs) . fromHListTable
121− toIdentity = toHListTable . fmap (toIdentity' @exprs)
122
63
123−
64+instance
124−instance ToExprs a exprs => ToExprs (Maybe a) (MaybeTable exprs) where
65+ ( ToExprs exprs1 a
125− fromIdentity =
66+ , ToExprs exprs2 b
126− fmap (fromIdentity' @exprs . hunlabel unlabeler) .
67+ , ToExprs exprs3 c
127− fromHMaybeTable
68+ , x ~ (exprs1, exprs2, exprs3)
128− toIdentity =
69+ )
129− toHMaybeTable .
70+ => ToExprs x (a, b, c)
130− fmap (hlabel labeler . toIdentity' @exprs)
131−
132−
133−instance ToExprs a exprs => ToExprs (NonEmpty a) (NonEmptyTable exprs)
134− where
135− fromIdentity = fmap (fromIdentity' @exprs) . fromHNonEmptyTable
136− toIdentity = toHNonEmptyTable . fmap (toIdentity' @exprs)
137−
138−
139−instance (ToExprs a exprs1, ToExprs b exprs2, x ~ TheseTable exprs1 exprs2) =>
140− ToExprs (These a b) x
141− where
142− fromIdentity =
143− bimap
144− (fromIdentity' @exprs1 . hunlabel unlabeler)
145− (fromIdentity' @exprs2 . hunlabel unlabeler) .
146− fromHTheseTable
147− toIdentity =
148− toHTheseTable .
149− bimap
150− (hlabel labeler . toIdentity' @exprs1)
151− (hlabel labeler . toIdentity' @exprs2)
152
71
153
72
154−instance (ToExprs a exprs1, ToExprs b exprs2, x ~ (exprs1, exprs2)) =>
73+instance
155− ToExprs (a, b) x
74+ ( ToExprs exprs1 a
156− where
75+ , ToExprs exprs2 b
157− fromIdentity (HPair a b) =
76+ , ToExprs exprs3 c
158− ( fromIdentity' @exprs1 $ hunlabel unlabeler a
77+ , ToExprs exprs4 d
159− , fromIdentity' @exprs2 $ hunlabel unlabeler b
78+ , x ~ (exprs1, exprs2, exprs3, exprs4)
160− )
79+ )
161− toIdentity (a, b) = HPair
80+ => ToExprs x (a, b, c, d)
162− { hfst = hlabel labeler $ toIdentity' @exprs1 a
163− , hsnd = hlabel labeler $ toIdentity' @exprs2 b
164− }
165
81
166
82
167instance
83instance
168− ( ToExprs a exprs1
84+ ( ToExprs exprs1 a
169− , ToExprs b exprs2
85+ , ToExprs exprs2 b
170− , ToExprs c exprs3
86+ , ToExprs exprs3 c
171− , x ~ (exprs1, exprs2, exprs3)
87+ , ToExprs exprs4 d
172− ) => ToExprs (a, b, c) x
88+ , ToExprs exprs5 e
173− where
89+ , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
174− fromIdentity (HTrio a b c) =
90+ )
175− ( fromIdentity' @exprs1 $ hunlabel unlabeler a
91+ => ToExprs x (a, b, c, d, e)
176− , fromIdentity' @exprs2 $ hunlabel unlabeler b
177− , fromIdentity' @exprs3 $ hunlabel unlabeler c
178− )
179− toIdentity (a, b, c) = HTrio
180− { hfst = hlabel labeler $ toIdentity' @exprs1 a
181− , hsnd = hlabel labeler $ toIdentity' @exprs2 b
182− , htrd = hlabel labeler $ toIdentity' @exprs3 c
183− }
184
92
185
93
186instance
94instance
187− ( ToExprs a exprs1
95+ ( ToExprs exprs1 a
188− , ToExprs b exprs2
96+ , ToExprs exprs2 b
189− , ToExprs c exprs3
97+ , ToExprs exprs3 c
190− , ToExprs d exprs4
98+ , ToExprs exprs4 d
191− , x ~ (exprs1, exprs2, exprs3, exprs4)
99+ , ToExprs exprs5 e
192− ) => ToExprs (a, b, c, d) x
100+ , ToExprs exprs6 f
193− where
101+ , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6)
194− fromIdentity (HQuartet a b c d) =
102+ )
195− ( fromIdentity' @exprs1 $ hunlabel unlabeler a
103+ => ToExprs x (a, b, c, d, e, f)
196− , fromIdentity' @exprs2 $ hunlabel unlabeler b
197− , fromIdentity' @exprs3 $ hunlabel unlabeler c
198− , fromIdentity' @exprs4 $ hunlabel unlabeler d
199− )
200− toIdentity (a, b, c, d) = HQuartet
201− { hfst = hlabel labeler $ toIdentity' @exprs1 a
202− , hsnd = hlabel labeler $ toIdentity' @exprs2 b
203− , htrd = hlabel labeler $ toIdentity' @exprs3 c
204− , hfrt = hlabel labeler $ toIdentity' @exprs4 d
205− }
206
104
207
105
208instance
106instance
209− ( ToExprs a exprs1
107+ ( ToExprs exprs1 a
210− , ToExprs b exprs2
108+ , ToExprs exprs2 b
211− , ToExprs c exprs3
109+ , ToExprs exprs3 c
212− , ToExprs d exprs4
110+ , ToExprs exprs4 d
213− , ToExprs e exprs5
111+ , ToExprs exprs5 e
214− , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
112+ , ToExprs exprs6 f
215− ) => ToExprs (a, b, c, d, e) x
113+ , ToExprs exprs7 g
216− where
114+ , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6, exprs7)
217− fromIdentity (HQuintet a b c d e) =
115+ )
218− ( fromIdentity' @exprs1 $ hunlabel unlabeler a
116+ => ToExprs x (a, b, c, d, e, f, g)
219− , fromIdentity' @exprs2 $ hunlabel unlabeler b
220− , fromIdentity' @exprs3 $ hunlabel unlabeler c
221− , fromIdentity' @exprs4 $ hunlabel unlabeler d
222− , fromIdentity' @exprs5 $ hunlabel unlabeler e
223− )
224− toIdentity (a, b, c, d, e) = HQuintet
225− { hfst = hlabel labeler $ toIdentity' @exprs1 a
226− , hsnd = hlabel labeler $ toIdentity' @exprs2 b
227− , htrd = hlabel labeler $ toIdentity' @exprs3 c
228− , hfrt = hlabel labeler $ toIdentity' @exprs4 d
229− , hfft = hlabel labeler $ toIdentity' @exprs5 e
230− }
231−
232−
233−instance (HTable t, result ~ Col Identity, x ~ t (Col Expr)) =>
234− ToExprs (t result) x
235− where
236− fromIdentity = id
237− toIdentity = id
238−
239−
240−instance (Recontextualize Identity Expr (t Identity) (t Expr), result ~ Identity, x ~ t Expr) =>
241− ToExprs (t result) x
242− where
243− fromIdentity = fromColumns
244− toIdentity = toColumns
245−
246−
247−instance (KnownSpec spec, x ~ Col Expr spec) =>
248− ToExprs (Col Identity spec) x
249− where
250− fromIdentity = fromColumns
251− toIdentity = toColumns
252−
253−
254−type FromExprs :: Type -> Type
255−type family FromExprs a where
256− FromExprs (Expr a) = a
257− FromExprs (Col Expr spec) = Col Identity spec
258− FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
259− FromExprs (ListTable a) = [FromExprs a]
260− FromExprs (MaybeTable a) = Maybe (FromExprs a)
261− FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)
262− FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
263− FromExprs (a, b) = (FromExprs a, FromExprs b)
264− FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)
265− FromExprs (a, b, c, d) =
266− (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
267− FromExprs (a, b, c, d, e) =
268− (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
269− FromExprs (t Expr) = t Identity
270− FromExprs (t (Col Expr)) = t (Col Identity)
271
117
272
118
273-- | @Serializable@ witnesses the one-to-one correspondence between the type
119-- | @Serializable@ witnesses the one-to-one correspondence between the type
274-- @sql@, which contains SQL expressions, and the type @haskell@, which
120-- @sql@, which contains SQL expressions, and the type @haskell@, which
275-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
121-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
276type Serializable :: Type -> Type -> Constraint
122type Serializable :: Type -> Type -> Constraint
277−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
278−instance (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a
124+instance (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a
279instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a
125instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a
280
126
281
127
128+-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is
129+-- capable of lifting single @Expr@s to full tables.
282lit :: forall exprs a. Serializable exprs a => a -> exprs
130lit :: forall exprs a. Serializable exprs a => a -> exprs
283−lit = fromColumns . litHTable . toIdentity' @exprs
131+lit = fromColumns . litHTable . toResult @_ @exprs
284
132
285
133
286parse :: forall exprs a. Serializable exprs a => Hasql.Row a
134parse :: forall exprs a. Serializable exprs a => Hasql.Row a
287−parse = fromIdentity' @exprs <$> parseHTable
135+parse = fromResult @_ @exprs <$> parseHTable
288−
289−
290−type Encodes :: Type -> Type -> Constraint
291−class Serializable exprs a => Encodes a exprs | a -> exprs, exprs -> a
292−
293−
294−instance KnownSpec spec => Encodes (Col Identity spec) (Col Expr spec)
295−
296−
297−instance Serializable (t Identity) (t Expr) => Encodes (t Expr) (t Identity)
298−
299−
300−instance HTable t => Encodes (t (Col Identity)) (t (Col Expr))
301−
302−
303−instance (Encodes a x, Encodes b y) => Encodes (Either a b) (EitherTable x y)
304−
305−
306−instance Encodes a x => Encodes [a] (ListTable x)
307−
308−
309−instance Encodes a x => Encodes (Maybe a) (MaybeTable x)
310−
311−
312−instance Encodes a x => Encodes (NonEmpty a) (NonEmptyTable x)
313−
314−
315−instance (Encodes a x, Encodes b y) => Encodes (These a b) (TheseTable x y)
316−
317−
318−instance (Encodes a x, Encodes b y) => Encodes (a, b) (x, y)
319−
320−
321−instance (Encodes a x, Encodes b y, Encodes c z) =>
322− Encodes (a, b, c) (x, y, z)
323−
324−
325−instance (Encodes a w, Encodes b x, Encodes c y, Encodes d z) =>
326− Encodes (a, b, c, d) (w, x, y, z)
327−
328−
329−instance (Encodes a v, Encodes b w, Encodes c x, Encodes d y, Encodes e z) =>
330− Encodes (a, b, c, d, e) (v, w, x, y, z)
331−
332−
333−litTable :: Encodes a exprs => a -> exprs
334−litTable = lit
335
136
336
137
337−litHTable :: HTable t => t (Col Identity) -> t (Col Expr)
138+litHTable :: HTable t => t Result -> t Expr
338litHTable as = htabulate $ \field ->
139litHTable as = htabulate $ \field ->
339 case hfield hspecs field of
140 case hfield hspecs field of
340− SSpec {nullability, info} -> case hfield as field of
141+ Spec {nullity, info} -> case hfield as field of
341− Result value -> DB (slitExpr nullability info value)
142+ Identity value -> slitExpr nullity info value
342
143
343
144
344−parseHTable :: HTable t => Hasql.Row (t (Col Identity))
145+parseHTable :: HTable t => Hasql.Row (t Result)
345parseHTable = unwrapApplicative $ htabulateA $ \field ->
146parseHTable = unwrapApplicative $ htabulateA $ \field ->
346 WrapApplicative $ case hfield hspecs field of
147 WrapApplicative $ case hfield hspecs field of
347− SSpec {nullability, info} -> Result <$> sparseValue nullability info
148+ Spec {nullity, info} -> Identity <$> sparseValue nullity info
src/Rel8/Table/Tag.hsdeleted−104
@@ -1,104 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language FlexibleInstances #-}
3−{-# language GADTs #-}
4−{-# language InstanceSigs #-}
5−{-# language NamedFieldPuns #-}
6−{-# language ScopedTypeVariables #-}
7−{-# language StandaloneKindSignatures #-}
8−{-# language TypeApplications #-}
9−{-# language UndecidableInstances #-}
10−
11−module Rel8.Table.Tag
12− ( Tag(..), Taggable
13− , fromAggregate
14− , fromExpr
15− , fromName
16− )
17−where
18−
19−-- base
20−import Control.Applicative ( (<|>), empty )
21−import Data.Kind ( Constraint, Type )
22−import Data.Foldable ( fold )
23−import Data.Monoid ( getFirst )
24−import Data.Proxy ( Proxy( Proxy ) )
25−import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
26−import Prelude
27−
28−-- rel8
29−import Rel8.Aggregate ( Aggregate, Aggregator, foldInputs )
30−import Rel8.Expr ( Expr )
31−import Rel8.Expr.Opaleye ( fromPrimExpr )
32−import Rel8.Schema.Dict ( Dict( Dict ) )
33−import Rel8.Schema.Name ( Name( Name ) )
34−import Rel8.Schema.Nullability ( Sql, mapSql )
35−import Rel8.Type.Monoid ( DBMonoid )
36−import Rel8.Type.Semigroup ( DBSemigroup )
37−
38−
39−type Tag :: Symbol -> Type -> Type
40−data Tag label a = Tag
41− { expr :: Expr a
42− , aggregator :: Maybe Aggregator
43− , name :: Name a
44− }
45−
46−
47−type Taggable :: Type -> Constraint
48−class Taggable a where
49− tappend :: KnownSymbol label => Tag label a -> Tag label a -> Tag label a
50− tempty :: KnownSymbol label => Tag label a
51−
52−
53−instance Sql DBMonoid a => Taggable a where
54− tappend :: forall label. KnownSymbol label
55− => Tag label a -> Tag label a -> Tag label a
56− tappend a b = Tag
57− { expr = case mapSql dbSemigroupFromDBMonoid (Dict @_ @a) of
58− Dict -> expr a <> expr b
59− , aggregator = aggregator a <|> aggregator b
60− , name = case (name a, symbolVal (Proxy @label)) of
61− (Name x, y)
62− | x == y -> name b
63− | otherwise -> name a
64− }
65− {-# INLINABLE tappend #-}
66−
67− tempty :: forall label. KnownSymbol label => Tag label a
68− tempty = Tag
69− { expr = mempty
70− , aggregator = empty
71− , name = Name (symbolVal (Proxy @label))
72− }
73− {-# INLINABLE tempty #-}
74−
75−
76−instance (KnownSymbol label, Taggable a) => Semigroup (Tag label a) where
77− (<>) = tappend
78−
79−
80−instance (KnownSymbol label, Taggable a) => Monoid (Tag label a) where
81− mempty = tempty
82−
83−
84−fromAggregate :: forall a label. (KnownSymbol label, Taggable a)
85− => Aggregate (Expr a) -> Tag label a
86−fromAggregate = fold . getFirst . foldInputs go
87− where
88− go aggregator primExpr = pure $ (tempty @a @label)
89− { expr = fromPrimExpr primExpr
90− , aggregator
91− }
92−
93−
94−fromExpr :: forall label a. (KnownSymbol label, Taggable a)
95− => Expr a -> Tag label a
96−fromExpr expr = (tempty @a @label) {expr}
97−
98−
99−fromName :: forall a label. Taggable a => Name a -> Tag label a
100−fromName name = (tempty @a @"") {name}
101−
102−
103−dbSemigroupFromDBMonoid :: Dict DBMonoid a -> Dict DBSemigroup a
104−dbSemigroupFromDBMonoid Dict = Dict
src/Rel8/Table/These.hs+211−133
@@ -5,7 +5,6 @@
5{-# language FlexibleInstances #-}
5{-# language FlexibleInstances #-}
6{-# language MultiParamTypeClasses #-}
6{-# language MultiParamTypeClasses #-}
7{-# language NamedFieldPuns #-}
7{-# language NamedFieldPuns #-}
8−{-# language RecordWildCards #-}
9{-# language ScopedTypeVariables #-}
8{-# language ScopedTypeVariables #-}
10{-# language StandaloneKindSignatures #-}
9{-# language StandaloneKindSignatures #-}
11{-# language TupleSections #-}
10{-# language TupleSections #-}
@@ -13,87 +12,115 @@
13{-# language TypeFamilies #-}
12{-# language TypeFamilies #-}
14{-# language UndecidableInstances #-}
13{-# language UndecidableInstances #-}
15
14
15+{-# options_ghc -fno-warn-orphans #-}
16+
16module Rel8.Table.These
17module Rel8.Table.These
17 ( TheseTable(..)
18 ( TheseTable(..)
18 , theseTable, thisTable, thatTable, thoseTable
19 , theseTable, thisTable, thatTable, thoseTable
19 , isThisTable, isThatTable, isThoseTable
20 , isThisTable, isThatTable, isThoseTable
20 , hasHereTable, hasThereTable
21 , hasHereTable, hasThereTable
21 , justHereTable, justThereTable
22 , justHereTable, justThereTable
22− , aggregateTheseTable, nameTheseTable
23+ , alignMaybeTable
24+ , aggregateTheseTable
25+ , nameTheseTable
23 )
26 )
24where
27where
25
28
26-- base
29-- base
27import Data.Bifunctor ( Bifunctor, bimap )
30import Data.Bifunctor ( Bifunctor, bimap )
28−import Data.Functor.Identity ( runIdentity )
29import Data.Kind ( Type )
31import Data.Kind ( Type )
30−import Prelude hiding ( undefined )
32+import Data.Maybe ( isJust )
33+import Prelude hiding ( null, undefined )
31
34
32-- rel8
35-- rel8
33import Rel8.Aggregate ( Aggregate )
36import Rel8.Aggregate ( Aggregate )
34import Rel8.Expr ( Expr )
37import Rel8.Expr ( Expr )
35−import Rel8.Expr.Bool ( (&&.), not_ )
38+import Rel8.Expr.Bool ( (&&.), (||.), boolExpr, not_ )
36−import Rel8.Expr.Null ( isNonNull )
39+import Rel8.Expr.Null ( null, isNonNull )
37−import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler, hlabeler )
40+import Rel8.Kind.Context ( Reifiable )
38−import Rel8.Schema.Context.Nullify
41+import Rel8.Schema.Context.Nullify ( Nullifiable )
39− ( Nullifiable, ConstrainTag
42+import Rel8.Schema.Dict ( Dict( Dict ) )
40− , hencodeTag, hdecodeTag
43+import Rel8.Schema.HTable.Label ( hlabel, hrelabel, hunlabel )
41− , hnullifier, hunnullifier
42− )
43−import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
44import Rel8.Schema.HTable.Identity ( HIdentity(..) )
44import Rel8.Schema.HTable.Identity ( HIdentity(..) )
45−import Rel8.Schema.HTable.Maybe ( HMaybeNullifiable )
45+import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
46−import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
47import Rel8.Schema.HTable.These ( HTheseTable(..) )
46import Rel8.Schema.HTable.These ( HTheseTable(..) )
48−import Rel8.Schema.Name ( Name )
47+import qualified Rel8.Schema.Kind as K
49−import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
48+import Rel8.Schema.Name ( Name )
50−import Rel8.Table.Eq ( EqTable, eqTable )
49+import Rel8.Table
51−import Rel8.Table.Lifted
50+ ( Table, Columns, Context, fromColumns, toColumns
52− ( Table2, Columns2, ConstrainHContext2, fromColumns2, toColumns2
51+ , FromExprs, fromResult, toResult
52+ , Transpose
53 )
53 )
54+import Rel8.Table.Eq ( EqTable, eqTable )
54import Rel8.Table.Maybe
55import Rel8.Table.Maybe
55 ( MaybeTable(..)
56 ( MaybeTable(..)
56 , maybeTable, justTable, nothingTable
57 , maybeTable, justTable, nothingTable
57 , isJustTable
58 , isJustTable
58− , aggregateMaybeTable, nameMaybeTable
59+ , aggregateMaybeTable
60+ , nameMaybeTable
59 )
61 )
62+import Rel8.Table.Nullify ( Nullify, guard )
60import Rel8.Table.Ord ( OrdTable, ordTable )
63import Rel8.Table.Ord ( OrdTable, ordTable )
61−import Rel8.Table.Recontextualize ( Recontextualize )
64+import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )
62−import Rel8.Table.Tag ( Tag(..) )
65+import Rel8.Table.Serialize ( ToExprs )
63import Rel8.Table.Undefined ( undefined )
66import Rel8.Table.Undefined ( undefined )
64import Rel8.Type.Tag ( MaybeTag )
67import Rel8.Type.Tag ( MaybeTag )
65
68
66-- semigroupoids
69-- semigroupoids
67−import Data.Functor.Apply ( Apply, (<.>), liftF2 )
70+import Data.Functor.Apply ( Apply, (<.>) )
68import Data.Functor.Bind ( Bind, (>>-) )
71import Data.Functor.Bind ( Bind, (>>-) )
69
72
70−
73+-- these
71−type TheseTable :: Type -> Type -> Type
74+import Data.These ( These( This, That, These ) )
72−data TheseTable a b = TheseTable
75+import Data.These.Combinators ( justHere, justThere )
73− { here :: MaybeTable a
76+
74− , there :: MaybeTable b
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
75 }
89 }
76 deriving stock Functor
90 deriving stock Functor
77
91
78
92
79−instance Bifunctor TheseTable where
93+instance Biprojectable (TheseTable context) where
94+ biproject f g (TheseTable a b) = TheseTable (project f a) (project g b)
95+
96+
97+instance Nullifiable context => Bifunctor (TheseTable context) where
80 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
98 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
81
99
82
100
83−instance (Table Expr a, Semigroup a) => Apply (TheseTable a) where
101+instance Projectable (TheseTable context a) where
102+ project f (TheseTable a b) = TheseTable a (project f b)
103+
104+
105+instance (context ~ Expr, Table Expr a, Semigroup a) =>
106+ Apply (TheseTable context a)
107+ where
84 fs <.> as = TheseTable
108 fs <.> as = TheseTable
85 { here = here fs <> here as
109 { here = here fs <> here as
86 , there = there fs <.> there as
110 , there = there fs <.> there as
87 }
111 }
88
112
89
113
90−instance (Table Expr a, Semigroup a) => Applicative (TheseTable a)
114+instance (context ~ Expr, Table Expr a, Semigroup a) =>
115+ Applicative (TheseTable context a)
91 where
116 where
92 pure = thatTable
117 pure = thatTable
93 (<*>) = (<.>)
118 (<*>) = (<.>)
94
119
95
120
96−instance (Table Expr a, Semigroup a) => Bind (TheseTable a) where
121+instance (context ~ Expr, Table Expr a, Semigroup a) =>
122+ Bind (TheseTable context a)
123+ where
97 TheseTable here1 ma >>- f = case ma >>- f' of
124 TheseTable here1 ma >>- f = case ma >>- f' of
98 mtb -> TheseTable
125 mtb -> TheseTable
99 { here = maybeTable here1 ((here1 <>) . fst) mtb
126 { here = maybeTable here1 ((here1 <>) . fst) mtb
@@ -104,12 +131,14 @@ instance (Table Expr a, Semigroup a) => Bind (TheseTable a) where
104 TheseTable here2 mb -> (here2,) <$> mb
131 TheseTable here2 mb -> (here2,) <$> mb
105
132
106
133
107−instance (Table Expr a, Semigroup a) => Monad (TheseTable a) where
134+instance (context ~ Expr, Table Expr a, Semigroup a) =>
135+ Monad (TheseTable context a)
136+ where
108 (>>=) = (>>-)
137 (>>=) = (>>-)
109
138
110
139
111−instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
140+instance (context ~ Expr, Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
112− Semigroup (TheseTable a b)
141+ Semigroup (TheseTable context a b)
113 where
142 where
114 a <> b = TheseTable
143 a <> b = TheseTable
115 { here = here a <> here b
144 { here = here a <> here b
@@ -117,139 +146,177 @@ instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
117 }
146 }
118
147
119
148
120−instance Table2 TheseTable where
149+instance
121− type Columns2 TheseTable = HTheseTable
150+ ( Table context a, Table context b
122− type ConstrainHContext2 TheseTable = HMaybeNullifiable
151+ , Reifiable context, context ~ context'
123−
152+ )
124− toColumns2 f g TheseTable {here, there} = HTheseTable
153+ => Table context' (TheseTable context a b)
125− { hhereTag = HIdentity $ hencodeTag (toHereTag (tag here))
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
126 , hhere =
164 , hhere =
127− hnullify (hnullifier (tag here) isNonNull) $ f (just here)
165+ hlabel $ guard (tag here) isJust isNonNull $ toColumns $ just here
128− , hthereTag = HIdentity $ hencodeTag (toThereTag (tag there))
166+ , hthereTag = hlabel $ HIdentity $ tag there
129 , hthere =
167 , hthere =
130− hnullify (hnullifier (tag there) isNonNull) $ g (just there)
168+ hlabel $ guard (tag there) isJust isNonNull $ toColumns $ just there
131 }
169 }
132
170
133− fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} =
171+ fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable
134− TheseTable
172+ { here = MaybeTable
135− { here =
173+ { tag = unHIdentity $ hunlabel hhereTag
136− let
174+ , just = fromColumns $ hunlabel hhere
137− tag = hdecodeTag $ unHIdentity hhereTag
175+ }
138− in
176+ , there = MaybeTable
139− MaybeTable
177+ { tag = unHIdentity $ hunlabel hthereTag
140− { tag
178+ , just = fromColumns $ hunlabel hthere
141− , just = f $
179+ }
142− runIdentity $
180+ }
143− hunnullify (\a -> pure . hunnullifier a)
144− hhere
145− }
146− , there =
147− let
148− tag = hdecodeTag $ unHIdentity hthereTag
149− in
150− MaybeTable
151− { tag
152− , just = g $
153− runIdentity $
154− hunnullify (\a -> pure . hunnullifier a)
155− hthere
156− }
157− }
158−
159− {-# INLINABLE fromColumns2 #-}
160− {-# INLINABLE toColumns2 #-}
161−
162
181
163−instance
182+ toResult tables = HTheseTable
164− ( Table context a, Table context b
183+ { hhereTag = hrelabel hhereTag
165− , Labelable context, Nullifiable context, ConstrainTag context MaybeTag
184+ , hhere = hrelabel hhere
166− ) => Table context (TheseTable a b)
185+ , hthereTag = hrelabel hthereTag
186+ , hthere = hrelabel hthere
187+ }
188+ where
189+ HMaybeTable
190+ { htag = hhereTag
191+ , hjust = hhere
192+ } = toResult @_ @(MaybeTable context a) (justHere tables)
193+ HMaybeTable
194+ { htag = hthereTag
195+ , hjust = hthere
196+ } = toResult @_ @(MaybeTable context b) (justThere tables)
197+
198+ fromResult HTheseTable {hhereTag, hhere, hthereTag, hthere} =
199+ case (here, there) of
200+ (Just a, Nothing) -> This a
201+ (Nothing, Just b) -> That b
202+ (Just a, Just b) -> These a b
203+ _ -> error "These.fromColumns: mismatch between tags and data"
204+ where
205+ here = fromResult @_ @(MaybeTable context a) mhere
206+ there = fromResult @_ @(MaybeTable context b) mthere
207+ mhere = HMaybeTable
208+ { htag = hrelabel hhereTag
209+ , hjust = hrelabel hhere
210+ }
211+ mthere = HMaybeTable
212+ { htag = hrelabel hthereTag
213+ , hjust = hrelabel hthere
214+ }
215+
216+
217+instance (EqTable a, EqTable b, context ~ Expr) =>
218+ EqTable (TheseTable context a b)
167 where
219 where
168− type Columns (TheseTable a b) =
220+ eqTable = HTheseTable
169− HTheseTable (HLabel "Here" (Columns a)) (HLabel "There" (Columns b))
221+ { hhereTag = hlabel (HIdentity Dict)
170− type Context (TheseTable a b) = Context a
222+ , hhere = hlabel (eqTable @(Nullify context a))
171−
223+ , hthereTag = hlabel (HIdentity Dict)
172− toColumns =
224+ , hthere = hlabel (eqTable @(Nullify context b))
173− toColumns2
225+ }
174− (hlabel labeler . toColumns)
175− (hlabel labeler . toColumns)
176− fromColumns =
177− fromColumns2
178− (fromColumns . hunlabel unlabeler)
179− (fromColumns . hunlabel unlabeler)
180−
181−
182−instance
183− ( Labelable from, Nullifiable from, ConstrainTag from MaybeTag
184− , Labelable to, Nullifiable to, ConstrainTag to MaybeTag
185− , Recontextualize from to a1 b1
186− , Recontextualize from to a2 b2
187− ) =>
188− Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2)
189−
190−
191−instance (EqTable a, EqTable b) => EqTable (TheseTable a b) where
192− eqTable =
193− toColumns2 (hlabel hlabeler) (hlabel hlabeler)
194− (thoseTable (eqTable @a) (eqTable @b))
195−
196−
197−instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where
198− ordTable =
199− toColumns2 (hlabel hlabeler) (hlabel hlabeler)
200− (thoseTable (ordTable @a) (ordTable @b))
201
226
202
227
203−toHereTag :: Tag "isJust" a -> Tag "hasHere" a
228+instance (OrdTable a, OrdTable b, context ~ Expr) =>
204−toHereTag Tag {..} = Tag {..}
229+ OrdTable (TheseTable context a b)
230+ where
231+ ordTable = HTheseTable
232+ { hhereTag = hlabel (HIdentity Dict)
233+ , hhere = hlabel (ordTable @(Nullify context a))
234+ , hthereTag = hlabel (HIdentity Dict)
235+ , hthere = hlabel (ordTable @(Nullify context b))
236+ }
205
237
206
238
207−toThereTag :: Tag "isJust" a -> Tag "hasThere" a
239+instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable Expr exprs1 exprs2) =>
208−toThereTag Tag {..} = Tag {..}
240+ ToExprs x (These a b)
209
241
210
242
211−isThisTable :: TheseTable a b -> Expr Bool
243+-- | Test if a 'TheseTable' was constructed with 'thisTable'.
244+--
245+-- Corresponds to 'Data.These.Combinators.isThis'.
246+isThisTable :: TheseTable Expr a b -> Expr Bool
212isThisTable a = hasHereTable a &&. not_ (hasThereTable a)
247isThisTable a = hasHereTable a &&. not_ (hasThereTable a)
213
248
214
249
215−isThatTable :: TheseTable a b -> Expr Bool
250+-- | Test if a 'TheseTable' was constructed with 'thatTable'.
251+--
252+-- Corresponds to 'Data.These.Combinators.isThat'.
253+isThatTable :: TheseTable Expr a b -> Expr Bool
216isThatTable a = not_ (hasHereTable a) &&. hasThereTable a
254isThatTable a = not_ (hasHereTable a) &&. hasThereTable a
217
255
218
256
219−isThoseTable :: TheseTable a b -> Expr Bool
257+-- | Test if a 'TheseTable' was constructed with 'thoseTable'.
258+--
259+-- Corresponds to 'Data.These.Combinators.isThese'.
260+isThoseTable :: TheseTable Expr a b -> Expr Bool
220isThoseTable a = hasHereTable a &&. hasThereTable a
261isThoseTable a = hasHereTable a &&. hasThereTable a
221
262
222
263
223−hasHereTable :: TheseTable a b -> Expr Bool
264+-- | Test if the @a@ side of @TheseTable a b@ is present.
265+--
266+-- Corresponds to 'Data.These.Combinators.hasHere'.
267+hasHereTable :: TheseTable Expr a b -> Expr Bool
224hasHereTable TheseTable {here} = isJustTable here
268hasHereTable TheseTable {here} = isJustTable here
225
269
226
270
227−hasThereTable :: TheseTable a b -> Expr Bool
271+-- | Test if the @b@ table of @TheseTable a b@ is present.
272+--
273+-- Corresponds to 'Data.These.Combinators.hasThere'.
274+hasThereTable :: TheseTable Expr a b -> Expr Bool
228hasThereTable TheseTable {there} = isJustTable there
275hasThereTable TheseTable {there} = isJustTable there
229
276
230
277
231−justHereTable :: TheseTable a b -> MaybeTable a
278+-- | Attempt to project out the @a@ table of a @TheseTable a b@.
279+--
280+-- Corresponds to 'Data.These.Combinators.justHere'.
281+justHereTable :: TheseTable context a b -> MaybeTable context a
232justHereTable = here
282justHereTable = here
233
283
234
284
235−justThereTable :: TheseTable a b -> MaybeTable b
285+-- | Attempt to project out the @b@ table of a @TheseTable a b@.
286+--
287+-- Corresponds to 'Data.These.Combinators.justThere'.
288+justThereTable :: TheseTable context a b -> MaybeTable context b
236justThereTable = there
289justThereTable = there
237
290
238
291
239−thisTable :: Table Expr b => a -> TheseTable a b
292+-- | Construct a @TheseTable@ from two 'MaybeTable's.
293+alignMaybeTable :: ()
294+ => MaybeTable Expr a
295+ -> MaybeTable Expr b
296+ -> MaybeTable Expr (TheseTable Expr a b)
297+alignMaybeTable a b = MaybeTable tag (pure (TheseTable a b))
298+ where
299+ tag = boolExpr null mempty (isJustTable a ||. isJustTable b)
300+
301+
302+-- | Construct a @TheseTable@. Corresponds to 'This'.
303+thisTable :: Table Expr b => a -> TheseTable Expr a b
240thisTable a = TheseTable (justTable a) nothingTable
304thisTable a = TheseTable (justTable a) nothingTable
241
305
242
306
243−thatTable :: Table Expr a => b -> TheseTable a b
307+-- | Construct a @TheseTable@. Corresponds to 'That'.
308+thatTable :: Table Expr a => b -> TheseTable Expr a b
244thatTable b = TheseTable nothingTable (justTable b)
309thatTable b = TheseTable nothingTable (justTable b)
245
310
246
311
247−thoseTable :: a -> b -> TheseTable a b
312+-- | Construct a @TheseTable@. Corresponds to 'These'.
313+thoseTable :: a -> b -> TheseTable Expr a b
248thoseTable a b = TheseTable (justTable a) (justTable b)
314thoseTable a b = TheseTable (justTable a) (justTable b)
249
315
250
316
317+-- | Pattern match on a 'TheseTable'. Corresponds to 'these'.
251theseTable :: Table Expr c
318theseTable :: Table Expr c
252− => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable a b -> c
319+ => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable Expr a b -> c
253theseTable f g h TheseTable {here, there} =
320theseTable f g h TheseTable {here, there} =
254 maybeTable
321 maybeTable
255 (maybeTable undefined f here)
322 (maybeTable undefined f here)
@@ -257,21 +324,32 @@ theseTable f g h TheseTable {here, there} =
257 there
324 there
258
325
259
326
327+-- | Lift a pair of aggregating functions to operate on an 'TheseTable'.
328+-- @thisTable@s, @thatTable@s and @thoseTable@s are grouped separately.
260aggregateTheseTable :: ()
329aggregateTheseTable :: ()
261− => (a -> Aggregate c)
330+ => (exprs -> aggregates)
262− -> (b -> Aggregate d)
331+ -> (exprs' -> aggregates')
263− -> TheseTable a b
332+ -> TheseTable Expr exprs exprs'
264− -> Aggregate (TheseTable c d)
333+ -> TheseTable Aggregate aggregates aggregates'
265−aggregateTheseTable f g TheseTable {here, there} =
334+aggregateTheseTable f g (TheseTable here there) = TheseTable
266− liftF2 TheseTable (aggregateMaybeTable f here) (aggregateMaybeTable g there)
335+ { here = aggregateMaybeTable f here
336+ , there = aggregateMaybeTable g there
337+ }
267
338
268
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'.
269nameTheseTable :: ()
343nameTheseTable :: ()
270 => Name (Maybe MaybeTag)
344 => Name (Maybe MaybeTag)
345+ -- ^ The name of the column to track the presence of the @a@ table.
271 -> Name (Maybe MaybeTag)
346 -> Name (Maybe MaybeTag)
347+ -- ^ The name of the column to track the presence of the @b@ table.
272 -> a
348 -> a
349+ -- ^ Names of the columns in the @a@ table.
273 -> b
350 -> b
274− -> TheseTable a b
351+ -- ^ Names of the columns in the @b@ table.
352+ -> TheseTable Name a b
275nameTheseTable here there a b =
353nameTheseTable here there a b =
276 TheseTable
354 TheseTable
277 { here = nameMaybeTable here a
355 { here = nameMaybeTable here a
src/Rel8/Table/Transpose.hsnew file+46
@@ -0,0 +1,46 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleInstances #-}
3+{-# language FunctionalDependencies #-}
4+{-# language StandaloneKindSignatures #-}
5+{-# language TypeFamilies #-}
6+{-# language UndecidableInstances #-}
7+
8+module Rel8.Table.Transpose
9+ ( Transposes
10+ )
11+where
12+
13+-- base
14+import Data.Kind ( Constraint, Type )
15+import Prelude ()
16+
17+-- rel8
18+import qualified Rel8.Schema.Kind as K
19+import Rel8.Table ( Table, Transpose, Congruent )
20+
21+
22+-- | @'Transposes' from to a b@ means that @a@ and @b@ are 'Table's, in the
23+-- @from@ and @to@ contexts respectively, which share the same underlying
24+-- structure. In other words, @b@ is a version of @a@ transposed from the
25+-- @from@ context to the @to@ context (and vice versa).
26+type Transposes :: K.Context -> K.Context -> Type -> Type -> Constraint
27+class
28+ ( Table from a
29+ , Table to b
30+ , Congruent a b
31+ , b ~ Transpose to a
32+ , a ~ Transpose from b
33+ )
34+ => Transposes from to a b
35+ | a -> from
36+ , b -> to
37+ , a to -> b
38+ , b from -> a
39+instance
40+ ( Table from a
41+ , Table to b
42+ , Congruent a b
43+ , b ~ Transpose to a
44+ , a ~ Transpose from b
45+ )
46+ => Transposes from to a b
src/Rel8/Table/Undefined.hs+6−6
@@ -11,16 +11,16 @@ where
11import Prelude hiding ( undefined )
11import Prelude hiding ( undefined )
12
12
13-- rel8
13-- rel8
14−import Rel8.Expr ( Expr, Col(..) )
14+import Rel8.Expr ( Expr )
15import Rel8.Expr.Null ( snull, unsafeUnnullify )
15import Rel8.Expr.Null ( snull, unsafeUnnullify )
16import Rel8.Schema.HTable ( htabulate, hfield, hspecs )
16import Rel8.Schema.HTable ( htabulate, hfield, hspecs )
17−import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
17+import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
18−import Rel8.Schema.Spec ( SSpec(..) )
18+import Rel8.Schema.Spec ( Spec(..) )
19import Rel8.Table ( Table, fromColumns )
19import Rel8.Table ( Table, fromColumns )
20
20
21
21
22undefined :: Table Expr a => a
22undefined :: Table Expr a => a
23undefined = fromColumns $ htabulate $ \field -> case hfield hspecs field of
23undefined = fromColumns $ htabulate $ \field -> case hfield hspecs field of
24− SSpec {nullability, info} -> case nullability of
24+ Spec {nullity, info} -> case nullity of
25− Nullable -> DB (snull info)
25+ Null -> snull info
26− NonNullable -> DB (unsafeUnnullify (snull info))
26+ NotNull -> unsafeUnnullify (snull info)
src/Rel8/Table/Window.hsnew file+43
@@ -0,0 +1,43 @@
1+{-# language MonoLocalBinds #-}
2+
3+module Rel8.Table.Window
4+ ( cumulative
5+ , cumulative_
6+ , currentRow
7+ )
8+where
9+
10+-- base
11+import Prelude
12+
13+-- opaleye
14+import qualified Opaleye.Window as Opaleye
15+
16+-- rel8
17+import Rel8.Aggregate ( Aggregates )
18+import qualified Rel8.Expr.Window as Expr
19+import Rel8.Schema.HTable ( hfield, htabulateA )
20+import Rel8.Table ( fromColumns, toColumns )
21+import Rel8.Window ( Window( Window ) )
22+
23+
24+-- | 'cumulative' allows the use of aggregation functions in 'Window'
25+-- expressions. In particular, @'cumulative' 'Rel8.sum'@
26+-- (when combined with 'Rel8.Window.orderPartitionBy') gives a running total,
27+-- also known as a \"cumulative sum\", hence the name @cumulative@.
28+cumulative :: Aggregates aggregates exprs => (a -> aggregates) -> Window a exprs
29+cumulative f =
30+ fmap fromColumns $
31+ htabulateA $ \field ->
32+ Expr.cumulative ((`hfield` field) . toColumns . f)
33+
34+
35+-- | A version of 'cumulative' for use with nullary aggregators like
36+-- 'Rel8.Expr.Aggregate.countStar'.
37+cumulative_ :: Aggregates aggregates exprs => aggregates -> Window a exprs
38+cumulative_ = cumulative . const
39+
40+
41+-- | Return every column of the current row of a window query.
42+currentRow :: Window a a
43+currentRow = Window $ Opaleye.over (Opaleye.noWindowFunction id) mempty mempty
src/Rel8/Tabulate.hs+549−140
@@ -1,231 +1,640 @@
1−{-# language DeriveFunctor #-}
2−{-# language DerivingStrategies #-}
3{-# language FlexibleContexts #-}
1{-# language FlexibleContexts #-}
2+{-# language MonoLocalBinds #-}
3+{-# language ScopedTypeVariables #-}
4+{-# language StandaloneKindSignatures #-}
5+{-# language TypeApplications #-}
4{-# language TupleSections #-}
6{-# language TupleSections #-}
7+{-# language UndecidableInstances #-}
8+
9+-- | "Rel8.Tabulate" provides an alternative API ('Tabulation') for writing
10+-- queries that complements the main "Rel8" API ('Query').
5
11
6module Rel8.Tabulate
12module Rel8.Tabulate
7− ( Tabulation
13+ (
8− , runTabulation
14+ Tabulation
9− , tabulate
15+
10− , tabulateA
16+ -- * Interfacing with 'Query's
11 , fromQuery
17 , fromQuery
18+ , toQuery
12 , liftQuery
19 , liftQuery
13− , prebind
20+ , through
14− , postbind
15− , indexed
16− , ifilter
17 , lookup
21 , lookup
22+
23+ -- * Aggregation and Ordering
24+ , aggregate
25+ , distinct
26+ , order
27+
28+ -- ** Magic 'Tabulation's
29+ -- $magic
30+ , count
31+ , optional
32+ , many
33+ , some
34+ , exists
35+ , present
36+ , absent
37+
38+ -- * Natural joins
18 , align
39 , align
19 , alignWith
40 , alignWith
20 , leftAlign
41 , leftAlign
21 , leftAlignWith
42 , leftAlignWith
43+ , rightAlign
44+ , rightAlignWith
22 , zip
45 , zip
23 , zipWith
46 , zipWith
24 , similarity
47 , similarity
25 , difference
48 , difference
26− , aggregateTabulation
27− , optionalTabulation
28 )
49 )
29where
50where
30
51
31-- base
52-- base
32−import Control.Applicative ( liftA2 )
53+import Control.Applicative ( (<|>), empty, liftA2 )
33−import Control.Monad ( join, liftM2 )
54+import Control.Monad ( liftM2 )
34−import Data.Bifunctor ( bimap, first )
55+import Data.Bifunctor ( Bifunctor, bimap, first, second )
35import Data.Foldable ( traverse_ )
56import Data.Foldable ( traverse_ )
36−import Data.Maybe ( fromMaybe )
57+import Data.Function ( on )
37−import Prelude hiding ( filter, lookup, undefined, zip, zipWith )
58+import Data.Functor.Contravariant ( Contravariant, (>$<), contramap )
59+import Data.Int ( Int64 )
60+import Data.Kind ( Type )
61+import Data.Maybe ( fromJust, fromMaybe )
62+import Prelude hiding ( lookup, zip, zipWith )
63+
64+-- bifunctors
65+import Data.Bifunctor.Clown ( Clown( Clown ), runClown )
66+
67+-- comonad
68+import Control.Comonad ( extract )
69+
70+-- opaleye
71+import qualified Opaleye.Aggregate as Opaleye
72+import qualified Opaleye.Order as Opaleye ( orderBy, distinctOnExplicit )
73+
74+-- profunctors
75+import Data.Profunctor ( dimap, lmap )
76+
77+-- product-profunctors
78+import Data.Profunctor.Product
79+ ( ProductProfunctor, (***!)
80+ , SumProfunctor, (+++!)
81+ )
82+import qualified Data.Profunctor.Product as PP
38
83
39-- rel8
84-- rel8
40−import Rel8.Aggregate ( Aggregate )
85+import Rel8.Aggregate ( Aggregates )
41import Rel8.Expr ( Expr )
86import Rel8.Expr ( Expr )
42−import Rel8.Expr.Bool ( not_, true )
87+import Rel8.Expr.Aggregate ( countStar )
88+import Rel8.Expr.Bool ( true )
89+import Rel8.Order ( Order( Order ) )
43import Rel8.Query ( Query )
90import Rel8.Query ( Query )
44−import Rel8.Query.Aggregate ( aggregate )
91+import qualified Rel8.Query.Exists as Q ( exists, present, absent )
45−import Rel8.Query.Exists ( withBy, withoutBy )
92+import Rel8.Query.Filter ( where_ )
46−import Rel8.Query.Filter ( filter, where_ )
93+import Rel8.Query.List ( catNonEmptyTable )
47−import Rel8.Query.Maybe ( optional )
94+import qualified Rel8.Query.Maybe as Q ( optional )
95+import Rel8.Query.Opaleye ( mapOpaleye, unsafePeekQuery )
96+import Rel8.Query.Rebind ( rebind )
48import Rel8.Query.These ( alignBy )
97import Rel8.Query.These ( alignBy )
49−import Rel8.Table ( Table )
98+import Rel8.Table ( Table, fromColumns, toColumns )
50−import Rel8.Table.Aggregate ( groupBy )
99+import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )
51−import Rel8.Table.Eq ( EqTable, (==:) )
100+import Rel8.Table.Alternative
52−import Rel8.Table.Maybe ( MaybeTable )
101+ ( AltTable, (<|>:)
53−import Rel8.Table.These ( TheseTable, theseTable )
102+ , AlternativeTable, emptyTable
54−import Rel8.Table.Undefined ( undefined )
103+ )
104+import Rel8.Table.Cols ( fromCols, toCols )
105+import Rel8.Table.Eq ( EqTable, (==:), eqTable )
106+import Rel8.Table.List ( ListTable( ListTable ) )
107+import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), maybeTable )
108+import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )
109+import Rel8.Table.Opaleye ( aggregator, unpackspec )
110+import Rel8.Table.Ord ( OrdTable )
111+import Rel8.Table.Order ( ascTable )
112+import Rel8.Table.Projection
113+ ( Biprojectable, biproject
114+ , Projectable, project
115+ , apply
116+ )
117+import Rel8.Table.These ( TheseTable( TheseTable ), theseTable )
55
118
56-- semigroupoids
119-- semigroupoids
57import Data.Functor.Apply ( Apply, liftF2 )
120import Data.Functor.Apply ( Apply, liftF2 )
58−import Data.Functor.Bind ( Bind )
121+import Data.Functor.Bind ( Bind, (>>-) )
59−import qualified Data.Functor.Bind
122+
60−import Data.Semigroup.Traversable.Class ( bitraverse1 )
123+
124+type Key :: Type -> Type
125+type Key = Maybe
126+
127+
128+cat :: Table Expr k => Key k -> Query k
129+cat = maybe emptyTable pure
130+
131+
132+key :: (ProductProfunctor p, SumProfunctor p)
133+ => p a b -> p (Key a) (Key b)
134+key a = dimap from to (PP.empty +++! a)
135+ where
136+ from = maybe (Left ()) Right
137+ to = either (const Nothing) Just
138+
139+
140+keyed :: (ProductProfunctor p, SumProfunctor p)
141+ => p k l -> p a b -> p (Key k, a) (Key l, b)
142+keyed k a = key k ***! a
143+
144+
145+type Predicate :: Type -> Type
146+newtype Predicate a = Predicate (Maybe (a -> Expr Bool))
147+
148+
149+instance Contravariant Predicate where
150+ contramap f (Predicate a) = Predicate (lmap f <$> a)
151+
152+
153+instance Semigroup (Predicate k) where
154+ Predicate ma <> Predicate mb = Predicate $ ma <|> mb
155+
156+
157+instance Monoid (Predicate k) where
158+ mempty = Predicate Nothing
159+
160+
161+match :: EqTable k => Key k -> Predicate k
162+match = Predicate . fmap (==:)
163+
164+
165+ensure :: Predicate k -> Key k -> Query ()
166+ensure (Predicate mp) = traverse_ (\k -> traverse_ (\p -> where_ (p k)) mp)
167+
168+
169+-- | A @'Tabulation' k a@ is like a @'Query' a@, except that each row also
170+-- has a key @k@ in addition to the value @a@. 'Tabulation's can be composed
171+-- monadically just like 'Query's, but the resulting join is more like a
172+-- @NATURAL JOIN@ (based on the common key column(s) @k@) than the
173+-- @CROSS JOIN@ given by 'Query'.
174+--
175+-- Another way to think of @'Tabulation' k a@ is as analogous to @Map k a@ in
176+-- the same way @'Query' a@ is analogous to @[a]@. However, there's nothing
177+-- stopping a 'Tabulation' from containing multiple rows with the same key, so
178+-- technically @Map k (NonEmpty a)@ is more accurate.
179+--
180+-- 'Tabulation's can be created from 'Query's with 'fromQuery' and 'liftQuery'
181+-- and converted back to 'Query's with 'lookup' and 'toQuery' (though note the
182+-- caveats that come with the latter).
183+type Tabulation :: Type -> Type -> Type
184+newtype Tabulation k a = Tabulation (Predicate k -> Query (Key k, a))
61
185
62
186
63−newtype Tabulation k a = Tabulation (k -> Query (Maybe k, a))
187+instance Biprojectable Tabulation where
64− deriving stock Functor
188+ biproject f g =
189+ bimap
190+ (fromColumns . apply f . toColumns)
191+ (fromColumns . apply g . toColumns)
65
192
66
193
194+instance Bifunctor Tabulation where
195+ bimap f g (Tabulation a) = Tabulation $ \p ->
196+ bimap (fmap f) g <$> a (f >$< p)
197+
198+
199+instance Functor (Tabulation k) where
200+ fmap = second
201+
202+
203+instance Projectable (Tabulation k) where
204+ project f = fmap (fromColumns . apply f . toColumns)
205+
206+
207+-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<.>)@ is
208+-- @intersectionWith (liftA2 (<*>))@
67instance EqTable k => Apply (Tabulation k) where
209instance EqTable k => Apply (Tabulation k) where
68 liftF2 = liftA2
210 liftF2 = liftA2
69
211
70
212
213+-- | @pure = 'liftQuery' . pure@
71instance EqTable k => Applicative (Tabulation k) where
214instance EqTable k => Applicative (Tabulation k) where
72 pure = liftQuery . pure
215 pure = liftQuery . pure
73 liftA2 = liftM2
216 liftA2 = liftM2
74
217
75
218
76instance EqTable k => Bind (Tabulation k) where
219instance EqTable k => Bind (Tabulation k) where
77− join = join
220+ Tabulation as >>- f = Tabulation $ \p -> do
221+ (k, a) <- as p
222+ case f a of
223+ Tabulation bs -> do
224+ let p' = match k
225+ (k', b) <- bs (p' <> p)
226+ ensure p' k'
227+ pure (k' <|> k, b)
78
228
79
229
80instance EqTable k => Monad (Tabulation k) where
230instance EqTable k => Monad (Tabulation k) where
81− Tabulation as >>= f = Tabulation $ \i -> do
231+ (>>=) = (>>-)
82− (mk, a) <- as i
83− case mk of
84− Nothing -> case f a of
85− Tabulation bs -> bs i
86− Just k -> case f a of
87− Tabulation bs -> do
88− (mk', b) <- bs k
89− case mk' of
90− Nothing -> pure (mk, b)
91− Just k' -> do
92− where_ $ k ==: k'
93− pure (mk', b)
94−
95−
96−runTabulation :: EqTable k => Tabulation k a -> Query (k, a)
97−runTabulation (Tabulation f) = do
98− (mk, a) <- f i
99− case mk of
100− Nothing -> do
101− -- Opaleye tries to be too clever optimising "WHERE FALSE" and generates
102− -- invalid SQL, so we use "WHERE NOT TRUE" instead
103− where_ $ not_ true
104− pure (i, a)
105− Just k -> pure (k, a)
106− where
107− i = undefined
108
232
109
233
110−liftQuery :: Query a -> Tabulation k a
234+-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<|>:)@ is
111−liftQuery query = Tabulation $ const $ fmap (Nothing,) query
235+-- @unionWith (<>)@.
236+instance EqTable k => AltTable (Tabulation k) where
237+ tas <|>: tbs = do
238+ eas <- peek tas
239+ ebs <- peek tbs
240+ case (eas, ebs) of
241+ (Left as, Left bs) -> liftQuery $ as <|>: bs
242+ (Right as, Right bs) -> fromQuery $ as <|>: bs
243+ _ -> catNonEmptyTable `through` ((<>) `on` some) tas tbs
112
244
113
245
114−tabulate :: (a -> k) -> a -> Tabulation k a
246+instance EqTable k => AlternativeTable (Tabulation k) where
115−tabulate key a = fromQuery $ pure (key a, a)
247+ emptyTable = Tabulation $ const $ fmap (empty,) emptyTable
116
248
117
249
118−tabulateA :: (a -> Query k) -> a -> Tabulation k a
250+-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<>)@ is
119−tabulateA key a = fromQuery $ (,a) <$> key a
251+-- @unionWith (liftA2 (<>))@.
252+instance (EqTable k, Table Expr a, Semigroup a) => Semigroup (Tabulation k a)
253+ where
254+ (<>) = alignWith (theseTable id id (<>))
120
255
121
256
122−fromQuery :: Query (k, a) -> Tabulation k a
257+instance (EqTable k, Table Expr a, Semigroup a) => Monoid (Tabulation k a)
123−fromQuery = Tabulation . const . fmap (first Just)
258+ where
259+ mempty = emptyTable
124
260
125
261
126−indexed :: Tabulation k a -> Tabulation k (k, a)
262+-- | Any 'Query' of key-value pairs @(k, a)@ can be a @'Tabulation' k a@.
127−indexed (Tabulation query) = Tabulation $ \i ->
263+fromQuery :: Query (k, a) -> Tabulation k a
128− (\(mk, a) -> (mk, (fromMaybe i mk, a))) <$> query i
264+fromQuery = Tabulation . const . fmap (first pure)
265+
266+
267+-- | Convert a @'Tabulation' k a@ back into a 'Query' of key-value pairs.
268+--
269+-- Note that the result of a 'toQuery' is undefined (will always return zero
270+-- rows) on 'Tabulation's constructed with 'liftQuery' or 'pure'. So while
271+-- @toQuery . fromQuery@ is always @id@, @fromQuery . toQuery@ is not.
272+--
273+-- A safer, more predictable alternative to 'toQuery' is to use 'lookup' with
274+-- an explicit set of keys:
275+--
276+-- @
277+-- do
278+-- k <- keys
279+-- a <- lookup k tabulation
280+-- pure (k, a)
281+-- @
282+--
283+-- Having said that, in practice, most legitimate uses of 'Tabulation' will
284+-- have a well-defined 'toQuery'. It would be possible in theory to encode
285+-- the necessary invariants at the type level using an indexed monad, but we
286+-- would lose the ability to use @do@-notation, which is the main benefit
287+-- of having 'Tabulation' as a monad in the first place.
288+--
289+-- In particular, @'toQuery' t@ is well-defined for any 'Tabulation' @t@
290+-- defined as @t = fromQuery _@. @'toQuery' t@ is also well-defined for any
291+-- 'Tabulation' @t@ defined as @t = t' >>= _@ or @t = t' *> _@ where
292+-- @'toQuery' t'@ is well-defined. There are other valid permutations too.
293+-- Generally, anything that uses 'fromQuery' at some point, unless wrapped in
294+-- a top-level 'present' or 'absent', will have a well-defined 'toQuery'.
295+toQuery :: Table Expr k => Tabulation k a -> Query (k, a)
296+toQuery (Tabulation f) = do
297+ (mk, a) <- f mempty
298+ k <- cat mk
299+ pure (k, a)
300+
301+
302+-- | A @'Query' a@ can be treated as a @'Tabulation' k a@ where the given @a@
303+-- values exist at every possible key @k@.
304+liftQuery :: Query a -> Tabulation k a
305+liftQuery = Tabulation . const . fmap (empty,)
129
306
130
307
131−ifilter :: (k -> a -> Expr Bool) -> Tabulation k a -> Tabulation k a
308+-- | Run a Kleisli arrow in the the 'Query' monad \"through\" a 'Tabulation'.
132−ifilter f tabulation = snd <$> do
309+-- Useful for 'Rel8.filter'ing a 'Tabulation'.
133− filter (uncurry f) `postbind` indexed tabulation
310+--
311+-- @
312+-- 'Rel8.filter' ((>=. 30) . userAge) `'through'` usersById
313+-- @
314+through :: (a -> Query b) -> Tabulation k a -> Tabulation k b
315+through f (Tabulation as) = Tabulation $ \p -> do
316+ (k, a) <- as p
317+ b <- f a
318+ pure (k, b)
319+infixr 1 `through`
134
320
135
321
136−prebind :: (a -> Tabulation k b) -> Query a -> Tabulation k b
322+-- | @'lookup' k t@ returns the value(s) at the key @k@ in the tabulation @t@.
137−prebind f as = Tabulation $ \k -> do
323+lookup :: EqTable k => k -> Tabulation k a -> Query a
138− a <- as
324+lookup k (Tabulation f) = do
139− case f a of
325+ (k', a) <- f p
140− Tabulation query -> query k
326+ ensure p k'
141−infixr 1 `prebind`
327+ pure a
328+ where
329+ p = match (pure k)
142
330
143
331
144−postbind :: (a -> Query b) -> Tabulation k a -> Tabulation k b
332+-- | 'aggregate' aggregates the values within each key of a
145−postbind f (Tabulation as) = Tabulation $ \i -> do
333+-- 'Tabulation'. There is an implicit @GROUP BY@ on all the key columns.
146− (k, a) <- as i
334+aggregate :: forall k aggregates exprs.
147− case f a of
335+ ( EqTable k
148− bs -> do
336+ , Aggregates aggregates exprs
149− b <- bs
337+ )
150− pure (k, b)
338+ => Tabulation k aggregates -> Tabulation k exprs
151−infixr 1 `postbind`
339+aggregate (Tabulation f) = Tabulation $
340+ mapOpaleye (Opaleye.aggregate (keyed haggregator aggregator)) .
341+ fmap (first (fmap (hgroupBy (eqTable @k) . toColumns))) .
342+ f
343+ where
344+ haggregator = dimap fromColumns fromCols aggregator
152
345
153
346
154−lookup :: EqTable k => k -> Tabulation k a -> Query a
347+-- | 'distinct' ensures a 'Tabulation' has at most one value for
155−lookup key (Tabulation query) = do
348+-- each key, i.e., it drops duplicates. In general it keeps only the
156− (mk, a) <- query key
349+-- \"first\" value it encounters for each key, but note that \"first\" is
157− traverse_ (where_ . (key ==:)) mk
350+-- undefined unless you first call 'order'.
158− pure a
351+distinct :: EqTable k => Tabulation k a -> Tabulation k a
352+distinct (Tabulation f) = Tabulation $
353+ mapOpaleye (Opaleye.distinctOnExplicit (key unpackspec) fst) . f
159
354
160
355
161−align :: (EqTable k, Table Expr a, Table Expr b)
356+-- | 'order' orders the /values/ of a 'Tabulation' within their
162− => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable a b)
357+-- respective keys. This specifies a defined order for 'distinct'.
358+-- It also defines the order of the lists produced by 'many' and
359+-- 'some'.
360+order :: OrdTable k => Order a -> Tabulation k a -> Tabulation k a
361+order ordering (Tabulation f) =
362+ Tabulation $ mapOpaleye (Opaleye.orderBy ordering') . f
363+ where
364+ Order ordering' = runClown (keyed (Clown ascTable) (Clown ordering))
365+
366+
367+-- $magic
368+--
369+-- Some of the following combinators produce \"magic\" 'Tabulation's. Let's
370+-- use 'count' as an example to demonstrate this concept. Consider
371+-- the following:
372+--
373+-- @
374+-- count $ fromQuery $ values
375+-- [ (lit 'a', lit True)
376+-- , (lit 'a', lit False)
377+-- , (lit 'b', lit True)
378+-- ]
379+-- @
380+--
381+-- You might expect this to be equivalent to the following 'Tabulation':
382+--
383+-- @
384+-- fromQuery $ values
385+-- [ (lit 'a', 2)
386+-- , (lit 'b', 1)
387+-- ]
388+-- @
389+--
390+-- However, it isn't quite. While the resulting 'Tabulation' does effectively
391+-- contain the above entries, it also behaves as though it contained the value
392+-- @0@ at every other possible key.
393+--
394+-- This means you can do:
395+--
396+-- @
397+-- do
398+-- user <- usersById
399+-- orderCount <- count ordersByUserId
400+-- @
401+--
402+-- To see how many orders a user has (getting @0@ if they have no orders).
403+
404+
405+-- | 'count' returns a count of how many entries are in the given
406+-- 'Tabulation' at each key.
407+--
408+-- The resulting 'Tabulation' is \"magic\" in that the value @0@ exists at
409+-- every possible key that wasn't in the given 'Tabulation'.
410+count :: EqTable k => Tabulation k a -> Tabulation k (Expr Int64)
411+count =
412+ fmap (maybeTable 0 id) .
413+ optional .
414+ aggregate .
415+ fmap (const countStar)
416+
417+
418+-- | 'optional' produces a \"magic\" 'Tabulation' whereby each
419+-- entry in the given 'Tabulation' is wrapped in 'Rel8.justTable', and every
420+-- other possible key contains a single 'Rel8.nothingTable'.
421+--
422+-- This is used to implement 'leftAlignWith'.
423+optional :: Tabulation k a -> Tabulation k (MaybeTable Expr a)
424+optional (Tabulation f) = Tabulation $ \p -> case p of
425+ Predicate Nothing -> fmap pure <$> f p
426+ _ -> fmap (\m -> (empty, snd <$> m)) $ Q.optional $ do
427+ (k, a) <- f p
428+ ensure p k
429+ pure (k, a)
430+
431+
432+-- | 'many' aggregates each entry with a particular key into a
433+-- single entry with all of the values contained in a 'ListTable'.
434+--
435+-- 'order' can be used to give this 'ListTable' a defined order.
436+--
437+-- The resulting 'Tabulation' is \"magic\" in that the value
438+-- @'Rel8.listTable []'@ exists at every possible key that wasn't in the given
439+-- 'Tabulation'.
440+many :: (EqTable k, Table Expr a)
441+ => Tabulation k a -> Tabulation k (ListTable Expr a)
442+many =
443+ fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .
444+ optional .
445+ aggregate .
446+ fmap (listAgg . toCols)
447+
448+
449+-- | 'some' aggregates each entry with a particular key into a
450+-- single entry with all of the values contained in a 'NonEmptyTable'.
451+--
452+-- 'order' can be used to give this 'NonEmptyTable' a defined order.
453+some :: (EqTable k, Table Expr a)
454+ => Tabulation k a -> Tabulation k (NonEmptyTable Expr a)
455+some =
456+ fmap (\(NonEmptyTable a) -> NonEmptyTable a) .
457+ aggregate .
458+ fmap (nonEmptyAgg . toCols)
459+
460+
461+-- | 'exists' produces a \"magic\" 'Tabulation' which contains the
462+-- value 'Rel8.true' at each key in the given 'Tabulation', and the value
463+-- 'Rel8.false' at every other possible key.
464+exists :: Tabulation k a -> Tabulation k (Expr Bool)
465+exists (Tabulation f) = Tabulation $ \p -> case p of
466+ Predicate Nothing -> (true <$) <$> f p
467+ _ -> fmap (empty,) $ Q.exists $ do
468+ (k, _) <- f p
469+ ensure p k
470+
471+
472+-- | 'present' produces a 'Tabulation' where a single @()@ row
473+-- exists for every key that was present in the given 'Tabulation'.
474+--
475+-- This is used to implement 'similarity'.
476+present :: Tabulation k a -> Tabulation k ()
477+present (Tabulation f) = Tabulation $ \p -> do
478+ Q.present $ do
479+ (k, _) <- f p
480+ ensure p k
481+ pure (empty, ())
482+
483+
484+-- | 'absent' produces a 'Tabulation' where a single @()@ row exists
485+-- at every possible key that absent from the given 'Tabulation'.
486+--
487+-- This is used to implement 'difference'.
488+absent :: Tabulation k a -> Tabulation k ()
489+absent (Tabulation f) = Tabulation $ \p -> do
490+ Q.absent $ do
491+ (k, _) <- f p
492+ ensure p k
493+ pure (empty, ())
494+
495+
496+-- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns.
497+--
498+-- Analogous to 'Data.Semialign.align'.
499+align :: EqTable k
500+ => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable Expr a b)
163align = alignWith id
501align = alignWith id
164
502
165
503
166−alignWith :: (EqTable k, Table Expr a, Table Expr b)
504+-- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns.
167− => (TheseTable a b -> c)
505+--
506+-- Analogous to 'Data.Semialign.alignWith'.
507+alignWith :: EqTable k
508+ => (TheseTable Expr a b -> c)
168 -> Tabulation k a -> Tabulation k b -> Tabulation k c
509 -> Tabulation k a -> Tabulation k b -> Tabulation k c
169−alignWith f kas kbs = do
510+alignWith f (Tabulation as) (Tabulation bs) = Tabulation $ \p -> do
170− as <- toQuery kas
511+ tkab <- liftF2 (alignBy condition) as bs p
171− bs <- toQuery kbs
512+ k <- traverse (rebind "key") $ recover $ bimap fst fst tkab
172− fromQuery $ do
513+ let
173− tkab <- alignBy (\(l, _) (m, _) -> l ==: m) as bs
514+ tab = bimap snd snd tkab
174− let
515+ pure (k, f tab)
175− k' = theseTable fst fst (const fst) tkab
516+ where
176− tab = bimap snd snd tkab
517+ condition (k, _) (k', _) = fromMaybe true (liftA2 (==:) k k')
177− pure (k', f tab)
518+ recover (TheseTable mma@(MaybeTable _ ma) mmb@(MaybeTable _ mb)) =
178−
519+ case extract ma of
179−
520+ Nothing -> extract mb
521+ Just a -> case extract mb of
522+ Nothing -> extract ma
523+ Just b -> case a <$ mma <|>: b <$ mmb of
524+ MaybeTable _ c -> pure (extract c)
525+
526+
527+-- | Performs a @NATURAL LEFT OUTER JOIN@ based on the common key columns.
528+--
529+-- Analogous to 'Data.Semialign.rpadZip'.
530+--
531+-- Note that you can achieve the same effect with 'optional' and the
532+-- 'Applicative' instance for 'Tabulation', i.e., this is just
533+-- @\left right -> liftA2 (,) left (optional right). You can also
534+-- use @do@-notation.
180leftAlign :: EqTable k
535leftAlign :: EqTable k
181− => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable b)
536+ => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable Expr b)
182leftAlign = leftAlignWith (,)
537leftAlign = leftAlignWith (,)
183
538
184
539
540+-- | Performs a @NATURAL LEFT OUTER JOIN@ based on the common key columns.
541+--
542+-- Analogous to 'Data.Semialign.rpadZipWith'.
543+--
544+-- Note that you can achieve the same effect with 'optional' and the
545+-- 'Applicative' instance for 'Tabulation', i.e., this is just
546+-- @\f left right -> liftA2 f left (optional right). You can also
547+-- use @do@-notation.
185leftAlignWith :: EqTable k
548leftAlignWith :: EqTable k
186− => (a -> MaybeTable b -> c)
549+ => (a -> MaybeTable Expr b -> c)
187 -> Tabulation k a -> Tabulation k b -> Tabulation k c
550 -> Tabulation k a -> Tabulation k b -> Tabulation k c
188−leftAlignWith f left right = liftA2 f left (optionalTabulation right)
551+leftAlignWith f left right = liftA2 f left (optional right)
552+
553+
554+-- | Performs a @NATURAL RIGHT OUTER JOIN@ based on the common key columns.
555+--
556+-- Analogous to 'Data.Semialign.lpadZip'.
557+--
558+-- Note that you can achieve the same effect with 'optional' and the
559+-- 'Applicative' instance for 'Tabulation', i.e., this is just
560+-- @\left right -> liftA2 (flip (,)) right (optional left). You can
561+-- also use @do@-notation.
562+rightAlign :: EqTable k
563+ => Tabulation k a -> Tabulation k b -> Tabulation k (MaybeTable Expr a, b)
564+rightAlign = rightAlignWith (,)
565+
566+
567+-- | Performs a @NATURAL RIGHT OUTER JOIN@ based on the common key columns.
568+--
569+-- Analogous to 'Data.Semialign.lpadZipWith'.
570+--
571+-- Note that you can achieve the same effect with 'optional' and the
572+-- 'Applicative' instance for 'Tabulation', i.e., this is just
573+-- @\f left right -> liftA2 (flip f) right (optional left). You can
574+-- also use @do@-notation.
575+rightAlignWith :: EqTable k
576+ => (MaybeTable Expr a -> b -> c)
577+ -> Tabulation k a -> Tabulation k b -> Tabulation k c
578+rightAlignWith f left right = liftA2 (flip f) right (optional left)
189
579
190
580
581+-- | Performs a @NATURAL INNER JOIN@ based on the common key columns.
582+--
583+-- Analagous to 'Data.Semialign.zip'.
584+--
585+-- Note that you can achieve the same effect with the 'Applicative' instance
586+-- of 'Tabulation', i.e., this is just @'liftA2 (,)'@. You can also use
587+-- @do@-notation.
191zip :: EqTable k
588zip :: EqTable k
192 => Tabulation k a -> Tabulation k b -> Tabulation k (a, b)
589 => Tabulation k a -> Tabulation k b -> Tabulation k (a, b)
193zip = zipWith (,)
590zip = zipWith (,)
194
591
195
592
593+-- | Performs a @NATURAL INNER JOIN@ based on the common key columns.
594+--
595+-- Analagous to 'Data.Semialign.zipWith'.
596+--
597+-- Note that you can achieve the same effect with the 'Applicative' instance
598+-- of 'Tabulation', i.e., this is just @'liftA2'@. You can also use
599+-- @do@-notation.
196zipWith :: EqTable k
600zipWith :: EqTable k
197 => (a -> b -> c) -> Tabulation k a -> Tabulation k b -> Tabulation k c
601 => (a -> b -> c) -> Tabulation k a -> Tabulation k b -> Tabulation k c
198zipWith = liftA2
602zipWith = liftA2
199
603
200
604
605+-- | Performs a [@NATURAL SEMI JOIN@](https://en.wikipedia.org/wiki/Relational_algebra#Semijoin_%28%E2%8B%89%29%28%E2%8B%8A%29)
606+-- based on the common key columns.
607+--
608+-- The result is a subset of the left tabulation where only entries which have
609+-- a corresponding entry in the right tabulation are kept.
610+--
611+-- Note that you can achieve a similar effect with 'present' and the
612+-- 'Applicative' instance of 'Tabulation', i.e., this is just
613+-- @\left right -> left <* present right@. You can also use
614+-- @do@-notation.
201similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
615similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
202−similarity kas kbs = do
616+similarity a b = a <* present b
203− as <- toQuery kas
617+
204− bs <- toQuery kbs
618+
205− fromQuery $ as >>= withBy (\(k, _) (l, _) -> k ==: l) bs
619+-- | Performs a [@NATURAL ANTI JOIN@](https://en.wikipedia.org/wiki/Relational_algebra#Antijoin_%28%E2%96%B7%29)
206−
620+-- based on the common key columns.
207−
621+--
622+-- The result is a subset of the left tabulation where only entries which do
623+-- not have a corresponding entry in the right tabulation are kept.
624+--
625+-- Note that you can achieve a similar effect with 'absent' and the
626+-- 'Applicative' instance of 'Tabulation', i.e., this is just
627+-- @\left right -> left <* absent right@. You can also use
628+-- @do@-notation.
208difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
629difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
209−difference kas kbs = do
630+difference a b = a <* absent b
210− as <- toQuery kas
211− bs <- toQuery kbs
212− fromQuery $ as >>= withoutBy (\(k, _) (l, _) -> k ==: l) bs
213−
214−
215−aggregateTabulation :: EqTable k
216− => Tabulation k (Aggregate a) -> Tabulation k a
217−aggregateTabulation kas = do
218− as <- toQuery kas
219− fromQuery $ aggregate $ bitraverse1 groupBy id <$> as
220−
221−
222−optionalTabulation :: EqTable k
223− => Tabulation k a -> Tabulation k (MaybeTable a)
224−optionalTabulation as = Tabulation $ \k -> do
225− ma <- optional $ lookup k as
226− pure (Just k, ma)
227
631
228
632
229−toQuery :: Tabulation k a -> Tabulation k (Query (k, a))
633+-- | 'Tabulation's can be produced with either 'fromQuery' or 'liftQuery', and
230−toQuery (Tabulation as) = Tabulation $ \k ->
634+-- in some cases we might want to treat these differently. 'peek' uses
231− pure (Nothing, first (fromMaybe k) <$> as k)
635+-- 'unsafePeekQuery' to determine which type of 'Tabulation' we have.
636+peek :: Tabulation k a -> Tabulation k (Either (Query a) (Query (k, a)))
637+peek (Tabulation f) = Tabulation $ \p ->
638+ pure $ (empty,) $ case unsafePeekQuery (f p) of
639+ (Nothing, _) -> Left $ fmap snd (f p)
640+ (Just _, _) -> Right $ fmap (first fromJust) (f p)
src/Rel8/Type.hs+16−50
@@ -1,8 +1,8 @@
1+{-# language FlexibleContexts #-}
1{-# language FlexibleInstances #-}
2{-# language FlexibleInstances #-}
2−{-# language MultiParamTypeClasses #-}
3+{-# language MonoLocalBinds #-}
4+{-# language MultiWayIf #-}
3{-# language StandaloneKindSignatures #-}
5{-# language StandaloneKindSignatures #-}
4−{-# language TypeApplications #-}
5−{-# language UndecidableInstances #-}
6{-# language UndecidableInstances #-}
6{-# language UndecidableInstances #-}
7
7
8module Rel8.Type
8module Rel8.Type
@@ -37,12 +37,7 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
37import qualified Opaleye.Internal.HaskellDB.Sql.Default as Opaleye ( quote )
37import qualified Opaleye.Internal.HaskellDB.Sql.Default as Opaleye ( quote )
38
38
39-- rel8
39-- rel8
40−import Rel8.Opaque ( Opaque )
40+import Rel8.Schema.Null ( NotNull, Sql, nullable )
41−import Rel8.Schema.Nullability
42− ( NotNull, Unnullify
43− , HasNullability, nullabilization
44− , Sql
45− )
46import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
41import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
47import Rel8.Type.Information ( TypeInformation(..), mapTypeInformation )
42import Rel8.Type.Information ( TypeInformation(..), mapTypeInformation )
48
43
@@ -79,18 +74,6 @@ import qualified Data.UUID as UUID
79-- should only need to derive instances of this class for custom database
74-- should only need to derive instances of this class for custom database
80-- types, such as types defined in PostgreSQL extensions, or custom domain
75-- types, such as types defined in PostgreSQL extensions, or custom domain
81-- types.
76-- types.
82−--
83−-- [ Creating @DBType@s using @newtype@ ]
84−--
85−-- Generalized newtype deriving can be used when you want use a @newtype@
86−-- around a database type for clarity and accuracy in your Haskell code. A
87−-- common example is to @newtype@ row id types:
88−--
89−-- >>> newtype UserId = UserId { toInt32 :: Int32 } deriving newtype (DBType)
90−--
91−-- You can now write queries using @UserId@ instead of @Int32@, which may help
92−-- avoid making bad joins. However, when SQL is generated, it will be as if you
93−-- just used integers (the type distinction does not impact query generation).
94type DBType :: Type -> Constraint
77type DBType :: Type -> Constraint
95class NotNull a => DBType a where
78class NotNull a => DBType a where
96 typeInformation :: TypeInformation a
79 typeInformation :: TypeInformation a
@@ -102,7 +85,6 @@ instance DBType Bool where
102 { encode = Opaleye.ConstExpr . Opaleye.BoolLit
85 { encode = Opaleye.ConstExpr . Opaleye.BoolLit
103 , decode = Hasql.bool
86 , decode = Hasql.bool
104 , typeName = "bool"
87 , typeName = "bool"
105− , out = id
106 }
88 }
107
89
108
90
@@ -112,7 +94,6 @@ instance DBType Char where
112 { encode = Opaleye.ConstExpr . Opaleye.StringLit . pure
94 { encode = Opaleye.ConstExpr . Opaleye.StringLit . pure
113 , decode = Hasql.char
95 , decode = Hasql.char
114 , typeName = "char"
96 , typeName = "char"
115− , out = id
116 }
97 }
117
98
118
99
@@ -122,7 +103,6 @@ instance DBType Int16 where
122 { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger
103 { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger
123 , decode = Hasql.int2
104 , decode = Hasql.int2
124 , typeName = "int2"
105 , typeName = "int2"
125− , out = id
126 }
106 }
127
107
128
108
@@ -132,7 +112,6 @@ instance DBType Int32 where
132 { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger
112 { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger
133 , decode = Hasql.int4
113 , decode = Hasql.int4
134 , typeName = "int4"
114 , typeName = "int4"
135− , out = id
136 }
115 }
137
116
138
117
@@ -142,27 +121,32 @@ instance DBType Int64 where
142 { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger
121 { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger
143 , decode = Hasql.int8
122 , decode = Hasql.int8
144 , typeName = "int8"
123 , typeName = "int8"
145− , out = id
146 }
124 }
147
125
148
126
149-- | Corresponds to @float4@
127-- | Corresponds to @float4@
150instance DBType Float where
128instance DBType Float where
151 typeInformation = TypeInformation
129 typeInformation = TypeInformation
152− { encode = Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac
130+ { encode = \x -> Opaleye.ConstExpr
131+ if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'"
132+ | isNaN x -> Opaleye.OtherLit "'NaN'"
133+ | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"
134+ | otherwise -> Opaleye.NumericLit $ realToFrac x
153 , decode = Hasql.float4
135 , decode = Hasql.float4
154 , typeName = "float4"
136 , typeName = "float4"
155− , out = id
156 }
137 }
157
138
158
139
159-- | Corresponds to @float8@
140-- | Corresponds to @float8@
160instance DBType Double where
141instance DBType Double where
161 typeInformation = TypeInformation
142 typeInformation = TypeInformation
162− { encode = Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac
143+ { encode = \x -> Opaleye.ConstExpr
144+ if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'"
145+ | isNaN x -> Opaleye.OtherLit "'NaN'"
146+ | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"
147+ | otherwise -> Opaleye.NumericLit $ realToFrac x
163 , decode = Hasql.float8
148 , decode = Hasql.float8
164 , typeName = "float8"
149 , typeName = "float8"
165− , out = id
166 }
150 }
167
151
168
152
@@ -172,7 +156,6 @@ instance DBType Scientific where
172 { encode = Opaleye.ConstExpr . Opaleye.NumericLit
156 { encode = Opaleye.ConstExpr . Opaleye.NumericLit
173 , decode = Hasql.numeric
157 , decode = Hasql.numeric
174 , typeName = "numeric"
158 , typeName = "numeric"
175− , out = id
176 }
159 }
177
160
178
161
@@ -184,7 +167,6 @@ instance DBType UTCTime where
184 formatTime defaultTimeLocale "'%FT%T%QZ'"
167 formatTime defaultTimeLocale "'%FT%T%QZ'"
185 , decode = Hasql.timestamptz
168 , decode = Hasql.timestamptz
186 , typeName = "timestamptz"
169 , typeName = "timestamptz"
187− , out = id
188 }
170 }
189
171
190
172
@@ -196,7 +178,6 @@ instance DBType Day where
196 formatTime defaultTimeLocale "'%F'"
178 formatTime defaultTimeLocale "'%F'"
197 , decode = Hasql.date
179 , decode = Hasql.date
198 , typeName = "date"
180 , typeName = "date"
199− , out = id
200 }
181 }
201
182
202
183
@@ -208,7 +189,6 @@ instance DBType LocalTime where
208 formatTime defaultTimeLocale "'%FT%T%Q'"
189 formatTime defaultTimeLocale "'%FT%T%Q'"
209 , decode = Hasql.timestamp
190 , decode = Hasql.timestamp
210 , typeName = "timestamp"
191 , typeName = "timestamp"
211− , out = id
212 }
192 }
213
193
214
194
@@ -220,7 +200,6 @@ instance DBType TimeOfDay where
220 formatTime defaultTimeLocale "'%T%Q'"
200 formatTime defaultTimeLocale "'%T%Q'"
221 , decode = Hasql.time
201 , decode = Hasql.time
222 , typeName = "time"
202 , typeName = "time"
223− , out = id
224 }
203 }
225
204
226
205
@@ -232,7 +211,6 @@ instance DBType CalendarDiffTime where
232 formatTime defaultTimeLocale "'%bmon %0Es'"
211 formatTime defaultTimeLocale "'%bmon %0Es'"
233 , decode = CalendarDiffTime 0 . realToFrac <$> Hasql.interval
212 , decode = CalendarDiffTime 0 . realToFrac <$> Hasql.interval
234 , typeName = "interval"
213 , typeName = "interval"
235− , out = id
236 }
214 }
237
215
238
216
@@ -242,7 +220,6 @@ instance DBType Text where
242 { encode = Opaleye.ConstExpr . Opaleye.StringLit . Text.unpack
220 { encode = Opaleye.ConstExpr . Opaleye.StringLit . Text.unpack
243 , decode = Hasql.text
221 , decode = Hasql.text
244 , typeName = "text"
222 , typeName = "text"
245− , out = id
246 }
223 }
247
224
248
225
@@ -272,7 +249,6 @@ instance DBType ByteString where
272 { encode = Opaleye.ConstExpr . Opaleye.ByteStringLit
249 { encode = Opaleye.ConstExpr . Opaleye.ByteStringLit
273 , decode = Hasql.bytea
250 , decode = Hasql.bytea
274 , typeName = "bytea"
251 , typeName = "bytea"
275− , out = id
276 }
252 }
277
253
278
254
@@ -289,7 +265,6 @@ instance DBType UUID where
289 { encode = Opaleye.ConstExpr . Opaleye.StringLit . UUID.toString
265 { encode = Opaleye.ConstExpr . Opaleye.StringLit . UUID.toString
290 , decode = Hasql.uuid
266 , decode = Hasql.uuid
291 , typeName = "uuid"
267 , typeName = "uuid"
292− , out = id
293 }
268 }
294
269
295
270
@@ -302,21 +277,12 @@ instance DBType Value where
302 Lazy.unpack . Lazy.decodeUtf8 . Aeson.encode
277 Lazy.unpack . Lazy.decodeUtf8 . Aeson.encode
303 , decode = Hasql.jsonb
278 , decode = Hasql.jsonb
304 , typeName = "jsonb"
279 , typeName = "jsonb"
305− , out = id
306 }
280 }
307
281
308
282
309instance Sql DBType a => DBType [a] where
283instance Sql DBType a => DBType [a] where
310− typeInformation = listTypeInformation nullabilization typeInformation
284+ typeInformation = listTypeInformation nullable typeInformation
311
285
312
286
313instance Sql DBType a => DBType (NonEmpty a) where
287instance Sql DBType a => DBType (NonEmpty a) where
314− typeInformation = nonEmptyTypeInformation nullabilization typeInformation
288+ typeInformation = nonEmptyTypeInformation nullable typeInformation
315−
316−
317−instance {-# OVERLAPPING #-} DBType Opaque where
318− typeInformation = error "opaque"
319−
320−
321−instance {-# INCOHERENT #-} (HasNullability a, DBType (Unnullify a)) =>
322− Sql DBType a
src/Rel8/Type/Array.hs+52−32
@@ -1,12 +1,13 @@
1{-# language GADTs #-}
1{-# language GADTs #-}
2+{-# language LambdaCase #-}
2{-# language NamedFieldPuns #-}
3{-# language NamedFieldPuns #-}
3{-# language OverloadedStrings #-}
4{-# language OverloadedStrings #-}
5+{-# language ViewPatterns #-}
4
6
5module Rel8.Type.Array
7module Rel8.Type.Array
6− ( array
8+ ( array, encodeArrayElement, extractArrayElement
7 , listTypeInformation
9 , listTypeInformation
8 , nonEmptyTypeInformation
10 , nonEmptyTypeInformation
9− , fromPrimArray, toPrimArray, zipPrimArraysWith
10 )
11 )
11where
12where
12
13
@@ -22,59 +23,78 @@ import qualified Hasql.Decoders as Hasql
22import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
23import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
23
24
24-- rel8
25-- rel8
25−import Rel8.Schema.Nullability ( Unnullify, Nullability( Nullable, NonNullable ) )
26+import Rel8.Schema.Null ( Unnullify, Nullity( Null, NotNull ) )
26import Rel8.Type.Information ( TypeInformation(..), parseTypeInformation )
27import Rel8.Type.Information ( TypeInformation(..), parseTypeInformation )
27
28
28
29
29array :: Foldable f
30array :: Foldable f
30 => TypeInformation a -> f Opaleye.PrimExpr -> Opaleye.PrimExpr
31 => TypeInformation a -> f Opaleye.PrimExpr -> Opaleye.PrimExpr
31−array TypeInformation {typeName} =
32+array info =
32− fromPrimArray .
33+ Opaleye.CastExpr (arrayType info <> "[]") .
33− Opaleye.CastExpr (typeName <> "[]") .
34+ Opaleye.ArrayExpr . map (encodeArrayElement info) . toList
34− Opaleye.ArrayExpr . toList
35+{-# INLINABLE array #-}
35
36
36
37
37listTypeInformation :: ()
38listTypeInformation :: ()
38− => Nullability a
39+ => Nullity a
39 -> TypeInformation (Unnullify a)
40 -> TypeInformation (Unnullify a)
40 -> TypeInformation [a]
41 -> TypeInformation [a]
41−listTypeInformation nullability info =
42+listTypeInformation nullity info@TypeInformation {encode, decode} =
42− case info of
43+ TypeInformation
43− TypeInformation{ encode, decode, out } -> TypeInformation
44+ { decode = case nullity of
44− { decode = row $ case nullability of
45+ Null ->
45− Nullable -> Hasql.listArray (Hasql.nullable (out <$> decode))
46+ Hasql.listArray (decodeArrayElement info (Hasql.nullable decode))
46− NonNullable -> Hasql.listArray (Hasql.nonNullable (out <$> decode))
47+ NotNull ->
47− , encode = case nullability of
48+ Hasql.listArray (decodeArrayElement info (Hasql.nonNullable decode))
48− Nullable -> array info . fmap (maybe null encode)
49+ , encode = case nullity of
49− NonNullable -> array info . fmap encode
50+ Null ->
50− , typeName = "record"
51+ Opaleye.ArrayExpr .
51− , out = id
52+ fmap (encodeArrayElement info . maybe null encode)
52− }
53+ NotNull ->
54+ Opaleye.ArrayExpr .
55+ fmap (encodeArrayElement info . encode)
56+ , typeName = arrayType info <> "[]"
57+ }
53 where
58 where
54− row = Hasql.composite . Hasql.field . Hasql.nonNullable
55 null = Opaleye.ConstExpr Opaleye.NullLit
59 null = Opaleye.ConstExpr Opaleye.NullLit
56
60
57
61
58nonEmptyTypeInformation :: ()
62nonEmptyTypeInformation :: ()
59− => Nullability a
63+ => Nullity a
60 -> TypeInformation (Unnullify a)
64 -> TypeInformation (Unnullify a)
61 -> TypeInformation (NonEmpty a)
65 -> TypeInformation (NonEmpty a)
62−nonEmptyTypeInformation nullability =
66+nonEmptyTypeInformation nullity =
63− parseTypeInformation parse toList . listTypeInformation nullability
67+ parseTypeInformation parse toList . listTypeInformation nullity
64 where
68 where
65 parse = maybe (Left message) Right . nonEmpty
69 parse = maybe (Left message) Right . nonEmpty
66 message = "failed to decode NonEmptyList: got empty list"
70 message = "failed to decode NonEmptyList: got empty list"
67
71
68
72
69−fromPrimArray :: Opaleye.PrimExpr -> Opaleye.PrimExpr
73+isArray :: TypeInformation a -> Bool
70−fromPrimArray = Opaleye.UnExpr (Opaleye.UnOpOther "ROW")
74+isArray = \case
75+ (reverse . typeName -> ']' : '[' : _) -> True
76+ _ -> False
71
77
72
78
73−toPrimArray :: Opaleye.PrimExpr -> Opaleye.PrimExpr
79+arrayType :: TypeInformation a -> String
74−toPrimArray a = Opaleye.CompositeExpr a "f1"
80+arrayType info
81+ | isArray info = "record"
82+ | otherwise = typeName info
75
83
76
84
77−zipPrimArraysWith :: ()
85+decodeArrayElement :: TypeInformation a -> Hasql.NullableOrNot Hasql.Value x -> Hasql.NullableOrNot Hasql.Value x
78− => (Opaleye.PrimExpr -> Opaleye.PrimExpr -> Opaleye.PrimExpr)
86+decodeArrayElement info
79− -> Opaleye.PrimExpr -> Opaleye.PrimExpr -> Opaleye.PrimExpr
87+ | isArray info = Hasql.nonNullable . Hasql.composite . Hasql.field
80−zipPrimArraysWith f a b = fromPrimArray (f (toPrimArray a) (toPrimArray b))
88+ | otherwise = id
89+
90+
91+encodeArrayElement :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr
92+encodeArrayElement info
93+ | isArray info = Opaleye.UnExpr (Opaleye.UnOpOther "ROW")
94+ | otherwise = id
95+
96+
97+extractArrayElement :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr
98+extractArrayElement info
99+ | isArray info = flip Opaleye.CompositeExpr "f1"
100+ | otherwise = id
src/Rel8/Type/Array1D.hsdeleted−136
@@ -1,136 +0,0 @@
1−{-# language DataKinds #-}
2−{-# language DeriveTraversable #-}
3−{-# language DerivingStrategies #-}
4−{-# language GeneralizedNewtypeDeriving #-}
5−{-# language NamedFieldPuns #-}
6−{-# language StandaloneKindSignatures #-}
7−{-# language TypeFamilies #-}
8−{-# language UndecidableInstances #-}
9−
10−{-# options_ghc -fno-warn-redundant-constraints #-}
11−
12−module Rel8.Type.Array1D
13− ( Array1D( Array1D )
14− , getArray1D
15− )
16−where
17−
18−-- aeson
19−import Data.Aeson
20− ( ToJSON
21− , ToJSON1
22− , ToJSONKey
23− , FromJSON
24− , FromJSON1
25− , FromJSONKey
26− )
27−
28−-- base
29−import Control.Applicative ( Alternative, (<|>) )
30−import Control.Monad ( MonadPlus )
31−import Data.Functor.Classes ( Eq1, Ord1, Read1, Show1 )
32−import Data.Kind ( Type )
33−import GHC.Exts ( IsList )
34−import Prelude hiding ( null )
35−
36−-- hasql
37−import qualified Hasql.Decoders as Hasql
38−
39−-- opaleye
40−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
41−
42−-- rel8
43−import Rel8.Expr.Opaleye ( zipPrimExprsWith )
44−import Rel8.Expr.Serialize ( litExpr )
45−import Rel8.Schema.Nullability
46− ( Unnullify
47− , Nullability( Nullable, NonNullable )
48− , Sql, nullabilization
49− )
50−import Rel8.Type ( DBType, typeInformation )
51−import Rel8.Type.Eq ( DBEq )
52−import Rel8.Type.Information ( TypeInformation(..) )
53−import Rel8.Type.Monoid ( DBMonoid, memptyExpr )
54−import Rel8.Type.Ord ( DBMax, DBMin, DBOrd )
55−import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )
56−
57−-- semigroupoids
58−import Data.Functor.Alt ( Alt, (<!>) )
59−import Data.Functor.Apply ( Apply )
60−import Data.Functor.Bind ( Bind )
61−import Data.Functor.Plus ( Plus )
62−
63−-- semialign
64−import Data.Align ( Align )
65−import Data.Semialign ( Semialign )
66−import Data.Zip ( Repeat, Unzip, Zip )
67−
68−
69−newtype Array1D a = Array1D [a]
70− deriving stock Traversable
71− deriving newtype
72− ( Eq, Ord, Read, Show, Semigroup, Monoid, IsList
73− , Functor, Foldable
74− , Eq1, Ord1, Read1, Show1
75− , FromJSON1, ToJSON1, FromJSON, FromJSONKey, ToJSON, ToJSONKey
76− , Apply, Applicative, Alternative, Plus, Bind, Monad, MonadPlus
77− , Align, Semialign, Repeat, Unzip, Zip
78− )
79−
80−
81−instance Alt Array1D where
82− (<!>) = (<|>)
83−
84−
85−getArray1D :: Array1D a -> [a]
86−getArray1D (Array1D a) = a
87−
88−
89−type IsArray1D :: Type -> Bool
90−type family IsArray1D a where
91− IsArray1D (Array1D _) = 'True
92− IsArray1D _ = 'False
93−
94−
95−array1DTypeInformation :: IsArray1D (Unnullify a) ~ 'False
96− => Nullability a
97− -> TypeInformation (Unnullify a)
98− -> TypeInformation (Array1D a)
99−array1DTypeInformation nullability info =
100− case info of
101− TypeInformation{ encode, decode, typeName, out } -> TypeInformation
102− { decode = case nullability of
103− Nullable -> Array1D <$> Hasql.listArray (Hasql.nullable (out <$> decode))
104− NonNullable -> Array1D <$> Hasql.listArray (Hasql.nonNullable (out <$> decode))
105− , encode = case nullability of
106− Nullable -> Opaleye.ArrayExpr . fmap (maybe null encode) . getArray1D
107− NonNullable -> Opaleye.ArrayExpr . fmap encode . getArray1D
108− , typeName = typeName <> "[]"
109− , out = id
110− }
111− where
112− null = Opaleye.ConstExpr Opaleye.NullLit
113−
114−
115−instance (Sql DBType a, IsArray1D (Unnullify a) ~ 'False) => DBType (Array1D a) where
116− typeInformation = array1DTypeInformation nullabilization typeInformation
117−
118−
119−instance (Sql DBEq a, IsArray1D (Unnullify a) ~ 'False) => DBEq (Array1D a)
120−
121−
122−instance (Sql DBOrd a, IsArray1D (Unnullify a) ~ 'False) => DBOrd (Array1D a)
123−
124−
125−instance (Sql DBMax a, IsArray1D (Unnullify a) ~ 'False) => DBMax (Array1D a)
126−
127−
128−instance (Sql DBMin a, IsArray1D (Unnullify a) ~ 'False) => DBMin (Array1D a)
129−
130−
131−instance (Sql DBType a, IsArray1D (Unnullify a) ~ 'False) => DBSemigroup (Array1D a) where
132− (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
133−
134−
135−instance (Sql DBType a, IsArray1D (Unnullify a) ~ 'False) => DBMonoid (Array1D a) where
136− memptyExpr = litExpr mempty
src/Rel8/Type/Composite.hsnew file+135
@@ -0,0 +1,135 @@
1+{-# language AllowAmbiguousTypes #-}
2+{-# language BlockArguments #-}
3+{-# language DataKinds #-}
4+{-# language FlexibleContexts #-}
5+{-# language GADTs #-}
6+{-# language NamedFieldPuns #-}
7+{-# language ScopedTypeVariables #-}
8+{-# language StandaloneKindSignatures #-}
9+{-# language TypeApplications #-}
10+{-# language UndecidableInstances #-}
11+{-# language UndecidableSuperClasses #-}
12+{-# language ViewPatterns #-}
13+
14+module Rel8.Type.Composite
15+ ( Composite( Composite )
16+ , DBComposite( compositeFields, compositeTypeName )
17+ , compose, decompose
18+ )
19+where
20+
21+-- base
22+import Data.Functor.Const ( Const( Const ), getConst )
23+import Data.Functor.Identity ( Identity( Identity ) )
24+import Data.Kind ( Constraint, Type )
25+import Prelude
26+
27+-- hasql
28+import qualified Hasql.Decoders as Hasql
29+
30+-- opaleye
31+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
32+
33+-- rel8
34+import Rel8.Expr ( Expr )
35+import Rel8.Expr.Opaleye ( castExpr, fromPrimExpr, toPrimExpr )
36+import Rel8.Schema.HTable ( HTable, hfield, hspecs, htabulate, htabulateA )
37+import Rel8.Schema.Name ( Name( Name ) )
38+import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
39+import Rel8.Schema.Result ( Result )
40+import Rel8.Schema.Spec ( Spec( Spec, nullity, info ) )
41+import Rel8.Table ( fromColumns, toColumns, fromResult, toResult )
42+import Rel8.Table.Eq ( EqTable )
43+import Rel8.Table.HKD ( HKD, HKDable )
44+import Rel8.Table.Ord ( OrdTable )
45+import Rel8.Table.Rel8able ()
46+import Rel8.Table.Serialize ( litHTable )
47+import Rel8.Type ( DBType, typeInformation )
48+import Rel8.Type.Eq ( DBEq )
49+import Rel8.Type.Information ( TypeInformation(..) )
50+import Rel8.Type.Ord ( DBOrd, DBMax, DBMin )
51+
52+-- semigroupoids
53+import Data.Functor.Apply ( WrappedApplicative(..) )
54+
55+
56+-- | A deriving-via helper type for column types that store a Haskell product
57+-- type in a single Postgres column using a Postgres composite type.
58+--
59+-- Note that this must map to a specific extant type in your database's schema
60+-- (created with @CREATE TYPE@). Use 'DBComposite' to specify the name of this
61+-- Postgres type and the names of the individual fields (for projecting with
62+-- 'decompose').
63+type Composite :: Type -> Type
64+newtype Composite a = Composite
65+ { unComposite :: a
66+ }
67+
68+
69+instance DBComposite a => DBType (Composite a) where
70+ typeInformation = TypeInformation
71+ { decode = Hasql.composite (Composite . fromResult @_ @(HKD a Expr) <$> decoder)
72+ , encode = encoder . litHTable . toResult @_ @(HKD a Expr) . unComposite
73+ , typeName = compositeTypeName @a
74+ }
75+
76+
77+instance (DBComposite a, EqTable (HKD a Expr)) => DBEq (Composite a)
78+
79+
80+instance (DBComposite a, OrdTable (HKD a Expr)) => DBOrd (Composite a)
81+
82+
83+instance (DBComposite a, OrdTable (HKD a Expr)) => DBMax (Composite a)
84+
85+
86+instance (DBComposite a, OrdTable (HKD a Expr)) => DBMin (Composite a)
87+
88+
89+-- | 'DBComposite' is used to associate composite type metadata with a Haskell
90+-- type.
91+type DBComposite :: Type -> Constraint
92+class (DBType a, HKDable a) => DBComposite a where
93+ -- | The names of all fields in the composite type that @a@ maps to.
94+ compositeFields :: HKD a Name
95+
96+ -- | The name of the composite type that @a@ maps to.
97+ compositeTypeName :: String
98+
99+
100+-- | Collapse a 'HKD' into a PostgreSQL composite type.
101+--
102+-- 'HKD' values are represented in queries by having a column for each field in
103+-- the corresponding Haskell type. 'compose' collapses these columns into a
104+-- single column expression, by combining them into a PostgreSQL composite
105+-- type.
106+compose :: DBComposite a => HKD a Expr -> Expr a
107+compose = castExpr . fromPrimExpr . encoder . toColumns
108+
109+
110+-- | Expand a composite type into a 'HKD'.
111+--
112+-- 'decompose' is the inverse of 'compose'.
113+decompose :: forall a. DBComposite a => Expr a -> HKD a Expr
114+decompose (toPrimExpr -> a) = fromColumns $ htabulate \field ->
115+ case hfield names field of
116+ Name name -> case hfield hspecs field of
117+ Spec {} -> fromPrimExpr $ Opaleye.CompositeExpr a name
118+ where
119+ names = toColumns (compositeFields @a)
120+
121+
122+decoder :: HTable t => Hasql.Composite (t Result)
123+decoder = unwrapApplicative $ htabulateA \field ->
124+ case hfield hspecs field of
125+ Spec {nullity, info} -> WrapApplicative $ Identity <$>
126+ case nullity of
127+ Null -> Hasql.field $ Hasql.nullable $ decode info
128+ NotNull -> Hasql.field $ Hasql.nonNullable $ decode info
129+
130+
131+encoder :: HTable t => t Expr -> Opaleye.PrimExpr
132+encoder a = Opaleye.FunExpr "ROW" exprs
133+ where
134+ exprs = getConst $ htabulateA \field -> case hfield a field of
135+ expr -> Const [toPrimExpr expr]
src/Rel8/Type/Enum.hsnew file+139
@@ -0,0 +1,139 @@
1+{-# language AllowAmbiguousTypes #-}
2+{-# language DataKinds #-}
3+{-# language FlexibleContexts #-}
4+{-# language FlexibleInstances #-}
5+{-# language LambdaCase #-}
6+{-# language RankNTypes #-}
7+{-# language ScopedTypeVariables #-}
8+{-# language StandaloneKindSignatures #-}
9+{-# language TypeApplications #-}
10+{-# language TypeFamilies #-}
11+{-# language TypeOperators #-}
12+{-# language UndecidableInstances #-}
13+
14+module Rel8.Type.Enum
15+ ( Enum( Enum )
16+ , DBEnum( enumValue, enumTypeName )
17+ , Enumable
18+ )
19+where
20+
21+-- base
22+import Control.Applicative ( (<|>) )
23+import Control.Arrow ( (&&&) )
24+import Data.Kind ( Constraint, Type )
25+import Data.Proxy ( Proxy( Proxy ) )
26+import GHC.Generics
27+ ( Generic, Rep, from, to
28+ , (:+:)( L1, R1 ), M1( M1 ), U1( U1 )
29+ , D, C, Meta( MetaCons )
30+ )
31+import GHC.TypeLits ( KnownSymbol, symbolVal )
32+import Prelude hiding ( Enum )
33+
34+-- hasql
35+import qualified Hasql.Decoders as Hasql
36+
37+-- opaleye
38+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
39+
40+-- rel8
41+import Rel8.Type ( DBType, typeInformation )
42+import Rel8.Type.Eq ( DBEq )
43+import Rel8.Type.Information ( TypeInformation(..) )
44+import Rel8.Type.Ord ( DBOrd, DBMax, DBMin )
45+
46+-- text
47+import Data.Text ( pack )
48+
49+
50+-- | A deriving-via helper type for column types that store an \"enum\" type
51+-- (in Haskell terms, a sum type where all constructors are nullary) using a
52+-- Postgres @enum@ type.
53+--
54+-- Note that this should map to a specific type in your database's schema
55+-- (explicitly created with @CREATE TYPE ... AS ENUM@). Use 'DBEnum' to
56+-- specify the name of this Postgres type and the names of the individual
57+-- values. If left unspecified, the names of the values of the Postgres
58+-- @enum@ are assumed to match exactly exactly the names of the constructors
59+-- of the Haskell type (up to and including case sensitivity).
60+type Enum :: Type -> Type
61+newtype Enum a = Enum
62+ { unEnum :: a
63+ }
64+
65+
66+instance DBEnum a => DBType (Enum a) where
67+ typeInformation = TypeInformation
68+ { decode =
69+ Hasql.enum $
70+ flip lookup $
71+ map ((pack . enumValue &&& Enum) . to) $
72+ genumerate @(Rep a)
73+ , encode =
74+ Opaleye.ConstExpr .
75+ Opaleye.StringLit .
76+ enumValue @a .
77+ unEnum
78+ , typeName = enumTypeName @a
79+ }
80+
81+
82+instance DBEnum a => DBEq (Enum a)
83+
84+
85+instance DBEnum a => DBOrd (Enum a)
86+
87+
88+instance DBEnum a => DBMax (Enum a)
89+
90+
91+instance DBEnum a => DBMin (Enum a)
92+
93+
94+-- | @DBEnum@ contains the necessary metadata to describe a PostgreSQL @enum@ type.
95+type DBEnum :: Type -> Constraint
96+class (DBType a, Enumable a) => DBEnum a where
97+ -- | Map Haskell values to the corresponding element of the @enum@ type. The
98+ -- default implementation of this method will use the exact name of the
99+ -- Haskell constructors.
100+ enumValue :: a -> String
101+ enumValue = gshow @(Rep a) . from
102+
103+ -- | The name of the PostgreSQL @enum@ type that @a@ maps to.
104+ enumTypeName :: String
105+
106+
107+-- | Types that are sum types, where each constructor is unary (that is, has no
108+-- fields).
109+type Enumable :: Type -> Constraint
110+class (Generic a, GEnumable (Rep a)) => Enumable a
111+instance (Generic a, GEnumable (Rep a)) => Enumable a
112+
113+
114+type GEnumable :: (Type -> Type) -> Constraint
115+class GEnumable rep where
116+ genumerate :: [rep x]
117+ gshow :: rep x -> String
118+
119+
120+instance GEnumable rep => GEnumable (M1 D meta rep) where
121+ genumerate = M1 <$> genumerate
122+ gshow (M1 rep) = gshow rep
123+
124+
125+instance (GEnumable a, GEnumable b) => GEnumable (a :+: b) where
126+ genumerate = L1 <$> genumerate <|> R1 <$> genumerate
127+ gshow = \case
128+ L1 a -> gshow a
129+ R1 a -> gshow a
130+
131+
132+instance
133+ ( meta ~ 'MetaCons name _fixity _isRecord
134+ , KnownSymbol name
135+ )
136+ => GEnumable (M1 C meta U1)
137+ where
138+ genumerate = [M1 U1]
139+ gshow (M1 U1) = symbolVal (Proxy @name)
src/Rel8/Type/Eq.hs+2−37
@@ -1,5 +1,6 @@
1{-# language FlexibleContexts #-}
1{-# language FlexibleContexts #-}
2{-# language FlexibleInstances #-}
2{-# language FlexibleInstances #-}
3+{-# language MonoLocalBinds #-}
3{-# language MultiParamTypeClasses #-}
4{-# language MultiParamTypeClasses #-}
4{-# language StandaloneKindSignatures #-}
5{-# language StandaloneKindSignatures #-}
5{-# language UndecidableInstances #-}
6{-# language UndecidableInstances #-}
@@ -26,8 +27,7 @@ import qualified Data.ByteString.Lazy as Lazy ( ByteString )
26import Data.CaseInsensitive ( CI )
27import Data.CaseInsensitive ( CI )
27
28
28-- rel8
29-- rel8
29−import Rel8.Opaque ( Opaque )
30+import Rel8.Schema.Null ( Sql )
30−import Rel8.Schema.Nullability ( Unnullify, HasNullability, Sql )
31import Rel8.Type ( DBType )
31import Rel8.Type ( DBType )
32
32
33-- scientific
33-- scientific
@@ -49,36 +49,6 @@ import Data.UUID ( UUID )
49-- | Database types that can be compared for equality in queries. If a type is
49-- | Database types that can be compared for equality in queries. If a type is
50-- an instance of 'DBEq', it means we can compare expressions for equality
50-- an instance of 'DBEq', it means we can compare expressions for equality
51-- using the SQL @=@ operator.
51-- using the SQL @=@ operator.
52−--
53−-- [ @DBEq@ with @newtype@s ]
54−--
55−-- Like with 'Rel8.DBType', @DBEq@ plays well with generalized newtype
56−-- deriving. The example given for @DBType@ added a @UserId@ @newtype@, but
57−-- without a @DBEq@ instance won't actually be able to use that in joins or
58−-- where-clauses, because it lacks equality. We can add this by changing our
59−-- @newtype@ definition to:
60−--
61−-- >>> newtype UserId = UserId { toInt32 :: Int32 } deriving newtype (DBType, DBEq)
62−--
63−-- This will re-use the equality logic for @Int32@, which is to just use the
64−-- @=@ operator.
65−--
66−-- [ @DBEq@ with @DeriveAnyType@ ]
67−--
68−-- You can also use @DBEq@ with the @DeriveAnyType@ extension to easily add
69−-- equality to your type, assuming that @=@ is sufficient on @DBType@ encoded
70−-- values. Extending the example from 'Rel8.ReadShow''s 'Rel8.DBType' instance,
71−-- we could add equality to @Color@ by writing:
72−--
73−-- >>> :{
74−-- data Color = Red | Green | Blue | Purple | Gold
75−-- deriving (Generic, Show, Read, DBEq)
76−-- deriving DBType via ReadShow Color
77−-- :}
78−--
79−-- This means @Color@s will be treated as the literal strings @"Red"@,
80−-- @"Green"@, etc, in the database, and they can be compared for equality by
81−-- just using @=@.
82type DBEq :: Type -> Constraint
52type DBEq :: Type -> Constraint
83class DBType a => DBEq a
53class DBType a => DBEq a
84
54
@@ -106,8 +76,3 @@ instance DBEq UUID
106instance DBEq Value
76instance DBEq Value
107instance Sql DBEq a => DBEq [a]
77instance Sql DBEq a => DBEq [a]
108instance Sql DBEq a => DBEq (NonEmpty a)
78instance Sql DBEq a => DBEq (NonEmpty a)
109−instance DBEq Opaque
110−
111−
112−instance {-# INCOHERENT #-} (HasNullability a, DBEq (Unnullify a)) =>
113− Sql DBEq a
src/Rel8/Type/Information.hs+11−34
@@ -28,23 +28,19 @@ import qualified Data.Text as Text
28-- from database queries. The @typeName@ is the name of the type in the
28-- from database queries. The @typeName@ is the name of the type in the
29-- database, which is used to accurately type literals.
29-- database, which is used to accurately type literals.
30type TypeInformation :: Type -> Type
30type TypeInformation :: Type -> Type
31−data TypeInformation a where
31+data TypeInformation a = TypeInformation
32− TypeInformation ::
32+ { encode :: a -> Opaleye.PrimExpr
33− { encode :: a -> Opaleye.PrimExpr
33+ -- ^ How to encode a single Haskell value as a SQL expression.
34− -- ^ How to encode a single Haskell value as a SQL expression.
34+ , decode :: Hasql.Value a
35− , decode :: Hasql.Value x
35+ -- ^ How to deserialize a single result back to Haskell.
36− -- ^ How to deserialize a single result back to Haskell.
36+ , typeName :: String
37− , typeName :: String
37+ -- ^ The name of the SQL type.
38− -- ^ The name of the SQL type.
38+ }
39− , out :: x -> a
40− -- ^ A final output function - usually this will just be 'id'. This is
41− -- needed to allow @TypeInformation@s to be coerced.
42− } -> TypeInformation a
43
39
44
40
45-- | Simultaneously map over how a type is both encoded and decoded, while
41-- | Simultaneously map over how a type is both encoded and decoded, while
46-- retaining the name of the type. This operation is useful if you want to
42-- retaining the name of the type. This operation is useful if you want to
47−-- essentially @newtype@ another 'DBType'.
43+-- essentially @newtype@ another 'Rel8.DBType'.
48--
44--
49-- The mapping is required to be total. If you have a partial mapping, see
45-- The mapping is required to be total. If you have a partial mapping, see
50-- 'parseTypeInformation'.
46-- 'parseTypeInformation'.
@@ -60,31 +56,12 @@ mapTypeInformation = parseTypeInformation . fmap pure
60-- a given 'TypeInformation'. The parser is applied when deserializing rows
56-- a given 'TypeInformation'. The parser is applied when deserializing rows
61-- returned - the encoder assumes that the input data is already in the
57-- returned - the encoder assumes that the input data is already in the
62-- appropriate form.
58-- appropriate form.
63−--
64−-- One example where this may be useful is with a database that stores data in
65−-- some legacy encoding:
66−--
67−-- >>> import Data.Text (Text)
68−--
69−-- >>> data Color = Red | Green | Blue
70−-- >>> :{
71−-- instance DBType Color where
72−-- typeInformation = parseTypeInformation parseLegacy toLegacy typeInformation
73−-- where
74−-- parseLegacy :: Text -> Either String Color
75−-- parseLegacy "red" = Right Red
76−-- parseLegacy "green" = Right Green
77−-- parseLegacy _ = Left "Unexpected Color"
78−-- toLegacy Red = "red"
79−-- toLegacy Green = "green"
80−-- :}
81parseTypeInformation :: ()
59parseTypeInformation :: ()
82 => (a -> Either String b) -> (b -> a)
60 => (a -> Either String b) -> (b -> a)
83 -> TypeInformation a -> TypeInformation b
61 -> TypeInformation a -> TypeInformation b
84−parseTypeInformation to from TypeInformation {encode, decode, typeName, out} =
62+parseTypeInformation to from TypeInformation {encode, decode, typeName} =
85 TypeInformation
63 TypeInformation
86 { encode = encode . from
64 { encode = encode . from
87− , decode = Hasql.refine (first Text.pack . to) (out <$> decode)
65+ , decode = Hasql.refine (first Text.pack . to) decode
88 , typeName
66 , typeName
89− , out = id
90 }
67 }
src/Rel8/Type/JSONBEncoded.hs+5−2
@@ -1,3 +1,5 @@
1+{-# language StandaloneKindSignatures #-}
2+
1module Rel8.Type.JSONBEncoded ( JSONBEncoded(..) ) where
3module Rel8.Type.JSONBEncoded ( JSONBEncoded(..) ) where
2
4
3-- aeson
5-- aeson
@@ -6,6 +8,7 @@ import Data.Aeson.Types ( parseEither )
6
8
7-- base
9-- base
8import Data.Bifunctor ( first )
10import Data.Bifunctor ( first )
11+import Data.Kind ( Type )
9import Prelude
12import Prelude
10
13
11-- hasql
14-- hasql
@@ -19,7 +22,8 @@ import Rel8.Type.Information ( TypeInformation(..) )
19import Data.Text ( pack )
22import Data.Text ( pack )
20
23
21
24
22−-- | Like 'JSONEncoded', but works for @jsonb@ columns.
25+-- | Like 'Rel8.JSONEncoded', but works for @jsonb@ columns.
26+type JSONBEncoded :: Type -> Type
23newtype JSONBEncoded a = JSONBEncoded { fromJSONBEncoded :: a }
27newtype JSONBEncoded a = JSONBEncoded { fromJSONBEncoded :: a }
24
28
25
29
@@ -28,5 +32,4 @@ instance (FromJSON a, ToJSON a) => DBType (JSONBEncoded a) where
28 { encode = encode typeInformation . toJSON . fromJSONBEncoded
32 { encode = encode typeInformation . toJSON . fromJSONBEncoded
29 , decode = Hasql.refine (first pack . fmap JSONBEncoded . parseEither parseJSON) Hasql.jsonb
33 , decode = Hasql.refine (first pack . fmap JSONBEncoded . parseEither parseJSON) Hasql.jsonb
30 , typeName = "jsonb"
34 , typeName = "jsonb"
31− , out = id
32 }
35 }
src/Rel8/Type/JSONEncoded.hs+4−13
@@ -1,3 +1,5 @@
1+{-# language StandaloneKindSignatures #-}
2+
1module Rel8.Type.JSONEncoded ( JSONEncoded(..) ) where
3module Rel8.Type.JSONEncoded ( JSONEncoded(..) ) where
2
4
3-- aeson
5-- aeson
@@ -5,6 +7,7 @@ import Data.Aeson ( FromJSON, ToJSON, parseJSON, toJSON )
5import Data.Aeson.Types ( parseEither )
7import Data.Aeson.Types ( parseEither )
6
8
7-- base
9-- base
10+import Data.Kind ( Type )
8import Prelude
11import Prelude
9
12
10-- rel8
13-- rel8
@@ -15,19 +18,7 @@ import Rel8.Type.Information ( parseTypeInformation )
15-- | A deriving-via helper type for column types that store a Haskell value
18-- | A deriving-via helper type for column types that store a Haskell value
16-- using a JSON encoding described by @aeson@'s 'ToJSON' and 'FromJSON' type
19-- using a JSON encoding described by @aeson@'s 'ToJSON' and 'FromJSON' type
17-- classes.
20-- classes.
18−--
21+type JSONEncoded :: Type -> Type
19−-- The declaration:
20−--
21−-- >>> import Data.Aeson
22−--
23−-- >>> :{
24−-- data Pet = Pet { petName :: String, petAge :: Int }
25−-- deriving (Generic, ToJSON, FromJSON)
26−-- deriving PrimitiveType via JSONEncoded Pet
27−-- :}
28−--
29−-- will allow you to store @Pet@ values in a single SQL column (stored as
30−-- @json@ values).
31newtype JSONEncoded a = JSONEncoded { fromJSONEncoded :: a }
22newtype JSONEncoded a = JSONEncoded { fromJSONEncoded :: a }
32
23
33
24
src/Rel8/Type/Monoid.hs+4−11
@@ -27,10 +27,7 @@ import Data.CaseInsensitive ( CI )
27import {-# SOURCE #-} Rel8.Expr ( Expr )
27import {-# SOURCE #-} Rel8.Expr ( Expr )
28import Rel8.Expr.Array ( sempty )
28import Rel8.Expr.Array ( sempty )
29import Rel8.Expr.Serialize ( litExpr )
29import Rel8.Expr.Serialize ( litExpr )
30−import Rel8.Schema.Nullability
30+import Rel8.Schema.Null ( Sql )
31− ( Unnullify
32− , Sql, HasNullability, nullabilization
33− )
34import Rel8.Type ( DBType, typeInformation )
31import Rel8.Type ( DBType, typeInformation )
35import Rel8.Type.Semigroup ( DBSemigroup )
32import Rel8.Type.Semigroup ( DBSemigroup )
36
33
@@ -42,8 +39,8 @@ import qualified Data.Text.Lazy as Lazy ( Text )
42import Data.Time.LocalTime ( CalendarDiffTime( CalendarDiffTime ) )
39import Data.Time.LocalTime ( CalendarDiffTime( CalendarDiffTime ) )
43
40
44
41
45−-- | The class of 'DBType's that form a semigroup. This class is purely a Rel8
42+-- | The class of 'Rel8.DBType's that form a semigroup. This class is purely a
46−-- concept, and exists to mirror the 'Monoid' class.
43+-- Rel8 concept, and exists to mirror the 'Monoid' class.
47type DBMonoid :: Type -> Constraint
44type DBMonoid :: Type -> Constraint
48class DBSemigroup a => DBMonoid a where
45class DBSemigroup a => DBMonoid a where
49 -- The identity for '<>.'
46 -- The identity for '<>.'
@@ -51,7 +48,7 @@ class DBSemigroup a => DBMonoid a where
51
48
52
49
53instance Sql DBType a => DBMonoid [a] where
50instance Sql DBType a => DBMonoid [a] where
54− memptyExpr = sempty nullabilization typeInformation
51+ memptyExpr = sempty typeInformation
55
52
56
53
57instance DBMonoid CalendarDiffTime where
54instance DBMonoid CalendarDiffTime where
@@ -80,7 +77,3 @@ instance DBMonoid ByteString where
80
77
81instance DBMonoid Lazy.ByteString where
78instance DBMonoid Lazy.ByteString where
82 memptyExpr = litExpr ""
79 memptyExpr = litExpr ""
83−
84−
85−instance {-# INCOHERENT #-} (HasNullability a, DBMonoid (Unnullify a)) =>
86− Sql DBMonoid a
src/Rel8/Type/Num.hs+12−13
@@ -7,7 +7,7 @@
7{-# language UndecidableInstances #-}
7{-# language UndecidableInstances #-}
8
8
9module Rel8.Type.Num
9module Rel8.Type.Num
10− ( DBNum, DBIntegral, DBFractional
10+ ( DBNum, DBIntegral, DBFractional, DBFloating
11 )
11 )
12where
12where
13
13
@@ -17,8 +17,8 @@ import Data.Kind ( Constraint, Type )
17import Prelude
17import Prelude
18
18
19-- rel8
19-- rel8
20−import Rel8.Schema.Nullability ( HasNullability, Unnullify, Sql )
21import Rel8.Type ( DBType )
20import Rel8.Type ( DBType )
21+import Rel8.Type.Ord ( DBOrd )
22
22
23-- scientific
23-- scientific
24import Data.Scientific ( Scientific )
24import Data.Scientific ( Scientific )
@@ -36,27 +36,26 @@ instance DBNum Double
36instance DBNum Scientific
36instance DBNum Scientific
37
37
38
38
39−instance {-# INCOHERENT #-} (HasNullability a, DBNum (Unnullify a)) =>
39+-- | The class of database types that can be coerced to from integral
40− Sql DBNum a
40+-- expressions. This is a Rel8 concept, and allows us to provide
41−
41+-- 'fromIntegral'.
42−
43type DBIntegral :: Type -> Constraint
42type DBIntegral :: Type -> Constraint
44−class DBNum a => DBIntegral a
43+class (DBNum a, DBOrd a) => DBIntegral a
45instance DBIntegral Int16
44instance DBIntegral Int16
46instance DBIntegral Int32
45instance DBIntegral Int32
47instance DBIntegral Int64
46instance DBIntegral Int64
48
47
49
48
50−instance {-# INCOHERENT #-} (HasNullability a, DBIntegral (Unnullify a)) =>
51− Sql DBIntegral a
52−
53−
54-- | The class of database types that support the @/@ operator.
49-- | The class of database types that support the @/@ operator.
50+type DBFractional :: Type -> Constraint
55class DBNum a => DBFractional a
51class DBNum a => DBFractional a
56instance DBFractional Float
52instance DBFractional Float
57instance DBFractional Double
53instance DBFractional Double
58instance DBFractional Scientific
54instance DBFractional Scientific
59
55
60
56
61−instance {-# INCOHERENT #-} (HasNullability a, DBFractional (Unnullify a)) =>
57+-- | The class of database types that support the @/@ operator.
62− Sql DBFractional a
58+type DBFloating :: Type -> Constraint
59+class DBFractional a => DBFloating a
60+instance DBFloating Float
61+instance DBFloating Double
src/Rel8/Type/Ord.hs+2−17

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

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

This diff is too big to show here.

src/Rel8/Type/Tag.hs+13

This diff is too big to show here.

src/Rel8/Window.hsnew file+97

This diff is too big to show here.

tests/Main.hs+338−174

This diff is too big to show here.

tests/Rel8/Generic/Rel8able/Test.hsnew file+188

This diff is too big to show here.