master..f8b1a55 · rel8

git.iko.soy/rel8

on f8b1a55 help sign in

.github/workflows/build.yaml+3−3

since splitsnapshots

unifiedsplit

@@ -9,14 +9,14 @@ jobs:

9 persist-credentials: false

10 submodules: true

12− - uses: cachix/install-nix-action@v14.1

12+ - uses: cachix/install-nix-action@v12

13 with:

14 nix_path: nixpkgs=channel:nixos-unstable

15 extra_nix_config: |

16 trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ=

17− substituters = https://cache.nixos.org/ https://cache.iog.io

17+ substituters = https://cache.nixos.org/ https://hydra.iohk.io

19− - uses: cachix/cachix-action@v10

19+ - uses: cachix/cachix-action@v8

20 with:

21 name: rel8

22 authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}'

Changelog.mddeleted−159

@@ -1,159 +0,0 @@

1−# 1.4.0.0 (2002-08-17)

2−

3−## Breaking changes

4−

5−* The behavior of `greatest`/`least` has been corrected, and was previously flipped. ([#183](https://github.com/circuithub/rel8/pull/183))

6−

7−## New features

8−

9−* `NullTable`/`HNull` have been added. This is an alternative to `MaybeTable` that doesn't use a tag columns. It's less flexible (no `Functor` or `Applicative` instance) and is meaningless when used with a table that has no non-nullable columns (so nesting `NullTable` is redundant). But in situations where the underlying `Table` does have non-nullable columns, it can losslessly converted to and from `MaybeTable`. It is useful for embedding into a base table when you don't want to store the extra tag column in your schema. ([#173](https://github.com/circuithub/rel8/pull/173))

10−* Add `fromMaybeTable`. ([#179](https://github.com/circuithub/rel8/pull/179))

11−* Add `alignMaybeTable`. ([#196](https://github.com/circuithub/rel8/pull/196))

12−

13−## Improvements

14−

15−* Optimize implementation of `AltTable` for `Tabulation` ([#178](https://github.com/circuithub/rel8/pull/178))

16−

17−## Other

18−

19−* Documentation improvements for `HADT`. ([#177](https://github.com/circuithub/rel8/pull/177))

20−* Document example usage of `groupBy`. ([#184](https://github.com/circuithub/rel8/pull/184))

21−* Build with and require Opaleye >= 0.9.3.3. ([#190](https://github.com/circuithub/rel8/pull/190))

22−* Build with `hasql` 1.6. ([#195](https://github.com/circuithub/rel8/pull/195))

23−

24−# 1.3.1.0 (2022-01-20)

25−

26−## Other

27−

28−* Rel8 now requires Opaleye >= 0.9.1. ([#165](https://github.com/circuithub/rel8/pull/165))

29−

30−# 1.3.0.0 (2022-01-31)

31−

32−## Breaking changes

33−

34−* `div` and `mod` have been changed to match Haskell semantics. If you need the PostgreSQL `div()` and `mod()` functions, use `quot` and `rem`. While this is not an API change, we feel this is a breaking change in semantics and have bumped the major version number. ([#155](https://github.com/circuithub/rel8/pull/155))

35−

36−## New features

37−

38−* `divMod` and `quotRem` functions have been added, matching Haskell's `Prelude` functions. ([#155](https://github.com/circuithub/rel8/pull/155))

39−* `avg` and `mode` aggregation functions to find the mean value of an expression, or the most common row in a query, respectively. ([#152](https://github.com/circuithub/rel8/pull/152))

40−* The full `EqTable` and `OrdTable` classes have been exported, allowing for instances to be manually created. ([#157](https://github.com/circuithub/rel8/pull/157))

41−* Added `like` and `ilike` (for the `LIKE` and `ILIKE` operators). ([#146](https://github.com/circuithub/rel8/pull/146))

42−

43−## Other

44−

45−* Rel8 now requires Opaleye 0.9. ([#158](https://github.com/circuithub/rel8/pull/158))

46−* Rel8's test suite supports Hedgehog 1.1. ([#160](https://github.com/circuithub/rel8/pull/160))

47−* The documentation for binary operations has been corrected. ([#162](https://github.com/circuithub/rel8/pull/162))

48−

49−# 1.2.2.0 (2021-11-21)

50−

51−## Other

52−

53−* Support GHC 9.2 ([#145](https://github.com/circuithub/rel8/pull/145))

54−* Correct the documentation for `except` ([#147](https://github.com/circuithub/rel8/pull/147))

55−* Support `hasql` 1.5 ([#149](https://github.com/circuithub/rel8/pull/149))

56−

57−# 1.2.1.0 (2021-11-21)

58−

59−## New features

60−

61−* `castTable` has been added, which casts all columns selected from in `Query` according to the types of columns. This can occasionally be useful when using `many`/`some` on older PostgreSQL versions. ([#137](https://github.com/circuithub/rel8/pull/137))

62−

63−* Added `<:`, `<=:`, `>:`, `>=:`, `greatest` and `least`, which sort all columns in a table lexicographically. These operators are like the `<.` operators which operate on `Expr`s, but the `<:` operate on entire tables. ([#139](https://github.com/circuithub/rel8/pull/139))

64−

65−## Other

66−

67−* Support opaleye-0.8 ([#142](https://github.com/circuithub/rel8/pull/142))

68−

69−# 1.2.0.0 (2021-10-22)

70−

71−## New features

72−

73−* New `$*` and `$+` operators for projecting out of `ListTable` and `NonEmptyTable` respectively (analogous to the existing `$?` for `MaybeTable`). ([#125](https://github.com/circuithub/rel8/pull/125))

74−

75−## Bug fixes

76−

77−* Fix `UPSERT` support (and add tests), which was broken due to a typo inside Rel8 that made it impossible to construct `Projection`s which are needed by `UPSERT`. ([#134](https://github.com/circuithub/rel8/pull/134))

78−

79−* Remove `DBMin` and `DBMax` instances for `Bool`, which are invalid as far as Postgres is concerned. `and` and `or` can be used to achieve the same thing. ([#126](https://github.com/circuithub/rel8/pull/126))

80−

81−* Fix `aggregateMaybeTable`, `aggregateEitherTable` and `aggregateTheseTable`, which generated invalid SQL previously. ([#127](https://github.com/circuithub/rel8/pull/127))

82−

83−## Breaking changes

84−

85−* `rebind` now takes an additional argument for the "name" of the binding. ([#128](https://github.com/circuithub/rel8/pull/128))

86−

87−# 1.1.0.0 (2021-07-16)

88−

89−## New features

90−

91−* You can derive `Rel8able` for "vanilla" higher-kinded data types - data types that don't use the `Column` type family. For example, the following is now possible:

92−

93− ```haskell

94− data MyTable f = MyTable

95− { myTableX :: f Int32

96− , myTableY :: f Text

97− } deriving (Generic, Rel8able)

98− ```

99−

100−* The `Projectable` and `Biprojectable` type classes have been introduced. These classes model a type of functors and bifunctors (respectively) on tables, where the mapping function is only able to rearrange columns. For example, the following is now possible:

101−

102− ```haskell

103− x <- project myTableX <$> many ...

104− ```

105−

106−* `Insert`'s `onConflict` field now has a new option - `DoUpdate`. This maps to PostgreSQL's `ON CONFLICT DO UPDATE` syntax, which provides upsert support. ([#85](https://github.com/circuithub/rel8/pull/85))

107−

108−* `Insert`, `Update` and `Delete` has all been expanded to work with `Query`s. In particular:

109−

110− * `Delete` now supports a `USING` sub-query

111− * `Update` now supports a `FROM` sub-query

112− * `Insert` can delete the result of any arbitrary `Query` (providing the types match)

113−

114−* The new `Rel8.Tabulate` module has been added, which gives a `Map`-esque interface to writing and composing queries. ([#70](https://github.com/circuithub/rel8/pull/70))

115−

116−* The new `indexed` `Query -> Query` function was added. This function augments each row in a query with it's 0-based index. ([#117](https://github.com/circuithub/rel8/pull/117))

117−

118−## Breaking changes

119−

120−* `Insert`, `Delete` and `Update` have all changed. In particular, for `Insert` users should now replace `rows = xs` with `rows = values xs`. ([#85](https://github.com/circuithub/rel8/pull/85))

121−

122−* Rename `whereExists` and `whereNotExists` to `present` and `absent` respectively. ([#57](https://github.com/circuithub/rel8/pull/57))

123−

124−* Simplify `evaluate` to run directly inside the `Query` monad, rendering the `Evaluate` monad unnecessary. ([#56](https://github.com/circuithub/rel8/pull/56))

125−

126−* The `Labelable` type class has been removed as it's no longer necessary. This class was mostly internal, though was visible in some public API functions. ([#76](https://github.com/circuithub/rel8/pull/76))

127−

128−* `EitherTable`, `ListTable`, `MaybeTable`, `NonEmptyTable` and `TheseTable` now all have an extra parameter which tracks the context of the table. If you manually specified any types before, you need to provide this parameter - usually `Expr` will be the correct choice. ([#101](https://github.com/circuithub/rel8/pull/101))

129−

130−* We've done a lot of work to simplify the internals of Rel8, but some of these are breaking changes. However, most of these API changes shouldn't affect users as they are mostly types used in type inference, or affect classes where users don't need to define their own instances.

131−

132− * The kind of a `Rel8able` is now `(Type -> Type) -> Type`. Previously it was `(X -> Type) -> Type`.

133− * `Table` has a new associated type - `FromExprs`. This was previously an open type family.

134− * `Table` has a new associated type - `Transpose` - and `Recontextualise` has been renamed to `Transposes`. This `Transposes` class now operates in terms of `Transpose`.

135−

136−* `select`, `insert`, `update` and `delete` now produce Hasql `Statement`s, rather than actually running the statement as IO. This allows Rel8 to be used with transaction/connection-managing monads like [`hasql-transaction`](https://hackage.haskell.org/package/hasql-transaction). ([#94](https://github.com/circuithub/rel8/pull/94))

137−

138−## Bug fixes

139−

140−* Fixes a bug where cartesian products of queries using `catListTable`, `catNonEmptyTable`, `catList` and `catNonEmpty` would incorrectly be zipped instead. ([#61](https://github.com/circuithub/rel8/pull/61))

141−

142−* Require Opaleye 0.7.3.0. This version has better support for lateral queries, which can improve query plans, especially in `optional`/`LEFT JOIN` ([#72](https://github.com/circuithub/rel8/pull/72))

143−

144−* Rel8 now compiles with GHC 9. ([#97](https://github.com/circuithub/rel8/pull/97))

145−

146−## Other changes

147−

148−* `exists` is now implemented in terms of the SQL `EXISTS` keyword. ([#69](https://github.com/circuithub/rel8/pull/69))

149−

150−* `alignBy` no longer requires `Table`s. ([#67](https://github.com/circuithub/rel8/pull/67))

151−

152−

153−# 1.0.0.1 (2021-06-21)

154−

155−This release contains various fixes for documentation.

156−

157−# 1.0.0.0 (2021-06-18)

158−

159−* Initial release.

LICENSE+1−1

@@ -1,4 +1,4 @@

3All rights reserved.

README.md−4

@@ -10,8 +10,4 @@ The main objectives of Rel8 are:

11* *Familiar*: writing Rel8 queries should feel like normal Haskell programming.

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−

17For more details, check out the [official documentation](https://rel8.readthedocs.io/en/latest/).

13For more details, check out the [official documentation](https://rel8.readthedocs.io/en/latest/).

cabal.project+5

@@ -1 +1,6 @@

1packages: .

3+allow-newer: generic-monoid:base

4+allow-newer: cryptohash-sha1:base

5+allow-newer: cryptohash-md5:base

6+allow-newer: entropy:Cabal

cabal.project.haskell-nix+6

@@ -2,3 +2,9 @@

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.

6+source-repository-package

7+ type: git

8+ location: git://github.com/jcpetruzza/barbies

9+ tag: f99b05454874192e3511bd133555dfb6cc6a6ecb

10+ --sha256: 0yy2i2jbllwavv5d2176rf8lmm4l1ws90lxkmdlfgvfzqxidx0gi

default.nix+5−5

@@ -1,15 +1,15 @@

1−let

1+let

2 haskellNix = import (import ./nix/sources.nix)."haskell.nix" {};

4− nixpkgsSrc = haskellNix.sources.nixpkgs-unstable;

4+ nixpkgsSrc = haskellNix.sources.nixpkgs-2009;

6 nixpkgsArgs = haskellNix.nixpkgsArgs;

8− compiler-nix-name = "ghc924";

8+ compiler-nix-name = "ghc8104";

10 pkgs = import nixpkgsSrc nixpkgsArgs;

12−in

12+in

13pkgs.haskell-nix.project {

14 inherit compiler-nix-name;

@@ -20,7 +20,7 @@ pkgs.haskell-nix.project {

20 src = ./.;

21 };

23− modules = [

23+ modules = [

24 { packages.rel8 = {

25 preCheck = ''

26 export PATH="${pkgs.postgresql}/bin:${"$PATH"}"

docs/concepts/dbtype.rst+17−18

@@ -11,19 +11,18 @@ though most of these primitive ``DBType``\s should already be available.

11Combining ``newtype`` and ``DBType``

12------------------------------------

14−You can define new instances of ``DBType`` by using Haskell "generalized

14+You can define new instances of ``DBType`` by using Haskell "generalized newtype

15−newtype deriving" strategy. This is useful when you have a common database

15+deriving" strategy. This is useful when you have a common database type, but

16−type, but need to interpret this type differently in different contexts. A very

16+need to interpret this type differently in different contexts. A very common

17−common example here is with auto-incrementing ``id`` counters. In PostgreSQL,

17+example here is with auto-incrementing ``id`` counters. In PostgreSQL, it's

18−it's common for a table to have a primary key that uses the ``serial`` type,

18+common for a table to have a primary key that uses the ``serial`` type, which

19−which means the key is an ``int8`` with a default value for ``INSERT``. In

19+means the key is an ``int8`` with a default value for ``INSERT``. In Rel8, we

20−Rel8, we could use ``Int64`` (as ``Int64`` is the ``DBType`` instance for

20+could use ``Int64`` (as ``Int64`` is the ``DBType`` instance for ``int8``), but

21−``int8``), but we can be even clearer if we make a ``newtype`` for each *type*

21+we can be even clearer if we make a ``newtype`` for each *type* of id.

22−of id.

22+

23−

24−If our database has users and orders, these tables might both have ids, but

23+If our database has users and orders, these tables might both have ids, but they

25−they are clearly not meant to be treated as a common type. Instead, we can make

24+are clearly not meant to be treated as a common type. Instead, we can make these

26−these types clearly different by writing::

25+types clearly different by writing::

28 newtype UserId = UserId { getUserId :: Int64 }

27 newtype UserId = UserId { getUserId :: Int64 }

29 deriving newtype DBType

28 deriving newtype DBType

@@ -58,8 +57,8 @@ In our PostgreSQL we have a few choices, but for now we'll assume that they are

58stored as ``text`` values.

57stored as ``text`` values.

60In order to use this type in Rel8 queries, we need to write an instance of

59In order to use this type in Rel8 queries, we need to write an instance of

61−``DBType`` for ``OrderStatus``. One approach is to use

60+``DBType`` for ``OrderStatus``. One approach is to use ``parseTypeInformation``,

62−``parseTypeInformation``, which allows you to refine an existing ``DBType``::

61+which allows you to refine an existing ``DBType``::

64 instance DBType OrderStatus where

63 instance DBType OrderStatus where

65 typeInformation = parseTypeInformation parser printer typeInformation

64 typeInformation = parseTypeInformation parser printer typeInformation

@@ -101,9 +100,9 @@ There usage is very similar to ``ReadShow`` - simply derive ``DBType via

101JSONEncoded``, and Rel8 will use ``ToJSON`` and ``FromJSON`` instances (from

100JSONEncoded``, and Rel8 will use ``ToJSON`` and ``FromJSON`` instances (from

102``aeson``) to serialize the given type.

101``aeson``) to serialize the given type.

103

102

104−For example, a project might use event sourcing with a table of events. Each

103+For example, a project might use event sourcing with a table of events. Each row

105−row in this table is an event, but this event is stored as a JSON object. We

104+in this table is an event, but this event is stored as a JSON object. We can use

106−can use this type with Rel8 by writing::

105+this type with Rel8 by writing::

107

106

108 data Event = UserCreated UserCreatedData | OrderCreated OrderCreatedData

107 data Event = UserCreated UserCreatedData | OrderCreated OrderCreatedData

109 deriving stock Generic

108 deriving stock Generic

docs/concepts/expr.rst+2−2

@@ -58,7 +58,7 @@ 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

59have::

61− litExpr :: Sql DBType a => a -> Expr a

61+ litExpr :: Sql DBType a => a -> Expr a

63Here ``Sql DBType a`` means that ``a`` can either be literally a type that has

64an instance of ``DBType`` (like ``UserId`` or ``Bool``), *or* that same type

@@ -69,6 +69,6 @@ Some functions work regardless of whether or not a value is null, and in these

69cases you'll see ``Sql DBType a``. ``Sql`` can be used with any ``DBType``

70subtype. For example, the type of ``div`` is::

72− div :: Sql DBIntegral a => Expr a -> Expr a -> Expr a

72+ div :: Sql DBIntegral a => Expr a -> Expr a -> Expr a

74Which means ``div`` works on any ``DBIntegral a``, including ``Maybe a``.

docs/concepts/insert.rstdeleted−181

@@ -1,181 +0,0 @@

1−``INSERT``, ``UPDATE`` and ``DELETE``

2−=====================================

3−

4−While the majority of Rel8 is about building and executing ``SELECT``

5−statement, Rel8 also has support for ``INSERT``, ``UPDATE`` and ``DELETE``.

6−These statements are all executed using the ``insert``, ``update`` and

7−``delete`` functions, all of which take a record of parameters.

8−

9−.. note::

10−

11− This part of Rel8's API uses the ``DuplicateRecordFields`` language

12− extension. In code that needs to use this API, you should also enable this

13− language extension, or you may get errors about ambiguous field names.

14−

15−``DELETE``

16−----------

17−

18−To perform a ``DELETE`` statement, construct a ``Delete`` value and execute it

19−using ``delete``. ``Delete`` takes:

20−

21−``from``

22− The ``TableSchema`` for the table to delete rows from.

23−

24−``using``

25− This is a simple ``Query`` that forms the ``USING`` clause of the ``DELETE``

26− statement. This can be used to join against other tables, and the results

27− can be referenced in the ``deleteWhere`` parameter. For simple ``DELETE``\s

28− where you don't need to do this, you can set ``using = pure ()``.

29−

30−``deleteWhere``

31− The ``WHERE`` clause of the ``DELETE`` statement. This is a function that

32− takes two inputs: the result of the ``using`` query, and the current value

33− of the row.

34−

35−``returning``

36− What to return - see :ref:`returning`.

37−

38−``UPDATE``

39−----------

40−

41−To perform a ``UPDATE`` statement, construct a ``Update`` value and execute it

42−using ``update``. ``Update`` takes:

43−

44−``target``

45− The ``TableSchema`` for the table to update rows in.

46−

47−``from``

48− This is a simple ``Query`` that forms the ``FROM`` clause of the ``UPDATE``

49− statement. This can be used to join against other tables, and the results

50− can be referenced in the ``set`` and ``updateWhere`` parameters. For simple

51− ``UPDATE``\s where you don't need to do this, you can set ``from = pure ()``.

52−

53−``set``

54− A row to row transformation function, indicating how to update selected rows.

55− This function takes rows of the same shape as ``target`` but in the ``Expr``

56− context. One way to write this function is to use record update syntax::

57−

58− set = \from row -> row { rowName = "new name" }

59−

60−``updateWhere``

61− The ``WHERE`` clause of the ``UPDATE`` statement. This is a function that

62− takes two inputs: the result of the ``from`` query, and the current value of

63− the row.

64−

65−``returning``

66− What to return - see :ref:`returning`.

67−

68−``INSERT``

69−----------

70−

71−To perform a ``INSERT`` statement, construct a ``Insert`` value and execute it

72−using ``insert``. ``Insert`` takes:

73−

74−``into``

75− The ``TableSchema`` for the table to insert rows into.

76−

77−``rows``

78− The rows to insert. These are the same as ``into``, but in the ``Expr``

79− context. You can construct rows from their individual fields::

80−

81− rows = values [ MyTable { myTableA = lit "A", myTableB = lit 42 }

82−

83− or you can use ``lit`` on a table value in the ``Result`` context::

84−

85− rows = values [ lit MyTable { myTableA = "A", myTableB = 42 }

86−

87−``onConflict``

88− What should happen if an insert clashes with rows that already exist. This

89− corresponds to PostgreSQL's ``ON CONFLICT`` clause. You can specify:

90−

91− ``Abort``

92− PostgreSQL should abort the ``INSERT`` with an exception

93−

94− ``DoNothing``

95− PostgreSQL should not insert the duplicate rows.

96−

97− ``DoUpdate``

98− PostgreSQL should instead try to update any existing rows that conflict

99− with rows proposed for insertion.

100−

101−``returning``

102− What to return - see :ref:`returning`.

103−

104−.. _returning:

105−

106−``RETURNING``

107−-------------

108−

109−PostgreSQL has the ability to return extra information after a ``DELETE``,

110−``INSERT`` or ``UPDATE`` statement by attaching a ``RETURNING`` clause. A common

111−use of this clause is to return any automatically generated sequence values for

112−primary key columns. Rel8 supports ``RETURNING`` clauses by filling in the

113−``returning`` field and specifying a ``Projection``. A ``Projection`` is a row

114−to row transformation, allowing you to project out a subset of fields.

115−

116−For example, if we are inserting orders, we might want the order ids returned::

117−

118− insert Insert

119− { into = orderSchema

120− , rows = values [ order ]

121− , onConflict = Abort

122− , returning = Projection orderId

123− }

124−

125−If we don't want to return anything, we can use ``pure ()``::

126−

127− insert Insert

128− { into = orderSchema

129− , rows = values [ order ]

130− , onConflict = Abort

131− , returning = pure ()

132− }

133−

134−Default values

135−--------------

136−

137−It is fairly common to define tables with default values. While Rel8 does not

138−have specific functionality for ``DEFAULT``, there are a few options:

139−

140−``unsafeDefault``

141−~~~~~~~~~~~~~~~~~~~~~~~~~~~

142−

143−Rel8 does not have any special support for ``DEFAULT``. If you need to use

144−default column values in inserts, you can use ``unsafeDefault`` to

145−construct the ``DEFAULT`` expression::

146−

147− insert Insert

148− { into = orderSchema

149− , rows = values [ Order { orderId = unsafeDefault, ... } ]

150− , onConflict = Abort

151− , returning = Projection orderId

152− }

153−

154−.. warning::

155− As the name suggests, this is an unsafe operation. In particular, Rel8 is not

156− able to prove that this column does have a default value, so it may be

157− possible to introduce a runtime error. Furthermore, ``DEFAULT`` is fairly

158− special in SQL, and cannot be combined like other expressions. For example,

159− the innocuous expression::

160−

161− unsafeDefault + 1

162−

163− will lead to a runtime crash.

164−

165−Reimplement default values in Rel8

166−~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

167−

168−If you only need to access default values in Rel8, another option is to specify

169−them in Rel8, rather than in your database schema.

170−

171−.. hint::

172− A common default value for primary keys is to use `nextval` to obtain the

173− next value from a sequence. This can be done in Rel8 by using the ``nextval``

174− function::

175−

176− insert Insert

177− { into = orderSchema

178− , rows = values [ Order { orderId = nextval "order_id_seq", ... } ]

179− , onConflict = Abort

180− , returning = Projection orderId

181− }

docs/concepts/queries.rst+9−9

@@ -88,7 +88,7 @@ notation allows you to write these queries in a simpler form, where we don't

88have to introduce functions. Expanding on the latter query, we could write::

90 do user <- getAllUsers

91− order <- getOrdersForUser user

91+ order <- getOrdersForUser (user)

92 return (user, order)

94Now we have a query that, for each ``User``, fetches all orders for that user.

@@ -138,20 +138,20 @@ a query. The above query could thus be written as::

138

139``where_`` and ``filter`` allow you to filter rows based on an expression, but

140sometimes we want to filter based on another query. For this, Rel8 offers

141−``present`` and ``absent``. For example, if all blog posts have a

141+``whereExists`` and ``whereNotExists``. For example, if all blog posts have a

142−list of tags, we could use ``present`` to find all blog posts that have been

142+list of tags, we could use ``whereExists`` to find all blog posts that have been

143tagged as "Haskell"::

144

145 blogPost <- each blogPostSchema

146− present do

146+ whereExists do

147 filter (("Haskell" ==.) . tagName) =<< tagFromBlogPost blogPost

148

149−Notice that this example uses ``present`` with a query that itself uses

149+Notice that this example uses ``whereExists`` with a query that itself uses

150−``filter``. For each blog post, ``present`` causes that row to be selected

150+``filter``. For each blog post, ``whereExists`` causes that row to be selected

151only 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``.

154+Like ``filter`` there is also a chaining variant of ``whereExists`` - ``with``.

155We could rewrite the above query using ``with`` as::

156

157 haskellBlogPost <-

@@ -194,11 +194,11 @@ and this query can be written in Rel8 as::

194

195 authorForBlogPost :: BlogPost Expr -> Query (Author Expr)

196 authorForBlogPost blogPost =

197− filter ((blogPostAuthorId blogPost ==.) . authorId) =<<

197+ filter ((blogPostAuthorId blogPost ==.) authorId author) =<<

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.

201+ dramatically increases the readabality of queries using joins.

202

203Left (outer) joins with ``optional``

204------------------------------------

docs/cookbook.rst+8−10

@@ -72,7 +72,7 @@ can be written as::

72 each myTableSchema

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.

77If all columns of a table have an ordering, you can also use ``ascTable`` and

78``descTable``. For example::

@@ -142,25 +142,23 @@ rows, but can also return *tree*\s.

142To understand what this means, we'll consider a small example query for blog

143posts. We want our query to return:

144

145−1. The latest 5 blog posts that have at least one tag each.

145+1. The latest 5 blog posts.

1462. For each blog post, all tags.

147−3. For each blog post, the latest 3 comments if they exist.

147+3. For each blog post, the latest 3 comments.

148

149In Rel8, we can write this query as::

150

151 latestBlogPosts = do

152 post <- each postSchema

153

154− -- Returns a `NonEmptyTable a` which ends up as a `Data.List.NonEmpty a` after the query is run

155− tags <- some $ do

154+ tags <- aggregate do

156 tag <- each tagSchema

155 tag <- each tagSchema

157 where_ (tagPostId tag ==. postId post)

156 where_ (tagPostId tag ==. postId post)

158− return (tagName tag)

157+ return (listAgg (tagName tag))

159

158

160− -- Returns a `ListTable a` which ends up as a `[a]` after the query is run

161− latestComments <-

159+ latestComments <-

162− many $

160+ many $

163− limit 3 $

161+ limit 3 $

164 orderBy (commentCreatedAt >$< desc) do

162 orderBy (commentCreatedAt >$< desc) do

165 comment <- each commentSchema

163 comment <- each commentSchema

166 where_ (commentPostId comment ==. postId post)

164 where_ (commentPostId comment ==. postId post)

docs/index.rst+1−2

@@ -30,7 +30,6 @@ The main objectives of Rel8 are:

30 concepts/expr

31 concepts/tables

32 concepts/queries

33− concepts/insert

35.. toctree::

34.. toctree::

36 :caption: Tips and tricks

35 :caption: Tips and tricks

@@ -50,4 +49,4 @@ More Resources

51* If you think you've found a bug, confusing behavior, or have a feature

50* If you think you've found a bug, confusing behavior, or have a feature

52 request, please raise an issue at `Rel8's issue tracker

51 request, please raise an issue at `Rel8's issue tracker

53− <https://github.com/circuithub/rel8>`_.

52+ <https://github.com/circuithub/rel8>`_.

docs/tutorial.rst+47−64

@@ -5,25 +5,24 @@ Getting Started

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

8−tables to Haskell, and then look at writing some simple queries.

8+tables to Haskell, and then look at writing some simple queries.

10Before we get started, we'll be using the following language extensions and

11imports throughout this guide::

13− {-# language BlockArguments #-}

13+ {-# language -XBlockArguments #-}

14− {-# language DeriveAnyClass #-}

14+ {-# language -XDeriveAnyClass #-}

15− {-# language DeriveGeneric #-}

15+ {-# language -XDeriveGeneric #-}

16− {-# language DerivingStrategies #-}

16+ {-# language -XDerivingStrategies #-}

17− {-# language DerivingVia #-}

17+ {-# language -XDerivingVia #-}

18− {-# language DuplicateRecordFields #-}

18+ {-# language -XDuplicateRecordFields #-}

19− {-# language GeneralizedNewtypeDeriving #-}

19+ {-# language -XGeneralizedNewtypeDeriving #-}

20− {-# language OverloadedStrings #-}

20+ {-# language -XOverloadedStrings #-}

21− {-# language StandaloneDeriving #-}

21+ {-# language -XStandaloneDeriving #-}

22− {-# language TypeApplications #-}

22+ {-# language -XTypeApplications #-}

23− {-# language TypeFamilies #-}

23+ {-# language -XTypeFamilies #-}

25 import Prelude

26− import Rel8

28The Example Schema

27The Example Schema

29------------------

28------------------

@@ -71,7 +70,7 @@ Following these steps for ``author``, we have::

71 { authorId :: Column f Int64

70 { authorId :: Column f Int64

72 , name :: Column f Text

71 , name :: Column f Text

73 , url :: Column f (Maybe Text)

72 , url :: Column f (Maybe Text)

74− }

73+ }

75 deriving stock (Generic)

74 deriving stock (Generic)

76 deriving anyclass (Rel8able)

75 deriving anyclass (Rel8able)

@@ -82,7 +81,7 @@ in our project, it would be too easy to accidentally mix them up and create

82nonsensical joins. As Haskell programmers, we often solve this problem by

81nonsensical joins. As Haskell programmers, we often solve this problem by

83creating ``newtype`` wrappers, and we can also use this technique with Rel8::

82creating ``newtype`` wrappers, and we can also use this technique with Rel8::

85− newtype AuthorId = AuthorId { toInt64 :: Int64 }

84+ newtype AuthorId = AuthorId { toInt64 :: Int64 }

86 deriving newtype (DBEq, DBType, Eq, Show)

85 deriving newtype (DBEq, DBType, Eq, Show)

88Now we can write our final schema mapping. First, the ``author`` table::

87Now we can write our final schema mapping. First, the ``author`` table::

@@ -91,7 +90,7 @@ Now we can write our final schema mapping. First, the ``author`` table::

91 { authorId :: Column f AuthorId

90 { authorId :: Column f AuthorId

92 , authorName :: Column f Text

91 , authorName :: Column f Text

93 , authorUrl :: Column f (Maybe Text)

92 , authorUrl :: Column f (Maybe Text)

94− }

93+ }

95 deriving stock (Generic)

94 deriving stock (Generic)

96 deriving anyclass (Rel8able)

95 deriving anyclass (Rel8able)

@@ -100,16 +99,16 @@ And similarly, the ``project`` table::

100 data Project f = Project

99 data Project f = Project

101 { projectAuthorId :: Column f AuthorId

100 { projectAuthorId :: Column f AuthorId

102 , projectName :: Column f Text

101 , projectName :: Column f Text

103− }

102+ }

104 deriving stock (Generic)

103 deriving stock (Generic)

105− deriving anyclass (Rel8able)

104+ deriving anyclass (Rel8able

106

105

107To show query results in this documentation, we'll also need ``Show`` instances:

106To show query results in this documentation, we'll also need ``Show`` instances:

108Unfortunately these definitions look a bit scary, but they are essentially just

107Unfortunately these definitions look a bit scary, but they are essentially just

109``deriving (Show)``::

108``deriving (Show)``::

110

109

111− deriving stock instance f ~ Result => Show (Author f)

110+ deriving stock instance f ~ Identity => Show (Author f)

112− deriving stock instance f ~ Result => Show (Project f)

111+ deriving stock instance f ~ Identity => Show (Project f)

113

112

114These data types describe the structural mapping of the tables, but we also

113These data types describe the structural mapping of the tables, but we also

115need to specify a ``TableSchema`` for each table. A ``TableSchema`` contains

114need to specify a ``TableSchema`` for each table. A ``TableSchema`` contains

@@ -126,9 +125,9 @@ associated with the ``Author`` type::

126

125

127 authorSchema :: TableSchema (Author Name)

126 authorSchema :: TableSchema (Author Name)

128 authorSchema = TableSchema

127 authorSchema = TableSchema

129− { name = "author"

128+ { tableName = "author"

130− , schema = Nothing

129+ , tableSchema = Nothing

131− , columns = Author

130+ , tableColumns = Author

132 { authorId = "author_id"

131 { authorId = "author_id"

133 , authorName = "name"

132 , authorName = "name"

134 , authorUrl = "url"

133 , authorUrl = "url"

@@ -139,27 +138,14 @@ And likewise for ``project`` and ``Project``::

139

138

140 projectSchema :: TableSchema (Project Name)

139 projectSchema :: TableSchema (Project Name)

141 projectSchema = TableSchema

140 projectSchema = TableSchema

142− { name = "project"

141+ { tableName = "project"

143− , schema = Nothing

142+ , tableSchema = Nothing

144− , columns = Project

143+ , tableColumns = Project

145 { projectAuthorId = "author_id"

144 { projectAuthorId = "author_id"

146 , projectName = "name"

145 , projectName = "name"

147 }

146 }

148 }

147 }

149

148

150−There is also some generics machinery available if you want to grab the field

151−information from your ``Rel8able`` type::

152−

153− projectSchema :: TableSchema (Project Name)

154− projectSchema = TableSchema

155− { name = "project"

156− , schema = Nothing

157− , columns = namesFromLabels @(Project Name)

158− }

159−

160−This will create a ``TableSchema`` for ``Project`` where every column name

161−corresponds exactly to the name of the field. If you need more flexibility, you

162−can use ``namesFromLabelsWith``, which takes a transformation function.

163

149

164.. note::

150.. note::

165

151

@@ -183,7 +169,7 @@ database heavy applications.

183

169

184In Rel8, ``SELECT`` statements are built using the ``Query`` monad. You can

170In Rel8, ``SELECT`` statements are built using the ``Query`` monad. You can

185think of this monad like the ordinary ``[]`` (List) monad - but this isn't

171think of this monad like the ordinary ``[]`` (List) monad - but this isn't

186−required knowledge.

172+required knowledge.

187

173

188To start, we'll look at one of the simplest queries possible - a basic ``SELECT

174To start, we'll look at one of the simplest queries possible - a basic ``SELECT

189* FROM`` statement. To select all rows from a table, we use ``each``, and

175* FROM`` statement. To select all rows from a table, we use ``each``, and

@@ -204,28 +190,25 @@ Recall we defined ``projectAuthorId`` as ``Column f AuthorId``. Now we have

204We'll see more about ``Expr`` soon, but you can think of ``Expr a`` as "SQL

190We'll see more about ``Expr`` soon, but you can think of ``Expr a`` as "SQL

205expressions of type ``a``\".

191expressions of type ``a``\".

206

192

207−To execute this ``Query``, we pass it to ``select``. This function takes both a

193+To execute this ``Query``, we pass it to ``select``::

208−database connection (which can be obtained using hasql's ``acquire`` function),

209−and the ``Query`` to run::

210

194

211− >>> Right conn <- acquire "user=postgres"

212− >>> :t select conn (each projectSchema)

195+ >>> :t select c (each projectSchema)

213− select conn (each projectSchema) :: MonadIO m => m [Project Result]

196+ select c (each projectSchema) :: MonadIO m => m [Project Identity]

214

197

215−When we ``select`` things containing ``Expr``\s, Rel8 builds a new response

198+When we ``select`` things containing ``Expr``s, Rel8 builds a new response

216−table with the ``Result`` interpretation. This means you'll get back plain

199+table with the ``Identity`` interpretation. This means you'll get back plain

217Haskell values. Studying ``projectAuthorId`` again, we have::

200Haskell values. Studying ``projectAuthorId`` again, we have::

218

201

219− >>> let aProjectResult = undefined :: Project Result

202+ >>> let aProjectIdentity = undefined :: Project Identity

220− >>> :t projectAuthorId aProjectResult

203+ >>> :t projectAuthorId aProjectIdentity

221− projectAuthorId aProjectResult :: AuthorId

204+ projectAuthorId aProjectIdentity :: AuthorId

222

205

223−Here ``Column Result AuthorId`` reduces to just ``AuthorId``, with no

206+Here ``Column Identity AuthorId`` reduces to just ``AuthorId``, with no

224wrappping type at all.

207wrappping type at all.

225

208

226Putting this all together, we can run our first query::

209Putting this all together, we can run our first query::

227

210

228− >>> select conn (each projectSchema) >>= mapM_ print

211+ >>> select c (each projectSchema) >>= mapM_ print

229 Project {projectAuthorId = 1, projectName = "rel8"}

212 Project {projectAuthorId = 1, projectName = "rel8"}

230 Project {projectAuthorId = 2, projectName = "aeson"}

213 Project {projectAuthorId = 2, projectName = "aeson"}

231 Project {projectAuthorId = 2, projectName = "text"}

214 Project {projectAuthorId = 2, projectName = "text"}

@@ -235,7 +218,7 @@ sometimes we're only interested in a subset of the columns of a table. To

235restrict the returned columns, we can specify a projection by using ``Query``\s

218restrict the returned columns, we can specify a projection by using ``Query``\s

236``Functor`` instance::

219``Functor`` instance::

237

220

238− >>> select conn $ projectName <$> each projectSchema

221+ >>> select c $ projectName <$> each projectSchema

239 ["rel8","aeson","text"]

222 ["rel8","aeson","text"]

240

223

241Joins

224Joins

@@ -251,7 +234,7 @@ We can do this by simply calling ``each`` twice, and then returning a tuple of

251their results::

234their results::

252

235

253 >>> :{

236 >>> :{

254− mapM_ print =<< select conn do

237+ mapM_ print =<< select c do

255 author <- each authorSchema

238 author <- each authorSchema

256 project <- each projectSchema

239 project <- each projectSchema

257 return (projectName project, authorName author)

240 return (projectName project, authorName author)

@@ -270,7 +253,7 @@ This isn't quite right, though, as we have ended up pairing up the wrong

270projects and authors. To fix this, we can use ``where_`` to restrict the

253projects and authors. To fix this, we can use ``where_`` to restrict the

271returned rows. We could write::

254returned rows. We could write::

272

255

273− select conn $ do

256+ select c $ do

274 author <- each authorSchema

257 author <- each authorSchema

275 project <- each projectSchema

258 project <- each projectSchema

276 where_ $ projectAuthorId project ==. authorId author

259 where_ $ projectAuthorId project ==. authorId author

@@ -287,7 +270,7 @@ for the particular joins in your database. In our case, this would be::

287Our final query is then::

270Our final query is then::

288

271

289 >>> :{

272 >>> :{

290− mapM_ print =<< select conn do

273+ mapM_ print =<< select c do

291 author <- each authorSchema

274 author <- each authorSchema

292 project <- projectsForAuthor author

275 project <- projectsForAuthor author

293 return (projectName project, authorName author)

276 return (projectName project, authorName author)

@@ -306,7 +289,7 @@ transformer to allow for the possibility of the join to fail.

306In our test database, we can see that there's another author who we haven't

289In our test database, we can see that there's another author who we haven't

307seen yet::

290seen yet::

308

291

309− >>> select conn $ authorName <$> each authorSchema

292+ >>> select c $ authorName <$> each authorSchema

310 ["Ollie","Bryan O'Sullivan","Emily Pillmore"]

293 ["Ollie","Bryan O'Sullivan","Emily Pillmore"]

311

294

312Emily wasn't returned in our earlier query because - in our database - she

295Emily wasn't returned in our earlier query because - in our database - she

@@ -314,7 +297,7 @@ doesn't have any registered projects. We can account for this partiality in our

314original query by wrapping the ``projectsForAuthor`` call with ``optional``::

297original query by wrapping the ``projectsForAuthor`` call with ``optional``::

315

298

316 >>> :{

299 >>> :{

317− mapM_ print =<< select conn do

300+ mapM_ print =<< select c do

318 author <- each authorSchema

301 author <- each authorSchema

319 mproject <- optional $ projectsForAuthor author

302 mproject <- optional $ projectsForAuthor author

320 return (authorName author, projectName <$> mproject)

303 return (authorName author, projectName <$> mproject)

@@ -359,9 +342,9 @@ focus on the /type/ of that query::

359 return (author, project)

342 return (author, project)

360 where

343 where

361

344

362− >>> :t select conn authorsAndProjects

345+ >>> :t select c authorsAndProjects

363− select conn authorsAndProjects

346+ select c authorsAndProjects

364− :: MonadIO m => m [(Author Result, Project Result)]

347+ :: MonadIO m => m [(Author Identity, Project Identity)]

365

348

366

349

367Our query gives us a single list of pairs of authors and projects. However,

350Our query gives us a single list of pairs of authors and projects. However,

@@ -369,7 +352,7 @@ with our domain knowledge of the schema, this isn't a great type - what we'd

369rather have is a list of pairs of authors and /lists/ of projects. That is,

352rather have is a list of pairs of authors and /lists/ of projects. That is,

370what we'd like is::

353what we'd like is::

371

354

372− [(Author Result, [Project Result])]

355+ [(Author Identity, [Project Identity])]

373

356

374This would be a much better type! Rel8 can produce a query with this type by

357This would be a much better type! Rel8 can produce a query with this type by

375simply wrapping the call to ``projectsForAuthor`` with either ``some`` or

358simply wrapping the call to ``projectsForAuthor`` with either ``some`` or

@@ -377,7 +360,7 @@ simply wrapping the call to ``projectsForAuthor`` with either ``some`` or

377author to have no projects::

360author to have no projects::

378

361

379 >>> :{

362 >>> :{

380− mapM_ print =<< select conn do

363+ mapM_ print =<< select c do

381 author <- each authorSchema

364 author <- each authorSchema

382 projectNames <- many $ projectName <$> projectsForAuthor author

365 projectNames <- many $ projectName <$> projectsForAuthor author

383 return (authorName author, projectNames)

366 return (authorName author, projectNames)

nix/sources.json+9−9

@@ -5,10 +5,10 @@

5 "homepage": "https://input-output-hk.github.io/haskell.nix",

6 "owner": "input-output-hk",

7 "repo": "haskell.nix",

8− "rev": "0837156c56cb5350dd9bd84eb424187e00aa1e8a",

8+ "rev": "5b5a18e442df6e27ad8549d69b8868b62adb08c3",

9− "sha256": "1djmv5a0vfj78csw2cad6nicrs8iqrp928b9b3v4h7lwwhhzliwl",

9+ "sha256": "055mk7kmjppng66ppnb8kr96v4wwc8pcxfsls5gl77129hsz9aph",

10 "type": "tarball",

11− "url": "https://github.com/input-output-hk/haskell.nix/archive/0837156c56cb5350dd9bd84eb424187e00aa1e8a.tar.gz",

11+ "url": "https://github.com/input-output-hk/haskell.nix/archive/5b5a18e442df6e27ad8549d69b8868b62adb08c3.tar.gz",

12 "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"

13 },

14 "niv": {

@@ -17,10 +17,10 @@

17 "homepage": "https://github.com/nmattia/niv",

18 "owner": "nmattia",

19 "repo": "niv",

20− "rev": "acdb1726783637852c01e0ad639ac9cbec28d8c8",

20+ "rev": "af958e8057f345ee1aca714c1247ef3ba1c15f5e",

21− "sha256": "1wszl8q70z6wfgkh2dvgmhhry6qp9nar421qq2ifd17hq2jj9ck3",

21+ "sha256": "1qjavxabbrsh73yck5dcq8jggvh3r2jkbr6b5nlz5d9yrqm9255n",

22 "type": "tarball",

23− "url": "https://github.com/nmattia/niv/archive/acdb1726783637852c01e0ad639ac9cbec28d8c8.tar.gz",

23+ "url": "https://github.com/nmattia/niv/archive/af958e8057f345ee1aca714c1247ef3ba1c15f5e.tar.gz",

24 "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"

25 },

26 "nixpkgs": {

@@ -29,10 +29,10 @@

29 "homepage": null,

30 "owner": "nixos",

31 "repo": "nixpkgs",

32− "rev": "1c1f5649bb9c1b0d98637c8c365228f57126f361",

32+ "rev": "a6847cb5460b47241eb35d1a6588652411642066",

33− "sha256": "0f2nvdijyxfgl5kwyb4465pppd5vkhqxddx6v40k2s0z9jfhj0xl",

33+ "sha256": "0wb5hwgffr4in66qng22sfvbascwnq078q81ziwwayvmnkn73rrm",

34 "type": "tarball",

35− "url": "https://github.com/nixos/nixpkgs/archive/1c1f5649bb9c1b0d98637c8c365228f57126f361.tar.gz",

35+ "url": "https://github.com/nixos/nixpkgs/archive/a6847cb5460b47241eb35d1a6588652411642066.tar.gz",

36 "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"

37 }

38}

nix/sources.nix+20−66

@@ -6,53 +6,25 @@ let

6 # The fetchers. fetch_<type> fetches specs of type <type>.

7 #

9− fetch_file = pkgs: name: spec:

9+ fetch_file = pkgs: spec:

10− let

11− name' = sanitizeName name + "-src";

12− in

13− if spec.builtin or true then

10+ if spec.builtin or true then

14− builtins_fetchurl { inherit (spec) url sha256; name = name'; }

11+ builtins_fetchurl { inherit (spec) url sha256; }

15− else

12+ else

16− pkgs.fetchurl { inherit (spec) url sha256; name = name'; };

13+ pkgs.fetchurl { inherit (spec) url sha256; };

18 fetch_tarball = pkgs: name: spec:

15 fetch_tarball = pkgs: name: spec:

19 let

16 let

20− name' = sanitizeName name + "-src";

17+ ok = str: ! builtins.isNull (builtins.match "[a-zA-Z0-9+-._?=]" str);

18+ # sanitize the name, though nix will still fail if name starts with period

19+ name' = stringAsChars (x: if ! ok x then "-" else x) "${name}-src";

21 in

20 in

22 if spec.builtin or true then

21 if spec.builtin or true then

23 builtins_fetchTarball { name = name'; inherit (spec) url sha256; }

22 builtins_fetchTarball { name = name'; inherit (spec) url sha256; }

24 else

23 else

25 pkgs.fetchzip { name = name'; inherit (spec) url sha256; };

24 pkgs.fetchzip { name = name'; inherit (spec) url sha256; };

27− fetch_git = name: spec:

26+ fetch_git = spec:

28− let

29− ref =

30− if spec ? ref then spec.ref else

31− if spec ? branch then "refs/heads/${spec.branch}" else

32− if spec ? tag then "refs/tags/${spec.tag}" else

33− abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!";

34− submodules = if spec ? submodules then spec.submodules else false;

35− submoduleArg =

36− let

37− nixSupportsSubmodules = builtins.compareVersions builtins.nixVersion "2.4" >= 0;

38− emptyArgWithWarning =

39− if submodules == true

40− then

41− builtins.trace

42− (

43− "The niv input \"${name}\" uses submodules "

44− + "but your nix's (${builtins.nixVersion}) builtins.fetchGit "

45− + "does not support them"

46− )

47− {}

48− else {};

49− in

50− if nixSupportsSubmodules

51− then { inherit submodules; }

52− else emptyArgWithWarning;

53− in

54− builtins.fetchGit

55− ({ url = spec.repo; inherit (spec) rev; inherit ref; } // submoduleArg);

27+ builtins.fetchGit { url = spec.repo; inherit (spec) rev ref; };

57 fetch_local = spec: spec.path;

29 fetch_local = spec: spec.path;

@@ -68,21 +40,11 @@ let

68 # Various helpers

40 # Various helpers

69 #

41 #

71− # https://github.com/NixOS/nixpkgs/pull/83241/files#diff-c6f540a4f3bfa4b0e8b6bafd4cd54e8bR695

72− sanitizeName = name:

73− (

74− concatMapStrings (s: if builtins.isList s then "-" else s)

75− (

76− builtins.split "[^[:alnum:]+._?=-]+"

77− ((x: builtins.elemAt (builtins.match "\\.*(.*)" x) 0) name)

78− )

79− );

80−

81 # The set of packages used when specs are fetched using non-builtins.

43 # The set of packages used when specs are fetched using non-builtins.

82− mkPkgs = sources: system:

44+ mkPkgs = sources:

83 let

45 let

84 sourcesNixpkgs =

46 sourcesNixpkgs =

85− import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; };

47+ import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) {};

86 hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath;

48 hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath;

87 hasThisAsNixpkgsPath = <nixpkgs> == ./.;

49 hasThisAsNixpkgsPath = <nixpkgs> == ./.;

88 in

50 in

@@ -102,9 +64,9 @@ let

102

103 if ! builtins.hasAttr "type" spec then

65 if ! builtins.hasAttr "type" spec then

104 abort "ERROR: niv spec ${name} does not have a 'type' attribute"

66 abort "ERROR: niv spec ${name} does not have a 'type' attribute"

105− else if spec.type == "file" then fetch_file pkgs name spec

67+ else if spec.type == "file" then fetch_file pkgs spec

106 else if spec.type == "tarball" then fetch_tarball pkgs name spec

68 else if spec.type == "tarball" then fetch_tarball pkgs name spec

107− else if spec.type == "git" then fetch_git name spec

69+ else if spec.type == "git" then fetch_git spec

108 else if spec.type == "local" then fetch_local spec

70 else if spec.type == "local" then fetch_local spec

109 else if spec.type == "builtin-tarball" then fetch_builtin-tarball name

71 else if spec.type == "builtin-tarball" then fetch_builtin-tarball name

110 else if spec.type == "builtin-url" then fetch_builtin-url name

72 else if spec.type == "builtin-url" then fetch_builtin-url name

@@ -118,10 +80,7 @@ let

118 saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name;

80 saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name;

119 ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}";

81 ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}";

120 in

82 in

121− if ersatz == "" then drv else

83+ if ersatz == "" then drv else ersatz;

122− # this turns the string into an actual Nix path (for both absolute and

123− # relative paths)

124− if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}";

125

126 # Ports of functions for older nix versions

85 # Ports of functions for older nix versions

127

@@ -139,29 +98,25 @@ let

139

140 # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269

99 # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269

141 stringAsChars = f: s: concatStrings (map f (stringToCharacters s));

100 stringAsChars = f: s: concatStrings (map f (stringToCharacters s));

142− concatMapStrings = f: list: concatStrings (map f list);

143 concatStrings = builtins.concatStringsSep "";

101 concatStrings = builtins.concatStringsSep "";

144

102

145− # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331

146− optionalAttrs = cond: as: if cond then as else {};

147−

148 # fetchTarball version that is compatible between all the versions of Nix

103 # fetchTarball version that is compatible between all the versions of Nix

149− builtins_fetchTarball = { url, name ? null, sha256 }@attrs:

104+ builtins_fetchTarball = { url, name, sha256 }@attrs:

150 let

105 let

151 inherit (builtins) lessThan nixVersion fetchTarball;

106 inherit (builtins) lessThan nixVersion fetchTarball;

152 in

107 in

153 if lessThan nixVersion "1.12" then

108 if lessThan nixVersion "1.12" then

154− fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; }))

109+ fetchTarball { inherit name url; }

155 else

110 else

156 fetchTarball attrs;

111 fetchTarball attrs;

157

112

158 # fetchurl version that is compatible between all the versions of Nix

113 # fetchurl version that is compatible between all the versions of Nix

159− builtins_fetchurl = { url, name ? null, sha256 }@attrs:

114+ builtins_fetchurl = { url, sha256 }@attrs:

160 let

115 let

161 inherit (builtins) lessThan nixVersion fetchurl;

116 inherit (builtins) lessThan nixVersion fetchurl;

162 in

117 in

163 if lessThan nixVersion "1.12" then

118 if lessThan nixVersion "1.12" then

164− fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; }))

119+ fetchurl { inherit url; }

165 else

120 else

166 fetchurl attrs;

121 fetchurl attrs;

167

122

@@ -180,8 +135,7 @@ let

180 mkConfig =

135 mkConfig =

181 { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null

136 { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null

182 , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile)

137 , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile)

183− , system ? builtins.currentSystem

184− , pkgs ? mkPkgs sources system

138+ , pkgs ? mkPkgs sources

185 }: rec {

139 }: rec {

186 # The sources, i.e. the attribute set of spec name to spec

140 # The sources, i.e. the attribute set of spec name to spec

187 inherit sources;

141 inherit sources;

rel8.cabal+28−50

@@ -1,36 +1,24 @@

1cabal-version: 2.0

2name: rel8

3−version: 1.4.0.0

3+version: 0.1.0.0

4synopsis: Hey! Hey! Can u rel8?

5license: BSD3

6license-file: LICENSE

7author: Oliver Charles

8maintainer: ollie@ocharles.org.uk

9−homepage: https://github.com/circuithub/rel8

10−bug-reports: https://github.com/circuithub/rel8/issues

11build-type: Simple

9build-type: Simple

12−extra-doc-files:

13− README.md

14− Changelog.md

15−

16−source-repository head

17− type: git

18− location: https://github.com/circuithub/rel8

20library

11library

21 build-depends:

12 build-depends:

22 aeson

13 aeson

23− , base ^>= 4.14 || ^>=4.15 || ^>=4.16

14+ , base ^>= 4.14 || ^>=4.15

24− , bifunctors

25 , bytestring

15 , bytestring

26 , case-insensitive

16 , case-insensitive

27− , comonad

17+ , casing

28 , contravariant

18 , contravariant

29− , hasql ^>= 1.4.5.1 || ^>= 1.5.0.0 || ^>= 1.6.0.0

19+ , hasql ^>= 1.4.5.1

30− , opaleye ^>= 0.9.6.1

20+ , opaleye ^>= 0.7.1.0

31− , pretty

32 , profunctors

21 , profunctors

33− , product-profunctors

34 , scientific

22 , scientific

35 , semialign

23 , semialign

36 , semigroupoids

24 , semigroupoids

@@ -41,12 +29,10 @@ library

41 default-language:

29 default-language:

42 Haskell2010

30 Haskell2010

43 ghc-options:

31 ghc-options:

44− -Werror=missing-methods -Werror=incomplete-patterns -Werror=missing-fields

45 -Weverything -Wno-unsafe -Wno-safe -Wno-missing-safe-haskell-mode

32 -Weverything -Wno-unsafe -Wno-safe -Wno-missing-safe-haskell-mode

46 -Wno-missing-import-lists -Wno-prepositive-qualified-module

33 -Wno-missing-import-lists -Wno-prepositive-qualified-module

47 -Wno-monomorphism-restriction

34 -Wno-monomorphism-restriction

48− -Wno-missing-local-signatures

35+ -Wno-missing-local-signatures

49− -Wno-missing-kind-signatures

50 hs-source-dirs:

36 hs-source-dirs:

51 src

37 src

52 exposed-modules:

38 exposed-modules:

@@ -56,45 +42,49 @@ library

56 Rel8.Expr.Time

42 Rel8.Expr.Time

57 Rel8.Tabulate

43 Rel8.Tabulate

45+ -- deprecated

46+ Rel8.Aggregate.Legacy

47+

59 other-modules:

48 other-modules:

60 Rel8.Aggregate

49 Rel8.Aggregate

62 Rel8.Column

51 Rel8.Column

63 Rel8.Column.ADT

52 Rel8.Column.ADT

64 Rel8.Column.Either

53 Rel8.Column.Either

54+ Rel8.Column.Field

65 Rel8.Column.Lift

55 Rel8.Column.Lift

66 Rel8.Column.List

56 Rel8.Column.List

67 Rel8.Column.Maybe

57 Rel8.Column.Maybe

68 Rel8.Column.NonEmpty

58 Rel8.Column.NonEmpty

69− Rel8.Column.Null

70 Rel8.Column.These

59 Rel8.Column.These

72 Rel8.Expr

61 Rel8.Expr

73 Rel8.Expr.Aggregate

62 Rel8.Expr.Aggregate

74 Rel8.Expr.Array

63 Rel8.Expr.Array

75 Rel8.Expr.Bool

64 Rel8.Expr.Bool

76− Rel8.Expr.Default

77 Rel8.Expr.Eq

65 Rel8.Expr.Eq

78 Rel8.Expr.Function

66 Rel8.Expr.Function

79 Rel8.Expr.Null

67 Rel8.Expr.Null

80 Rel8.Expr.Opaleye

68 Rel8.Expr.Opaleye

81 Rel8.Expr.Ord

69 Rel8.Expr.Ord

82 Rel8.Expr.Order

70 Rel8.Expr.Order

83− Rel8.Expr.Sequence

84 Rel8.Expr.Serialize

71 Rel8.Expr.Serialize

85− Rel8.Expr.Window

87 Rel8.FCF

73 Rel8.FCF

89 Rel8.Kind.Algebra

75 Rel8.Kind.Algebra

90 Rel8.Kind.Context

76 Rel8.Kind.Context

77+ Rel8.Kind.Labels

78+ Rel8.Kind.Necessity

92 Rel8.Generic.Construction

80 Rel8.Generic.Construction

93 Rel8.Generic.Construction.ADT

81 Rel8.Generic.Construction.ADT

94 Rel8.Generic.Construction.Record

82 Rel8.Generic.Construction.Record

95 Rel8.Generic.Map

83 Rel8.Generic.Map

96 Rel8.Generic.Record

84 Rel8.Generic.Record

85+ Rel8.Generic.Reify

97 Rel8.Generic.Rel8able

86 Rel8.Generic.Rel8able

87+ Rel8.Generic.Rel8able.Test

98 Rel8.Generic.Table

88 Rel8.Generic.Table

99 Rel8.Generic.Table.ADT

89 Rel8.Generic.Table.ADT

100 Rel8.Generic.Table.Record

90 Rel8.Generic.Table.Record

@@ -106,26 +96,23 @@ library

106 Rel8.Query.Distinct

96 Rel8.Query.Distinct

107 Rel8.Query.Each

97 Rel8.Query.Each

108 Rel8.Query.Either

98 Rel8.Query.Either

109− Rel8.Query.Evaluate

110 Rel8.Query.Exists

99 Rel8.Query.Exists

111 Rel8.Query.Filter

100 Rel8.Query.Filter

112− Rel8.Query.Indexed

113 Rel8.Query.Limit

101 Rel8.Query.Limit

114 Rel8.Query.List

102 Rel8.Query.List

115 Rel8.Query.Maybe

103 Rel8.Query.Maybe

116 Rel8.Query.Null

104 Rel8.Query.Null

117 Rel8.Query.Opaleye

105 Rel8.Query.Opaleye

118 Rel8.Query.Order

106 Rel8.Query.Order

119− Rel8.Query.Rebind

120 Rel8.Query.Set

107 Rel8.Query.Set

121 Rel8.Query.SQL

108 Rel8.Query.SQL

122 Rel8.Query.These

109 Rel8.Query.These

123 Rel8.Query.Values

110 Rel8.Query.Values

124− Rel8.Query.Window

125

111

112+ Rel8.Schema.Context

113+ Rel8.Schema.Context.Label

126 Rel8.Schema.Context.Nullify

114 Rel8.Schema.Context.Nullify

127 Rel8.Schema.Dict

115 Rel8.Schema.Dict

128− Rel8.Schema.Field

129 Rel8.Schema.HTable

116 Rel8.Schema.HTable

130 Rel8.Schema.HTable.Either

117 Rel8.Schema.HTable.Either

131 Rel8.Schema.HTable.Identity

118 Rel8.Schema.HTable.Identity

@@ -138,53 +125,51 @@ library

138 Rel8.Schema.HTable.Product

125 Rel8.Schema.HTable.Product

139 Rel8.Schema.HTable.These

126 Rel8.Schema.HTable.These

140 Rel8.Schema.HTable.Vectorize

127 Rel8.Schema.HTable.Vectorize

128+ Rel8.Schema.Insert

141 Rel8.Schema.Kind

129 Rel8.Schema.Kind

142 Rel8.Schema.Name

130 Rel8.Schema.Name

143 Rel8.Schema.Null

131 Rel8.Schema.Null

132+ Rel8.Schema.Reify

144 Rel8.Schema.Result

133 Rel8.Schema.Result

145 Rel8.Schema.Spec

134 Rel8.Schema.Spec

135+ Rel8.Schema.Spec.ConstrainDBType

136+ Rel8.Schema.Spec.ConstrainType

146 Rel8.Schema.Table

137 Rel8.Schema.Table

147

138

148 Rel8.Statement.Delete

139 Rel8.Statement.Delete

149 Rel8.Statement.Insert

140 Rel8.Statement.Insert

150− Rel8.Statement.OnConflict

151 Rel8.Statement.Returning

141 Rel8.Statement.Returning

152 Rel8.Statement.Select

142 Rel8.Statement.Select

153− Rel8.Statement.Set

154− Rel8.Statement.SQL

155 Rel8.Statement.Update

143 Rel8.Statement.Update

156− Rel8.Statement.Using

157 Rel8.Statement.View

144 Rel8.Statement.View

158− Rel8.Statement.Where

159

145

160 Rel8.Table

146 Rel8.Table

161 Rel8.Table.ADT

147 Rel8.Table.ADT

162 Rel8.Table.Aggregate

148 Rel8.Table.Aggregate

163 Rel8.Table.Alternative

149 Rel8.Table.Alternative

164 Rel8.Table.Bool

150 Rel8.Table.Bool

165− Rel8.Table.Cols

166 Rel8.Table.Either

151 Rel8.Table.Either

167 Rel8.Table.Eq

152 Rel8.Table.Eq

168 Rel8.Table.HKD

153 Rel8.Table.HKD

154+ Rel8.Table.Insert

169 Rel8.Table.List

155 Rel8.Table.List

170 Rel8.Table.Maybe

156 Rel8.Table.Maybe

171 Rel8.Table.Name

157 Rel8.Table.Name

172 Rel8.Table.NonEmpty

158 Rel8.Table.NonEmpty

173− Rel8.Table.Null

174− Rel8.Table.Nullify

175 Rel8.Table.Opaleye

159 Rel8.Table.Opaleye

176 Rel8.Table.Ord

160 Rel8.Table.Ord

177 Rel8.Table.Order

161 Rel8.Table.Order

178− Rel8.Table.Projection

162+ Rel8.Table.Recontextualize

179 Rel8.Table.Rel8able

163 Rel8.Table.Rel8able

180 Rel8.Table.Serialize

164 Rel8.Table.Serialize

165+ Rel8.Table.Tag

181 Rel8.Table.These

166 Rel8.Table.These

182− Rel8.Table.Transpose

183 Rel8.Table.Undefined

167 Rel8.Table.Undefined

184− Rel8.Table.Window

168+ Rel8.Table.Unreify

185

169

186 Rel8.Type

170 Rel8.Type

187 Rel8.Type.Array

171 Rel8.Type.Array

172+ Rel8.Type.Array1D

188 Rel8.Type.Composite

173 Rel8.Type.Composite

189 Rel8.Type.Eq

174 Rel8.Type.Eq

190 Rel8.Type.Enum

175 Rel8.Type.Enum

@@ -200,9 +185,6 @@ library

200 Rel8.Type.Sum

185 Rel8.Type.Sum

201 Rel8.Type.Tag

186 Rel8.Type.Tag

202

187

203− Rel8.Window

204−

205−

206test-suite tests

188test-suite tests

207 type: exitcode-stdio-1.0

189 type: exitcode-stdio-1.0

208 build-depends:

190 build-depends:

@@ -211,9 +193,9 @@ test-suite tests

211 , case-insensitive

193 , case-insensitive

212 , containers

194 , containers

213 , hasql

195 , hasql

214− , hasql-transaction

215− , hedgehog ^>= 1.0 || ^>= 1.1

196+ , hedgehog ^>=1.0.2

216− , mmorph

197+ , lifted-base ^>=0.2.3.12

198+ , monad-control ^>=1.0.2.3

217 , rel8

199 , rel8

218 , scientific

200 , scientific

219 , tasty

201 , tasty

@@ -221,12 +203,8 @@ test-suite tests

221 , text

203 , text

222 , time

204 , time

223 , tmp-postgres ^>=1.34.1.0

205 , tmp-postgres ^>=1.34.1.0

224− , transformers

225 , uuid

206 , uuid

226

207

227− other-modules:

228− Rel8.Generic.Rel8able.Test

229−

230 main-is: Main.hs

208 main-is: Main.hs

231 hs-source-dirs: tests

209 hs-source-dirs: tests

232 default-language: Haskell2010

210 default-language: Haskell2010

shell.nix+1−1

@@ -1,6 +1,6 @@

1let

2 sources = import ./nix/sources.nix;

3− pkgs = import sources.nixpkgs {overlays = [];};

3+ pkgs = import sources.nixpkgs {};

4 hsPkgs = import ./default.nix;

5in

6 hsPkgs.shellFor {

src/Rel8.hs+51−340

@@ -14,8 +14,8 @@ module Rel8

14 , ReadShow(..)

16 -- **** Generic

17− , Composite(..), DBComposite(..), compose, decompose

17+ , Composite(..)

18− , Enum(..), DBEnum(..), Enumable

18+ , Enum(..)

20 -- *** @TypeInformation@

21 , TypeInformation(..)

@@ -28,41 +28,37 @@ module Rel8

28 , DBNum

29 , DBIntegral

30 , DBFractional

31− , DBFloating

33 -- * Tables and higher-kinded tables

32 -- * Tables and higher-kinded tables

34 , Rel8able, KRel8able

33 , Rel8able, KRel8able

35− , Column

34+ , Column, Field, Necessity( Required, Optional )

35+ , Default

36 , HADT

37 , HEither

38 , HMaybe

39 , HList

40 , HNonEmpty

41− , HNull

42 , HThese

41 , HThese

43 , Lift

42 , Lift

45 , Table(..)

44 , Table(..)

46− , HTable

47− , Transposes

48 , AltTable((<|>:))

45 , AltTable((<|>:))

49− , AlternativeTable( emptyTable )

50− , EqTable(..), (==:), (/=:)

46+ , EqTable, (==:), (/=:)

51− , OrdTable(..), (<:), (<=:), (>:), (>=:), ascTable, descTable, greatest, least

47+ , OrdTable, ascTable, descTable

52 , lit

48 , lit

53 , bool

49 , bool

54 , case_

50 , case_

55− , castTable

57 -- ** @MaybeTable@

52 -- ** @MaybeTable@

58 , MaybeTable

53 , MaybeTable

59 , maybeTable, ($?), nothingTable, justTable

54 , maybeTable, ($?), nothingTable, justTable

60 , isNothingTable, isJustTable

55 , isNothingTable, isJustTable

61− , fromMaybeTable

62 , optional

56 , optional

63 , catMaybeTable

57 , catMaybeTable

58+ , bindMaybeTable

64 , traverseMaybeTable

59 , traverseMaybeTable

65 , aggregateMaybeTable

60 , aggregateMaybeTable

61+ , insertMaybeTable

66 , nameMaybeTable

62 , nameMaybeTable

68 -- ** @EitherTable@

64 -- ** @EitherTable@

@@ -71,8 +67,10 @@ module Rel8

71 , isLeftTable, isRightTable

67 , isLeftTable, isRightTable

72 , keepLeftTable

68 , keepLeftTable

73 , keepRightTable

69 , keepRightTable

70+ , bindEitherTable

74 , bitraverseEitherTable

71 , bitraverseEitherTable

75 , aggregateEitherTable

72 , aggregateEitherTable

73+ , insertEitherTable

76 , nameEitherTable

74 , nameEitherTable

78 -- ** @TheseTable@

76 -- ** @TheseTable@

@@ -81,71 +79,45 @@ module Rel8

81 , isThisTable, isThatTable, isThoseTable

79 , isThisTable, isThatTable, isThoseTable

82 , hasHereTable, hasThereTable

80 , hasHereTable, hasThereTable

83 , justHereTable, justThereTable

81 , justHereTable, justThereTable

84− , alignMaybeTable

85 , alignBy

82 , alignBy

86 , keepHereTable, loseHereTable

83 , keepHereTable, loseHereTable

87 , keepThereTable, loseThereTable

84 , keepThereTable, loseThereTable

88 , keepThisTable, loseThisTable

85 , keepThisTable, loseThisTable

89 , keepThatTable, loseThatTable

86 , keepThatTable, loseThatTable

90 , keepThoseTable, loseThoseTable

87 , keepThoseTable, loseThoseTable

88+ , bindTheseTable

91 , bitraverseTheseTable

89 , bitraverseTheseTable

92 , aggregateTheseTable

90 , aggregateTheseTable

91+ , insertTheseTable

93 , nameTheseTable

92 , nameTheseTable

95 -- ** @ListTable@

94 -- ** @ListTable@

96 , ListTable

95 , ListTable

97− , listTable, ($*)

96+ , listTable

97+ , insertListTable

98 , nameListTable

99 , many

100− , manyExpr

101− , catListTable

102− , catList

103

100

104 -- ** @NonEmptyTable@

101 -- ** @NonEmptyTable@

105 , NonEmptyTable

102 , NonEmptyTable

106− , nonEmptyTable, ($+)

103+ , nonEmptyTable

104+ , insertNonEmptyTable

107 , nameNonEmptyTable

105 , nameNonEmptyTable

108 , some

106 , 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

107

129− -- *** Deconstruction of ADTs

108+ -- ** @ADT@

130− -- $deconstruction

109+ , ADT, ADTable

131− , DeconstructADT, deconstructADT

132−

133− -- *** Construction of ADTs

134− -- $construction

135− , BuildADT, buildADT

136 , ConstructADT, constructADT

110 , ConstructADT, constructADT

137−

111+ , DeconstructADT, deconstructADT

138− -- *** Other ADT operations

112+ , InsertADT, insertADT

113+ , NameADT, nameADT

139 , AggregateADT, aggregateADT

114 , AggregateADT, aggregateADT

140

115

141− -- *** Miscellaneous notes

142− -- $misc-notes

143−

144 -- ** @HKD@

116 -- ** @HKD@

145 , HKD, HKDable

117 , HKD, HKDable

146− , BuildHKD, buildHKD

147 , ConstructHKD, constructHKD

118 , ConstructHKD, constructHKD

148 , DeconstructHKD, deconstructHKD

119 , DeconstructHKD, deconstructHKD

120+ , InsertHKD, insertHKD

149 , NameHKD, nameHKD

121 , NameHKD, nameHKD

150 , AggregateHKD, aggregateHKD

122 , AggregateHKD, aggregateHKD

151

123

@@ -160,12 +132,8 @@ module Rel8

160 , Sql

132 , Sql

161 , litExpr

133 , litExpr

162 , unsafeCastExpr

134 , unsafeCastExpr

163− , unsafeLiteral

164

135

165 -- ** @null@

136 -- ** @null@

166− , NotNull

167− , Nullable

168− , Homonullable

169 , null

137 , null

170 , nullify

138 , nullify

171 , nullable

139 , nullable

@@ -184,7 +152,6 @@ module Rel8

184 , (==.), (/=.), (==?), (/=?)

152 , (==.), (/=.), (==?), (/=?)

185 , in_

153 , in_

186 , boolExpr, caseExpr

154 , boolExpr, caseExpr

187− , like, ilike

188

155

189 -- ** Ordering

156 -- ** Ordering

190 , DBOrd

157 , DBOrd

@@ -202,13 +169,6 @@ module Rel8

202 , Query

169 , Query

203 , showQuery

170 , showQuery

204

171

205− -- ** Projection

206− , Projection

207− , Projectable( project )

208− , Biprojectable( biproject )

209− , Projecting

210− , Field

211−

212 -- ** Selecting rows

172 -- ** Selecting rows

213 , Selects

173 , Selects

214 , each

174 , each

@@ -217,8 +177,8 @@ module Rel8

217 -- ** Filtering

177 -- ** Filtering

218 , filter

178 , filter

219 , where_

179 , where_

220− , present

180+ , whereExists

221− , absent

181+ , whereNotExists

222 , distinct

182 , distinct

223 , distinctOn

183 , distinctOn

224 , distinctOnBy

184 , distinctOnBy

@@ -248,16 +208,15 @@ module Rel8

248

208

249 -- ** Aggregation

209 -- ** Aggregation

250 , Aggregate

210 , Aggregate

251− , Aggregates

252 , aggregate

211 , aggregate

253 , countRows

212 , countRows

213+ , array1DAggExpr

214+ , listAgg, listAggWithOrder, listAggExpr

215+ , nonEmptyAgg, nonEmptyAggWithOrder, nonEmptyAggExpr

254 , groupBy

216 , groupBy

255− , listAgg, listAggExpr

256− , mode

257− , nonEmptyAgg, nonEmptyAggExpr

258 , DBMax, max

217 , DBMax, max

259 , DBMin, min

218 , DBMin, min

260− , DBSum, sum, sumWhere, avg

219+ , DBSum, sum, sumWhere

261 , DBString, stringAgg

220 , DBString, stringAgg

262 , count

221 , count

263 , countStar

222 , countStar

@@ -274,71 +233,48 @@ module Rel8

274 , nullsFirst

233 , nullsFirst

275 , nullsLast

234 , nullsLast

276

235

277− -- ** Window functions

278− , Window

279− , window

280− , Partition

281− , over

282− , partitionBy

283− , orderPartitionBy

284− , cumulative

285− , cumulative_

286− , currentRow

287− , rowNumber

288− , rank

289− , denseRank

290− , percentRank

291− , cumeDist

292− , ntile

293− , lag

294− , lead

295− , firstValue

296− , lastValue

297− , nthValue

298− , indexed

299−

300− -- ** Bindings

301− , rebind

302−

303 -- * IO

236 -- * IO

304 , Serializable

237 , Serializable

305− , ToExprs

306− , Result

307

238

308 -- * Running statements

239 -- * Running statements

309− -- $running

310−

311 -- ** @SELECT@

240 -- ** @SELECT@

312 , select

241 , select

313

242

314 -- ** @INSERT@

243 -- ** @INSERT@

315 , Insert(..)

244 , Insert(..)

316 , OnConflict(..)

245 , OnConflict(..)

317− , Upsert(..)

318 , insert

246 , insert

319− , unsafeDefault

247+ , toInsert

320− , showInsert

248+ , toInsertDefaults

321

249

322 -- ** @DELETE@

250 -- ** @DELETE@

323 , Delete(..)

251 , Delete(..)

324 , delete

252 , delete

325− , showDelete

326

253

327 -- ** @UPDATE@

254 -- ** @UPDATE@

328− , Update(..)

329 , update

255 , update

330− , showUpdate

256+ , Update(..)

331

257

332 -- ** @.. RETURNING@

258 -- ** @.. RETURNING@

333 , Returning(..)

259 , Returning(..)

334

260

335 -- ** @CREATE VIEW@

261 -- ** @CREATE VIEW@

336 , createView

262 , createView

337− , createOrReplaceView

338

263

339− -- ** Sequences

264+ -- * TODO

340− , nextval

265+ -- TODO

341− , evaluate

266+ -- These need organizing, but are reachable from Rel8's documentation so we

267+ -- do need to export and document them.

268+ , Array1D( Array1D )

269+ , NotArray

270+ , Nullable

271+ , NotNull

272+ , HTable

273+ , Labelable

274+ , ToExprs(..)

275+ , FromExprs

276+ , Result

277+ , HKDT(..)

342 ) where

278 ) where

343

279

344-- base

280-- base

@@ -349,49 +285,42 @@ import Rel8.Aggregate

349import Rel8.Column

285import Rel8.Column

350import Rel8.Column.ADT

286import Rel8.Column.ADT

351import Rel8.Column.Either

287import Rel8.Column.Either

288+import Rel8.Column.Field

352import Rel8.Column.Lift

289import Rel8.Column.Lift

353import Rel8.Column.List

290import Rel8.Column.List

354import Rel8.Column.Maybe

291import Rel8.Column.Maybe

355import Rel8.Column.NonEmpty

292import Rel8.Column.NonEmpty

356−import Rel8.Column.Null

357import Rel8.Column.These

293import Rel8.Column.These

358import Rel8.Expr

294import Rel8.Expr

359import Rel8.Expr.Aggregate

295import Rel8.Expr.Aggregate

360import Rel8.Expr.Bool

296import Rel8.Expr.Bool

361−import Rel8.Expr.Default

362import Rel8.Expr.Eq

297import Rel8.Expr.Eq

363import Rel8.Expr.Function

298import Rel8.Expr.Function

364import Rel8.Expr.Null

299import Rel8.Expr.Null

365−import Rel8.Expr.Opaleye (unsafeCastExpr, unsafeLiteral)

300+import Rel8.Expr.Opaleye (unsafeCastExpr)

366import Rel8.Expr.Ord

301import Rel8.Expr.Ord

367import Rel8.Expr.Order

302import Rel8.Expr.Order

368import Rel8.Expr.Serialize

303import Rel8.Expr.Serialize

369−import Rel8.Expr.Sequence

370−import Rel8.Expr.Text ( like, ilike )

371−import Rel8.Expr.Window hiding ( cumulative )

372import Rel8.Generic.Rel8able ( KRel8able, Rel8able )

304import Rel8.Generic.Rel8able ( KRel8able, Rel8able )

305+import Rel8.Kind.Necessity

373import Rel8.Order

306import Rel8.Order

374import Rel8.Query

307import Rel8.Query

375import Rel8.Query.Aggregate

308import Rel8.Query.Aggregate

376import Rel8.Query.Distinct

309import Rel8.Query.Distinct

377import Rel8.Query.Each

310import Rel8.Query.Each

378import Rel8.Query.Either

311import Rel8.Query.Either

379−import Rel8.Query.Evaluate

380import Rel8.Query.Exists

312import Rel8.Query.Exists

381import Rel8.Query.Filter

313import Rel8.Query.Filter

382−import Rel8.Query.Indexed

383import Rel8.Query.Limit

314import Rel8.Query.Limit

384import Rel8.Query.List

315import Rel8.Query.List

385import Rel8.Query.Maybe

316import Rel8.Query.Maybe

386import Rel8.Query.Null

317import Rel8.Query.Null

387import Rel8.Query.Order

318import Rel8.Query.Order

388−import Rel8.Query.Rebind

389import Rel8.Query.SQL (showQuery)

319import Rel8.Query.SQL (showQuery)

390import Rel8.Query.Set

320import Rel8.Query.Set

391import Rel8.Query.These

321import Rel8.Query.These

392import Rel8.Query.Values

322import Rel8.Query.Values

393−import Rel8.Query.Window

323+import Rel8.Schema.Context.Label

394−import Rel8.Schema.Field

395import Rel8.Schema.HTable

324import Rel8.Schema.HTable

396import Rel8.Schema.Name

325import Rel8.Schema.Name

397import Rel8.Schema.Null hiding ( nullable )

326import Rel8.Schema.Null hiding ( nullable )

@@ -399,10 +328,8 @@ import Rel8.Schema.Result ( Result )

399import Rel8.Schema.Table

328import Rel8.Schema.Table

400import Rel8.Statement.Delete

329import Rel8.Statement.Delete

401import Rel8.Statement.Insert

330import Rel8.Statement.Insert

402−import Rel8.Statement.OnConflict

403import Rel8.Statement.Returning

331import Rel8.Statement.Returning

404import Rel8.Statement.Select

332import Rel8.Statement.Select

405−import Rel8.Statement.SQL

406import Rel8.Statement.Update

333import Rel8.Statement.Update

407import Rel8.Statement.View

334import Rel8.Statement.View

408import Rel8.Table

335import Rel8.Table

@@ -413,21 +340,18 @@ import Rel8.Table.Bool

413import Rel8.Table.Either

340import Rel8.Table.Either

414import Rel8.Table.Eq

341import Rel8.Table.Eq

415import Rel8.Table.HKD

342import Rel8.Table.HKD

343+import Rel8.Table.Insert

416import Rel8.Table.List

344import Rel8.Table.List

417import Rel8.Table.Maybe

345import Rel8.Table.Maybe

418import Rel8.Table.Name

346import Rel8.Table.Name

419import Rel8.Table.NonEmpty

347import Rel8.Table.NonEmpty

420−import Rel8.Table.Null

421−import Rel8.Table.Opaleye ( castTable )

422import Rel8.Table.Ord

348import Rel8.Table.Ord

423import Rel8.Table.Order

349import Rel8.Table.Order

424−import Rel8.Table.Projection

425import Rel8.Table.Rel8able ()

350import Rel8.Table.Rel8able ()

426import Rel8.Table.Serialize

351import Rel8.Table.Serialize

427import Rel8.Table.These

352import Rel8.Table.These

428−import Rel8.Table.Transpose

429−import Rel8.Table.Window

430import Rel8.Type

353import Rel8.Type

354+import Rel8.Type.Array1D

431import Rel8.Type.Composite

355import Rel8.Type.Composite

432import Rel8.Type.Eq

356import Rel8.Type.Eq

433import Rel8.Type.Enum

357import Rel8.Type.Enum

@@ -441,216 +365,3 @@ import Rel8.Type.ReadShow

441import Rel8.Type.Semigroup

365import Rel8.Type.Semigroup

442import Rel8.Type.String

366import Rel8.Type.String

443import Rel8.Type.Sum

367import Rel8.Type.Sum

444−import Rel8.Window

445−

446−

447−-- $running

448−-- To run queries and otherwise interact with a PostgreSQL database, Rel8

449−-- provides 'select', 'insert', 'update' and 'delete' functions. Note that

450−-- 'insert', 'update' and 'delete' will generally need the

451−-- `DuplicateRecordFields` language extension enabled.

452−

453−-- $adts

454−-- Algebraic data types can be modelled between Haskell and SQL.

455−--

456−-- * Your SQL table needs a certain text field that tags which Haskell constructor is in use.

457−-- * You have to use a few combinators to specify the sum type's individual constructors.

458−-- * If you want to do case analysis at the @Expr@ (SQL) level, you can use 'maybe'/'either'-like eliminators.

459−--

460−-- The documentation in this section will assume a set of database types like this:

461−--

462−-- @

463−-- data Thing f = ThingEmployer (Employer f) | ThingPotato (Potato f) | Nullary

464−-- deriving stock Generic

465−--

466−-- data Employer f = Employer { employerId :: f Int32, employerName :: f Text}

467−-- deriving stock Generic

468−-- deriving anyclass Rel8able

469−--

470−-- data Potato f = Potato { size :: f Int32, grower :: f Text }

471−-- deriving stock Generic

472−-- deriving anyclass Rel8able

473−-- @

474−

475−-- $naming

476−--

477−-- First, in your 'TableSchema', name your type like this:

478−--

479−-- @

480−-- thingSchema :: TableSchema (ADT Thing Name)

481−-- thingSchema =

482−-- TableSchema

483−-- { schema = Nothing,

484−-- name = \"thing\",

485−-- columns =

486−-- nameADT @Thing

487−-- \"tag\"

488−-- Employer

489−-- { employerName = \"name\",

490−-- employerId = \"id\"

491−-- }

492−-- Potato {size = \"size\", grower = \"Mary\"}

493−-- }

494−-- @

495−--

496−-- Note that @nameADT \@Thing "tag"@ is variadic: it accepts one

497−-- argument per constructor, except the nullary ones (Nullary) because

498−-- there's nothing to do for them.

499−

500−-- $deconstruction

501−--

502−-- To deconstruct sum types at the SQL level, use 'deconstructADT',

503−-- which is also variadic, and has one argument for each

504−-- constructor. Similar to 'maybe'.

505−--

506−-- @

507−-- query :: Query (ADT Thing Expr)

508−-- query = do

509−-- thingExpr <- each thingSchema

510−-- where_ $

511−-- deconstructADT @Thing

512−-- (\employer -> employerName employer ==. lit \"Mary\")

513−-- (\potato -> grower potato ==. lit \"Mary\")

514−-- (lit False) -- Nullary case

515−-- thingExpr

516−-- pure thingExpr

517−-- @

518−--

519−-- SQL output:

520−--

521−-- @

522−-- SELECT

523−-- CAST("tag0_1" AS text) as "tag",

524−-- CAST("id1_1" AS int4) as "ThingEmployer/_1/employerId",

525−-- CAST("name2_1" AS text) as "ThingEmployer/_1/employerName",

526−-- CAST("size3_1" AS int4) as "ThingPotato/_1/size",

527−-- CAST("Mary4_1" AS text) as "ThingPotato/_1/grower"

528−-- FROM (SELECT

529−-- *

530−-- FROM (SELECT

531−-- "tag" as "tag0_1",

532−-- "id" as "id1_1",

533−-- "name" as "name2_1",

534−-- "size" as "size3_1",

535−-- "Mary" as "Mary4_1"

536−-- FROM "thing" as "T1") as "T1"

537−-- WHERE (CASE WHEN ("tag0_1") = (CAST(E'ThingPotato' AS text)) THEN ("Mary4_1") = (CAST(E'Mary' AS text))

538−-- WHEN ("tag0_1") = (CAST(E'Nullary' AS text)) THEN CAST(FALSE AS bool) ELSE ("name2_1") = (CAST(E'Mary' AS text)) END)) as "T1"

539−-- @

540−

541−-- $construction

542−--

543−-- To construct an ADT, you can use 'buildADT' or 'constructADT'. Consider the following type:

544−--

545−-- @

546−-- data Task f = Pending | Complete (CompletedTask f)

547−-- @

548−--

549−-- 'buildADT' is for constructing values of 'Task' in the 'Expr'

550−-- context. 'buildADT' needs two type-level arguments before its type

551−-- makes any sense. The first argument is the type of the "ADT", which

552−-- in our case is 'Task'. The second is the name of the constructor we

553−-- want to use. So that means we have the following possible

554−-- instantiations of 'buildADT' for 'Task':

555−--

556−-- @

557−-- > :t buildADT @Task @\"Pending\"

558−-- buildADT @Task @\"Pending\" :: ADT Task Expr

559−-- > :t buildADT @Task @\"Complete\"

560−-- buildADT @Task @\"Complete\" :: CompletedTask Expr -> ADT Task Expr

561−-- @

562−--

563−-- Note that as the "Pending" constructor has no fields, @buildADT

564−-- \@Task \@"Pending"@ is equivalent to @lit Pending@. But @buildADT

565−-- \@Task \@"Complete"@ is not the same as @lit . Complete@:

566−--

567−-- @

568−-- > :t lit . Complete

569−-- lit . Complete :: CompletedTask Result -> ADT Task Expr

570−-- @

571−--

572−--

573−-- Note that the former takes a @CompletedTask Expr@ while the latter

574−-- takes a @CompletedTask Result@. The former is more powerful because

575−-- you can construct @Task@s using dynamic values coming a database

576−-- query.

577−--

578−-- To show what this can look like in SQL, consider:

579−--

580−-- @

581−-- > :{

582−-- showQuery $ values

583−-- [ buildADT @Task @\"Pending\"

584−-- , buildADT @Task @\"Complete\" CompletedTask {date = Rel8.Expr.Time.now}

585−-- ]

586−-- :}

587−-- @

588−--

589−-- This produces the following SQL:

590−--

591−-- @

592−-- SELECT

593−-- CAST(\"values0_1\" AS text) as \"tag\",

594−-- CAST(\"values1_1\" AS timestamptz) as \"Complete/_1/date\"

595−-- FROM (SELECT

596−-- *

597−-- FROM (SELECT \"column1\" as \"values0_1\",

598−-- \"column2\" as \"values1_1\"

599−-- FROM

600−-- (VALUES

601−-- (CAST(E'Pending' AS text),CAST(NULL AS timestamptz)),

602−-- (CAST(E'Complete' AS text),CAST(now() AS timestamptz))) as \"V\") as \"T1\") as \"T1\"

603−-- @

604−--

605−-- This is what you get if you run it in @psql@:

606−--

607−--

608−-- @

609−-- tag | Complete/_1/date

610−-- ----------+-------------------------------

611−-- Pending |

612−-- Complete | 2022-05-19 21:28:23.969065+00

613−-- (2 rows)

614−-- @

615−--

616−-- "constructADT" is less convenient but more general alternative to

617−-- "buildADT". It requires only one type-level argument for its type

618−-- to make sense:

619−--

620−-- @

621−-- > :t constructADT @Task

622−-- constructADT @Task

623−-- :: (forall r. r -> (CompletedTask Expr -> r) -> r) -> ADT Task Expr

624−-- @

625−--

626−-- This might still seem a bit opaque, but basically it gives you a

627−-- Church-encoded constructor for arbitrary algebraic data types. You

628−-- might use it as follows:

629−--

630−-- @

631−-- let

632−-- pending :: ADT Task Expr

633−-- pending = constructADT @Task $ \pending _complete -> pending

634−--

635−-- complete :: ADT Task Expr

636−-- complete = constructADT @Task $ \_pending complete -> complete CompletedTask {date = Rel8.Expr.Time.now}

637−-- @

638−--

639−-- These values are otherwise identical to the ones we saw above with

640−-- @buildADT@, it's just a different style of constructing them.

641−--

642−

643−-- $misc-notes

644−--

645−-- 1. Note that the order of the arguments for all of these functions

646−-- is determined by the order of the constructors in the data

647−-- definition. If it were @data Task = Complete (CompletedTask f) |

648−-- Pending@ then the order of all the invocations of @constructADT@

649−-- and @deconstructADT@ would need to change.

650−--

651−-- 2. Maybe this is obvious, but just to spell it out: once you're in

652−-- the @Result@ context, you can of course construct @Task@ values

653−-- normally and use standard Haskell pattern-matching. @constructADT@

654−-- and @deconstructADT@ are specifically only needed in the @Expr@

655−-- context, and they allow you to do the equivalent of pattern

656−-- matching in PostgreSQL.

src/Rel8/Aggregate.hs+128−42

@@ -1,83 +1,169 @@

1{-# language DataKinds #-}

2+{-# language DerivingVia #-}

2{-# language FlexibleContexts #-}

3{-# language FlexibleContexts #-}

3{-# language FlexibleInstances #-}

4{-# language FlexibleInstances #-}

5+{-# language GADTs #-}

4{-# language MultiParamTypeClasses #-}

6{-# language MultiParamTypeClasses #-}

5−{-# language RankNTypes #-}

7+{-# language NamedFieldPuns #-}

8+{-# language PolyKinds #-}

6{-# language StandaloneKindSignatures #-}

9{-# language StandaloneKindSignatures #-}

7{-# language TypeFamilies #-}

10{-# language TypeFamilies #-}

8{-# language UndecidableInstances #-}

11{-# language UndecidableInstances #-}

12+{-# language UndecidableSuperClasses #-}

10module Rel8.Aggregate

14module Rel8.Aggregate

11− ( Aggregate(..), zipOutputs

15+ ( Aggregate(..), foldInputs, mapInputs

12− , unsafeMakeAggregate

16+ , Aggregator(..), unsafeMakeAggregate

13 , Aggregates

17 , Aggregates

18+ , Col( Aggregation )

14 )

19 )

15where

20where

17-- base

22-- base

18−import Control.Applicative ( liftA2 )

23+import Data.Functor.Const ( Const( Const ), getConst )

19−import Data.Functor.Identity ( Identity( Identity ) )

24+import Data.Functor.Identity ( Identity )

20import Data.Kind ( Constraint, Type )

25import Data.Kind ( Constraint, Type )

21import Prelude

26import Prelude

23−-- profunctors

24−import Data.Profunctor ( dimap )

25−

26-- opaleye

28-- opaleye

27−import qualified Opaleye.Aggregate as Opaleye

29+import qualified Opaleye.Internal.Aggregate as Opaleye

28import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

30import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

29−import qualified Opaleye.Internal.Column as Opaleye

31+import qualified Opaleye.Internal.PackMap as Opaleye

31-- rel8

33-- rel8

32−import Rel8.Expr ( Expr )

34+import Rel8.Expr ( Expr, Col(..) )

35+import Rel8.Schema.Context ( Interpretation(..) )

36+import Rel8.Schema.Context.Label ( Labelable(..) )

33−import Rel8.Schema.HTable.Identity ( HIdentity(..) )

37+import Rel8.Schema.HTable ( hfield, htabulate, htabulateA, hspecs )

34−import qualified Rel8.Schema.Kind as K

38+import Rel8.Schema.Name ( Name )

35import Rel8.Schema.Null ( Sql )

39import Rel8.Schema.Null ( Sql )

40+import Rel8.Schema.Reify ( notReify )

41+import Rel8.Schema.Result ( Result )

42+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

36import Rel8.Table

43import Rel8.Table

37 ( Table, Columns, Context, fromColumns, toColumns

44 ( Table, Columns, Context, fromColumns, toColumns

38− , FromExprs, fromResult, toResult

45+ , reify, unreify

39− , Transpose

40 )

46 )

41−import Rel8.Table.Transpose ( Transposes )

47+import Rel8.Table.Recontextualize ( Recontextualize )

42import Rel8.Type ( DBType )

48import Rel8.Type ( DBType )

50+-- semigroupoids

51+import Data.Functor.Apply ( Apply, (<.>) )

52+

53+

54+-- | An @Aggregate a@ describes how to aggregate @Table@s of type @a@. You can

55+-- unpack an @Aggregate@ back to @a@ by running it with 'Rel8.aggregate'. As

56+-- @Aggregate@ is almost an 'Applicative' functor - but there is no 'pure'

57+-- operation. This means 'Aggregate' is an instance of 'Apply', and you can

58+-- combine @Aggregate@s using the @<.>@ combinator.

59+type Aggregate :: k -> Type

60+data Aggregate a where

61+ Aggregate :: !(Opaleye.Aggregator () a) -> Aggregate a

62+

63+

64+instance Functor Aggregate where

65+ fmap f (Aggregate a) = Aggregate (fmap f a)

66+

67+

68+instance Apply Aggregate where

69+ Aggregate f <.> Aggregate a = Aggregate (f <*> a)

70+

45−-- | 'Aggregate' is a special context used by 'Rel8.aggregate'.

72+instance Interpretation Aggregate where

46−type Aggregate :: K.Context

73+ data Col Aggregate _spec where

74+ Aggregation :: ()

47−newtype Aggregate a = Aggregate (Opaleye.Aggregator () (Expr a))

75+ => Aggregate (Expr a)

76+ -> Col Aggregate ('Spec labels necessity a)

50−instance Sql DBType a => Table Aggregate (Aggregate a) where

79+instance Table Expr a => Table Aggregate (Aggregate a) where

51− type Columns (Aggregate a) = HIdentity a

80+ type Columns (Aggregate a) = Columns a

52 type Context (Aggregate a) = Aggregate

81 type Context (Aggregate a) = Aggregate

53− type FromExprs (Aggregate a) = a

54− type Transpose to (Aggregate a) = to a

56− toColumns = HIdentity

83+ toColumns a = htabulate $ \field -> case hfield hspecs field of

57− fromColumns (HIdentity a) = a

84+ SSpec {} -> Aggregation $ unDB . (`hfield` field) . toColumns <$> a

58− toResult = HIdentity . Identity

85+ fromColumns as = fmap fromColumns $ htabulateA $ \field ->

59− fromResult (HIdentity (Identity a)) = a

86+ case hfield as field of

87+ Aggregation a -> DB <$> a

88+

89+ reify = notReify

90+ unreify = notReify

91+

92+

93+instance Sql DBType a =>

94+ Recontextualize Aggregate Aggregate (Aggregate (Expr a)) (Aggregate (Expr a))

95+

96+

97+instance Sql DBType a =>

98+ Recontextualize Aggregate Expr (Aggregate (Expr a)) (Expr a)

99+

100+

101+instance Sql DBType a =>

102+ Recontextualize Aggregate Result (Aggregate (Expr a)) (Identity a)

103

104

105+instance Sql DBType a =>

106+ Recontextualize Aggregate Name (Aggregate (Expr a)) (Name a)

107+

108+

109+instance Sql DBType a =>

110+ Recontextualize Expr Aggregate (Expr a) (Aggregate (Expr a))

111+

112+

113+instance Sql DBType a =>

114+ Recontextualize Result Aggregate (Identity a) (Aggregate (Expr a))

115+

116+

117+instance Sql DBType a =>

118+ Recontextualize Name Aggregate (Name a) (Aggregate (Expr a))

119+

120+

121+instance Labelable Aggregate where

122+ labeler (Aggregation aggregate) = Aggregation aggregate

123+ unlabeler (Aggregation aggregate) = Aggregation aggregate

124+

125+

62−-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate's

126+-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate' 'Expr's

63−-- for the 'Expr' columns in @b@.

127+-- for the columns in @b@.

64type Aggregates :: Type -> Type -> Constraint

128type Aggregates :: Type -> Type -> Constraint

65−class Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs

129+class Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs

66−instance Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs

130+instance Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs

131+

132+

133+foldInputs :: Monoid b

134+ => (Maybe Aggregator -> Opaleye.PrimExpr -> b) -> Aggregate a -> b

135+foldInputs f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =

136+ getConst $ flip agg () $ \(aggregator, a) ->

137+ Const $ f (detuplize <$> aggregator) a

138+ where

139+ detuplize (operation, ordering, distinction) =

140+ Aggregator {operation, ordering, distinction}

141+

142+

143+mapInputs :: ()

144+ => (Opaleye.PrimExpr -> Opaleye.PrimExpr) -> Aggregate a -> Aggregate a

145+mapInputs transform (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =

146+ Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ agg . \f input ->

147+ f (fmap transform input)

148

149

69−zipOutputs :: ()

150+type Aggregator :: Type

70− => (Expr a -> Expr b -> Expr c) -> Aggregate a -> Aggregate b -> Aggregate c

151+data Aggregator = Aggregator

71−zipOutputs f (Aggregate a) (Aggregate b) = Aggregate (liftA2 f a b)

152+ { operation :: Opaleye.AggrOp

153+ , ordering :: [Opaleye.OrderExpr]

154+ , distinction :: Opaleye.AggrDistinct

155+ }

156

157

74−unsafeMakeAggregate :: forall (input :: Type) (output :: Type) n n' a a'. ()

158+unsafeMakeAggregate :: ()

75− => (Expr input -> Opaleye.PrimExpr)

159+ => (input -> Opaleye.PrimExpr)

76− -> (Opaleye.PrimExpr -> Expr output)

160+ -> (Opaleye.PrimExpr -> output)

77− -> Opaleye.Aggregator (Opaleye.Field_ n a) (Opaleye.Field_ n' a')

161+ -> Maybe Aggregator

78− -> Expr input

162+ -> input

79 -> Aggregate output

163 -> Aggregate output

80unsafeMakeAggregate input output aggregator expr =

164unsafeMakeAggregate input output aggregator expr =

81− Aggregate $ dimap in_ out aggregator

165+ Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ \f _ ->

82− where out = output . Opaleye.unColumn

166+ output <$> f (tuplize <$> aggregator, input expr)

83− in_ = Opaleye.Column . input . const expr

167+ where

168+ tuplize Aggregator {operation, ordering, distinction} =

169+ (operation, ordering, distinction)

src/Rel8/Aggregate/Legacy.hsnew file+129

@@ -0,0 +1,129 @@

1+{-# language AllowAmbiguousTypes #-}

2+{-# language DataKinds #-}

3+{-# language FlexibleContexts #-}

4+{-# language RankNTypes #-}

5+{-# language ScopedTypeVariables #-}

6+{-# language StandaloneKindSignatures #-}

7+{-# language TypeApplications #-}

8+{-# language TypeFamilies #-}

9+{-# language ViewPatterns #-}

10+

11+module Rel8.Aggregate.Legacy

12+ ( Aggregates

13+ , aggregate

14+ , aggregateTabulation

15+ , groupBy

16+ , listAgg

17+ , nonEmptyAgg

18+

19+ , AggregateADT, aggregateADT

20+ , AggregateHKD, aggregateHKD

21+ )

22+where

23+

24+-- base

25+import Data.Functor.Identity ( Identity( Identity ) )

26+import Data.Kind ( Type )

27+import GHC.Generics ( Rep )

28+import Prelude

29+

30+-- opaleye

31+import qualified Opaleye.Aggregate as Opaleye

32+

33+-- rel8

34+import Rel8.Aggregate ( Aggregate, Aggregates, Col(..) )

35+import Rel8.Expr ( Col(..), Expr )

36+import Rel8.Expr.Aggregate ( groupByExpr, listAggExpr, nonEmptyAggExpr )

37+import Rel8.Generic.Construction ( GGAggregate', ggaggregate' )

38+import Rel8.Generic.Table ( GAlgebra )

39+import Rel8.Kind.Algebra ( Algebra( Sum ) )

40+import Rel8.Query ( Query )

41+import Rel8.Query.Opaleye ( mapOpaleye )

42+import Rel8.Schema.Dict ( Dict( Dict ) )

43+import Rel8.Schema.HTable ( htabulate, hfield )

44+import Rel8.Schema.HTable.Vectorize ( hvectorize )

45+import Rel8.Schema.Kind ( Rel8able )

46+import Rel8.Table ( toColumns, fromColumns )

47+import Rel8.Table.ADT ( ConstructableADT, ADT( ADT ), ADTRep )

48+import Rel8.Table.Eq ( EqTable, eqTable )

49+import Rel8.Table.HKD ( ConstructableHKD, HKD( HKD ), HKDRep )

50+import Rel8.Table.List ( ListTable )

51+import Rel8.Table.NonEmpty ( NonEmptyTable )

52+import Rel8.Table.Opaleye ( aggregator )

53+import Rel8.Tabulate ( Tabulation )

54+import qualified Rel8.Tabulate

55+

56+

57+-- | Apply an aggregation to all rows returned by a 'Query'.

58+aggregate :: Aggregates aggregates exprs => Query aggregates -> Query exprs

59+aggregate = mapOpaleye (Opaleye.aggregate aggregator) . fmap (fromColumns . toColumns)

60+

61+

62+aggregateTabulation

63+ :: (EqTable k, Aggregates aggregates exprs)

64+ => (t -> aggregates) -> Tabulation k t -> Tabulation k exprs

65+aggregateTabulation f =

66+ Rel8.Tabulate.aggregateTabulation . fmap (fromColumns . toColumns . f)

67+

68+

69+-- | Group equal tables together. This works by aggregating each column in the

70+-- given table with 'groupByExpr'.

71+groupBy :: forall exprs aggregates. (EqTable exprs, Aggregates aggregates exprs)

72+ => exprs -> aggregates

73+groupBy (toColumns -> exprs) = fromColumns $ htabulate $ \field ->

74+ case hfield (eqTable @exprs) field of

75+ Dict -> case hfield exprs field of

76+ DB expr -> Aggregation $ groupByExpr expr

77+

78+

79+-- | Aggregate rows into a single row containing an array of all aggregated

80+-- rows. This can be used to associate multiple rows with a single row, without

81+-- changing the over cardinality of the query. This allows you to essentially

82+-- return a tree-like structure from queries.

83+--

84+-- For example, if we have a table of orders and each orders contains multiple

85+-- items, we could aggregate the table of orders, pairing each order with its

86+-- items:

87+--

88+-- @

89+-- ordersWithItems :: Query (Order Expr, ListTable (Item Expr))

90+-- ordersWithItems = do

91+-- order <- each orderSchema

92+-- items <- aggregate $ listAgg <$> itemsFromOrder order

93+-- return (order, items)

94+-- @

95+listAgg :: Aggregates aggregates exprs => exprs -> ListTable aggregates

96+listAgg (toColumns -> exprs) = fromColumns $

97+ hvectorize

98+ (\_ (Identity (DB a)) -> Aggregation $ listAggExpr a)

99+ (pure exprs)

100+

101+

102+-- | Like 'listAgg', but the result is guaranteed to be a non-empty list.

103+nonEmptyAgg :: Aggregates aggregates exprs => exprs -> NonEmptyTable aggregates

104+nonEmptyAgg (toColumns -> exprs) = fromColumns $

105+ hvectorize

106+ (\_ (Identity (DB a)) -> Aggregation $ nonEmptyAggExpr a)

107+ (pure exprs)

108+

109+

110+type AggregateADT :: Rel8able -> Type

111+type AggregateADT t = forall r. GGAggregate' 'Sum (ADTRep t) r

112+

113+

114+aggregateADT :: forall t. ConstructableADT t

115+ => AggregateADT t -> ADT t Expr -> ADT t Aggregate

116+aggregateADT f =

117+ ggaggregate' @'Sum @(ADTRep t) @(ADT t Expr) @(ADT t Aggregate) ADT (\(ADT a) -> a)

118+ (f @(ADT t Aggregate))

119+

120+

121+type AggregateHKD :: Type -> Type

122+type AggregateHKD a = forall r. GGAggregate' (GAlgebra (Rep a)) (HKDRep a) r

123+

124+

125+aggregateHKD :: forall a. ConstructableHKD a

126+ => AggregateHKD a -> HKD a Expr -> HKD a Aggregate

127+aggregateHKD f =

128+ ggaggregate' @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) @(HKD a Aggregate) HKD (\(HKD a) -> a)

129+ (f @(HKD a Aggregate))

src/Rel8/Column.hs+13−9

@@ -1,9 +1,9 @@

1{-# language DataKinds #-}

2−{-# language StandaloneKindSignatures #-}

3{-# language TypeFamilies #-}

2{-# language TypeFamilies #-}

3+{-# language StandaloneKindSignatures #-}

5module Rel8.Column

6− ( Column

6+ ( Column, Default

7 , TColumn

8 )

9where

@@ -13,18 +13,22 @@ import Data.Kind ( Type )

13import Prelude ()

15-- rel8

16+import Rel8.Column.Field ( Field )

16import Rel8.FCF ( Eval, Exp )

17import Rel8.FCF ( Eval, Exp )

18+import Rel8.Kind.Necessity ( Necessity( Required, Optional ) )

17import qualified Rel8.Schema.Kind as K

19import qualified Rel8.Schema.Kind as K

18−import Rel8.Schema.Result ( Result )

21−-- | This type family is used to specify columns in 'Rel8able's. In @Column f

22+-- | The @Column@ type family should be used to indicate which fields of your

22−-- a@, @f@ is the context of the column (which should be left polymorphic in

23+-- data types are single columns in queries. This type family has special

23−-- 'Rel8able' definitions), and @a@ is the type of the column.

24+-- support when a query is executed, allowing you to use a single data type for

25+-- both query data and rows decoded to Haskell.

24type Column :: K.Context -> Type -> Type

26type Column :: K.Context -> Type -> Type

25−type family Column context a where

27+type Column context a = Field context 'Required a

26− Column Result a = a

28+

29+

30+type Default :: K.Context -> Type -> Type

27− Column context a = context a

31+type Default context a = Field context 'Optional a

30data TColumn :: K.Context -> Type -> Exp Type

34data TColumn :: K.Context -> Type -> Exp Type

src/Rel8/Column/ADT.hs+70−3

@@ -1,23 +1,90 @@

1{-# language DataKinds #-}

2+{-# language LambdaCase #-}

3+{-# language MultiParamTypeClasses #-}

2{-# language StandaloneKindSignatures #-}

4{-# language StandaloneKindSignatures #-}

3{-# language TypeFamilies #-}

5{-# language TypeFamilies #-}

6+{-# language UndecidableInstances #-}

5module Rel8.Column.ADT

8module Rel8.Column.ADT

6− ( HADT

9+ ( HADT, AHADT(..)

7 )

10 )

8where

11where

10-- base

13-- base

11import Data.Kind ( Type )

14import Data.Kind ( Type )

12−import Prelude ()

15+import Prelude

14-- rel8

17-- rel8

18+import Rel8.Generic.Rel8able ( GColumns )

19+import Rel8.Kind.Context ( SContext(..), Reifiable, contextSing )

20+import Rel8.Schema.Context ( Col )

15import qualified Rel8.Schema.Kind as K

21import qualified Rel8.Schema.Kind as K

22+import Rel8.Schema.Reify ( Reify, hreify, hunreify )

16import Rel8.Schema.Result ( Result )

23import Rel8.Schema.Result ( Result )

17−import Rel8.Table.ADT ( ADT )

24+import Rel8.Table

25+ ( Table, Columns, Context, fromColumns, toColumns

26+ , Unreify, reify, unreify

27+ )

28+import Rel8.Table.ADT ( ADT( ADT ), ADTable, fromADT, toADT )

29+import Rel8.Table.Recontextualize ( Recontextualize )

20type HADT :: K.Context -> K.Rel8able -> Type

32type HADT :: K.Context -> K.Rel8able -> Type

21type family HADT context t where

33type family HADT context t where

34+ HADT (Reify context) t = AHADT context t

22 HADT Result t = t Result

35 HADT Result t = t Result

23 HADT context t = ADT t context

36 HADT context t = ADT t context

37+

38+

39+type AHADT :: K.Context -> K.Rel8able -> Type

40+newtype AHADT context t = AHADT (HADT context t)

41+

42+

43+instance (ADTable t, Reifiable context) =>

44+ Table (Reify context) (AHADT context t)

45+ where

46+ type Context (AHADT context t) = Reify context

47+ type Columns (AHADT context t) = GColumns (ADT t)

48+ type Unreify (AHADT context t) = HADT context t

49+

50+ fromColumns = sfromColumnsADT contextSing

51+ toColumns = stoColumnsADT contextSing

52+ reify _ = AHADT

53+ unreify _ (AHADT a) = a

54+

55+

56+instance

57+ ( Reifiable context, Reifiable context'

58+ , ADTable t, t ~ t'

59+ )

60+ => Recontextualize

61+ (Reify context)

62+ (Reify context')

63+ (AHADT context t)

64+ (AHADT context' t')

65+

66+

67+sfromColumnsADT :: ADTable t

68+ => SContext context

69+ -> GColumns (ADT t) (Col (Reify context))

70+ -> AHADT context t

71+sfromColumnsADT = \case

72+ SAggregate -> AHADT . ADT . hunreify

73+ SExpr -> AHADT . ADT . hunreify

74+ SInsert -> AHADT . ADT . hunreify

75+ SName -> AHADT . ADT . hunreify

76+ SResult -> AHADT . fromADT . ADT . hunreify

77+ SReify context -> AHADT . sfromColumnsADT context . hunreify

78+

79+

80+stoColumnsADT :: ADTable t

81+ => SContext context

82+ -> AHADT context t

83+ -> GColumns (ADT t) (Col (Reify context))

84+stoColumnsADT = \case

85+ SAggregate -> hreify . (\(AHADT (ADT a)) -> a)

86+ SExpr -> hreify . (\(AHADT (ADT a)) -> a)

87+ SInsert -> hreify . (\(AHADT (ADT a)) -> a)

88+ SName -> hreify . (\(AHADT (ADT a)) -> a)

89+ SResult -> hreify . (\(ADT a) -> a) . toADT . (\(AHADT a) -> a)

90+ SReify context -> hreify . stoColumnsADT context . (\(AHADT a) -> a)

src/Rel8/Column/Either.hs+153−7

@@ -1,26 +1,172 @@

1{-# language DataKinds #-}

2+{-# language FlexibleContexts #-}

3+{-# language LambdaCase #-}

4+{-# language MultiParamTypeClasses #-}

2{-# language StandaloneKindSignatures #-}

5{-# language StandaloneKindSignatures #-}

3−{-# language TypeFamilyDependencies #-}

6+{-# language TypeFamilies #-}

7+{-# language UndecidableInstances #-}

5module Rel8.Column.Either

9module Rel8.Column.Either

6− ( HEither

10+ ( HEither, AHEither(..)

7 )

11 )

8where

12where

10-- base

14-- base

15+import Control.Applicative ( liftA2 )

16+import Data.Bifunctor ( Bifunctor, bimap )

11import Data.Kind ( Type )

17import Data.Kind ( Type )

12import Prelude

18import Prelude

14-- rel8

20-- rel8

21+import Rel8.Aggregate ( Aggregate )

22+import Rel8.Expr ( Expr )

23+import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )

24+import Rel8.Schema.Context ( Col )

25+import Rel8.Schema.HTable.Either ( HEitherTable )

26+import Rel8.Schema.Insert ( Insert )

15import qualified Rel8.Schema.Kind as K

27import qualified Rel8.Schema.Kind as K

28+import Rel8.Schema.Name ( Name(..) )

29+import Rel8.Schema.Reify ( Reify, hreify, hunreify )

16import Rel8.Schema.Result ( Result )

30import Rel8.Schema.Result ( Result )

31+import Rel8.Table

32+ ( Table, Columns, Context, fromColumns, toColumns

33+ , Unreify, reify, unreify

34+ )

17import Rel8.Table.Either ( EitherTable )

35import Rel8.Table.Either ( EitherTable )

36+import Rel8.Table.Recontextualize ( Recontextualize )

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.

23type HEither :: K.Context -> Type -> Type -> Type

39type HEither :: K.Context -> Type -> Type -> Type

24−type family HEither context = either | either -> context where

40+type family HEither context where

41+ HEither (Reify context) = AHEither context

42+ HEither Aggregate = EitherTable

43+ HEither Expr = EitherTable

44+ HEither Insert = EitherTable

45+ HEither Name = EitherTable

25 HEither Result = Either

46 HEither Result = Either

26− HEither context = EitherTable context

47+

48+

49+type AHEither :: K.Context -> Type -> Type -> Type

50+newtype AHEither context a b = AHEither (HEither context a b)

51+

52+

53+instance Reifiable context => Bifunctor (AHEither context) where

54+ bimap = sbimapEither contextSing

55+

56+

57+instance Reifiable context => Functor (AHEither context a) where

58+ fmap = bimap id

59+

60+

61+instance (Reifiable context, Table (Reify context) a, Table (Reify context) b)

62+ => Table (Reify context) (AHEither context a b)

63+ where

64+ type Context (AHEither context a b) = Reify context

65+ type Columns (AHEither context a b) = HEitherTable (Columns a) (Columns b)

66+ type Unreify (AHEither context a b) = HEither context (Unreify a) (Unreify b)

67+

68+ fromColumns = sfromColumnsEither contextSing

69+ toColumns = stoColumnsEither contextSing

70+ reify proof = liftA2 bimap reify reify proof . AHEither

71+ unreify proof = (\(AHEither a) -> a) . liftA2 bimap unreify unreify proof

72+

73+

74+instance

75+ ( Reifiable context, Reifiable context'

76+ , Recontextualize (Reify context) (Reify context') a a'

77+ , Recontextualize (Reify context) (Reify context') b b'

78+ ) =>

79+ Recontextualize

80+ (Reify context)

81+ (Reify context')

82+ (AHEither context a b)

83+ (AHEither context' a' b')

84+

85+

86+sbimapEither :: ()

87+ => SContext context

88+ -> (a -> c)

89+ -> (b -> d)

90+ -> AHEither context a b

91+ -> AHEither context c d

92+sbimapEither = \case

93+ SAggregate -> \f g (AHEither a) -> AHEither (bimap f g a)

94+ SExpr -> \f g (AHEither a) -> AHEither (bimap f g a)

95+ SResult -> \f g (AHEither a) -> AHEither (bimap f g a)

96+ SInsert -> \f g (AHEither a) -> AHEither (bimap f g a)

97+ SName -> \f g (AHEither a) -> AHEither (bimap f g a)

98+ SReify context -> \f g (AHEither a) -> AHEither (sbimapEither context f g a)

99+

100+

101+sfromColumnsEither :: (Table (Reify context) a, Table (Reify context) b)

102+ => SContext context

103+ -> HEitherTable (Columns a) (Columns b) (Col (Reify context))

104+ -> AHEither context a b

105+sfromColumnsEither = \case

106+ SAggregate ->

107+ AHEither .

108+ bimap (fromColumns . hreify) (fromColumns . hreify) .

109+ fromColumns .

110+ hunreify

111+ SExpr ->

112+ AHEither .

113+ bimap (fromColumns . hreify) (fromColumns . hreify) .

114+ fromColumns .

115+ hunreify

116+ SResult ->

117+ AHEither .

118+ bimap (fromColumns . hreify) (fromColumns . hreify) .

119+ fromColumns .

120+ hunreify

121+ SInsert ->

122+ AHEither .

123+ bimap (fromColumns . hreify) (fromColumns . hreify) .

124+ fromColumns .

125+ hunreify

126+ SName ->

127+ AHEither .

128+ bimap (fromColumns . hreify) (fromColumns . hreify) .

129+ fromColumns .

130+ hunreify

131+ SReify context ->

132+ AHEither .

133+ sbimapEither context (fromColumns . hreify) (fromColumns . hreify) .

134+ sfromColumnsEither context .

135+ hunreify

136+

137+

138+stoColumnsEither :: (Table (Reify context) a, Table (Reify context) b)

139+ => SContext context

140+ -> AHEither context a b

141+ -> HEitherTable (Columns a) (Columns b) (Col (Reify context))

142+stoColumnsEither = \case

143+ SAggregate ->

144+ hreify .

145+ toColumns .

146+ bimap (hunreify . toColumns) (hunreify . toColumns) .

147+ (\(AHEither a) -> a)

148+ SExpr ->

149+ hreify .

150+ toColumns .

151+ bimap (hunreify . toColumns) (hunreify . toColumns) .

152+ (\(AHEither a) -> a)

153+ SResult ->

154+ hreify .

155+ toColumns .

156+ bimap (hunreify . toColumns) (hunreify . toColumns) .

157+ (\(AHEither a) -> a)

158+ SInsert ->

159+ hreify .

160+ toColumns .

161+ bimap (hunreify . toColumns) (hunreify . toColumns) .

162+ (\(AHEither a) -> a)

163+ SName ->

164+ hreify .

165+ toColumns .

166+ bimap (hunreify . toColumns) (hunreify . toColumns) .

167+ (\(AHEither a) -> a)

168+ SReify context ->

169+ hreify .

170+ stoColumnsEither context .

171+ sbimapEither context (hunreify . toColumns) (hunreify . toColumns) .

172+ (\(AHEither a) -> a)

src/Rel8/Column/Field.hsnew file+110

@@ -0,0 +1,110 @@

1+{-# language DataKinds #-}

2+{-# language FlexibleContexts #-}

3+{-# language LambdaCase #-}

4+{-# language MultiParamTypeClasses #-}

5+{-# language StandaloneKindSignatures #-}

6+{-# language TypeFamilies #-}

8+module Rel8.Column.Field

9+ ( Field, AField(..)

10+ )

11+where

12+

13+-- base

14+import Data.Kind ( Type )

15+import Prelude

16+

17+-- rel8

18+import Rel8.Aggregate ( Aggregate, Col(..) )

19+import Rel8.Expr ( Expr, Col(..) )

20+import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )

21+import Rel8.Kind.Necessity

22+ ( Necessity( Required, Optional )

23+ , SNecessity( SRequired, SOptional )

24+ , KnownNecessity, necessitySing

25+ )

26+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

27+import Rel8.Schema.Insert ( Insert, Col(..) )

28+import qualified Rel8.Schema.Kind as K

29+import Rel8.Schema.Name ( Name(..), Col(..) )

30+import Rel8.Schema.Null ( Sql )

31+import Rel8.Schema.Reify ( Reify, Col(..) )

32+import Rel8.Schema.Result ( Col( Result ), Result )

33+import Rel8.Schema.Spec ( Spec( Spec ) )

34+import Rel8.Table

35+ ( Table, Columns, Context, fromColumns, toColumns

36+ , Unreify, reify, unreify

37+ )

38+import Rel8.Table.Recontextualize ( Recontextualize )

39+import Rel8.Type ( DBType )

40+

41+

42+type Field :: K.Context -> Necessity -> Type -> Type

43+type family Field context necessity a where

44+ Field (Reify context) necessity a = AField context necessity a

45+ Field Aggregate _necessity a = Aggregate (Expr a)

46+ Field Expr _necessity a = Expr a

47+ Field Insert 'Required a = Expr a

48+ Field Insert 'Optional a = Maybe (Expr a)

49+ Field Name _necessity a = Name a

50+ Field Result _necessity a = a

51+

52+

53+type AField :: K.Context -> Necessity -> Type -> Type

54+newtype AField context necessity a = AField (Field context necessity a)

55+

56+

57+instance (Reifiable context, KnownNecessity necessity, Sql DBType a) =>

58+ Table (Reify context) (AField context necessity a)

59+ where

60+ type Context (AField context necessity a) = Reify context

61+ type Columns (AField context necessity a) = HIdentity ('Spec '[""] necessity a)

62+ type Unreify (AField context necessity a) = Field context necessity a

63+

64+ fromColumns (HIdentity (Reify a)) = sfromColumn contextSing a

65+ toColumns = HIdentity . Reify . stoColumn contextSing necessitySing

66+ reify _ = AField

67+ unreify _ (AField a) = a

68+

69+

70+instance

71+ ( Reifiable context, Reifiable context'

72+ , KnownNecessity necessity, Sql DBType a

73+ ) =>

74+ Recontextualize

75+ (Reify context)

76+ (Reify context')

77+ (AField context necessity a)

78+ (AField context' necessity a)

79+

80+

81+sfromColumn :: ()

82+ => SContext context

83+ -> Col context ('Spec labels necessity a)

84+ -> AField context necessity a

85+sfromColumn = \case

86+ SAggregate -> \(Aggregation a) -> AField a

87+ SExpr -> \(DB a) -> AField a

88+ SResult -> \(Result a) -> AField a

89+ SInsert -> \case

90+ RequiredInsert a -> AField a

91+ OptionalInsert a -> AField a

92+ SName -> \(NameCol a) -> AField (Name a)

93+ SReify context -> \(Reify a) -> AField (sfromColumn context a)

94+

95+

96+stoColumn :: ()

97+ => SContext context

98+ -> SNecessity necessity

99+ -> AField context necessity a

100+ -> Col context ('Spec labels necessity a)

101+stoColumn = \case

102+ SAggregate -> \_ (AField a) -> Aggregation a

103+ SExpr -> \_ (AField a) -> DB a

104+ SResult -> \_ (AField a) -> Result a

105+ SInsert -> \case

106+ SRequired -> \(AField a) -> RequiredInsert a

107+ SOptional -> \(AField a) -> OptionalInsert a

108+ SName -> \_ (AField (Name a)) -> NameCol a

109+ SReify context ->

110+ \necessity (AField a) -> Reify (stoColumn context necessity a)

src/Rel8/Column/Lift.hs+69−3

@@ -1,23 +1,89 @@

1{-# language DataKinds #-}

2+{-# language LambdaCase #-}

3+{-# language MultiParamTypeClasses #-}

2{-# language StandaloneKindSignatures #-}

4{-# language StandaloneKindSignatures #-}

3{-# language TypeFamilies #-}

5{-# language TypeFamilies #-}

5module Rel8.Column.Lift

7module Rel8.Column.Lift

6− ( Lift

8+ ( Lift, ALift(..)

7 )

9 )

8where

10where

10-- base

12-- base

11import Data.Kind ( Type )

13import Data.Kind ( Type )

12−import Prelude ()

14+import Prelude

14-- rel8

16-- rel8

17+import Rel8.Generic.Rel8able ( GColumns )

18+import Rel8.Kind.Context ( Reifiable(..), SContext(..) )

19+import Rel8.Schema.Context ( Col )

15import qualified Rel8.Schema.Kind as K

20import qualified Rel8.Schema.Kind as K

21+import Rel8.Schema.Reify ( Reify, hreify, hunreify )

16import Rel8.Schema.Result ( Result )

22import Rel8.Schema.Result ( Result )

17−import Rel8.Table.HKD ( HKD )

23+import Rel8.Table

24+ ( Table, Columns, Context, fromColumns, toColumns

25+ , Unreify, reify, unreify

26+ )

27+import Rel8.Table.Rel8able ()

28+import Rel8.Table.HKD ( HKD( HKD ), HKDable, fromHKD, toHKD )

29+import Rel8.Table.Recontextualize ( Recontextualize )

20type Lift :: K.Context -> Type -> Type

32type Lift :: K.Context -> Type -> Type

21type family Lift context a where

33type family Lift context a where

34+ Lift (Reify context) a = ALift context a

22 Lift Result a = a

35 Lift Result a = a

23 Lift context a = HKD a context

36 Lift context a = HKD a context

37+

38+

39+type ALift :: K.Context -> Type -> Type

40+newtype ALift context a = ALift

41+ { unALift :: Lift context a

42+ }

43+

44+

45+instance (Reifiable context, HKDable a) =>

46+ Table (Reify context) (ALift context a)

47+ where

48+ type Context (ALift context a) = Reify context

49+ type Columns (ALift context a) = GColumns (HKD a)

50+ type Unreify (ALift context a) = Lift context a

51+

52+ fromColumns = sfromColumnsLift contextSing

53+ toColumns = stoColumnsLift contextSing

54+ reify _ = ALift

55+ unreify _ (ALift a) = a

56+

57+

58+instance (Reifiable context, Reifiable context', HKDable a) =>

59+ Recontextualize

60+ (Reify context)

61+ (Reify context')

62+ (ALift context a)

63+ (ALift context' a)

64+

65+

66+sfromColumnsLift :: HKDable a

67+ => SContext context

68+ -> GColumns (HKD a) (Col (Reify context))

69+ -> ALift context a

70+sfromColumnsLift = \case

71+ SAggregate -> ALift . fromColumns . hunreify

72+ SExpr -> ALift . fromColumns . hunreify

73+ SInsert -> ALift . fromColumns . hunreify

74+ SName -> ALift . fromColumns . hunreify

75+ SResult -> ALift . fromHKD . HKD . hunreify

76+ SReify context -> ALift . sfromColumnsLift context . hunreify

77+

78+

79+stoColumnsLift :: HKDable a

80+ => SContext context

81+ -> ALift context a

82+ -> GColumns (HKD a) (Col (Reify context))

83+stoColumnsLift = \case

84+ SAggregate -> hreify . toColumns . unALift

85+ SExpr -> hreify . toColumns . unALift

86+ SInsert -> hreify . toColumns . unALift

87+ SName -> hreify . toColumns . unALift

88+ SResult -> hreify . (\(HKD a) -> a) . toHKD . unALift

89+ SReify context -> hreify . stoColumnsLift context . unALift

src/Rel8/Column/List.hs+130−8

@@ -1,25 +1,147 @@

1{-# language DataKinds #-}

2+{-# language FlexibleContexts #-}

3+{-# language LambdaCase #-}

4+{-# language MultiParamTypeClasses #-}

2{-# language StandaloneKindSignatures #-}

5{-# language StandaloneKindSignatures #-}

3−{-# language TypeFamilyDependencies #-}

6+{-# language TypeFamilies #-}

7+{-# language UndecidableInstances #-}

5module Rel8.Column.List

9module Rel8.Column.List

6− ( HList

10+ ( HList, AHList(..)

7 )

11 )

8where

12where

10-- base

14-- base

11import Data.Kind ( Type )

15import Data.Kind ( Type )

16+import Data.Type.Equality ( (:~:)( Refl ) )

12−import Prelude ()

17+import Prelude

14-- rel8

19-- rel8

20+import Rel8.Aggregate ( Aggregate )

21+import Rel8.Expr ( Expr )

22+import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )

23+import Rel8.Schema.Context ( Col )

24+import Rel8.Schema.HTable.List ( HListTable )

25+import Rel8.Schema.Insert ( Insert )

15import qualified Rel8.Schema.Kind as K

26import qualified Rel8.Schema.Kind as K

27+import Rel8.Schema.Name ( Name )

28+import Rel8.Schema.Reify ( Reify, hreify, hunreify )

16import Rel8.Schema.Result ( Result )

29import Rel8.Schema.Result ( Result )

17−import Rel8.Table.List ( ListTable )

30+import Rel8.Table

31+ ( Table, Columns, Congruent, Context, fromColumns, toColumns

32+ , Unreify, reify, unreify

33+ )

34+import Rel8.Table.List ( ListTable( ListTable ) )

35+import Rel8.Table.Recontextualize ( Recontextualize )

36+import Rel8.Table.Unreify

37+ ( Unreifiability( Unreifiability )

38+ , Unreifiable, unreifiability

39+ )

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.

22type HList :: K.Context -> Type -> Type

42type HList :: K.Context -> Type -> Type

23−type family HList context = list | list -> context where

43+type family HList context where

44+ HList (Reify context) = AHList context

45+ HList Aggregate = ListTable

46+ HList Expr = ListTable

47+ HList Insert = ListTable

48+ HList Name = ListTable

24 HList Result = []

49 HList Result = []

25− HList context = ListTable context

50+

51+

52+type AHList :: K.Context -> Type -> Type

53+newtype AHList context a = AHList (HList context a)

54+

55+

56+instance (Reifiable context, Unreifiable a, Table (Reify context) a) =>

57+ Table (Reify context) (AHList context a)

58+ where

59+ type Context (AHList context a) = Reify context

60+ type Columns (AHList context a) = HListTable (Columns a)

61+ type Unreify (AHList context a) = HList context (Unreify a)

62+

63+ fromColumns = sfromColumnsList contextSing

64+ toColumns = stoColumnsList contextSing

65+

66+ reify _ = sreifyList (unreifiability contextSing)

67+ unreify _ = sunreifyList (unreifiability contextSing)

68+

69+

70+instance

71+ ( Reifiable context, Reifiable context'

72+ , Unreifiable a, Unreifiable a'

73+ , Recontextualize (Reify context) (Reify context') a a'

74+ )

75+ => Recontextualize

76+ (Reify context)

77+ (Reify context')

78+ (AHList context a)

79+ (AHList context' a')

80+

81+

82+smapList :: Congruent a b

83+ => SContext context

84+ -> (a -> b)

85+ -> (HListTable (Columns a) (Col (Context a)) -> HListTable (Columns b) (Col (Context b)))

86+ -> AHList context a

87+ -> AHList context b

88+smapList = \case

89+ SAggregate -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))

90+ SExpr -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))

91+ SResult -> \f _ (AHList as) -> AHList (fmap f as)

92+ SInsert -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))

93+ SName -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))

94+ SReify context -> \f g (AHList as) -> AHList (smapList context f g as)

95+

96+

97+sfromColumnsList :: Table (Reify context) a

98+ => SContext context

99+ -> HListTable (Columns a) (Col (Reify context))

100+ -> AHList context a

101+sfromColumnsList = \case

102+ SAggregate -> AHList . ListTable

103+ SExpr -> AHList . ListTable

104+ SResult -> AHList . fmap (fromColumns . hreify) . fromColumns . hunreify

105+ SInsert -> AHList . ListTable

106+ SName -> AHList . ListTable

107+ SReify context ->

108+ AHList .

109+ smapList context (fromColumns . hreify) hreify .

110+ sfromColumnsList context .

111+ hunreify

112+

113+

114+stoColumnsList :: Table (Reify context) a

115+ => SContext context

116+ -> AHList context a

117+ -> HListTable (Columns a) (Col (Reify context))

118+stoColumnsList = \case

119+ SAggregate -> \(AHList (ListTable a)) -> a

120+ SExpr -> \(AHList (ListTable a)) -> a

121+ SResult ->

122+ hreify . toColumns . fmap (hunreify . toColumns) . (\(AHList a) -> a)

123+ SInsert -> \(AHList (ListTable a)) -> a

124+ SName -> \(AHList (ListTable a)) -> a

125+ SReify context ->

126+ hreify .

127+ stoColumnsList context .

128+ smapList context (hunreify . toColumns) hunreify .

129+ (\(AHList a) -> a)

130+

131+

132+sreifyList :: ()

133+ => Unreifiability context a

134+ -> HList context (Unreify a)

135+ -> AHList context a

136+sreifyList (Unreifiability context) =

137+ smapList context (reify Refl) hreify .

138+ AHList

139+

140+

141+sunreifyList :: ()

142+ => Unreifiability context a

143+ -> AHList context a

144+ -> HList context (Unreify a)

145+sunreifyList (Unreifiability context) =

146+ (\(AHList a) -> a) .

147+ smapList context (unreify Refl) hunreify

src/Rel8/Column/Maybe.hs+111−7

@@ -1,9 +1,14 @@

1{-# language DataKinds #-}

2+{-# language FlexibleContexts #-}

3+{-# language GADTs #-}

4+{-# language LambdaCase #-}

5+{-# language MultiParamTypeClasses #-}

2{-# language StandaloneKindSignatures #-}

6{-# language StandaloneKindSignatures #-}

3−{-# language TypeFamilyDependencies #-}

7+{-# language TypeFamilies #-}

8+{-# language UndecidableInstances #-}

5module Rel8.Column.Maybe

10module Rel8.Column.Maybe

6− ( HMaybe

11+ ( HMaybe, AHMaybe(..)

7 )

12 )

8where

13where

@@ -12,15 +17,114 @@ import Data.Kind ( Type )

12import Prelude

17import Prelude

14-- rel8

19-- rel8

20+import Rel8.Aggregate ( Aggregate )

21+import Rel8.Expr ( Expr )

22+import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )

23+import Rel8.Schema.Context ( Col )

24+import Rel8.Schema.HTable.Maybe ( HMaybeTable )

25+import Rel8.Schema.Insert ( Insert )

15import qualified Rel8.Schema.Kind as K

26import qualified Rel8.Schema.Kind as K

27+import Rel8.Schema.Name ( Name )

28+import Rel8.Schema.Reify ( Reify, hreify, hunreify )

16import Rel8.Schema.Result ( Result )

29import Rel8.Schema.Result ( Result )

30+import Rel8.Table

31+ ( Table, Columns, Context, fromColumns, toColumns

32+ , Unreify, reify, unreify

33+ )

17import Rel8.Table.Maybe ( MaybeTable )

34import Rel8.Table.Maybe ( MaybeTable )

35+import Rel8.Table.Recontextualize ( Recontextualize )

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.

23type HMaybe :: K.Context -> Type -> Type

38type HMaybe :: K.Context -> Type -> Type

24−type family HMaybe context = maybe | maybe -> context where

39+type family HMaybe context where

40+ HMaybe (Reify context) = AHMaybe context

41+ HMaybe Aggregate = MaybeTable

42+ HMaybe Expr = MaybeTable

43+ HMaybe Insert = MaybeTable

44+ HMaybe Name = MaybeTable

25 HMaybe Result = Maybe

45 HMaybe Result = Maybe

26− HMaybe context = MaybeTable context

46+

47+

48+type AHMaybe :: K.Context -> Type -> Type

49+newtype AHMaybe context a = AHMaybe (HMaybe context a)

50+

51+

52+instance Reifiable context => Functor (AHMaybe context) where

53+ fmap = smapMaybe contextSing

54+

55+

56+instance (Reifiable context, Table (Reify context) a) =>

57+ Table (Reify context) (AHMaybe context a)

58+ where

59+ type Context (AHMaybe context a) = Reify context

60+ type Columns (AHMaybe context a) = HMaybeTable (Columns a)

61+ type Unreify (AHMaybe context a) = HMaybe context (Unreify a)

62+

63+ fromColumns = sfromColumnsMaybe contextSing

64+ toColumns = stoColumnsMaybe contextSing

65+ reify proof = fmap fmap reify proof . AHMaybe

66+ unreify proof = (\(AHMaybe a) -> a) . fmap fmap unreify proof

67+

68+

69+instance

70+ ( Reifiable context, Reifiable context'

71+ , Recontextualize (Reify context) (Reify context') a a'

72+ ) =>

73+ Recontextualize

74+ (Reify context)

75+ (Reify context')

76+ (AHMaybe context a)

77+ (AHMaybe context' a')

78+

79+

80+smapMaybe :: ()

81+ => SContext context

82+ -> (a -> b)

83+ -> AHMaybe context a

84+ -> AHMaybe context b

85+smapMaybe = \case

86+ SAggregate -> \f (AHMaybe a) -> AHMaybe (fmap f a)

87+ SExpr -> \f (AHMaybe a) -> AHMaybe (fmap f a)

88+ SResult -> \f (AHMaybe a) -> AHMaybe (fmap f a)

89+ SInsert -> \f (AHMaybe a) -> AHMaybe (fmap f a)

90+ SName -> \f (AHMaybe a) -> AHMaybe (fmap f a)

91+ SReify context -> \f (AHMaybe a) -> AHMaybe (smapMaybe context f a)

92+

93+

94+sfromColumnsMaybe :: Table (Reify context) a

95+ => SContext context

96+ -> HMaybeTable (Columns a) (Col (Reify context))

97+ -> AHMaybe context a

98+sfromColumnsMaybe = \case

99+ SAggregate -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify

100+ SExpr -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify

101+ SResult -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify

102+ SInsert -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify

103+ SName -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify

104+ SReify context ->

105+ AHMaybe .

106+ smapMaybe context (fromColumns . hreify) .

107+ sfromColumnsMaybe context .

108+ hunreify

109+

110+

111+stoColumnsMaybe :: Table (Reify context) a

112+ => SContext context

113+ -> AHMaybe context a

114+ -> HMaybeTable (Columns a) (Col (Reify context))

115+stoColumnsMaybe = \case

116+ SAggregate ->

117+ hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)

118+ SExpr ->

119+ hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)

120+ SResult ->

121+ hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)

122+ SInsert ->

123+ hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)

124+ SName ->

125+ hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)

126+ SReify context ->

127+ hreify .

128+ stoColumnsMaybe context .

129+ smapMaybe context (hunreify . toColumns) .

130+ (\(AHMaybe a) -> a)

src/Rel8/Column/NonEmpty.hs+131−9

@@ -1,27 +1,149 @@

1{-# language DataKinds #-}

2+{-# language FlexibleContexts #-}

3+{-# language LambdaCase #-}

4+{-# language MultiParamTypeClasses #-}

2{-# language StandaloneKindSignatures #-}

5{-# language StandaloneKindSignatures #-}

3−{-# language TypeFamilyDependencies #-}

6+{-# language TypeFamilies #-}

7+{-# language UndecidableInstances #-}

5module Rel8.Column.NonEmpty

9module Rel8.Column.NonEmpty

6− ( HNonEmpty

10+ ( HNonEmpty, AHNonEmpty(..)

7 )

11 )

8where

12where

10-- base

14-- base

11import Data.Kind ( Type )

15import Data.Kind ( Type )

12import Data.List.NonEmpty ( NonEmpty )

16import Data.List.NonEmpty ( NonEmpty )

17+import Data.Type.Equality ( (:~:)( Refl ) )

13−import Prelude ()

18+import Prelude

15-- rel8

20-- rel8

21+import Rel8.Aggregate ( Aggregate )

22+import Rel8.Expr ( Expr )

23+import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )

24+import Rel8.Schema.Context ( Col )

25+import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )

26+import Rel8.Schema.Insert ( Insert )

16import qualified Rel8.Schema.Kind as K

27import qualified Rel8.Schema.Kind as K

28+import Rel8.Schema.Name ( Name )

29+import Rel8.Schema.Reify ( Reify, hreify, hunreify )

17import Rel8.Schema.Result ( Result )

30import Rel8.Schema.Result ( Result )

18−import Rel8.Table.NonEmpty ( NonEmptyTable )

31+import Rel8.Table

32+ ( Table, Columns, Congruent, Context, fromColumns, toColumns

33+ , Unreify, reify, unreify

34+ )

35+import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )

36+import Rel8.Table.Recontextualize ( Recontextualize )

37+import Rel8.Table.Unreify

38+ ( Unreifiability( Unreifiability )

39+ , Unreifiable, unreifiability

40+ )

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.

24type HNonEmpty :: K.Context -> Type -> Type

43type HNonEmpty :: K.Context -> Type -> Type

25−type family HNonEmpty context = nonEmpty | nonEmpty -> context where

44+type family HNonEmpty context where

45+ HNonEmpty (Reify context) = AHNonEmpty context

46+ HNonEmpty Aggregate = NonEmptyTable

47+ HNonEmpty Expr = NonEmptyTable

48+ HNonEmpty Insert = NonEmptyTable

49+ HNonEmpty Name = NonEmptyTable

26 HNonEmpty Result = NonEmpty

50 HNonEmpty Result = NonEmpty

27− HNonEmpty context = NonEmptyTable context

51+

52+

53+type AHNonEmpty :: K.Context -> Type -> Type

54+newtype AHNonEmpty context a = AHNonEmpty (HNonEmpty context a)

55+

56+

57+instance (Reifiable context, Unreifiable a, Table (Reify context) a) =>

58+ Table (Reify context) (AHNonEmpty context a)

59+ where

60+ type Context (AHNonEmpty context a) = Reify context

61+ type Columns (AHNonEmpty context a) = HNonEmptyTable (Columns a)

62+ type Unreify (AHNonEmpty context a) = HNonEmpty context (Unreify a)

63+

64+ fromColumns = sfromColumnsNonEmpty contextSing

65+ toColumns = stoColumnsNonEmpty contextSing

66+

67+ reify _ = sreifyNonEmpty (unreifiability contextSing)

68+ unreify _ = sunreifyNonEmpty (unreifiability contextSing)

69+

70+

71+instance

72+ ( Reifiable context, Reifiable context'

73+ , Unreifiable a, Unreifiable a'

74+ , Recontextualize (Reify context) (Reify context') a a'

75+ )

76+ => Recontextualize

77+ (Reify context)

78+ (Reify context')

79+ (AHNonEmpty context a)

80+ (AHNonEmpty context' a')

81+

82+

83+smapNonEmpty :: Congruent a b

84+ => SContext context

85+ -> (a -> b)

86+ -> (HNonEmptyTable (Columns a) (Col (Context a)) -> HNonEmptyTable (Columns b) (Col (Context b)))

87+ -> AHNonEmpty context a

88+ -> AHNonEmpty context b

89+smapNonEmpty = \case

90+ SAggregate -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))

91+ SExpr -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))

92+ SResult -> \f _ (AHNonEmpty as) -> AHNonEmpty (fmap f as)

93+ SInsert -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))

94+ SName -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))

95+ SReify context -> \f g (AHNonEmpty as) -> AHNonEmpty (smapNonEmpty context f g as)

96+

97+

98+sfromColumnsNonEmpty :: Table (Reify context) a

99+ => SContext context

100+ -> HNonEmptyTable (Columns a) (Col (Reify context))

101+ -> AHNonEmpty context a

102+sfromColumnsNonEmpty = \case

103+ SAggregate -> AHNonEmpty . NonEmptyTable

104+ SExpr -> AHNonEmpty . NonEmptyTable

105+ SResult ->

106+ AHNonEmpty . fmap (fromColumns . hreify) . fromColumns . hunreify

107+ SInsert -> AHNonEmpty . NonEmptyTable

108+ SName -> AHNonEmpty . NonEmptyTable

109+ SReify context ->

110+ AHNonEmpty .

111+ smapNonEmpty context (fromColumns . hreify) hreify .

112+ sfromColumnsNonEmpty context .

113+ hunreify

114+

115+

116+stoColumnsNonEmpty :: Table (Reify context) a

117+ => SContext context

118+ -> AHNonEmpty context a

119+ -> HNonEmptyTable (Columns a) (Col (Reify context))

120+stoColumnsNonEmpty = \case

121+ SAggregate -> \(AHNonEmpty (NonEmptyTable a)) -> a

122+ SExpr -> \(AHNonEmpty (NonEmptyTable a)) -> a

123+ SResult ->

124+ hreify . toColumns . fmap (hunreify . toColumns) . (\(AHNonEmpty a) -> a)

125+ SInsert -> \(AHNonEmpty (NonEmptyTable a)) -> a

126+ SName -> \(AHNonEmpty (NonEmptyTable a)) -> a

127+ SReify context ->

128+ hreify .

129+ stoColumnsNonEmpty context .

130+ smapNonEmpty context (hunreify . toColumns) hunreify .

131+ (\(AHNonEmpty a) -> a)

132+

133+

134+sreifyNonEmpty :: ()

135+ => Unreifiability context a

136+ -> HNonEmpty context (Unreify a)

137+ -> AHNonEmpty context a

138+sreifyNonEmpty (Unreifiability context) =

139+ smapNonEmpty context (reify Refl) hreify .

140+ AHNonEmpty

141+

142+

143+sunreifyNonEmpty :: ()

144+ => Unreifiability context a

145+ -> AHNonEmpty context a

146+ -> HNonEmpty context (Unreify a)

147+sunreifyNonEmpty (Unreifiability context) =

148+ (\(AHNonEmpty a) -> a) .

149+ smapNonEmpty context (unreify Refl) hunreify

src/Rel8/Column/Null.hsdeleted−26

@@ -1,26 +0,0 @@

1−{-# language DataKinds #-}

2−{-# language StandaloneKindSignatures #-}

3−{-# language TypeFamilyDependencies #-}

4−

5−module Rel8.Column.Null

6− ( HNull

7− )

8−where

9−

10−-- base

11−import Data.Kind ( Type )

12−import Prelude

13−

14−-- rel8

15−import qualified Rel8.Schema.Kind as K

16−import Rel8.Schema.Result ( Result )

17−import Rel8.Table.Null ( NullTable )

18−

19−

20−-- | Nest a 'Null' value within a 'Rel8able'. @HNull f a@ will produce a

21−-- 'NullTable' @a@ in the 'Expr' context, and a @'Maybe' a@ in the 'Result'

22−-- context.

23−type HNull :: K.Context -> Type -> Type

24−type family HNull context = maybe | maybe -> context where

25− HNull Result = Maybe

26− HNull context = NullTable context

src/Rel8/Column/These.hs+155−8

@@ -1,29 +1,176 @@

1{-# language DataKinds #-}

2+{-# language FlexibleContexts #-}

3+{-# language GADTs #-}

4+{-# language LambdaCase #-}

5+{-# language MultiParamTypeClasses #-}

2{-# language StandaloneKindSignatures #-}

6{-# language StandaloneKindSignatures #-}

3−{-# language TypeFamilyDependencies #-}

7+{-# language TypeFamilies #-}

8+{-# language UndecidableInstances #-}

5module Rel8.Column.These

10module Rel8.Column.These

6− ( HThese

11+ ( HThese, AHThese(..)

7 )

12 )

8where

13where

10-- base

15-- base

16+import Control.Applicative ( liftA2 )

17+import Data.Bifunctor ( Bifunctor, bimap )

11import Data.Kind ( Type )

18import Data.Kind ( Type )

12−import Prelude ()

19+import Prelude

14-- rel8

21-- rel8

22+import Rel8.Aggregate ( Aggregate )

23+import Rel8.Expr ( Expr )

24+import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )

25+import Rel8.Schema.Context ( Col )

26+import Rel8.Schema.HTable.These ( HTheseTable )

27+import Rel8.Schema.Insert ( Insert )

15import qualified Rel8.Schema.Kind as K

28import qualified Rel8.Schema.Kind as K

29+import Rel8.Schema.Name ( Name )

30+import Rel8.Schema.Reify ( Reify, hreify, hunreify )

16import Rel8.Schema.Result ( Result )

31import Rel8.Schema.Result ( Result )

32+import Rel8.Table

33+ ( Table, Columns, Context, fromColumns, toColumns

34+ , Unreify, reify, unreify

35+ )

36+import Rel8.Table.Recontextualize ( Recontextualize )

17import Rel8.Table.These ( TheseTable )

37import Rel8.Table.These ( TheseTable )

19-- these

39-- these

20import Data.These ( These )

40import Data.These ( These )

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.

26type HThese :: K.Context -> Type -> Type -> Type

43type HThese :: K.Context -> Type -> Type -> Type

27−type family HThese context = these | these -> context where

44+type family HThese context where

45+ HThese (Reify context) = AHThese context

46+ HThese Aggregate = TheseTable

47+ HThese Expr = TheseTable

48+ HThese Insert = TheseTable

49+ HThese Name = TheseTable

28 HThese Result = These

50 HThese Result = These

29− HThese context = TheseTable context

51+

52+

53+type AHThese :: K.Context -> Type -> Type -> Type

54+newtype AHThese context a b = AHThese (HThese context a b)

55+

56+

57+instance Reifiable context => Bifunctor (AHThese context) where

58+ bimap = sbimapThese contextSing

59+

60+

61+instance Reifiable context => Functor (AHThese context a) where

62+ fmap = bimap id

63+

64+

65+instance (Reifiable context, Table (Reify context) a, Table (Reify context) b)

66+ => Table (Reify context) (AHThese context a b)

67+ where

68+ type Context (AHThese context a b) = Reify context

69+ type Columns (AHThese context a b) = HTheseTable (Columns a) (Columns b)

70+ type Unreify (AHThese context a b) = HThese context (Unreify a) (Unreify b)

71+

72+ fromColumns = sfromColumnsThese contextSing

73+ toColumns = stoColumnsThese contextSing

74+ reify proof = liftA2 bimap reify reify proof . AHThese

75+ unreify proof = (\(AHThese a) -> a) . liftA2 bimap unreify unreify proof

76+

77+

78+instance

79+ ( Reifiable context, Reifiable context'

80+ , Recontextualize (Reify context) (Reify context') a a'

81+ , Recontextualize (Reify context) (Reify context') b b'

82+ ) =>

83+ Recontextualize

84+ (Reify context)

85+ (Reify context')

86+ (AHThese context a b)

87+ (AHThese context' a' b')

88+

89+

90+sbimapThese :: ()

91+ => SContext context

92+ -> (a -> c)

93+ -> (b -> d)

94+ -> AHThese context a b

95+ -> AHThese context c d

96+sbimapThese = \case

97+ SAggregate -> \f g (AHThese a) -> AHThese (bimap f g a)

98+ SExpr -> \f g (AHThese a) -> AHThese (bimap f g a)

99+ SResult -> \f g (AHThese a) -> AHThese (bimap f g a)

100+ SInsert -> \f g (AHThese a) -> AHThese (bimap f g a)

101+ SName -> \f g (AHThese a) -> AHThese (bimap f g a)

102+ SReify context -> \f g (AHThese a) -> AHThese (sbimapThese context f g a)

103+

104+

105+sfromColumnsThese :: (Table (Reify context) a, Table (Reify context) b)

106+ => SContext context

107+ -> HTheseTable (Columns a) (Columns b) (Col (Reify context))

108+ -> AHThese context a b

109+sfromColumnsThese = \case

110+ SAggregate ->

111+ AHThese .

112+ bimap (fromColumns . hreify) (fromColumns . hreify) .

113+ fromColumns .

114+ hunreify

115+ SExpr ->

116+ AHThese .

117+ bimap (fromColumns . hreify) (fromColumns . hreify) .

118+ fromColumns .

119+ hunreify

120+ SResult ->

121+ AHThese .

122+ bimap (fromColumns . hreify) (fromColumns . hreify) .

123+ fromColumns .

124+ hunreify

125+ SInsert ->

126+ AHThese .

127+ bimap (fromColumns . hreify) (fromColumns . hreify) .

128+ fromColumns .

129+ hunreify

130+ SName ->

131+ AHThese .

132+ bimap (fromColumns . hreify) (fromColumns . hreify) .

133+ fromColumns .

134+ hunreify

135+ SReify context ->

136+ AHThese .

137+ sbimapThese context (fromColumns . hreify) (fromColumns . hreify) .

138+ sfromColumnsThese context .

139+ hunreify

140+

141+

142+stoColumnsThese :: (Table (Reify context) a, Table (Reify context) b)

143+ => SContext context

144+ -> AHThese context a b

145+ -> HTheseTable (Columns a) (Columns b) (Col (Reify context))

146+stoColumnsThese = \case

147+ SAggregate ->

148+ hreify .

149+ toColumns .

150+ bimap (hunreify . toColumns) (hunreify . toColumns) .

151+ (\(AHThese a) -> a)

152+ SExpr ->

153+ hreify .

154+ toColumns .

155+ bimap (hunreify . toColumns) (hunreify . toColumns) .

156+ (\(AHThese a) -> a)

157+ SResult ->

158+ hreify .

159+ toColumns .

160+ bimap (hunreify . toColumns) (hunreify . toColumns) .

161+ (\(AHThese a) -> a)

162+ SInsert ->

163+ hreify .

164+ toColumns .

165+ bimap (hunreify . toColumns) (hunreify . toColumns) .

166+ (\(AHThese a) -> a)

167+ SName ->

168+ hreify .

169+ toColumns .

170+ bimap (hunreify . toColumns) (hunreify . toColumns) .

171+ (\(AHThese a) -> a)

172+ SReify context ->

173+ hreify .

174+ stoColumnsThese context .

175+ sbimapThese context (hunreify . toColumns) (hunreify . toColumns) .

176+ (\(AHThese a) -> a)

src/Rel8/Expr.hs+46−38

@@ -1,21 +1,27 @@

1{-# language DataKinds #-}

2{-# language DerivingStrategies #-}

3−{-# language FlexibleContexts #-}

4{-# language FlexibleInstances #-}

3{-# language FlexibleInstances #-}

4+{-# language GADTs #-}

5{-# language MultiParamTypeClasses #-}

6+{-# language PolyKinds #-}

7+{-# language RoleAnnotations #-}

6{-# language ScopedTypeVariables #-}

8{-# language ScopedTypeVariables #-}

9+{-# language StandaloneDeriving #-}

7{-# language StandaloneKindSignatures #-}

10{-# language StandaloneKindSignatures #-}

8{-# language TypeApplications #-}

11{-# language TypeApplications #-}

9{-# language TypeFamilies #-}

12{-# language TypeFamilies #-}

10{-# language UndecidableInstances #-}

13{-# language UndecidableInstances #-}

14+{-# language UndecidableSuperClasses #-}

12module Rel8.Expr

16module Rel8.Expr

13 ( Expr(..)

17 ( Expr(..)

18+ , Col( DB, unDB )

14 )

19 )

15where

20where

17-- base

22-- base

18−import Data.Functor.Identity ( Identity( Identity ) )

23+import Data.Functor.Identity ( Identity )

24+import Data.Kind ( Type )

19import Data.String ( IsString, fromString )

25import Data.String ( IsString, fromString )

20import Prelude hiding ( null )

26import Prelude hiding ( null )

@@ -23,7 +29,6 @@ import Prelude hiding ( null )

23import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

29import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

25-- rel8

31-- rel8

26−import Rel8.Expr.Function ( function, nullaryFunction )

27import Rel8.Expr.Null ( liftOpNull, nullify )

32import Rel8.Expr.Null ( liftOpNull, nullify )

28import Rel8.Expr.Opaleye

33import Rel8.Expr.Opaleye

29 ( castExpr

34 ( castExpr

@@ -32,24 +37,31 @@ import Rel8.Expr.Opaleye

32 , zipPrimExprsWith

37 , zipPrimExprsWith

33 )

38 )

34import Rel8.Expr.Serialize ( litExpr )

39import Rel8.Expr.Serialize ( litExpr )

40+import Rel8.Schema.Context ( Interpretation, Col )

41+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )

35−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

42+import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )

36−import qualified Rel8.Schema.Kind as K

37import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )

43import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )

44+import Rel8.Schema.Reify ( notReify )

45+import Rel8.Schema.Result ( Result )

46+import Rel8.Schema.Spec ( Spec( Spec ) )

38import Rel8.Table

47import Rel8.Table

39− ( Table, Columns, Context, fromColumns, toColumns

48+ ( Table, Columns, Context, fromColumns, toColumns, reify, unreify

40− , FromExprs, fromResult, toResult

41− , Transpose

42 )

49 )

50+import Rel8.Table.Recontextualize ( Recontextualize )

43import Rel8.Type ( DBType )

51import Rel8.Type ( DBType )

44import Rel8.Type.Monoid ( DBMonoid, memptyExpr )

52import Rel8.Type.Monoid ( DBMonoid, memptyExpr )

45−import Rel8.Type.Num ( DBFloating, DBFractional, DBNum )

53+import Rel8.Type.Num ( DBFractional, DBNum )

46import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )

54import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )

49-- | Typed SQL expressions.

57-- | Typed SQL expressions.

50−type Expr :: K.Context

58+type role Expr representational

59+type Expr :: k -> Type

60+data Expr a where

51−newtype Expr a = Expr Opaleye.PrimExpr

61+ Expr :: k ~ Type => !Opaleye.PrimExpr -> Expr (a :: k)

62+

63+

52− deriving stock Show

64+deriving stock instance Show (Expr a)

55instance Sql DBSemigroup a => Semigroup (Expr a) where

67instance Sql DBSemigroup a => Semigroup (Expr a) where

@@ -92,34 +104,30 @@ instance Sql DBFractional a => Fractional (Expr a) where

92 castExpr . Expr . Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac

104 castExpr . Expr . Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac

105

106

95−instance Sql DBFloating a => Floating (Expr a) where

107+instance Interpretation Expr where

96− pi = nullaryFunction "PI"

108+ data Col Expr _spec where

97− exp = function "exp"

109+ DB :: {unDB :: Expr a} -> Col Expr ('Spec labels necessity a)

98− log = function "ln"

99− sqrt = function "sqrt"

100− (**) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:^))

101− logBase = function "log"

102− sin = function "sin"

103− cos = function "cos"

104− tan = function "tan"

105− asin = function "asin"

106− acos = function "acos"

107− atan = function "atan"

108− sinh = function "sinh"

109− cosh = function "cosh"

110− tanh = function "tanh"

111− asinh = function "asinh"

112− acosh = function "acosh"

113− atanh = function "atanh"

114

110

115

111

116instance Sql DBType a => Table Expr (Expr a) where

112instance Sql DBType a => Table Expr (Expr a) where

117− type Columns (Expr a) = HIdentity a

113+ type Columns (Expr a) = HType a

118 type Context (Expr a) = Expr

114 type Context (Expr a) = Expr

119− type FromExprs (Expr a) = a

120− type Transpose to (Expr a) = to a

121

115

122− toColumns a = HIdentity a

116+ toColumns a = HType (DB a)

123− fromColumns (HIdentity a) = a

117+ fromColumns (HType (DB a)) = a

124− toResult a = HIdentity (Identity a)

118+ reify = notReify

125− fromResult (HIdentity (Identity a)) = a

119+ unreify = notReify

120+

121+

122+instance Sql DBType a => Recontextualize Expr Expr (Expr a) (Expr a)

123+

124+

125+instance Sql DBType a => Recontextualize Expr Result (Expr a) (Identity a)

126+

127+

128+instance Sql DBType a => Recontextualize Result Expr (Identity a) (Expr a)

129+

130+

131+instance Labelable Expr where

132+ labeler (DB a) = DB a

133+ unlabeler (DB a) = DB a

src/Rel8/Expr.hs-boot+8−6

@@ -1,4 +1,6 @@

1−{-# language DataKinds #-}

1+{-# language GADTs #-}

2+{-# language PolyKinds #-}

3+{-# language RoleAnnotations #-}

2{-# language StandaloneKindSignatures #-}

4{-# language StandaloneKindSignatures #-}

4module Rel8.Expr

6module Rel8.Expr

@@ -7,14 +9,14 @@ module Rel8.Expr

7where

9where

9-- base

11-- base

12+import Data.Kind ( Type )

10import Prelude ()

13import Prelude ()

12-- opaleye

15-- opaleye

13import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

16import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

15−-- rel8

16−import Rel8.Schema.Kind ( Context )

18−

19+type role Expr representational

19−type Expr :: Context

20+type Expr :: k -> Type

21+data Expr a where

20−newtype Expr a = Expr Opaleye.PrimExpr

22+ Expr :: k ~ Type => !Opaleye.PrimExpr -> Expr (a :: k)

src/Rel8/Expr/Aggregate.hs+115−53

@@ -10,11 +10,10 @@ module Rel8.Expr.Aggregate

10 , and, or

11 , min, max

12 , sum, sumWhere

13− , avg

14 , stringAgg

13 , stringAgg

15 , groupByExpr

14 , groupByExpr

16− , listAggExpr, nonEmptyAggExpr

15+ , array1DAggExpr, listAggExpr, nonEmptyAggExpr

17− , slistAggExpr, snonEmptyAggExpr

16+ , listAggExprWithOrder, nonEmptyAggExprWithOrder

18 )

17 )

19where

18where

@@ -24,12 +23,10 @@ import Data.List.NonEmpty ( NonEmpty )

24import Prelude hiding ( and, max, min, null, or, sum )

23import Prelude hiding ( and, max, min, null, or, sum )

26-- opaleye

25-- opaleye

27−import qualified Opaleye.Internal.Aggregate as Opaleye

26+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

28−import Opaleye.Internal.Column ( Field_( Column ) )

29−import qualified Opaleye.Aggregate as Opaleye

31-- rel8

28-- rel8

32−import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )

29+import Rel8.Aggregate ( Aggregate, Aggregator(..), unsafeMakeAggregate )

33import Rel8.Expr ( Expr )

30import Rel8.Expr ( Expr )

34import Rel8.Expr.Bool ( caseExpr )

31import Rel8.Expr.Bool ( caseExpr )

35import Rel8.Expr.Opaleye

32import Rel8.Expr.Opaleye

@@ -40,11 +37,11 @@ import Rel8.Expr.Opaleye

40 )

37 )

41import Rel8.Expr.Null ( null )

38import Rel8.Expr.Null ( null )

42import Rel8.Expr.Serialize ( litExpr )

39import Rel8.Expr.Serialize ( litExpr )

40+import Rel8.Order ( Order, toOrderExprs )

43−import Rel8.Schema.Null ( Sql, Unnullify )

41+import Rel8.Schema.Null ( Sql )

44−import Rel8.Type ( DBType, typeInformation )

45−import Rel8.Type.Array ( encodeArrayElement )

42+import Rel8.Type.Array ( fromPrimArray )

43+import Rel8.Type.Array1D ( Array1D, NotArray )

46import Rel8.Type.Eq ( DBEq )

44import Rel8.Type.Eq ( DBEq )

47−import Rel8.Type.Information ( TypeInformation )

48import Rel8.Type.Num ( DBNum )

45import Rel8.Type.Num ( DBNum )

49import Rel8.Type.Ord ( DBMax, DBMin )

46import Rel8.Type.Ord ( DBMax, DBMin )

50import Rel8.Type.String ( DBString )

47import Rel8.Type.String ( DBString )

@@ -52,99 +49,164 @@ import Rel8.Type.Sum ( DBSum )

54-- | Count the occurances of a single column. Corresponds to @COUNT(a)@

51-- | Count the occurances of a single column. Corresponds to @COUNT(a)@

55−count :: Expr a -> Aggregate Int64

52+count :: Expr a -> Aggregate (Expr Int64)

56−count = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.count

53+count = unsafeMakeAggregate toPrimExpr fromPrimExpr $

54+ Just Aggregator

55+ { operation = Opaleye.AggrCount

56+ , ordering = []

57+ , distinction = Opaleye.AggrAll

58+ }

59+

58-- | Count the number of distinct occurances of a single column. Corresponds to

61-- | Count the number of distinct occurances of a single column. Corresponds to

59-- @COUNT(DISTINCT a)@

62-- @COUNT(DISTINCT a)@

60−countDistinct :: Sql DBEq a => Expr a -> Aggregate Int64

63+countDistinct :: Sql DBEq a => Expr a -> Aggregate (Expr Int64)

61countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $

64countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $

62− Opaleye.distinctAggregator Opaleye.count

65+ Just Aggregator

66+ { operation = Opaleye.AggrCount

67+ , ordering = []

68+ , distinction = Opaleye.AggrDistinct

69+ }

65-- | Corresponds to @COUNT(*)@.

72-- | Corresponds to @COUNT(*)@.

66−countStar :: Aggregate Int64

73+countStar :: Aggregate (Expr Int64)

67countStar = count (litExpr True)

74countStar = count (litExpr True)

70-- | A count of the number of times a given expression is @true@.

77-- | A count of the number of times a given expression is @true@.

71−countWhere :: Expr Bool -> Aggregate Int64

78+countWhere :: Expr Bool -> Aggregate (Expr Int64)

72countWhere condition = count (caseExpr [(condition, litExpr (Just True))] null)

79countWhere condition = count (caseExpr [(condition, litExpr (Just True))] null)

75-- | Corresponds to @bool_and@.

82-- | Corresponds to @bool_and@.

76−and :: Expr Bool -> Aggregate Bool

83+and :: Expr Bool -> Aggregate (Expr Bool)

77−and = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolAnd

84+and = unsafeMakeAggregate toPrimExpr fromPrimExpr $

85+ Just Aggregator

86+ { operation = Opaleye.AggrBoolAnd

87+ , ordering = []

88+ , distinction = Opaleye.AggrAll

89+ }

80-- | Corresponds to @bool_or@.

92-- | Corresponds to @bool_or@.

81−or :: Expr Bool -> Aggregate Bool

93+or :: Expr Bool -> Aggregate (Expr Bool)

82−or = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolOr

94+or = unsafeMakeAggregate toPrimExpr fromPrimExpr $

95+ Just Aggregator

96+ { operation = Opaleye.AggrBoolOr

97+ , ordering = []

98+ , distinction = Opaleye.AggrAll

99+ }

100

101

85-- | Produce an aggregation for @Expr a@ using the @max@ function.

102-- | Produce an aggregation for @Expr a@ using the @max@ function.

86−max :: Sql DBMax a => Expr a -> Aggregate a

103+max :: Sql DBMax a => Expr a -> Aggregate (Expr a)

87−max = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMax

104+max = unsafeMakeAggregate toPrimExpr fromPrimExpr $

105+ Just Aggregator

106+ { operation = Opaleye.AggrMax

107+ , ordering = []

108+ , distinction = Opaleye.AggrAll

109+ }

110

111

90-- | Produce an aggregation for @Expr a@ using the @max@ function.

112-- | Produce an aggregation for @Expr a@ using the @max@ function.

91−min :: Sql DBMin a => Expr a -> Aggregate a

113+min :: Sql DBMin a => Expr a -> Aggregate (Expr a)

92−min = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMin

114+min = unsafeMakeAggregate toPrimExpr fromPrimExpr $

115+ Just Aggregator

116+ { operation = Opaleye.AggrMin

117+ , ordering = []

118+ , distinction = Opaleye.AggrAll

119+ }

120

94-- | Corresponds to @sum@. Note that in SQL, @sum@ is type changing - for

121-- | Corresponds to @sum@. Note that in SQL, @sum@ is type changing - for

95-- example the @sum@ of @integer@ returns a @bigint@. Rel8 doesn't support

122-- example the @sum@ of @integer@ returns a @bigint@. Rel8 doesn't support

96−-- this, and will add explicit casts back to the original input type. This can

123+-- this, and will add explicit cast back to the original input type. This can

97-- lead to overflows, and if you anticipate very large sums, you should upcast

124-- lead to overflows, and if you anticipate very large sums, you should upcast

98-- your input.

125-- your input.

99−sum :: Sql DBSum a => Expr a -> Aggregate a

126+sum :: Sql DBSum a => Expr a -> Aggregate (Expr a)

100−sum = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) Opaleye.unsafeSum

127+sum = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $

101−

128+ Just Aggregator

129+ { operation = Opaleye.AggrSum

130+ , ordering = []

131+ , distinction = Opaleye.AggrAll

132+ }

102

133

103−-- | Corresponds to @avg@. Note that in SQL, @avg@ is type changing - for

104−-- example, the @avg@ of @integer@ returns a @numeric@. Rel8 doesn't support

105−-- this, and will add explicit casts back to the original input type. If you

106−-- need a fractional result on an integral column, you should cast your input

107−-- to 'Double' or 'Data.Scientific.Scientific' before calling 'avg'.

108−avg :: Sql DBSum a => Expr a -> Aggregate a

109−avg = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) Opaleye.unsafeAvg

110

134

111-- | Take the sum of all expressions that satisfy a predicate.

135-- | Take the sum of all expressions that satisfy a predicate.

112sumWhere :: (Sql DBNum a, Sql DBSum a)

136sumWhere :: (Sql DBNum a, Sql DBSum a)

113− => Expr Bool -> Expr a -> Aggregate a

137+ => Expr Bool -> Expr a -> Aggregate (Expr a)

114sumWhere condition a = sum (caseExpr [(condition, a)] 0)

138sumWhere condition a = sum (caseExpr [(condition, a)] 0)

115

139

116

140

117-- | Corresponds to @string_agg()@.

141-- | Corresponds to @string_agg()@.

118stringAgg :: Sql DBString a

142stringAgg :: Sql DBString a

119− => Expr db -> Expr a -> Aggregate a

143+ => Expr db -> Expr a -> Aggregate (Expr a)

120stringAgg delimiter =

144stringAgg delimiter =

121− unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) (Opaleye.stringAgg (Column (toPrimExpr delimiter)))

145+ unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $

146+ Just Aggregator

147+ { operation = Opaleye.AggrStringAggr (toPrimExpr delimiter)

148+ , ordering = []

149+ , distinction = Opaleye.AggrAll

150+ }

122

151

123

152

124-- | Aggregate a value by grouping by it.

153-- | Aggregate a value by grouping by it.

125−groupByExpr :: Sql DBEq a => Expr a -> Aggregate a

154+groupByExpr :: Sql DBEq a => Expr a -> Aggregate (Expr a)

126−groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.groupBy

155+groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Nothing

156+

157+

158+-- | Collect expressions values as an array.

159+array1DAggExpr :: NotArray a => Expr a -> Aggregate (Expr (Array1D a))

160+array1DAggExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr $ Just

161+ Aggregator

162+ { operation = Opaleye.AggrArr

163+ , ordering = []

164+ , distinction = Opaleye.AggrAll

165+ }

127

166

128

167

129-- | Collect expressions values as a list.

168-- | Collect expressions values as a list.

130−listAggExpr :: Sql DBType a => Expr a -> Aggregate [a]

169+listAggExpr :: Expr a -> Aggregate (Expr [a])

131−listAggExpr = slistAggExpr typeInformation

170+listAggExpr = unsafeMakeAggregate toPrimExpr from $ Just

171+ Aggregator

172+ { operation = Opaleye.AggrArr

173+ , ordering = []

174+ , distinction = Opaleye.AggrAll

175+ }

176+ where

177+ from = fromPrimExpr . fromPrimArray

132

178

133

179

134-- | Collect expressions values as a non-empty list.

180-- | Collect expressions values as a non-empty list.

135−nonEmptyAggExpr :: Sql DBType a => Expr a -> Aggregate (NonEmpty a)

181+nonEmptyAggExpr :: Expr a -> Aggregate (Expr (NonEmpty a))

136−nonEmptyAggExpr = snonEmptyAggExpr typeInformation

182+nonEmptyAggExpr = unsafeMakeAggregate toPrimExpr from $ Just

183+ Aggregator

184+ { operation = Opaleye.AggrArr

185+ , ordering = []

186+ , distinction = Opaleye.AggrAll

187+ }

188+ where

189+ from = fromPrimExpr . fromPrimArray

137

190

138

191

139−slistAggExpr :: ()

192+listAggExprWithOrder :: Order o -> o -> Expr a -> Aggregate (Expr [a])

140− => TypeInformation (Unnullify a) -> Expr a -> Aggregate [a]

193+listAggExprWithOrder order o = unsafeMakeAggregate toPrimExpr from $ Just

141−slistAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg

194+ Aggregator

195+ { operation = Opaleye.AggrArr

196+ , ordering = toOrderExprs order o

197+ , distinction = Opaleye.AggrAll

198+ }

142 where

199 where

143− to = encodeArrayElement info . toPrimExpr

200+ from = fromPrimExpr . fromPrimArray

144

201

145

202

146−snonEmptyAggExpr :: ()

203+nonEmptyAggExprWithOrder :: ()

147− => TypeInformation (Unnullify a) -> Expr a -> Aggregate (NonEmpty a)

204+ => Order o -> o -> Expr a -> Aggregate (Expr (NonEmpty a))

148−snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg

205+nonEmptyAggExprWithOrder order o = unsafeMakeAggregate toPrimExpr from $ Just

206+ Aggregator

207+ { operation = Opaleye.AggrArr

208+ , ordering = toOrderExprs order o

209+ , distinction = Opaleye.AggrAll

210+ }

149 where

211 where

150− to = encodeArrayElement info . toPrimExpr

212+ from = fromPrimExpr . fromPrimArray

src/Rel8/Expr/Array.hs+6−6

@@ -25,21 +25,21 @@ import Rel8.Expr.Opaleye

25 , zipPrimExprsWith

26 )

27import Rel8.Type ( DBType, typeInformation )

28−import Rel8.Type.Array ( array )

28+import Rel8.Type.Array ( array, zipPrimArraysWith )

29import Rel8.Type.Information ( TypeInformation(..) )

30−import Rel8.Schema.Null ( Unnullify, Sql )

30+import Rel8.Schema.Null ( Unnullify, Nullity, Sql )

33sappend :: Expr [a] -> Expr [a] -> Expr [a]

34−sappend = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))

34+sappend = zipPrimExprsWith (zipPrimArraysWith (Opaleye.BinExpr (Opaleye.:||)))

37sappend1 :: Expr (NonEmpty a) -> Expr (NonEmpty a) -> Expr (NonEmpty a)

38−sappend1 = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))

38+sappend1 = zipPrimExprsWith (zipPrimArraysWith (Opaleye.BinExpr (Opaleye.:||)))

41−sempty :: TypeInformation (Unnullify a) -> Expr [a]

41+sempty :: Nullity a -> TypeInformation (Unnullify a) -> Expr [a]

42−sempty info = fromPrimExpr $ array info []

42+sempty _ info = fromPrimExpr $ array info []

45slistOf :: TypeInformation (Unnullify a) -> [Expr a] -> Expr [a]

src/Rel8/Expr/Default.hsdeleted−35

@@ -1,35 +0,0 @@

1−module Rel8.Expr.Default

2− ( unsafeDefault

3− )

4−where

5−

6−-- base

7−import Prelude ()

8−

9−-- opaleye

10−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

11−

12−-- rel8

13−import Rel8.Expr ( Expr )

14−import Rel8.Expr.Opaleye ( fromPrimExpr )

15−

16−

17−-- | Corresponds to the SQL @DEFAULT@ expression.

18−--

19−-- This 'Expr' is unsafe for numerous reasons, and should be used with care:

20−--

21−-- 1. This 'Expr' only makes sense in an @INSERT@ or @UPDATE@ statement.

22−--

23−-- 2. Rel8 is not able to verify that a particular column actually has a

24−-- @DEFAULT@ value. Trying to use @unsafeDefault@ where there is no default

25−-- will cause a runtime crash

26−--

27−-- 3. @DEFAULT@ values can not be transformed. For example, the innocuous Rel8

28−-- code @unsafeDefault + 1@ will crash, despite type checking.

29−--

30−-- Given all these caveats, we suggest avoiding the use of default values where

31−-- possible, instead being explicit. A common scenario where default values are

32−-- used is with auto-incrementing identifier columns. In this case, we suggest

33−-- using 'Rel8.nextval' instead.

34−unsafeDefault :: Expr a

35−unsafeDefault = fromPrimExpr Opaleye.DefaultInsertExpr

src/Rel8/Expr/Eq.hs+1−1

@@ -22,7 +22,7 @@ import Prelude

22import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

24-- rel8

25−import Rel8.Expr ( Expr )

25+import {-# SOURCE #-} Rel8.Expr ( Expr )

26import Rel8.Expr.Bool ( (&&.), (||.), false, or_, coalesce )

27import Rel8.Expr.Null ( isNull, unsafeLiftOpNull )

28import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr, zipPrimExprsWith )

src/Rel8/Expr/Function.hs+1−1

@@ -20,7 +20,7 @@ import Prelude

20import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

22-- rel8

23−import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )

23+import Rel8.Expr ( Expr( Expr ) )

24import Rel8.Expr.Opaleye

25 ( castExpr

26 , fromPrimExpr, toPrimExpr, zipPrimExprsWith

src/Rel8/Expr/Null.hs+3−3

@@ -5,7 +5,7 @@

5{-# options -fno-warn-redundant-constraints #-}

7module Rel8.Expr.Null

8− ( null, snull, nullableExpr, nullableOf

8+ ( null, snull, nullable, nullableOf

9 , isNull, isNonNull

10 , nullify, unsafeUnnullify

11 , mapNull, liftOpNull

@@ -40,8 +40,8 @@ unsafeUnnullify (Expr a) = Expr a

42-- | Like 'maybe', but to eliminate @null@.

43−nullableExpr :: Expr b -> (Expr a -> Expr b) -> Expr (Maybe a) -> Expr b

43+nullable :: Expr b -> (Expr a -> Expr b) -> Expr (Maybe a) -> Expr b

44−nullableExpr b f ma = boolExpr (f (unsafeUnnullify ma)) b (isNull ma)

44+nullable b f ma = boolExpr (f (unsafeUnnullify ma)) b (isNull ma)

47nullableOf :: DBType a => Maybe (Expr a) -> Expr (Maybe a)

src/Rel8/Expr/Num.hs+10−43

@@ -4,24 +4,18 @@

4{-# options_ghc -fno-warn-redundant-constraints #-}

6module Rel8.Expr.Num

7− ( fromIntegral

8− , realToFrac

9− , div, mod, divMod

10− , quot, rem, quotRem

11− , ceiling, floor, round, truncate

7+ ( fromIntegral, realToFrac, div, mod, ceiling, floor, round, truncate

12 )

8 )

13where

9where

15-- base

11-- base

16−import Prelude ( (+), (-), fst, negate, signum, snd )

12+import Prelude ()

18-- rel

14-- rel

19import Rel8.Expr ( Expr( Expr ) )

15import Rel8.Expr ( Expr( Expr ) )

20−import Rel8.Expr.Eq ( (==.) )

21import Rel8.Expr.Function ( function )

16import Rel8.Expr.Function ( function )

22import Rel8.Expr.Opaleye ( castExpr )

17import Rel8.Expr.Opaleye ( castExpr )

23import Rel8.Schema.Null ( Homonullable, Sql )

18import Rel8.Schema.Null ( Homonullable, Sql )

24−import Rel8.Table.Bool ( bool )

25import Rel8.Type.Num ( DBFractional, DBIntegral, DBNum )

19import Rel8.Type.Num ( DBFractional, DBIntegral, DBNum )

@@ -45,44 +39,17 @@ realToFrac (Expr a) = castExpr (Expr a)

45-- Corresponds to the @ceiling()@ function.

39-- Corresponds to the @ceiling()@ function.

46ceiling :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)

40ceiling :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)

47 => Expr a -> Expr b

41 => Expr a -> Expr b

48−ceiling = function "ceiling"

42+ceiling = function "CEILING"

51−-- | Emulates the behaviour of the Haskell function 'Prelude.div' in

45+-- | Perform integral division. Corresponds to the @div()@ function.

52−-- PostgreSQL.

53div :: Sql DBIntegral a => Expr a -> Expr a -> Expr a

46div :: Sql DBIntegral a => Expr a -> Expr a -> Expr a

54−div n d = fst (divMod n d)

47+div = function "DIV"

57−-- | Emulates the behaviour of the Haskell function 'Prelude.mod' in

50+-- | Corresponds to the @mod()@ function.

58−-- PostgreSQL.

59mod :: Sql DBIntegral a => Expr a -> Expr a -> Expr a

51mod :: Sql DBIntegral a => Expr a -> Expr a -> Expr a

60−mod n d = snd (divMod n d)

52+mod = function "MOD"

61−

62−

63−-- | Simultaneous 'div' and 'mod'.

64−divMod :: Sql DBIntegral a => Expr a -> Expr a -> (Expr a, Expr a)

65−divMod n d = bool qr (q - 1, r + d) (signum r ==. negate (signum d))

66− where

67− qr@(q, r) = quotRem n d

68−

69−

70−-- | Perform integral division. Corresponds to the @div()@ function in

71−-- PostgreSQL, which behaves like Haskell's 'Prelude.quot' rather than

72−-- 'Prelude.div'.

73−quot :: Sql DBIntegral a => Expr a -> Expr a -> Expr a

74−quot = function "div"

75−

76−

77−-- | Corresponds to the @mod()@ function in PostgreSQL, which behaves like

78−-- Haskell's 'Prelude.rem' rather than 'Prelude.mod'.

79−rem :: Sql DBIntegral a => Expr a -> Expr a -> Expr a

80−rem = function "mod"

81−

82−

83−-- | Simultaneous 'quot' and 'rem'.

84−quotRem :: Sql DBIntegral a => Expr a -> Expr a -> (Expr a, Expr a)

85−quotRem n d = (quot n d, rem n d)

88-- | Round a 'DFractional' to a 'DBIntegral' by rounding to the nearest smaller

55-- | Round a 'DFractional' to a 'DBIntegral' by rounding to the nearest smaller

@@ -91,7 +58,7 @@ quotRem n d = (quot n d, rem n d)

91-- Corresponds to the @floor()@ function.

58-- Corresponds to the @floor()@ function.

92floor :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)

59floor :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)

93 => Expr a -> Expr b

60 => Expr a -> Expr b

94−floor = function "floor"

61+floor = function "FLOOR"

97-- | Round a 'DBFractional' to a 'DBIntegral' by rounding to the nearest

64-- | Round a 'DBFractional' to a 'DBIntegral' by rounding to the nearest

@@ -100,11 +67,11 @@ floor = function "floor"

100-- Corresponds to the @round()@ function.

67-- Corresponds to the @round()@ function.

101round :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)

68round :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)

102 => Expr a -> Expr b

69 => Expr a -> Expr b

103−round = function "round"

70+round = function "ROUND"

104

105

106-- | Round a 'DBFractional' to a 'DBIntegral' by rounding to the nearest

73-- | Round a 'DBFractional' to a 'DBIntegral' by rounding to the nearest

107-- integer towards zero.

74-- integer towards zero.

108truncate :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)

75truncate :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)

109 => Expr a -> Expr b

76 => Expr a -> Expr b

110−truncate = function "trunc"

77+truncate = function "TRUNC"

src/Rel8/Expr/Opaleye.hs+5−19

@@ -10,7 +10,7 @@ module Rel8.Expr.Opaleye

10 , scastExpr, sunsafeCastExpr

11 , unsafeLiteral

12 , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith, traversePrimExpr

13− , toColumn, fromColumn, traverseFieldP

13+ , toColumn, fromColumn

14 )

15where

@@ -27,9 +27,6 @@ import Rel8.Schema.Null ( Unnullify, Sql )

27import Rel8.Type ( DBType, typeInformation )

28import Rel8.Type.Information ( TypeInformation(..) )

30−-- profunctors

31−import Data.Profunctor ( Profunctor, dimap )

32−

34castExpr :: Sql DBType a => Expr a -> Expr a

31castExpr :: Sql DBType a => Expr a -> Expr a

35castExpr = scastExpr typeInformation

32castExpr = scastExpr typeInformation

@@ -51,13 +48,8 @@ sunsafeCastExpr TypeInformation {typeName} =

51 fromPrimExpr . Opaleye.CastExpr typeName . toPrimExpr

48 fromPrimExpr . Opaleye.CastExpr typeName . toPrimExpr

54−-- | Unsafely construct an expression from literal SQL.

55−--

56−-- This is an escape hatch, and can be used if Rel8 can not adequately express

57−-- the query you need. If you find yourself using this function, please let us

58−-- know, as it may indicate that something is missing from Rel8!

59−unsafeLiteral :: String -> Expr a

51+unsafeLiteral :: Sql DBType a => String -> Expr a

60−unsafeLiteral = Expr . Opaleye.ConstExpr . Opaleye.OtherLit

52+unsafeLiteral = castExpr . Expr . Opaleye.ConstExpr . Opaleye.OtherLit

63fromPrimExpr :: Opaleye.PrimExpr -> Expr a

55fromPrimExpr :: Opaleye.PrimExpr -> Expr a

@@ -83,15 +75,9 @@ traversePrimExpr :: Functor f

83traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr

75traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr

86−traverseFieldP :: Profunctor p

87− => p (Opaleye.Field_ n x) (Opaleye.Field_ m y)

88− -> p (Expr a) (Expr b)

89−traverseFieldP = dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn)

90−

91−

92−toColumn :: Opaleye.PrimExpr -> Opaleye.Field_ n b

78+toColumn :: Opaleye.PrimExpr -> Opaleye.Column b

93toColumn = Opaleye.Column

79toColumn = Opaleye.Column

96−fromColumn :: Opaleye.Field_ n b -> Opaleye.PrimExpr

82+fromColumn :: Opaleye.Column b -> Opaleye.PrimExpr

97fromColumn (Opaleye.Column a) = a

83fromColumn (Opaleye.Column a) = a

src/Rel8/Expr/Ord.hs+11−10

@@ -22,9 +22,10 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

22-- rel8

23import Rel8.Expr ( Expr( Expr ) )

24import Rel8.Expr.Bool ( (&&.), (||.), coalesce )

25−import Rel8.Expr.Null ( isNull, isNonNull, nullableExpr, unsafeLiftOpNull )

25+import Rel8.Expr.Null ( isNull, isNonNull, nullable, unsafeLiftOpNull )

26import Rel8.Expr.Opaleye ( toPrimExpr, zipPrimExprsWith )

27−import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )

27+import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql )

28+import qualified Rel8.Schema.Null as Schema ( nullable )

28import Rel8.Type.Ord ( DBOrd )

29import Rel8.Type.Ord ( DBOrd )

@@ -48,7 +49,7 @@ ge = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:>=))

48-- as @null@ will sort below any other value. For a version of @<@ that exactly

49-- as @null@ will sort below any other value. For a version of @<@ that exactly

49-- matches SQL, see '(<?)'.

50-- matches SQL, see '(<?)'.

50(<.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool

51(<.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool

51−(<.) = case nullable @a of

52+(<.) = case Schema.nullable @a of

52 Null -> \ma mb -> isNull ma &&. isNonNull mb ||. ma <? mb

53 Null -> \ma mb -> isNull ma &&. isNonNull mb ||. ma <? mb

53 NotNull -> lt

54 NotNull -> lt

54infix 4 <.

55infix 4 <.

@@ -58,7 +59,7 @@ infix 4 <.

58-- as @null@ will sort below any other value. For a version of @<=@ that exactly

59-- as @null@ will sort below any other value. For a version of @<=@ that exactly

59-- matches SQL, see '(<=?)'.

60-- matches SQL, see '(<=?)'.

60(<=.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool

61(<=.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool

61−(<=.) = case nullable @a of

62+(<=.) = case Schema.nullable @a of

62 Null -> \ma mb -> isNull ma ||. ma <=? mb

63 Null -> \ma mb -> isNull ma ||. ma <=? mb

63 NotNull -> le

64 NotNull -> le

64infix 4 <=.

65infix 4 <=.

@@ -68,7 +69,7 @@ infix 4 <=.

68-- as @null@ will sort below any other value. For a version of @>@ that exactly

69-- as @null@ will sort below any other value. For a version of @>@ that exactly

69-- matches SQL, see '(>?)'.

70-- matches SQL, see '(>?)'.

70(>.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool

71(>.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool

71−(>.) = case nullable @a of

72+(>.) = case Schema.nullable @a of

72 Null -> \ma mb -> isNonNull ma &&. isNull mb ||. ma >? mb

73 Null -> \ma mb -> isNonNull ma &&. isNull mb ||. ma >? mb

73 NotNull -> gt

74 NotNull -> gt

74infix 4 >.

75infix 4 >.

@@ -78,7 +79,7 @@ infix 4 >.

78-- as @null@ will sort below any other value. For a version of @>=@ that

79-- as @null@ will sort below any other value. For a version of @>=@ that

79-- exactly matches SQL, see '(>=?)'.

80-- exactly matches SQL, see '(>=?)'.

80(>=.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool

81(>=.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool

81−(>=.) = case nullable @a of

82+(>=.) = case Schema.nullable @a of

82 Null -> \ma mb -> isNull mb ||. ma >=? mb

83 Null -> \ma mb -> isNull mb ||. ma >=? mb

83 NotNull -> ge

84 NotNull -> ge

84infix 4 >=.

85infix 4 >=.

@@ -117,8 +118,8 @@ infix 4 >=?

117--

118--

118-- Corresponds to the SQL @least()@ function.

119-- Corresponds to the SQL @least()@ function.

119leastExpr :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr a

120leastExpr :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr a

120−leastExpr ma mb = case nullable @a of

121+leastExpr ma mb = case Schema.nullable @a of

121− Null -> nullableExpr ma (\a -> nullableExpr mb (least_ a) mb) ma

122+ Null -> nullable ma (\a -> nullable mb (least_ a) mb) ma

122 NotNull -> least_ ma mb

123 NotNull -> least_ ma mb

123 where

124 where

124 least_ a b = Expr (Opaleye.FunExpr "LEAST" [toPrimExpr a, toPrimExpr b])

125 least_ a b = Expr (Opaleye.FunExpr "LEAST" [toPrimExpr a, toPrimExpr b])

@@ -129,8 +130,8 @@ leastExpr ma mb = case nullable @a of

129--

130--

130-- Corresponds to the SQL @greatest()@ function.

131-- Corresponds to the SQL @greatest()@ function.

131greatestExpr :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr a

132greatestExpr :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr a

132−greatestExpr ma mb = case nullable @a of

133+greatestExpr ma mb = case Schema.nullable @a of

133− Null -> nullableExpr mb (\a -> nullableExpr ma (greatest_ a) mb) ma

134+ Null -> nullable mb (\a -> nullable ma (greatest_ a) mb) ma

134 NotNull -> greatest_ ma mb

135 NotNull -> greatest_ ma mb

135 where

136 where

136 greatest_ a b =

137 greatest_ a b =

src/Rel8/Expr/Sequence.hsdeleted−22

@@ -1,22 +0,0 @@

1−module Rel8.Expr.Sequence

2− ( nextval

3− )

4−where

5−

6−-- base

7−import Data.Int ( Int64 )

8−import Prelude

9−

10−-- rel8

11−import Rel8.Expr ( Expr )

12−import Rel8.Expr.Function ( function )

13−import Rel8.Expr.Serialize ( litExpr )

14−import Rel8.Expr.Text ( quoteIdent )

15−

16−-- text

17−import Data.Text ( pack )

18−

19−

20−-- | See https://www.postgresql.org/docs/current/functions-sequence.html

21−nextval :: String -> Expr Int64

22−nextval = function "nextval" . quoteIdent . litExpr . pack

src/Rel8/Expr/Text.hs+4−24

@@ -17,9 +17,6 @@ module Rel8.Expr.Text

17 , pgClientEncoding, quoteIdent, quoteLiteral, quoteNullable, regexpReplace

18 , regexpSplitToArray, repeat, replace, reverse, right, rpad, rtrim

19 , splitPart, strpos, substr, translate

20−

21− -- * @LIKE@ and @ILIKE@

22− , like, ilike

23 )

20 )

24where

21where

@@ -27,7 +24,7 @@ where

27import Data.Bool ( Bool )

24import Data.Bool ( Bool )

28import Data.Int ( Int32 )

25import Data.Int ( Int32 )

29import Data.Maybe ( Maybe( Nothing, Just ) )

26import Data.Maybe ( Maybe( Nothing, Just ) )

30−import Prelude ( flip )

27+import Prelude ()

32-- bytestring

29-- bytestring

33import Data.ByteString ( ByteString )

30import Data.ByteString ( ByteString )

@@ -35,6 +32,7 @@ import Data.ByteString ( ByteString )

35-- rel8

32-- rel8

36import Rel8.Expr ( Expr )

33import Rel8.Expr ( Expr )

37import Rel8.Expr.Function ( binaryOperator, function, nullaryFunction )

34import Rel8.Expr.Function ( binaryOperator, function, nullaryFunction )

35+import Rel8.Type.Array1D ( Array1D )

39-- text

37-- text

40import Data.Text (Text)

38import Data.Text (Text)

@@ -52,7 +50,7 @@ infixr 6 ++.

54-- | Matches regular expression, case sensitive

52-- | Matches regular expression, case sensitive

55−--

53+--

56-- Corresponds to the @~.@ operator.

54-- Corresponds to the @~.@ operator.

57(~.) :: Expr Text -> Expr Text -> Expr Bool

55(~.) :: Expr Text -> Expr Text -> Expr Bool

58(~.) = binaryOperator "~."

56(~.) = binaryOperator "~."

@@ -220,7 +218,7 @@ regexpReplace a b c Nothing = function "regexp_replace" a b c

220

218

221-- | Corresponds to the @regexp_split_to_array@ function.

219-- | Corresponds to the @regexp_split_to_array@ function.

222regexpSplitToArray :: ()

220regexpSplitToArray :: ()

223− => Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr [Text]

221+ => Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr (Array1D Text)

224regexpSplitToArray a b (Just c) = function "regexp_split_to_array" a b c

222regexpSplitToArray a b (Just c) = function "regexp_split_to_array" a b c

225regexpSplitToArray a b Nothing = function "regexp_split_to_array" a b

223regexpSplitToArray a b Nothing = function "regexp_split_to_array" a b

226

224

@@ -276,21 +274,3 @@ substr a b Nothing = function "substr" a b

276-- | Corresponds to the @translate@ function.

274-- | Corresponds to the @translate@ function.

277translate :: Expr Text -> Expr Text -> Expr Text -> Expr Text

275translate :: Expr Text -> Expr Text -> Expr Text -> Expr Text

278translate = function "translate"

276translate = function "translate"

279−

280−

281−-- | @like x y@ corresponds to the expression @y LIKE x@.

282−--

283−-- Note that the arguments to @like@ are swapped. This is to aid currying, so

284−-- you can write expressions like

285−-- @filter (like "Rel%" . packageName) =<< each haskellPackages@

286−like :: Expr Text -> Expr Text -> Expr Bool

287−like = flip (binaryOperator "LIKE")

288−

289−

290−-- | @ilike x y@ corresponds to the expression @y ILIKE x@.

291−--

292−-- Note that the arguments to @ilike@ are swapped. This is to aid currying, so

293−-- you can write expressions like

294−-- @filter (ilike "Rel%" . packageName) =<< each haskellPackages@

295−ilike :: Expr Text -> Expr Text -> Expr Bool

296−ilike = flip (binaryOperator "ILIKE")

src/Rel8/Expr/Time.hs+2−2

@@ -31,7 +31,7 @@ import Prelude

31-- rel8

32import Rel8.Expr ( Expr )

33import Rel8.Expr.Function ( binaryOperator, nullaryFunction )

34−import Rel8.Expr.Opaleye ( castExpr, unsafeCastExpr, unsafeLiteral )

34+import Rel8.Expr.Opaleye ( unsafeCastExpr, unsafeLiteral )

36-- time

37import Data.Time.Calendar ( Day )

@@ -164,4 +164,4 @@ years = (`scaleInterval` year)

164

165

166singleton :: String -> Expr CalendarDiffTime

167−singleton unit = castExpr $ unsafeLiteral $ "'1 " ++ unit ++ "'"

167+singleton unit = unsafeLiteral $ "'1 " ++ unit ++ "'"

src/Rel8/Expr/Window.hsdeleted−121

@@ -1,121 +0,0 @@

1−module Rel8.Expr.Window

2− ( cumulative

3− , rowNumber

4− , rank

5− , denseRank

6− , percentRank

7− , cumeDist

8− , ntile

9− , lag

10− , lead

11− , firstValue

12− , lastValue

13− , nthValue

14− )

15−where

16−

17−-- base

18−import Data.Int ( Int32, Int64 )

19−import Prelude

20−

21−-- opaleye

22−import qualified Opaleye.Internal.Aggregate as Opaleye

23−import qualified Opaleye.Internal.PackMap as Opaleye

24−import qualified Opaleye.Internal.Window as Opaleye

25−import qualified Opaleye.Window as Opaleye

26−

27−-- profunctors

28−import Data.Profunctor (dimap)

29−

30−-- rel8

31−import Rel8.Aggregate ( Aggregate( Aggregate ) )

32−import Rel8.Expr ( Expr )

33−import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr, toColumn, toPrimExpr )

34−import Rel8.Schema.Null ( Nullify )

35−import Rel8.Window ( Window( Window ) )

36−

37−

38−cumulative :: (a -> Aggregate b) -> Window a (Expr b)

39−cumulative f =

40− fromWindowFunction $ Opaleye.aggregatorWindowFunction (fromAggregate f) id

41−

42−

43−-- | [@row_number()@](https://www.postgresql.org/docs/current/functions-window.html)

44−rowNumber :: Window a (Expr Int64)

45−rowNumber = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.rowNumber

46−

47−

48−-- | [@rank()@](https://www.postgresql.org/docs/current/functions-window.html)

49−rank :: Window a (Expr Int64)

50−rank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.rank

51−

52−

53−-- | [@dense_rank()@](https://www.postgresql.org/docs/current/functions-window.html)

54−denseRank :: Window a (Expr Int64)

55−denseRank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.denseRank

56−

57−

58−-- | [@percent_rank()@](https://www.postgresql.org/docs/current/functions-window.html)

59−percentRank :: Window a (Expr Double)

60−percentRank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.percentRank

61−

62−

63−-- | [@cume_dist()@](https://www.postgresql.org/docs/current/functions-window.html)

64−cumeDist :: Window a (Expr Double)

65−cumeDist = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.cumeDist

66−

67−

68−-- | [@ntile(num_buckets)@](https://www.postgresql.org/docs/current/functions-window.html)

69−ntile :: Expr Int32 -> Window a (Expr Int32)

70−ntile buckets = fromWindowFunction $ fromPrimExpr . fromColumn <$>

71− Opaleye.ntile (toColumn (toPrimExpr buckets))

72−

73−

74−-- | [@lag(value, offset, default)@](https://www.postgresql.org/docs/current/functions-window.html)

75−lag :: Expr Int32 -> Expr a -> Window (Expr a) (Expr a)

76−lag offset def =

77− fromWindowFunction $

78− dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $

79− Opaleye.lag (toColumn (toPrimExpr offset)) (toColumn (toPrimExpr def))

80−

81−

82−-- | [@lead(value, offset, default)@](https://www.postgresql.org/docs/current/functions-window.html)

83−lead :: Expr Int32 -> Expr a -> Window (Expr a) (Expr a)

84−lead offset def =

85− fromWindowFunction $

86− dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $

87− Opaleye.lead (toColumn (toPrimExpr offset)) (toColumn (toPrimExpr def))

88−

89−

90−-- | [@first_value(value)@](https://www.postgresql.org/docs/current/functions-window.html)

91−firstValue :: Window (Expr a) (Expr a)

92−firstValue =

93− fromWindowFunction $

94− dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn)

95− Opaleye.firstValue

96−

97−

98−-- | [@last_value(value)@](https://www.postgresql.org/docs/current/functions-window.html)

99−lastValue :: Window (Expr a) (Expr a)

100−lastValue =

101− fromWindowFunction $

102− dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn)

103− Opaleye.lastValue

104−

105−

106−-- | [@nth_value(value, n)@](https://www.postgresql.org/docs/current/functions-window.html)

107−nthValue :: Expr Int32 -> Window (Expr a) (Expr (Nullify a))

108−nthValue n =

109− fromWindowFunction $

110− dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $

111− Opaleye.nthValue (toColumn (toPrimExpr n))

112−

113−

114−fromAggregate :: (a -> Aggregate b) -> Opaleye.Aggregator a (Expr b)

115−fromAggregate f = Opaleye.Aggregator $ Opaleye.PackMap $ \w a -> case f a of

116− Aggregate (Opaleye.Aggregator (Opaleye.PackMap x)) -> x w ()

117−

118−

119−fromWindowFunction :: Opaleye.WindowFunction a b -> Window a b

120−fromWindowFunction (Opaleye.WindowFunction (Opaleye.PackMap w)) =

121− Window $ Opaleye.Windows $ Opaleye.PackMap $ \f -> w $ \o -> f (o, mempty)

src/Rel8/FCF.hs+3−3

@@ -5,7 +5,7 @@

6module Rel8.FCF

7 ( Exp, Eval

8− , Id

8+ , Compose

9 )

10where

@@ -22,5 +22,5 @@ type Eval :: Exp e -> e

22type family Eval a

25−data Id :: a -> Exp a

25+data Compose :: (Type -> Type) -> (Type -> Exp Type) -> Type -> Exp Type

26−type instance Eval (Id a) = a

26+type instance Eval (Compose f g a) = f (Eval (g a))

src/Rel8/Generic/Construction.hs+300−199

@@ -2,6 +2,9 @@

2{-# language ConstraintKinds #-}

3{-# language DataKinds #-}

4{-# language FlexibleContexts #-}

5+{-# language FlexibleInstances #-}

6+{-# language LambdaCase #-}

7+{-# language MultiParamTypeClasses #-}

5{-# language NamedFieldPuns #-}

8{-# language NamedFieldPuns #-}

6{-# language ScopedTypeVariables #-}

9{-# language ScopedTypeVariables #-}

7{-# language StandaloneKindSignatures #-}

10{-# language StandaloneKindSignatures #-}

@@ -11,13 +14,13 @@

11{-# language ViewPatterns #-}

14{-# language ViewPatterns #-}

13module Rel8.Generic.Construction

16module Rel8.Generic.Construction

14− ( GGBuildable

15− , GGBuild, ggbuild

16− , GGConstructable

17+ ( GGConstructable

17 , GGConstruct, ggconstruct

18 , GGConstruct, ggconstruct

18 , GGDeconstruct, ggdeconstruct

19 , GGDeconstruct, ggdeconstruct

20+ , GGInsert, gginsert

19 , GGName, ggname

21 , GGName, ggname

20 , GGAggregate, ggaggregate

22 , GGAggregate, ggaggregate

23+ , GGAggregate', ggaggregate'

21 )

24 )

22where

25where

@@ -25,29 +28,27 @@ where

25import Data.Bifunctor ( first )

28import Data.Bifunctor ( first )

26import Data.Kind ( Constraint, Type )

29import Data.Kind ( Constraint, Type )

27import Data.List.NonEmpty ( NonEmpty( (:|) ) )

30import Data.List.NonEmpty ( NonEmpty( (:|) ) )

28−import GHC.TypeLits ( Symbol )

31+import Data.Type.Equality ( (:~:)( Refl ) )

29import Prelude

32import Prelude

31-- rel8

34-- rel8

32−import Rel8.Aggregate ( Aggregate( Aggregate ) )

35+import Rel8.Aggregate ( Col( Aggregation ), Aggregate )

33−import Rel8.Expr ( Expr )

36+import Rel8.Expr ( Col( DB ), Expr )

34import Rel8.Expr.Aggregate ( groupByExpr )

37import Rel8.Expr.Aggregate ( groupByExpr )

35import Rel8.Expr.Eq ( (==.) )

38import Rel8.Expr.Eq ( (==.) )

36import Rel8.Expr.Null ( nullify, snull, unsafeUnnullify )

39import Rel8.Expr.Null ( nullify, snull, unsafeUnnullify )

37import Rel8.Expr.Serialize ( litExpr )

40import Rel8.Expr.Serialize ( litExpr )

38−import Rel8.FCF ( Eval, Exp, Id )

41+import Rel8.FCF ( Compose, Eval, Exp )

39import Rel8.Generic.Construction.ADT

42import Rel8.Generic.Construction.ADT

40− ( GConstructorADT, GMakeableADT, gmakeADT

41− , GConstructableADT

43+ ( GConstructableADT

42 , GBuildADT, gbuildADT, gunbuildADT

44 , GBuildADT, gbuildADT, gunbuildADT

43 , GConstructADT, gconstructADT, gdeconstructADT

45 , GConstructADT, gconstructADT, gdeconstructADT

44− , RepresentableConstructors, GConstructors, gcindex, gctabulate

46+ , CorepConstructors, GConstructors, gcindex, gctabulate

45− , RepresentableFields, gfindex, gftabulate

47+ , CorepFields, gfindex, gftabulate, gftraverse

46 )

48 )

47import Rel8.Generic.Construction.Record

49import Rel8.Generic.Construction.Record

48− ( GConstructor

49− , GConstructable, GConstruct, gconstruct, gdeconstruct

50+ ( GConstructable, GConstruct, gconstruct, gdeconstruct

50− , Representable, gindex, gtabulate

51+ , Corep, gindex, gtabulate, gtraverse

51 )

52 )

52import Rel8.Generic.Table ( GGColumns )

53import Rel8.Generic.Table ( GGColumns )

53import Rel8.Kind.Algebra

54import Rel8.Kind.Algebra

@@ -55,92 +56,36 @@ import Rel8.Kind.Algebra

55 , KnownAlgebra, algebraSing

56 , KnownAlgebra, algebraSing

56 )

57 )

57import qualified Rel8.Kind.Algebra as K

58import qualified Rel8.Kind.Algebra as K

59+import Rel8.Kind.Necessity ( SNecessity( SOptional, SRequired ) )

58−import Rel8.Schema.Context.Nullify ( sguard, snullify )

60+import Rel8.Schema.Context.Nullify ( runTag )

59import Rel8.Schema.HTable ( HTable )

61import Rel8.Schema.HTable ( HTable )

60−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

62+import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )

63+import Rel8.Schema.Insert ( Col( OptionalInsert, RequiredInsert ), Insert )

61import qualified Rel8.Schema.Kind as K

64import qualified Rel8.Schema.Kind as K

62−import Rel8.Schema.Name ( Name( Name ) )

65+import Rel8.Schema.Name ( Col( NameCol ), Name( Name ) )

63import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

66import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

64−import Rel8.Schema.Spec ( Spec( Spec, nullity, info ) )

67+import Rel8.Schema.Spec ( SSpec( SSpec, necessity, nullity, info ) )

68+import Rel8.Schema.Reify ( Col( Reify ), Reify, hreify, hunreify )

69+import Rel8.Schema.Result ( Result )

65import Rel8.Table

70import Rel8.Table

66− ( TTable, TColumns

71+ ( TTable, TColumns, TUnreify

67− , Table, fromColumns, toColumns

72+ , Table, fromColumns, toColumns, reify, unreify

68 )

73 )

69import Rel8.Table.Bool ( case_ )

74import Rel8.Table.Bool ( case_ )

70import Rel8.Type.Tag ( Tag )

75import Rel8.Type.Tag ( Tag )

72−

77+-- semigroupoids

73−type GGBuildable :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Constraint

78+import Data.Functor.Apply ( Apply, MaybeApply( MaybeApply ), liftF2 )

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

137type GGConstructable :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint

81type GGConstructable :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint

138type GGConstructable algebra rep =

82type GGConstructable algebra rep =

139 ( KnownAlgebra algebra

83 ( KnownAlgebra algebra

140− , Eval (GGColumns algebra TColumns (Eval (rep Aggregate))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))

84+ , Eval (GGColumns algebra TColumns (Eval (rep (Reify Aggregate)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))

141− , Eval (GGColumns algebra TColumns (Eval (rep Expr))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))

85+ , Eval (GGColumns algebra TColumns (Eval (rep (Reify Expr)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))

86+ , Eval (GGColumns algebra TColumns (Eval (rep (Reify Insert)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))

142− , Eval (GGColumns algebra TColumns (Eval (rep Name))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))

87+ , Eval (GGColumns algebra TColumns (Eval (rep (Reify Name)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))

143− , HTable (Eval (GGColumns algebra TColumns (Eval (rep Expr))))

88+ , HTable (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))))

144 , GGConstructable' algebra rep

89 , GGConstructable' algebra rep

145 )

90 )

146

@@ -148,100 +93,112 @@ type GGConstructable algebra rep =

148type GGConstructable' :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint

93type GGConstructable' :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint

149type family GGConstructable' algebra rep where

94type family GGConstructable' algebra rep where

150 GGConstructable' 'K.Product rep =

95 GGConstructable' 'K.Product rep =

151− ( Representable Id (Eval (rep Aggregate))

96+ ( Corep (Compose Aggregate TUnreify) (Eval (rep (Reify Expr)))

97+ , Corep TUnreify (Eval (rep (Reify Aggregate)))

152− , Representable Id (Eval (rep Expr))

98+ , Corep TUnreify (Eval (rep (Reify Expr)))

99+ , Corep TUnreify (Eval (rep (Reify Insert)))

153− , Representable Id (Eval (rep Name))

100+ , Corep TUnreify (Eval (rep (Reify Name)))

154− , GConstructable (TTable Aggregate) TColumns Id Aggregate (Eval (rep Aggregate))

101+ , GConstructable (TTable (Reify Aggregate)) TColumns TUnreify (Col (Reify Aggregate)) (Eval (rep (Reify Aggregate)))

155− , GConstructable (TTable Expr) TColumns Id Expr (Eval (rep Expr))

102+ , GConstructable (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) (Eval (rep (Reify Expr)))

103+ , GConstructable (TTable (Reify Insert)) TColumns TUnreify (Col (Reify Insert)) (Eval (rep (Reify Insert)))

156− , GConstructable (TTable Name) TColumns Id Name (Eval (rep Name))

104+ , GConstructable (TTable (Reify Name)) TColumns TUnreify (Col (Reify Name)) (Eval (rep (Reify Name)))

157 )

105 )

158 GGConstructable' 'K.Sum rep =

106 GGConstructable' 'K.Sum rep =

159− ( RepresentableConstructors Id (Eval (rep Expr))

107+ ( CorepConstructors TUnreify (Eval (rep (Reify Expr)))

108+ , CorepConstructors TUnreify (Eval (rep (Reify Insert)))

109+ , CorepFields (Compose Aggregate TUnreify) (Eval (rep (Reify Expr)))

160− , RepresentableFields Id (Eval (rep Aggregate))

110+ , CorepFields TUnreify (Eval (rep (Reify Aggregate)))

161− , RepresentableFields Id (Eval (rep Expr))

111+ , CorepFields TUnreify (Eval (rep (Reify Expr)))

162− , RepresentableFields Id (Eval (rep Name))

112+ , CorepFields TUnreify (Eval (rep (Reify Name)))

163− , Functor (GConstructors Id (Eval (rep Expr)))

113+ , Functor (GConstructors TUnreify (Eval (rep (Reify Expr))))

114+ , Functor (GConstructors TUnreify (Eval (rep (Reify Insert))))

164− , GConstructableADT (TTable Aggregate) TColumns Id Aggregate (Eval (rep Aggregate))

115+ , GConstructableADT (TTable (Reify Aggregate)) TColumns TUnreify (Col (Reify Aggregate)) (Eval (rep (Reify Aggregate)))

165− , GConstructableADT (TTable Expr) TColumns Id Expr (Eval (rep Expr))

116+ , GConstructableADT (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) (Eval (rep (Reify Expr)))

117+ , GConstructableADT (TTable (Reify Insert)) TColumns TUnreify (Col (Reify Insert)) (Eval (rep (Reify Insert)))

166− , GConstructableADT (TTable Name) TColumns Id Name (Eval (rep Name))

118+ , GConstructableADT (TTable (Reify Name)) TColumns TUnreify (Col (Reify Name)) (Eval (rep (Reify Name)))

167 )

119 )

168

120

169

121

170type GGConstruct :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type

122type GGConstruct :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type

171−type family GGConstruct algebra rep r where

123+type family GGConstruct algebra rep a where

172− GGConstruct 'K.Product rep r = GConstruct Id (Eval (rep Expr)) r -> r

124+ GGConstruct 'K.Product rep a = GConstruct TUnreify (Eval (rep (Reify Expr))) a

125+ GGConstruct 'K.Sum rep a =

126+ -- Ideally this would be as follows, but GHC complains about "illegal polymorphic type"

173− GGConstruct 'K.Sum rep r = GConstructADT Id (Eval (rep Expr)) r r

127+ -- (forall r. GConstructADT TUnreify (Eval (rep (Reify Expr))) r r) -> a

128+ GConstructADT TUnreify (Eval (rep (Reify Expr))) a a -> a

174

129

175

130

176ggconstruct :: forall algebra rep a. GGConstructable algebra rep

131ggconstruct :: forall algebra rep a. GGConstructable algebra rep

177− => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a)

132+ => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr) -> a)

178− -> GGConstruct algebra rep a -> a

133+ -> GGConstruct algebra rep a

179−ggconstruct gfromColumns f = case algebraSing @algebra of

134+ggconstruct gfromColumns = case algebraSing @algebra of

180 SProduct ->

135 SProduct ->

181− f $

182− gtabulate @Id @(Eval (rep Expr)) @a $

136+ gtabulate @TUnreify @(Eval (rep (Reify Expr))) @a $

183 gfromColumns .

137 gfromColumns .

138+ hunreify .

184 gconstruct

139 gconstruct

185− @(TTable Expr)

140+ @(TTable (Reify Expr))

186 @TColumns

141 @TColumns

187− @Id

142+ @TUnreify

188− @Expr

143+ @(Col (Reify Expr))

189− @(Eval (rep Expr))

144+ @(Eval (rep (Reify Expr)))

190− (const toColumns)

145+ (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)

191− SSum ->

146+ SSum -> \f ->

192− gcindex @Id @(Eval (rep Expr)) @a f $

147+ gcindex @TUnreify @(Eval (rep (Reify Expr))) @a f $

193− fmap gfromColumns $

148+ fmap (gfromColumns . hunreify) $

194 gconstructADT

149 gconstructADT

195− @(TTable Expr)

150+ @(TTable (Reify Expr))

196 @TColumns

151 @TColumns

197− @Id

152+ @TUnreify

198− @Expr

153+ @(Col (Reify Expr))

199− @(Eval (rep Expr))

154+ @(Eval (rep (Reify Expr)))

200− (const toColumns)

155+ (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)

201− (\Spec {info} -> snull info)

156+ (\SSpec {info} -> Reify (DB (snull info)))

202− (\Spec {nullity} -> case nullity of

157+ (\SSpec {nullity} -> case nullity of

203 Null -> id

158 Null -> id

204− NotNull -> nullify)

159+ NotNull -> \(Reify (DB a)) -> Reify (DB (nullify a)))

205− (HIdentity . litExpr)

160+ (HType . Reify . DB . litExpr)

206

161

207

162

208type GGDeconstruct :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type -> Type

163type GGDeconstruct :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type -> Type

209type family GGDeconstruct algebra rep a r where

164type family GGDeconstruct algebra rep a r where

210 GGDeconstruct 'K.Product rep a r =

165 GGDeconstruct 'K.Product rep a r =

211− GConstruct Id (Eval (rep Expr)) r -> a -> r

166+ GConstruct TUnreify (Eval (rep (Reify Expr))) r -> a -> r

212 GGDeconstruct 'K.Sum rep a r =

167 GGDeconstruct 'K.Sum rep a r =

213− GConstructADT Id (Eval (rep Expr)) r (a -> r)

168+ GConstructADT TUnreify (Eval (rep (Reify Expr))) r (a -> r)

214

169

215

170

216ggdeconstruct :: forall algebra rep a r. (GGConstructable algebra rep, Table Expr r)

171ggdeconstruct :: forall algebra rep a r. (GGConstructable algebra rep, Table Expr r)

217− => (a -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)

172+ => (a -> Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr))

218 -> GGDeconstruct algebra rep a r

173 -> GGDeconstruct algebra rep a r

219ggdeconstruct gtoColumns = case algebraSing @algebra of

174ggdeconstruct gtoColumns = case algebraSing @algebra of

220 SProduct -> \build ->

175 SProduct -> \build ->

221− gindex @Id @(Eval (rep Expr)) @r build .

176+ gindex @TUnreify @(Eval (rep (Reify Expr))) @r build .

222 gdeconstruct

177 gdeconstruct

223− @(TTable Expr)

178+ @(TTable (Reify Expr))

224 @TColumns

179 @TColumns

225− @Id

180+ @TUnreify

226− @Expr

181+ @(Col (Reify Expr))

227− @(Eval (rep Expr))

182+ @(Eval (rep (Reify Expr)))

228− (const fromColumns) .

183+ (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns) .

184+ hreify .

229 gtoColumns

185 gtoColumns

230 SSum ->

186 SSum ->

231− gctabulate @Id @(Eval (rep Expr)) @r @(a -> r) $ \constructors as ->

187+ gctabulate @TUnreify @(Eval (rep (Reify Expr))) @r @(a -> r) $ \constructors as ->

232 let

188 let

233− (HIdentity tag, cases) =

189+ (HType (Reify (DB tag)), cases) =

234 gdeconstructADT

190 gdeconstructADT

235− @(TTable Expr)

191+ @(TTable (Reify Expr))

236 @TColumns

192 @TColumns

237− @Id

193+ @TUnreify

238− @Expr

194+ @(Col (Reify Expr))

239− @(Eval (rep Expr))

195+ @(Eval (rep (Reify Expr)))

240− (const fromColumns)

196+ (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns)

241− (\Spec {nullity} -> case nullity of

197+ (\SSpec {nullity} -> case nullity of

242 Null -> id

198 Null -> id

243− NotNull -> unsafeUnnullify)

199+ NotNull -> \(Reify (DB a)) -> Reify (DB (unsafeUnnullify a)))

244 constructors $

200 constructors $

201+ hreify $

245 gtoColumns as

202 gtoColumns as

246 in

203 in

247 case cases of

204 case cases of

@@ -249,104 +206,248 @@ ggdeconstruct gtoColumns = case algebraSing @algebra of

249 case_ cases' r

206 case_ cases' r

250

207

251

208

209+type GGInsert :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type

210+type family GGInsert algebra rep a where

211+ GGInsert 'K.Product rep a = GConstruct TUnreify (Eval (rep (Reify Insert))) a

212+ GGInsert 'K.Sum rep a =

213+ -- Ideally this would be as follows, but GHC complains about "illegal polymorphic type"

214+ -- (forall r. GConstructADT TUnreify (Eval (rep (Reify Insert))) r r) -> a

215+ GConstructADT TUnreify (Eval (rep (Reify Insert))) a a -> a

216+

217+

218+gginsert :: forall algebra rep a. GGConstructable algebra rep

219+ => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Insert) -> a)

220+ -> GGInsert algebra rep a

221+gginsert gfromColumns = case algebraSing @algebra of

222+ SProduct ->

223+ gtabulate @TUnreify @(Eval (rep (Reify Insert))) @a $

224+ gfromColumns .

225+ hunreify .

226+ gconstruct

227+ @(TTable (Reify Insert))

228+ @TColumns

229+ @TUnreify

230+ @(Col (Reify Insert))

231+ @(Eval (rep (Reify Insert)))

232+ (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)

233+ SSum -> \f ->

234+ gcindex @TUnreify @(Eval (rep (Reify Insert))) @a f $

235+ fmap (gfromColumns . hunreify) $

236+ gconstructADT

237+ @(TTable (Reify Insert))

238+ @TColumns

239+ @TUnreify

240+ @(Col (Reify Insert))

241+ @(Eval (rep (Reify Insert)))

242+ (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)

243+ (\SSpec {necessity, info} -> Reify $ case necessity of

244+ SRequired -> RequiredInsert (snull info)

245+ SOptional -> OptionalInsert (Just (snull info)))

246+ (\SSpec {nullity} -> case nullity of

247+ Null -> id

248+ NotNull -> \case

249+ Reify (RequiredInsert a) -> Reify (RequiredInsert (nullify a))

250+ Reify (OptionalInsert a) -> Reify (OptionalInsert (nullify <$> a)))

251+ (HType . Reify . RequiredInsert . litExpr)

252+

253+

252type GGName :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type

254type GGName :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type

253type family GGName algebra rep a where

255type family GGName algebra rep a where

254− GGName 'K.Product rep a = GConstruct Id (Eval (rep Name)) a

256+ GGName 'K.Product rep a = GConstruct TUnreify (Eval (rep (Reify Name))) a

255− GGName 'K.Sum rep a = Name Tag -> GBuildADT Id (Eval (rep Name)) a

257+ GGName 'K.Sum rep a = Name Tag -> GBuildADT TUnreify (Eval (rep (Reify Name))) a

256

258

257

259

258ggname :: forall algebra rep a. GGConstructable algebra rep

260ggname :: forall algebra rep a. GGConstructable algebra rep

259− => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Name -> a)

261+ => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Name) -> a)

260 -> GGName algebra rep a

262 -> GGName algebra rep a

261ggname gfromColumns = case algebraSing @algebra of

263ggname gfromColumns = case algebraSing @algebra of

262 SProduct ->

264 SProduct ->

263− gtabulate @Id @(Eval (rep Name)) @a $

265+ gtabulate @TUnreify @(Eval (rep (Reify Name))) @a $

264 gfromColumns .

266 gfromColumns .

267+ hunreify .

265 gconstruct

268 gconstruct

266− @(TTable Name)

269+ @(TTable (Reify Name))

267 @TColumns

270 @TColumns

268− @Id

271+ @TUnreify

269− @Name

272+ @(Col (Reify Name))

270− @(Eval (rep Name))

273+ @(Eval (rep (Reify Name)))

271− (const toColumns)

274+ (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)

272 SSum -> \tag ->

275 SSum -> \tag ->

273− gftabulate @Id @(Eval (rep Name)) @a $

276+ gftabulate @TUnreify @(Eval (rep (Reify Name))) @a $

274 gfromColumns .

277 gfromColumns .

278+ hunreify .

275 gbuildADT

279 gbuildADT

276− @(TTable Name)

280+ @(TTable (Reify Name))

277 @TColumns

281 @TColumns

278− @Id

282+ @TUnreify

279− @Name

283+ @(Col (Reify Name))

280− @(Eval (rep Name))

284+ @(Eval (rep (Reify Name)))

281− (const toColumns)

285+ (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)

282− (\_ _ (Name a) -> Name a)

286+ (\_ _ (Reify (NameCol a)) -> Reify (NameCol a))

283− (HIdentity tag)

287+ (HType ((\(Name a) -> Reify (NameCol a)) tag))

284

288

285

289

286type GGAggregate :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type

290type GGAggregate :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type

287type family GGAggregate algebra rep r where

291type family GGAggregate algebra rep r where

288 GGAggregate 'K.Product rep r =

292 GGAggregate 'K.Product rep r =

289− GConstruct Id (Eval (rep Aggregate)) r ->

293+ GConstruct (Compose Aggregate TUnreify) (Eval (rep (Reify Expr))) r ->

290− GConstruct Id (Eval (rep Expr)) r

294+ GConstruct TUnreify (Eval (rep (Reify Expr))) r

291 GGAggregate 'K.Sum rep r =

295 GGAggregate 'K.Sum rep r =

292− GBuildADT Id (Eval (rep Aggregate)) r ->

296+ GBuildADT (Compose Aggregate TUnreify) (Eval (rep (Reify Expr))) r ->

293− GBuildADT Id (Eval (rep Expr)) r

297+ GBuildADT TUnreify (Eval (rep (Reify Expr))) r

294

298

295

299

296−ggaggregate :: forall algebra rep exprs agg. GGConstructable algebra rep

300+ggaggregate :: forall algebra rep a. GGConstructable algebra rep

297− => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Aggregate -> agg)

301+ => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr) -> a)

298− -> (exprs -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)

302+ -> (a -> Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr))

299− -> GGAggregate algebra rep agg -> exprs -> agg

303+ -> GGAggregate algebra rep (Aggregate a) -> a -> Aggregate a

300ggaggregate gfromColumns gtoColumns agg es = case algebraSing @algebra of

304ggaggregate gfromColumns gtoColumns agg es = case algebraSing @algebra of

305+ SProduct -> flip f exprs $

306+ fmap

307+ ( gfromColumns

308+ . hunreify

309+ . gconstruct

310+ @(TTable (Reify Expr))

311+ @TColumns

312+ @TUnreify

313+ @(Col (Reify Expr))

314+ @(Eval (rep (Reify Expr)))

315+ (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)

316+ ) .

317+ liftF½ .

318+ gtraverse @TUnreify @(Eval (rep (Reify Expr))) @_ @Aggregate (MaybeApply . Left)

319+ where

320+ f =

321+ gindex @TUnreify @(Eval (rep (Reify Expr))) @(Aggregate a) .

322+ agg .

323+ gtabulate @(Compose Aggregate TUnreify) @(Eval (rep (Reify Expr))) @(Aggregate a)

324+ exprs =

325+ gdeconstruct

326+ @(TTable (Reify Expr))

327+ @TColumns

328+ @TUnreify

329+ @(Col (Reify Expr))

330+ @(Eval (rep (Reify Expr)))

331+ (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns) $

332+ hreify $

333+ gtoColumns es

334+ SSum -> flip f exprs $

335+ liftF1½

336+ (\tag' ->

337+ gfromColumns .

338+ hunreify .

339+ gbuildADT

340+ @(TTable (Reify Expr))

341+ @TColumns

342+ @TUnreify

343+ @(Col (Reify Expr))

344+ @(Eval (rep (Reify Expr)))

345+ (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)

346+ (\tag'' SSpec {nullity} (Reify (DB a)) ->

347+ Reify $ DB $ runTag nullity (tag ==. litExpr tag'') a)

348+ (HType (Reify (DB tag'))))

349+ (groupByExpr tag) .

350+ gftraverse @TUnreify @(Eval (rep (Reify Expr))) @_ @Aggregate (MaybeApply . Left)

351+ where

352+ f =

353+ gfindex @TUnreify @(Eval (rep (Reify Expr))) @(Aggregate a) .

354+ agg .

355+ gftabulate @(Compose Aggregate TUnreify) @(Eval (rep (Reify Expr))) @(Aggregate a)

356+ (HType (Reify (DB tag)), exprs) =

357+ gunbuildADT

358+ @(TTable (Reify Expr))

359+ @TColumns

360+ @TUnreify

361+ @(Col (Reify Expr))

362+ @(Eval (rep (Reify Expr)))

363+ (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns)

364+ (\SSpec {nullity} -> case nullity of

365+ Null -> id

366+ NotNull -> \(Reify (DB a)) -> Reify (DB (unsafeUnnullify a))) $

367+ hreify $

368+ gtoColumns es

369+

370+

371+type GGAggregate' :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type

372+type family GGAggregate' algebra rep r where

373+ GGAggregate' 'K.Product rep r =

374+ GConstruct TUnreify (Eval (rep (Reify Aggregate))) r ->

375+ GConstruct TUnreify (Eval (rep (Reify Expr))) r

376+ GGAggregate' 'K.Sum rep r =

377+ GBuildADT TUnreify (Eval (rep (Reify Aggregate))) r ->

378+ GBuildADT TUnreify (Eval (rep (Reify Expr))) r

379+

380+

381+ggaggregate' :: forall algebra rep exprs agg. GGConstructable algebra rep

382+ => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Aggregate) -> agg)

383+ -> (exprs -> Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr))

384+ -> GGAggregate' algebra rep agg -> exprs -> agg

385+ggaggregate' gfromColumns gtoColumns agg es = case algebraSing @algebra of

301 SProduct -> flip f exprs $

386 SProduct -> flip f exprs $

302 gfromColumns .

387 gfromColumns .

388+ hunreify .

303 gconstruct

389 gconstruct

304− @(TTable Aggregate)

390+ @(TTable (Reify Aggregate))

305 @TColumns

391 @TColumns

306− @Id

392+ @TUnreify

307− @Aggregate

393+ @(Col (Reify Aggregate))

308− @(Eval (rep Aggregate))

394+ @(Eval (rep (Reify Aggregate)))

309− (const toColumns)

395+ (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)

310 where

396 where

311 f =

397 f =

312− gindex @Id @(Eval (rep Expr)) @agg .

398+ gindex @TUnreify @(Eval (rep (Reify Expr))) @agg .

313 agg .

399 agg .

314− gtabulate @Id @(Eval (rep Aggregate)) @agg

400+ gtabulate @TUnreify @(Eval (rep (Reify Aggregate))) @agg

315 exprs =

401 exprs =

316 gdeconstruct

402 gdeconstruct

317− @(TTable Expr)

403+ @(TTable (Reify Expr))

318 @TColumns

404 @TColumns

319− @Id

405+ @TUnreify

320− @Expr

406+ @(Col (Reify Expr))

321− @(Eval (rep Expr))

407+ @(Eval (rep (Reify Expr)))

322− (const fromColumns) $

408+ (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns) $

409+ hreify $

323 gtoColumns es

410 gtoColumns es

324 SSum -> flip f exprs $

411 SSum -> flip f exprs $

325 gfromColumns .

412 gfromColumns .

413+ hunreify .

326 gbuildADT

414 gbuildADT

327− @(TTable Aggregate)

415+ @(TTable (Reify Aggregate))

328 @TColumns

416 @TColumns

329− @Id

417+ @TUnreify

330− @Aggregate

418+ @(Col (Reify Aggregate))

331− @(Eval (rep Aggregate))

419+ @(Eval (rep (Reify Aggregate)))

332− (const toColumns)

420+ (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)

333− (\tag' Spec {nullity} (Aggregate a) ->

421+ (\tag' SSpec {nullity} (Reify (Aggregation a)) ->

334− Aggregate $ sguard (tag ==. litExpr tag') . snullify nullity <$> a)

422+ Reify $ Aggregation $ runTag nullity (tag ==. litExpr tag') <$> a)

335− (HIdentity (groupByExpr tag))

423+ (HType (Reify (Aggregation (groupByExpr tag))))

336 where

424 where

337 f =

425 f =

338− gfindex @Id @(Eval (rep Expr)) @agg .

426+ gfindex @TUnreify @(Eval (rep (Reify Expr))) @agg .

339 agg .

427 agg .

340− gftabulate @Id @(Eval (rep Aggregate)) @agg

428+ gftabulate @TUnreify @(Eval (rep (Reify Aggregate))) @agg

341− (HIdentity tag, exprs) =

429+ (HType (Reify (DB tag)), exprs) =

342 gunbuildADT

430 gunbuildADT

343− @(TTable Expr)

431+ @(TTable (Reify Expr))

344 @TColumns

432 @TColumns

345− @Id

433+ @TUnreify

346− @Expr

434+ @(Col (Reify Expr))

347− @(Eval (rep Expr))

435+ @(Eval (rep (Reify Expr)))

348− (const fromColumns)

436+ (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns)

349− (\Spec {nullity} -> case nullity of

437+ (\SSpec {nullity} -> case nullity of

350 Null -> id

438 Null -> id

351− NotNull -> unsafeUnnullify) $

439+ NotNull -> \(Reify (DB a)) -> Reify (DB (unsafeUnnullify a))) $

440+ hreify $

352 gtoColumns es

441 gtoColumns es

442+

443+

444+liftF½ :: MaybeApply Aggregate a -> Aggregate a

445+liftF½ (MaybeApply ma) = case ma of

446+ Left a -> a

447+ Right a -> a <$ groupByExpr (litExpr False)

448+

449+

450+liftF1½ :: Apply v => (a -> b -> c) -> v a -> MaybeApply v b -> v c

451+liftF1½ f a (MaybeApply eb) = case eb of

452+ Left b -> liftF2 f a b

453+ Right b -> fmap (`f` b) a

src/Rel8/Generic/Construction/ADT.hs+59−178

@@ -1,7 +1,6 @@

1{-# language AllowAmbiguousTypes #-}

2{-# language BlockArguments #-}

3{-# language DataKinds #-}

4−{-# language FlexibleContexts #-}

5{-# language FlexibleInstances #-}

4{-# language FlexibleInstances #-}

6{-# language MultiParamTypeClasses #-}

5{-# language MultiParamTypeClasses #-}

7{-# language RankNTypes #-}

6{-# language RankNTypes #-}

@@ -17,13 +16,13 @@ module Rel8.Generic.Construction.ADT

17 ( GConstructableADT

16 ( GConstructableADT

18 , GBuildADT, gbuildADT, gunbuildADT

17 , GBuildADT, gbuildADT, gunbuildADT

19 , GConstructADT, gconstructADT, gdeconstructADT

18 , GConstructADT, gconstructADT, gdeconstructADT

20− , GFields, RepresentableFields, gftabulate, gfindex

19+ , GFields, CorepFields, gftabulate, gfindex, gftraverse

21− , GConstructors, RepresentableConstructors, gctabulate, gcindex

20+ , GConstructors, CorepConstructors, gctabulate, gcindex

22− , GConstructorADT, GMakeableADT, gmakeADT

23 )

21 )

24where

22where

26-- base

24-- base

25+import Control.Applicative ( liftA2 )

27import Data.Bifunctor ( first )

26import Data.Bifunctor ( first )

28import Data.Functor.Identity ( runIdentity )

27import Data.Functor.Identity ( runIdentity )

29import Data.Kind ( Constraint, Type )

28import Data.Kind ( Constraint, Type )

@@ -32,30 +31,28 @@ import Data.Proxy ( Proxy( Proxy ) )

32import GHC.Generics

31import GHC.Generics

33 ( (:+:), (:*:)( (:*:) ), M1, U1

32 ( (:+:), (:*:)( (:*:) ), M1, U1

34 , C, D

33 , C, D

35− , Meta( MetaData, MetaCons )

34+ , Meta( MetaCons )

36− )

37−import GHC.TypeLits

38− ( ErrorMessage( (:<>:), Text ), TypeError

39− , Symbol, KnownSymbol, symbolVal

40 )

35 )

36+import GHC.TypeLits ( KnownSymbol, symbolVal )

41import Prelude hiding ( null )

37import Prelude hiding ( null )

43-- rel8

39-- rel8

44−import Rel8.FCF ( Exp )

40+import Rel8.FCF ( Compose, Exp )

45import Rel8.Generic.Construction.Record

41import Rel8.Generic.Construction.Record

46 ( GConstruct, GConstructable, gconstruct, gdeconstruct

42 ( GConstruct, GConstructable, gconstruct, gdeconstruct

47− , GFields, Representable, gtabulate, gindex

43+ , GFields, Corep, gtabulate, gindex, gtraverse

48 , FromColumns, ToColumns

44 , FromColumns, ToColumns

49 )

45 )

50import Rel8.Generic.Table.ADT ( GColumnsADT, GColumnsADT' )

46import Rel8.Generic.Table.ADT ( GColumnsADT, GColumnsADT' )

51import Rel8.Generic.Table.Record ( GColumns )

47import Rel8.Generic.Table.Record ( GColumns )

48+import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )

52import Rel8.Schema.HTable ( HTable )

49import Rel8.Schema.HTable ( HTable )

53−import Rel8.Schema.HTable.Identity ( HIdentity )

50+import Rel8.Schema.HTable.Identity ( HType )

54import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )

51import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )

55import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify )

52import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify )

56import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )

53import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )

57import Rel8.Schema.Null ( Nullify )

54import Rel8.Schema.Null ( Nullify )

58−import Rel8.Schema.Spec ( Spec )

55+import Rel8.Schema.Spec ( Spec( Spec ), SSpec )

59import qualified Rel8.Schema.Kind as K

56import qualified Rel8.Schema.Kind as K

60import Rel8.Type.Tag ( Tag( Tag ) )

57import Rel8.Type.Tag ( Tag( Tag ) )

@@ -63,42 +60,24 @@ import Rel8.Type.Tag ( Tag( Tag ) )

63import Data.Text ( pack )

60import Data.Text ( pack )

66−type Null :: K.Context -> Type

63+type Null :: K.HContext -> Type

67−type Null context = forall a. Spec a -> context (Nullify a)

64+type Null context = forall labels necessity a. ()

68−

65+ => SSpec ('Spec labels necessity a)

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

66+ -> context ('Spec labels necessity (Nullify 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− )

88−type GConstructorADT :: Symbol -> (Type -> Type) -> Type -> Type

69+type Nullifier :: K.HContext -> Type

89−type family GConstructorADT name rep where

70+type Nullifier context = forall labels necessity a. ()

90− GConstructorADT name (M1 D ('MetaData datatype _ _ _) rep) =

71+ => SSpec ('Spec labels necessity a)

91− GConstructorADT' name rep (TypeError (NoConstructor datatype name))

72+ -> context ('Spec labels necessity a)

73+ -> context ('Spec labels necessity (Nullify a))

94−type GConstructorADT' :: Symbol -> (Type -> Type) -> (Type -> Type) -> Type -> Type

76+type Unnullifier :: K.HContext -> Type

95−type family GConstructorADT' name rep fallback where

77+type Unnullifier context = forall labels necessity a. ()

96− GConstructorADT' name (M1 D _ rep) fallback =

78+ => SSpec ('Spec labels necessity a)

97− GConstructorADT' name rep fallback

79+ -> context ('Spec labels necessity (Nullify a))

98− GConstructorADT' name (a :+: b) fallback =

80+ -> context ('Spec labels necessity a)

99− GConstructorADT' name a (GConstructorADT' name b fallback)

100− GConstructorADT' name (M1 C ('MetaCons name _ _) rep) _ = rep

101− GConstructorADT' _ _ fallback = fallback

102

103

104type GConstructADT

83type GConstructADT

@@ -117,26 +96,26 @@ type family GConstructors f rep where

117 GConstructors f (M1 C _ rep) = (->) (GFields f rep)

96 GConstructors f (M1 C _ rep) = (->) (GFields f rep)

118

119

120−type RepresentableConstructors :: (Type -> Exp Type) -> (Type -> Type) -> Constraint

99+type CorepConstructors :: (Type -> Exp Type) -> (Type -> Type) -> Constraint

121−class RepresentableConstructors f rep where

100+class CorepConstructors f rep where

122 gctabulate :: (GConstructors f rep r -> a) -> GConstructADT f rep r a

101 gctabulate :: (GConstructors f rep r -> a) -> GConstructADT f rep r a

123 gcindex :: GConstructADT f rep r a -> GConstructors f rep r -> a

102 gcindex :: GConstructADT f rep r a -> GConstructors f rep r -> a

124

103

125

104

126−instance RepresentableConstructors f rep => RepresentableConstructors f (M1 D meta rep) where

105+instance CorepConstructors f rep => CorepConstructors f (M1 D meta rep) where

127 gctabulate = gctabulate @f @rep

106 gctabulate = gctabulate @f @rep

128 gcindex = gcindex @f @rep

107 gcindex = gcindex @f @rep

129

108

130

109

131−instance (RepresentableConstructors f a, RepresentableConstructors f b) =>

110+instance (CorepConstructors f a, CorepConstructors f b) =>

132− RepresentableConstructors f (a :+: b)

111+ CorepConstructors f (a :+: b)

133 where

112 where

134 gctabulate f =

113 gctabulate f =

135 gctabulate @f @a \a -> gctabulate @f @b \b -> f (a :*: b)

114 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

115 gcindex f (a :*: b) = gcindex @f @b (gcindex @f @a f a) b

137

116

138

117

139−instance Representable f rep => RepresentableConstructors f (M1 C meta rep) where

118+instance Corep f rep => CorepConstructors f (M1 C meta rep) where

140 gctabulate f = f . gindex @f @rep

119 gctabulate f = f . gindex @f @rep

141 gcindex f = f . gtabulate @f @rep

120 gcindex f = f . gtabulate @f @rep

142

121

@@ -155,38 +134,44 @@ type family GFieldsADT f rep where

155 GFieldsADT f (M1 C _ rep) = GFields f rep

134 GFieldsADT f (M1 C _ rep) = GFields f rep

156

135

157

136

158−type RepresentableFields :: (Type -> Exp Type) -> (Type -> Type) -> Constraint

137+type CorepFields :: (Type -> Exp Type) -> (Type -> Type) -> Constraint

159−class RepresentableFields f rep where

138+class CorepFields f rep where

160 gftabulate :: (GFieldsADT f rep -> a) -> GBuildADT f rep a

139 gftabulate :: (GFieldsADT f rep -> a) -> GBuildADT f rep a

161 gfindex :: GBuildADT f rep a -> GFieldsADT f rep -> a

140 gfindex :: GBuildADT f rep a -> GFieldsADT f rep -> a

141+ gftraverse :: Applicative m

142+ => (forall a. g a -> m a)

143+ -> GFieldsADT (Compose g f) rep -> m (GFieldsADT f rep)

162

144

163

145

164−instance RepresentableFields f rep => RepresentableFields f (M1 D meta rep) where

146+instance CorepFields f rep => CorepFields f (M1 D meta rep) where

165 gftabulate = gftabulate @f @rep

147 gftabulate = gftabulate @f @rep

166 gfindex = gfindex @f @rep

148 gfindex = gfindex @f @rep

149+ gftraverse = gftraverse @f @rep

167

150

168

151

169−instance (RepresentableFields f a, RepresentableFields f b) => RepresentableFields f (a :+: b) where

152+instance (CorepFields f a, CorepFields f b) => CorepFields f (a :+: b) where

170 gftabulate f =

153 gftabulate f =

171 gftabulate @f @a \a -> gftabulate @f @b \b -> f (a, b)

154 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

155 gfindex f (a, b) = gfindex @f @b (gfindex @f @a f a) b

156+ gftraverse f (a, b) = liftA2 (,) (gftraverse @f @a f a) (gftraverse @f @b f b)

173

157

174

158

175−instance Representable f rep => RepresentableFields f (M1 C meta rep) where

159+instance Corep f rep => CorepFields f (M1 C meta rep) where

176 gftabulate = gtabulate @f @rep

160 gftabulate = gtabulate @f @rep

177 gfindex = gindex @f @rep

161 gfindex = gindex @f @rep

162+ gftraverse = gtraverse @f @rep

178

163

179

164

180type GConstructableADT

165type GConstructableADT

181 :: (Type -> Exp Constraint)

166 :: (Type -> Exp Constraint)

182 -> (Type -> Exp K.HTable)

167 -> (Type -> Exp K.HTable)

183 -> (Type -> Exp Type)

168 -> (Type -> Exp Type)

184− -> K.Context -> (Type -> Type) -> Constraint

169+ -> K.HContext -> (Type -> Type) -> Constraint

185class GConstructableADT _Table _Columns f context rep where

170class GConstructableADT _Table _Columns f context rep where

186 gbuildADT :: ()

171 gbuildADT :: ()

187 => ToColumns _Table _Columns f context

172 => ToColumns _Table _Columns f context

188 -> (Tag -> Nullifier context)

173 -> (Tag -> Nullifier context)

189− -> HIdentity Tag context

174+ -> HType Tag context

190 -> GFieldsADT f rep

175 -> GFieldsADT f rep

191 -> GColumnsADT _Columns rep context

176 -> GColumnsADT _Columns rep context

192

177

@@ -194,13 +179,13 @@ class GConstructableADT _Table _Columns f context rep where

194 => FromColumns _Table _Columns f context

179 => FromColumns _Table _Columns f context

195 -> Unnullifier context

180 -> Unnullifier context

196 -> GColumnsADT _Columns rep context

181 -> GColumnsADT _Columns rep context

197− -> (HIdentity Tag context, GFieldsADT f rep)

182+ -> (HType Tag context, GFieldsADT f rep)

198

183

199 gconstructADT :: ()

184 gconstructADT :: ()

200 => ToColumns _Table _Columns f context

185 => ToColumns _Table _Columns f context

201 -> Null context

186 -> Null context

202 -> Nullifier context

187 -> Nullifier context

203− -> (Tag -> HIdentity Tag context)

188+ -> (Tag -> HType Tag context)

204 -> GConstructors f rep (GColumnsADT _Columns rep context)

189 -> GConstructors f rep (GColumnsADT _Columns rep context)

205

190

206 gdeconstructADT :: ()

191 gdeconstructADT :: ()

@@ -208,29 +193,30 @@ class GConstructableADT _Table _Columns f context rep where

208 -> Unnullifier context

193 -> Unnullifier context

209 -> GConstructors f rep r

194 -> GConstructors f rep r

210 -> GColumnsADT _Columns rep context

195 -> GColumnsADT _Columns rep context

211− -> (HIdentity Tag context, NonEmpty (Tag, r))

196+ -> (HType Tag context, NonEmpty (Tag, r))

212

197

213

198

214instance

199instance

215− ( htable ~ HLabel "tag" (HIdentity Tag)

200+ ( htable ~ HLabel "tag" (HType Tag)

216 , GConstructableADT' _Table _Columns f context htable rep

201 , GConstructableADT' _Table _Columns f context htable rep

202+ , HLabelable context

217 )

203 )

218 => GConstructableADT _Table _Columns f context (M1 D meta rep)

204 => GConstructableADT _Table _Columns f context (M1 D meta rep)

219 where

205 where

220 gbuildADT toColumns nullifier =

206 gbuildADT toColumns nullifier =

221 gbuildADT' @_Table @_Columns @f @context @htable @rep toColumns nullifier .

207 gbuildADT' @_Table @_Columns @f @context @htable @rep toColumns nullifier .

222− hlabel

208+ hlabel hlabeler

223

209

224 gunbuildADT fromColumns unnullifier =

210 gunbuildADT fromColumns unnullifier =

225− first hunlabel .

211+ first (hunlabel hunlabeler) .

226 gunbuildADT' @_Table @_Columns @f @context @htable @rep fromColumns unnullifier

212 gunbuildADT' @_Table @_Columns @f @context @htable @rep fromColumns unnullifier

227

213

228 gconstructADT toColumns null nullifier mk =

214 gconstructADT toColumns null nullifier mk =

229 gconstructADT' @_Table @_Columns @f @context @htable @rep toColumns null nullifier

215 gconstructADT' @_Table @_Columns @f @context @htable @rep toColumns null nullifier

230− (hlabel . mk)

216+ (hlabel hlabeler . mk)

231

217

232 gdeconstructADT fromColumns unnullifier cases =

218 gdeconstructADT fromColumns unnullifier cases =

233− first hunlabel .

219+ first (hunlabel hunlabeler) .

234 gdeconstructADT' @_Table @_Columns @f @context @htable @rep fromColumns unnullifier cases

220 gdeconstructADT' @_Table @_Columns @f @context @htable @rep fromColumns unnullifier cases

235

221

236

222

@@ -238,7 +224,7 @@ type GConstructableADT'

238 :: (Type -> Exp Constraint)

224 :: (Type -> Exp Constraint)

239 -> (Type -> Exp K.HTable)

225 -> (Type -> Exp K.HTable)

240 -> (Type -> Exp Type)

226 -> (Type -> Exp Type)

241− -> K.Context -> K.HTable -> (Type -> Type) -> Constraint

227+ -> K.HContext -> K.HTable -> (Type -> Type) -> Constraint

242class GConstructableADT' _Table _Columns f context htable rep where

228class GConstructableADT' _Table _Columns f context htable rep where

243 gbuildADT' :: ()

229 gbuildADT' :: ()

244 => ToColumns _Table _Columns f context

230 => ToColumns _Table _Columns f context

@@ -325,6 +311,7 @@ instance {-# OVERLAPPABLE #-}

325 ( HTable (GColumns _Columns rep)

311 ( HTable (GColumns _Columns rep)

326 , KnownSymbol label

312 , KnownSymbol label

327 , meta ~ 'MetaCons label _fixity _isRecord

313 , meta ~ 'MetaCons label _fixity _isRecord

314+ , HLabelable context

328 , GConstructable _Table _Columns f context rep

315 , GConstructable _Table _Columns f context rep

329 , GColumnsADT' _Columns htable (M1 C meta rep) ~

316 , GColumnsADT' _Columns htable (M1 C meta rep) ~

330 HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))

317 HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))

@@ -333,7 +320,7 @@ instance {-# OVERLAPPABLE #-}

333 where

320 where

334 gbuildADT' toColumns nullifier htable =

321 gbuildADT' toColumns nullifier htable =

335 HProduct htable .

322 HProduct htable .

336− hlabel .

323+ hlabel hlabeler .

337 hnullify (nullifier tag) .

324 hnullify (nullifier tag) .

338 gconstruct @_Table @_Columns @f @context @rep toColumns

325 gconstruct @_Table @_Columns @f @context @rep toColumns

339 where

326 where

@@ -344,13 +331,13 @@ instance {-# OVERLAPPABLE #-}

344 , gdeconstruct @_Table @_Columns @f @context @rep fromColumns $

331 , gdeconstruct @_Table @_Columns @f @context @rep fromColumns $

345 runIdentity $

332 runIdentity $

346 hunnullify (\spec -> pure . unnullifier spec) $

333 hunnullify (\spec -> pure . unnullifier spec) $

347− hunlabel

334+ hunlabel hunlabeler

348 a

335 a

349 )

336 )

350

337

351 gconstructADT' toColumns _ nullifier mk =

338 gconstructADT' toColumns _ nullifier mk =

352 HProduct htable .

339 HProduct htable .

353− hlabel .

340+ hlabel hlabeler .

354 hnullify nullifier .

341 hnullify nullifier .

355 gconstruct @_Table @_Columns @f @context @rep toColumns

342 gconstruct @_Table @_Columns @f @context @rep toColumns

356 where

343 where

@@ -365,114 +352,8 @@ instance {-# OVERLAPPABLE #-}

365 a = gdeconstruct @_Table @_Columns @f @context @rep fromColumns $

352 a = gdeconstruct @_Table @_Columns @f @context @rep fromColumns $

366 runIdentity $

353 runIdentity $

367 hunnullify (\spec -> pure . unnullifier spec) $

354 hunnullify (\spec -> pure . unnullifier spec) $

368− hunlabel

355+ hunlabel hunlabeler

369 columns

356 columns

370 tag = Tag $ pack $ symbolVal (Proxy @label)

357 tag = Tag $ pack $ symbolVal (Proxy @label)

371

358

372− gfill null htable = HProduct htable (hlabel (hnulls null))

359+ gfill null htable = HProduct htable (hlabel hlabeler (hnulls null))

373−

374−

375−type GMakeableADT

376− :: (Type -> Exp Constraint)

377− -> (Type -> Exp K.HTable)

378− -> (Type -> Exp Type)

379− -> K.Context -> Symbol -> (Type -> Type) -> Constraint

380−class GMakeableADT _Table _Columns f context name rep where

381− gmakeADT :: ()

382− => ToColumns _Table _Columns f context

383− -> Null context

384− -> Nullifier context

385− -> (Tag -> HIdentity Tag context)

386− -> GFields f (GConstructorADT name rep)

387− -> GColumnsADT _Columns rep context

388−

389−

390−instance

391− ( htable ~ HLabel "tag" (HIdentity Tag)

392− , meta ~ 'MetaData datatype _module _package _newtype

393− , fallback ~ TypeError (NoConstructor datatype name)

394− , fields ~ GFields f (GConstructorADT' name rep fallback)

395− , GMakeableADT' _Table _Columns f context htable name rep fields

396− , KnownSymbol name

397− )

398− => GMakeableADT _Table _Columns f context name (M1 D meta rep)

399− where

400− gmakeADT toColumns null nullifier wrap =

401− gmakeADT'

402− @_Table @_Columns @f @context @htable @name @rep @fields

403− toColumns null nullifier htable

404− where

405− tag = Tag $ pack $ symbolVal (Proxy @name)

406− htable = hlabel (wrap tag)

407−

408−

409−type GMakeableADT'

410− :: (Type -> Exp Constraint)

411− -> (Type -> Exp K.HTable)

412− -> (Type -> Exp Type)

413− -> K.Context -> K.HTable -> Symbol -> (Type -> Type) -> Type -> Constraint

414−class GMakeableADT' _Table _Columns f context htable name rep fields where

415− gmakeADT' :: ()

416− => ToColumns _Table _Columns f context

417− -> Null context

418− -> Nullifier context

419− -> htable context

420− -> fields

421− -> GColumnsADT' _Columns htable rep context

422−

423−

424−instance

425− ( htable' ~ GColumnsADT' _Columns htable a

426− , GMakeableADT' _Table _Columns f context htable name a fields

427− , GMakeableADT' _Table _Columns f context htable' name b fields

428− )

429− => GMakeableADT' _Table _Columns f context htable name (a :+: b) fields

430− where

431− gmakeADT' toColumns null nullifier htable x =

432− gmakeADT' @_Table @_Columns @f @context @htable' @name @b @fields

433− toColumns null nullifier

434− (gmakeADT'

435− @_Table @_Columns @f @context @htable @name @a @fields toColumns

436− null nullifier htable x)

437− x

438−

439−

440−instance {-# OVERLAPPING #-}

441− GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons name _fixity _isRecord) U1) fields

442− where

443− gmakeADT' _ _ _ = const

444−

445−

446−instance {-# OVERLAPS #-}

447− GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons label _fixity _isRecord) U1) fields

448− where

449− gmakeADT' _ _ _ = const

450−

451−

452−instance {-# OVERLAPS #-}

453− ( HTable (GColumns _Columns rep)

454− , GConstructable _Table _Columns f context rep

455− , fields ~ GFields f rep

456− , GColumnsADT' _Columns htable (M1 C ('MetaCons name _fixity _isRecord) rep) ~

457− HProduct htable (HLabel name (HNullify (GColumns _Columns rep)))

458− )

459− => GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons name _fixity _isRecord) rep) fields

460− where

461− gmakeADT' toColumns _ nullifier htable =

462− HProduct htable .

463− hlabel .

464− hnullify nullifier .

465− gconstruct @_Table @_Columns @f @context @rep toColumns

466−

467−

468−instance {-# OVERLAPPABLE #-}

469− ( HTable (GColumns _Columns rep)

470− , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) rep) ~

471− HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))

472− )

473− => GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons label _fixity _isRecord) rep) fields

474− where

475− gmakeADT' _ null _ htable _ =

476− HProduct htable $

477− hlabel $

478− hnulls null

src/Rel8/Generic/Construction/Record.hs+30−30

@@ -12,28 +12,28 @@

12{-# language UndecidableInstances #-}

14module Rel8.Generic.Construction.Record

15− ( GConstructor, GConstruct, GConstructable, gconstruct, gdeconstruct

15+ ( GConstruct, GConstructable, gconstruct, gdeconstruct

16− , GFields, Representable, gtabulate, gindex

16+ , GFields, Corep, gtabulate, gindex, gtraverse

17 , FromColumns, ToColumns

18 )

19where

21-- base

22+import Control.Applicative ( liftA2 )

22import Data.Kind ( Constraint, Type )

23import Data.Kind ( Constraint, Type )

23import Data.Proxy ( Proxy( Proxy ) )

24import Data.Proxy ( Proxy( Proxy ) )

24import GHC.Generics

25import GHC.Generics

25 ( (:*:), K1, M1, U1

26 ( (:*:), K1, M1, U1

26− , D, C, S, Meta( MetaData, MetaCons, MetaSel )

27+ , D, C, S, Meta( MetaSel )

27− )

28−import GHC.TypeLits

29− ( ErrorMessage( (:<>:), Text ), TypeError

30− , Symbol

31 )

28 )

29+import GHC.TypeLits ( KnownSymbol )

32import Prelude

30import Prelude

34-- rel8

32-- rel8

35−import Rel8.FCF ( Eval, Exp )

33+import Rel8.FCF ( Compose, Eval, Exp )

36import Rel8.Generic.Table.Record ( GColumns )

34import Rel8.Generic.Table.Record ( GColumns )

35+import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )

36+import Rel8.Schema.HTable ( HTable )

37import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

38import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )

39import qualified Rel8.Schema.Kind as K

@@ -43,7 +43,7 @@ type FromColumns

43 :: (Type -> Exp Constraint)

44 -> (Type -> Exp K.HTable)

45 -> (Type -> Exp Type)

46− -> K.Context

46+ -> K.HContext

47 -> Type

48type FromColumns _Table _Columns f context = forall proxy x.

49 Eval (_Table x) => proxy x -> Eval (_Columns x) context -> Eval (f x)

@@ -53,22 +53,12 @@ type ToColumns

53 :: (Type -> Exp Constraint)

54 -> (Type -> Exp K.HTable)

55 -> (Type -> Exp Type)

56− -> K.Context

56+ -> K.HContext

57 -> Type

58type ToColumns _Table _Columns f context = forall proxy x.

59 Eval (_Table x) => proxy x -> Eval (f x) -> Eval (_Columns x) context

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−

72type GConstruct :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type

62type GConstruct :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type

73type family GConstruct f rep r where

63type family GConstruct f rep r where

74 GConstruct f (M1 _ _ rep) r = GConstruct f rep r

64 GConstruct f (M1 _ _ rep) r = GConstruct f rep r

@@ -85,39 +75,46 @@ type family GFields f rep where

85 GFields f (K1 _ a) = Eval (f a)

75 GFields f (K1 _ a) = Eval (f a)

88−type Representable :: (Type -> Exp Type) -> (Type -> Type) -> Constraint

78+type Corep :: (Type -> Exp Type) -> (Type -> Type) -> Constraint

89−class Representable f rep where

79+class Corep f rep where

90 gtabulate :: (GFields f rep -> a) -> GConstruct f rep a

80 gtabulate :: (GFields f rep -> a) -> GConstruct f rep a

91 gindex :: GConstruct f rep a -> GFields f rep -> a

81 gindex :: GConstruct f rep a -> GFields f rep -> a

82+ gtraverse :: Applicative m

83+ => (forall a. g a -> m a)

84+ -> GFields (Compose g f) rep -> m (GFields f rep)

94−instance Representable f rep => Representable f (M1 i meta rep) where

87+instance Corep f rep => Corep f (M1 i meta rep) where

95 gtabulate = gtabulate @f @rep

88 gtabulate = gtabulate @f @rep

96 gindex = gindex @f @rep

89 gindex = gindex @f @rep

90+ gtraverse = gtraverse @f @rep

99−instance (Representable f a, Representable f b) =>

93+instance (Corep f a, Corep f b) =>

100− Representable f (a :*: b)

94+ Corep f (a :*: b)

101 where

95 where

102 gtabulate f = gtabulate @f @a \a -> gtabulate @f @b \b -> f (a, b)

96 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

97 gindex f (a, b) = gindex @f @b (gindex @f @a f a) b

98+ gtraverse f (a, b) = liftA2 (,) (gtraverse @f @a f a) (gtraverse @f @b f b)

104

105

100

106−instance Representable f U1 where

101+instance Corep f U1 where

107 gtabulate = ($ ())

102 gtabulate = ($ ())

108 gindex = const

103 gindex = const

104+ gtraverse = const pure

109

105

110

106

111−instance Representable f (K1 i a) where

107+instance Corep f (K1 i a) where

112 gtabulate = id

108 gtabulate = id

113 gindex = id

109 gindex = id

110+ gtraverse = id

114

111

115

112

116type GConstructable

113type GConstructable

117 :: (Type -> Exp Constraint)

114 :: (Type -> Exp Constraint)

118 -> (Type -> Exp K.HTable)

115 -> (Type -> Exp K.HTable)

119 -> (Type -> Exp Type)

116 -> (Type -> Exp Type)

120− -> K.Context -> (Type -> Type) -> Constraint

117+ -> K.HContext -> (Type -> Type) -> Constraint

121class GConstructable _Table _Columns f context rep where

118class GConstructable _Table _Columns f context rep where

122 gconstruct :: ()

119 gconstruct :: ()

123 => ToColumns _Table _Columns f context

120 => ToColumns _Table _Columns f context

@@ -160,9 +157,12 @@ instance

160

157

161instance

158instance

162 ( Eval (_Table a)

159 ( Eval (_Table a)

160+ , HTable (Eval (_Columns a))

161+ , HLabelable context

162+ , KnownSymbol label

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)

167+ gconstruct toColumns = hlabel hlabeler . toColumns (Proxy @a)

168− gdeconstruct fromColumns = fromColumns (Proxy @a) . hunlabel

168+ gdeconstruct fromColumns = fromColumns (Proxy @a) . hunlabel hunlabeler

src/Rel8/Generic/Map.hs+64−20

@@ -1,19 +1,26 @@

1+{-# language AllowAmbiguousTypes #-}

1{-# language DataKinds #-}

2{-# language DataKinds #-}

3+{-# language EmptyCase #-}

4+{-# language FlexibleInstances #-}

5+{-# language LambdaCase #-}

6+{-# language MultiParamTypeClasses #-}

7+{-# language RankNTypes #-}

8+{-# language ScopedTypeVariables #-}

2{-# language StandaloneKindSignatures #-}

9{-# language StandaloneKindSignatures #-}

10+{-# language TypeApplications #-}

3{-# language TypeFamilies #-}

11{-# language TypeFamilies #-}

4{-# language TypeOperators #-}

12{-# language TypeOperators #-}

5{-# language UndecidableInstances #-}

13{-# language UndecidableInstances #-}

7module Rel8.Generic.Map

15module Rel8.Generic.Map

8− ( GMap

16+ ( GMap, GMappable (gmap, gunmap)

9− , Map

10 )

17 )

11where

18where

13-- base

20-- base

14−import Data.Kind ( Type )

21+import Data.Kind ( Constraint, Type )

15import GHC.Generics

22import GHC.Generics

16− ( (:+:), (:*:), K1, M1, U1, V1

23+ ( (:+:)( L1, R1 ), (:*:)( (:*:) ), K1( K1 ), M1( M1 ), U1( U1 ), V1

17 )

24 )

18import Prelude ()

25import Prelude ()

@@ -31,19 +38,56 @@ type family GMap f rep where

31 GMap f (K1 i a) = K1 i (Eval (f a))

38 GMap f (K1 i a) = K1 i (Eval (f a))

34−-- | Map a @Type -> Type@ function over the @Type@-kinded type variables in

35−-- of a type constructor.

36−type Map :: (Type -> Exp Type) -> Type -> Type

41+type GMappable :: (Type -> Exp Constraint) -> (Type -> Type) -> Constraint

37−type family Map f a where

42+class GMappable constraint rep where

38− Map p (t a b c d e f g) =

43+ gmap :: ()

39− t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e))

44+ => proxy f

40− (Eval (p f)) (Eval (p g))

45+ -> (forall a. Eval (constraint a) => a -> Eval (f a))

41− Map p (t a b c d e f) =

46+ -> rep x

42− t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e))

47+ -> GMap f rep x

43− (Eval (p f))

48+

44− Map p (t a b c d e) =

49+ gunmap :: ()

45− t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e))

50+ => proxy f

46− Map p (t a b c d) = t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d))

51+ -> (forall a. Eval (constraint a) => Eval (f a) -> a)

47− Map p (t a b c) = t (Eval (p a)) (Eval (p b)) (Eval (p c))

52+ -> GMap f rep x

48− Map p (t a b) = t (Eval (p a)) (Eval (p b))

53+ -> rep x

49− Map p (t a) = t (Eval (p a))

54+

55+

56+instance GMappable constraint rep => GMappable constraint (M1 i c rep) where

57+ gmap proxy f (M1 a) = M1 (gmap @constraint proxy f a)

58+ gunmap proxy f (M1 a) = M1 (gunmap @constraint proxy f a)

59+

60+

61+instance GMappable constraint V1 where

62+ gmap _ _ = \case

63+ gunmap _ _ = \case

64+

65+

66+instance (GMappable constraint rep1, GMappable constraint rep2) =>

67+ GMappable constraint (rep1 :+: rep2)

68+ where

69+ gmap proxy f = \case

70+ L1 a -> L1 (gmap @constraint proxy f a)

71+ R1 a -> R1 (gmap @constraint proxy f a)

72+ gunmap proxy f = \case

73+ L1 a -> L1 (gunmap @constraint proxy f a)

74+ R1 a -> R1 (gunmap @constraint proxy f a)

75+

76+

77+instance GMappable constraint U1 where

78+ gmap _ _ U1 = U1

79+ gunmap _ _ U1 = U1

80+

81+

82+instance (GMappable constraint rep1, GMappable constraint rep2) =>

83+ GMappable constraint (rep1 :*: rep2)

84+ where

85+ gmap proxy f (a :*: b) =

86+ gmap @constraint proxy f a :*: gmap @constraint proxy f b

87+ gunmap proxy f (a :*: b) =

88+ gunmap @constraint proxy f a :*: gunmap @constraint proxy f b

89+

90+

91+instance Eval (constraint a) => GMappable constraint (K1 i a) where

92+ gmap _ f (K1 a) = K1 (f a)

93+ gunmap _ f (K1 a) = K1 (f a)

src/Rel8/Generic/Record.hs−2

@@ -1,6 +1,5 @@

1{-# language AllowAmbiguousTypes #-}

2{-# language DataKinds #-}

3−{-# language FlexibleContexts #-}

4{-# language FlexibleInstances #-}

3{-# language FlexibleInstances #-}

5{-# language MultiParamTypeClasses #-}

4{-# language MultiParamTypeClasses #-}

6{-# language PolyKinds #-}

5{-# language PolyKinds #-}

@@ -142,7 +141,6 @@ instance {-# OVERLAPPABLE #-} Snd (Count n rep) ~ rep => Countable n rep where

142 uncount = id

141 uncount = id

143

142

144

143

145−type Record :: Type -> Type

146newtype Record a = Record

144newtype Record a = Record

147 { unrecord :: a

145 { unrecord :: a

148 }

146 }

src/Rel8/Generic/Reify.hsnew file+24

@@ -0,0 +1,24 @@

1+{-# language StandaloneKindSignatures #-}

2+{-# language TypeFamilies #-}

4+module Rel8.Generic.Reify

5+ ( ARep

6+ )

7+where

9+-- base

10+import Data.Functor.Contravariant ( Contravariant, contramap )

11+import Data.Kind ( Type )

12+import Data.Void ( Void, absurd )

13+import GHC.Generics ( Generic, Rep, from, to )

14+import Prelude

15+

16+

17+type ARep :: (Type -> Type) -> Type

18+newtype ARep rep = ARep (rep Void)

19+

20+

21+instance (Contravariant rep, Functor rep) => Generic (ARep rep) where

22+ type Rep (ARep rep) = rep

23+ from (ARep a) = fmap absurd a

24+ to = ARep . contramap absurd

src/Rel8/Generic/Rel8able.hs+81−188

@@ -1,18 +1,13 @@

1{-# language AllowAmbiguousTypes #-}

2−{-# language ConstraintKinds #-}

3{-# language DataKinds #-}

2{-# language DataKinds #-}

4{-# language DefaultSignatures #-}

3{-# language DefaultSignatures #-}

5{-# language FlexibleContexts #-}

4{-# language FlexibleContexts #-}

6{-# language FlexibleInstances #-}

5{-# language FlexibleInstances #-}

7−{-# language LambdaCase #-}

8{-# language MultiParamTypeClasses #-}

6{-# language MultiParamTypeClasses #-}

9−{-# language PolyKinds #-}

10−{-# language QuantifiedConstraints #-}

11{-# language ScopedTypeVariables #-}

7{-# language ScopedTypeVariables #-}

12{-# language StandaloneKindSignatures #-}

8{-# language StandaloneKindSignatures #-}

13{-# language TypeApplications #-}

9{-# language TypeApplications #-}

14−{-# language TypeFamilyDependencies #-}

10+{-# language TypeFamilies #-}

15−{-# language TypeOperators #-}

16{-# language UndecidableInstances #-}

11{-# language UndecidableInstances #-}

18module Rel8.Generic.Rel8able

13module Rel8.Generic.Rel8able

@@ -20,99 +15,42 @@ module Rel8.Generic.Rel8able

20 , Algebra

15 , Algebra

21 , GRep

16 , GRep

22 , GColumns, gfromColumns, gtoColumns

17 , GColumns, gfromColumns, gtoColumns

23− , GFromExprs, gfromResult, gtoResult

18+ , greify, gunreify

24− , TSerialize, serialize, deserialize

19+ , TUnreifyContext

25 )

20 )

26where

21where

28-- base

23-- base

29−import Data.Functor.Identity ( Identity )

30import Data.Kind ( Constraint, Type )

24import Data.Kind ( Constraint, Type )

31−import Data.Type.Bool ( type (&&) )

25+import Data.Proxy ( Proxy( Proxy ) )

26+import Data.Type.Equality ( (:~:)( Refl ) )

32import GHC.Generics ( Generic, Rep, from, to )

27import GHC.Generics ( Generic, Rep, from, to )

33import Prelude

28import Prelude

35-- rel8

30-- rel8

36−import Rel8.Aggregate ( Aggregate )

31+import Rel8.Kind.Context ( Reifiable )

37−import Rel8.Expr ( Expr )

38−import Rel8.FCF ( Exp, Eval )

32+import Rel8.FCF ( Eval, Exp )

33+import Rel8.Generic.Map ( GMap, GMappable, gmap, gunmap )

39import Rel8.Generic.Record ( Record(..) )

34import Rel8.Generic.Record ( Record(..) )

40import Rel8.Generic.Table ( GAlgebra )

35import Rel8.Generic.Table ( GAlgebra )

41import qualified Rel8.Generic.Table.Record as G

36import qualified Rel8.Generic.Table.Record as G

42import qualified Rel8.Kind.Algebra as K ( Algebra(..) )

37import qualified Rel8.Kind.Algebra as K ( Algebra(..) )

43−import Rel8.Kind.Context ( SContext(..) )

38+import Rel8.Schema.Context ( Col )

44−import Rel8.Schema.Field ( Field )

39+import Rel8.Schema.Context.Label ( Labelable )

45import Rel8.Schema.HTable ( HTable )

40import Rel8.Schema.HTable ( HTable )

46import qualified Rel8.Schema.Kind as K

41import qualified Rel8.Schema.Kind as K

47−import Rel8.Schema.Name ( Name )

42+import Rel8.Schema.Reify ( Reify, UnwrapReify )

48import Rel8.Schema.Result ( Result )

43import Rel8.Schema.Result ( Result )

49import Rel8.Table

44import Rel8.Table

50− ( Table, Columns, Context, fromColumns, toColumns

45+ ( fromColumns, toColumns, reify, unreify

51− , FromExprs, fromResult, toResult

52− , Transpose

53− , TTable, TColumns

46+ , TTable, TColumns, TContext, TUnreify

54 )

47 )

55−import Rel8.Table.Transpose ( Transposes )

58−-- | The kind of 'Rel8able' types

59type KRel8able :: Type

50type KRel8able :: Type

60type KRel8able = K.Rel8able

51type KRel8able = K.Rel8able

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

54-- | 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:

55-- data types. Higher-kinded data types are data types of the pattern:

118--

56--

@@ -124,158 +62,113 @@ type instance Eval (TSerialize expr a) =

124-- , fieldN :: Column f Tn OR HKn f

62-- , fieldN :: Column f Tn OR HKn f

125-- }

63-- }

126-- @

64-- @

127−--

65+--

128-- where @Tn@ is any Haskell type, and @HKn@ is any higher-kinded type.

66-- where @Tn@ is any Haskell type, and @HKn@ is any higher-kinded type.

129−--

67+--

130-- That is, higher-kinded data are records where all fields in the record are

68-- 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

69-- all either of the type @Column f T@ (for any @T@), or are themselves

132-- higher-kinded data:

70-- higher-kinded data:

133−--

71+--

134-- [Nested]

72-- [Nested]

135−--

73+--

136-- @

74-- @

137-- data Nested f =

75-- data Nested f =

138-- Nested { nested1 :: MyType f

76-- Nested { nested1 :: MyType f

139-- , nested2 :: MyType f

77-- , nested2 :: MyType f

140-- }

78-- }

141-- @

79-- @

142−--

80+--

143-- The @Rel8able@ type class is used to give us a special mapping operation

81-- The @Rel8able@ type class is used to give us a special mapping operation

144-- that lets us change the type parameter @f@.

82-- that lets us change the type parameter @f@.

145−--

83+--

146-- [Supplying @Rel8able@ instances]

84-- [Supplying @Rel8able@ instances]

147−--

85+--

148-- This type class should be derived generically for all table types in your

86-- This type class should be derived generically for all table types in your

149−-- project. To do this, enable the @DeriveAnyClass@ and @DeriveGeneric@ language

87+-- project. To do this, enable the @DeriveAnyType@ and @DeriveGeneric@ language

150-- extensions:

88-- extensions:

151−--

89+--

152-- @

90-- @

153-- \{\-\# LANGUAGE DeriveAnyClass, DeriveGeneric #-\}

91-- \{\-\# LANGUAGE DeriveAnyClass, DeriveGeneric #-\}

154−--

92+--

155-- data MyType f = MyType { fieldA :: Column f T }

93-- data MyType f = MyType { fieldA :: Column f T }

156-- deriving ( GHC.Generics.Generic, Rel8able )

94-- deriving ( GHC.Generics.Generic, Rel8able )

157-- @

95-- @

158type Rel8able :: K.Rel8able -> Constraint

96type Rel8able :: K.Rel8able -> Constraint

159class HTable (GColumns t) => Rel8able t where

97class HTable (GColumns t) => Rel8able t where

160 type GColumns t :: K.HTable

98 type GColumns t :: K.HTable

161− type GFromExprs t :: Type

162

100+ gfromColumns :: (Labelable context, Reifiable context)

163− gfromColumns :: SContext context -> GColumns t context -> t context

101+ => GColumns t (Col (Reify context)) -> t (Reify context)

164− gtoColumns :: SContext context -> t context -> GColumns t context

102+

103+ gtoColumns :: (Labelable context, Reifiable context)

104+ => t (Reify context) -> GColumns t (Col (Reify context))

105+

106+ greify :: (Labelable context, Reifiable context)

107+ => t context -> t (Reify context)

165

108

166− gfromResult :: GColumns t Result -> GFromExprs t

109+ gunreify :: (Labelable context, Reifiable context)

167− gtoResult :: GFromExprs t -> GColumns t Result

110+ => t (Reify context) -> t context

168

111

169− type GColumns t = G.GColumns TColumns (GRep t Expr)

112+ type GColumns t = G.GColumns TColumns (GRep t (Reify Result))

170− type GFromExprs t = t Result

171

113

172 default gfromColumns :: forall context.

114 default gfromColumns :: forall context.

173− ( SRel8able t Aggregate

115+ ( Generic (Record (t (Reify context)))

174− , SRel8able t Expr

116+ , G.GTable (TTable (Reify context)) TColumns (Col (Reify context)) (GRep t (Reify context))

175− , forall table. SRel8able t (Field table)

117+ , G.GColumns TColumns (GRep t (Reify context)) ~ GColumns t

176− , SRel8able t Name

177− , SSerialize t

178 )

118 )

179− => SContext context -> GColumns t context -> t context

119+ => GColumns t (Col (Reify context)) -> t (Reify context)

180− gfromColumns = \case

120+ gfromColumns =

181− SAggregate -> sfromColumns

121+ unrecord .

182− SExpr -> sfromColumns

122+ to .

183− SField -> sfromColumns

123+ G.gfromColumns @(TTable (Reify context)) @TColumns fromColumns

184− SName -> sfromColumns

185− SResult -> sfromResult

186

124

187 default gtoColumns :: forall context.

125 default gtoColumns :: forall context.

188− ( SRel8able t Aggregate

126+ ( Generic (Record (t (Reify context)))

189− , SRel8able t Expr

127+ , G.GTable (TTable (Reify context)) TColumns (Col (Reify context)) (GRep t (Reify context))

190− , forall table. SRel8able t (Field table)

128+ , G.GColumns TColumns (GRep t (Reify context)) ~ GColumns t

191− , SRel8able t Name

192− , SSerialize t

193 )

129 )

194− => SContext context -> t context -> GColumns t context

130+ => t (Reify context) -> GColumns t (Col (Reify context))

195− gtoColumns = \case

131+ gtoColumns =

196− SAggregate -> stoColumns

132+ G.gtoColumns @(TTable (Reify context)) @TColumns toColumns .

197− SExpr -> stoColumns

133+ from .

198− SField -> stoColumns

134+ Record

199− SName -> stoColumns

135+

200− SResult -> stoResult

136+ default greify :: forall context.

201−

137+ ( Generic (Record (t context))

202− default gfromResult :: (SSerialize t, GFromExprs t ~ t Result)

138+ , Generic (Record (t (Reify context)))

203− => GColumns t Result -> GFromExprs t

139+ , GMappable (TTable (Reify context)) (GRep t (Reify context))

204− gfromResult = sfromResult

140+ , GRep t context ~ GMap TUnreify (GRep t (Reify context))

205−

141+ )

206− default gtoResult :: (SSerialize t, GFromExprs t ~ t Result)

142+ => t context -> t (Reify context)

207− => GFromExprs t -> GColumns t Result

143+ greify =

208− gtoResult = stoResult

144+ unrecord .

145+ to .

146+ gunmap @(TTable (Reify context)) (Proxy @TUnreify) (reify Refl) .

147+ from .

148+ Record

149+

150+ default gunreify :: forall context.

151+ ( Generic (Record (t context))

152+ , Generic (Record (t (Reify context)))

153+ , GMappable (TTable (Reify context)) (GRep t (Reify context))

154+ , GRep t context ~ GMap TUnreify (GRep t (Reify context))

155+ )

156+ => t (Reify context) -> t context

157+ gunreify =

158+ unrecord .

159+ to .

160+ gmap @(TTable (Reify context)) (Proxy @TUnreify) (unreify Refl) .

161+ from .

162+ Record

209

163

210

164

211type Algebra :: K.Rel8able -> K.Algebra

165type Algebra :: K.Rel8able -> K.Algebra

212−type Algebra t = GAlgebra (GRep t Expr)

166+type Algebra t = GAlgebra (GRep t (Reify Result))

213

167

214

168

215type GRep :: K.Rel8able -> K.Context -> Type -> Type

169type GRep :: K.Rel8able -> K.Context -> Type -> Type

216type GRep t context = Rep (Record (t context))

170type GRep t context = Rep (Record (t context))

217

171

218

172

219−type SRel8able :: K.Rel8able -> K.Context -> Constraint

173+data TUnreifyContext :: Type -> Exp K.Context

220−class

174+type instance Eval (TUnreifyContext a) = UnwrapReify (Eval (TContext a))

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

tests/Rel8/Generic/Rel8able/Test.hs → src/Rel8/Generic/Rel8able/Test.hsrenamed+11−52

@@ -1,13 +1,12 @@

1{-# language DataKinds #-}

2{-# language DeriveAnyClass #-}

3{-# language DeriveGeneric #-}

4−{-# language DerivingStrategies #-}

4+{-# language DerivingVia #-}

5{-# language DuplicateRecordFields #-}

6{-# language FlexibleInstances #-}

7{-# language MultiParamTypeClasses #-}

8−{-# language StandaloneKindSignatures #-}

8+{-# language StandaloneDeriving #-}

9{-# language TypeFamilies #-}

10−{-# language UndecidableInstances #-}

12{-# options_ghc -O0 #-}

11{-# options_ghc -O0 #-}

@@ -27,7 +26,7 @@ import Rel8

27import Data.Text ( Text )

26import Data.Text ( Text )

30−data TableTest f = TableTest

29+data Table f = Table

31 { foo :: Column f Bool

30 { foo :: Column f Bool

32 , bar :: Column f (Maybe Bool)

31 , bar :: Column f (Maybe Bool)

33 }

32 }

@@ -36,7 +35,7 @@ data TableTest f = TableTest

38data TablePair f = TablePair

37data TablePair f = TablePair

39− { foo :: Column f Bool

38+ { foo :: Default f Bool

40 , bars :: (Column f Text, Column f Text)

39 , bars :: (Column f Text, Column f Text)

41 }

40 }

42 deriving stock Generic

41 deriving stock Generic

@@ -98,20 +97,22 @@ data S3Object = S3Object

98 deriving stock Generic

97 deriving stock Generic

100

100+deriving via HKDT S3Object

101−instance x ~ HKD S3Object Expr => ToExprs x S3Object

101+ instance x ~ HKD S3Object Expr => ToExprs x S3Object

102

103

104−data HKDSum = HKDSumA Text | HKDSumB Bool Char | HKDSumC

104+data HKDSum = HKDSumA Text | HKDSumB Bool Char

105 deriving stock Generic

106

107

108+deriving via HKDT HKDSum

108−instance x ~ HKD HKDSum Expr => ToExprs x HKDSum

109+ instance x ~ HKD HKDSum Expr => ToExprs x HKDSum

109

110

111

111data HKDTest f = HKDTest

112data HKDTest f = HKDTest

112 { s3Object :: Lift f S3Object

113 { s3Object :: Lift f S3Object

113 , hkdSum :: Lift f HKDSum

114 , hkdSum :: Lift f HKDSum

114− }

115+ }

115 deriving stock Generic

116 deriving stock Generic

116 deriving anyclass Rel8able

117 deriving anyclass Rel8able

117

118

@@ -138,51 +139,9 @@ data TableSum f

138 deriving stock Generic

139 deriving stock Generic

139

140

141

141−data BarbieSum f

142− = BarbieSumA (f Bool) (f Text)

143− | BarbieSumB

144− | BarbieSumC (f Text)

145− deriving stock Generic

146−

147−

148data TableProduct f = TableProduct

142data TableProduct f = TableProduct

149− { sum :: HADT f BarbieSum

143+ { sum :: HADT f TableSum

150 , list :: TableList f

144 , list :: TableList f

151− , foos :: HList f (HADT f TableSum, Lift f HKDSum, HKDTest f)

152− }

153− deriving stock Generic

154− deriving anyclass Rel8able

155−

156−

157−data TableTestB f = TableTestB

158− { foo :: f Bool

159− , bar :: f (Maybe Bool)

160− }

161− deriving stock Generic

162− deriving anyclass Rel8able

163−

164−

165−data NestedTableTestB f = NestedTableTestB

166− { foo :: f Bool

167− , bar :: f (Maybe Bool)

168− , baz :: Column f Char

169− , nest :: TableTestB f

170− }

171− deriving stock Generic

172− deriving anyclass Rel8able

173−

174−

175−newtype IdRecord a f = IdRecord { recordId :: Column f a }

176− deriving stock Generic

177−

178−

179−instance DBType a => Rel8able (IdRecord a)

180−

181−

182−type Nest :: KRel8able -> KRel8able -> KRel8able

183−data Nest t u f = Nest

184− { foo :: t f

185− , bar :: u f

186 }

145 }

187 deriving stock Generic

146 deriving stock Generic

188 deriving anyclass Rel8able

147 deriving anyclass Rel8able

src/Rel8/Generic/Table.hs+109−24

@@ -12,7 +12,8 @@

12{-# language UndecidableInstances #-}

14module Rel8.Generic.Table

15+ ( GGTable, GGColumns, GGContext, ggfromColumns, ggtoColumns, ggtable

15− ( GGSerialize, GGColumns, ggfromResult, ggtoResult

16+ , GGToExprs, ggfromResult, ggtoResult

16 , GAlgebra

17 , GAlgebra

17 )

18 )

18where

19where

@@ -25,19 +26,43 @@ import Prelude ()

25-- rel8

26-- rel8

26import Rel8.FCF ( Eval, Exp )

27import Rel8.FCF ( Eval, Exp )

27import Rel8.Generic.Table.ADT

28import Rel8.Generic.Table.ADT

29+ ( GTableADT, GColumnsADT, gfromColumnsADT, gtoColumnsADT, gtableADT

28− ( GSerializeADT, GColumnsADT, gtoResultADT, gfromResultADT

30+ , GToExprsADT, gtoResultADT, gfromResultADT

31+ )

32+import Rel8.Generic.Table.Record

33+ ( GTable, GColumns, GContext, gfromColumns, gtoColumns, gtable

34+ , GToExprs, gtoResult, gfromResult

29 )

35 )

30−import Rel8.Generic.Table.Record ( GSerialize, GColumns, gtoResult, gfromResult )

31import Rel8.Kind.Algebra

36import Rel8.Kind.Algebra

32 ( Algebra( Product, Sum )

37 ( Algebra( Product, Sum )

33 , SAlgebra( SProduct, SSum )

38 , SAlgebra( SProduct, SSum )

34 , KnownAlgebra, algebraSing

39 , KnownAlgebra, algebraSing

35 )

40 )

41+import Rel8.Schema.Context ( Col )

36import qualified Rel8.Schema.Kind as K

42import qualified Rel8.Schema.Kind as K

43+import Rel8.Schema.Null ( Nullify )

44+import Rel8.Schema.Spec ( Spec( Spec ), SSpec )

37import Rel8.Schema.Result ( Result )

45import Rel8.Schema.Result ( Result )

40−data GGSerialize

48+data GGTable

49+ :: Algebra

50+ -> (Type -> Exp Constraint)

51+ -> (Type -> Exp K.HTable)

52+ -> K.HContext

53+ -> (Type -> Type)

54+ -> Exp Constraint

55+

56+

57+type instance Eval (GGTable 'Product _Table _Columns context rep) =

58+ GTable _Table _Columns context rep

59+

60+

61+type instance Eval (GGTable 'Sum _Table _Columns context rep) =

62+ GTableADT _Table _Columns context rep

63+

64+

65+data GGToExprs

41 :: Algebra

66 :: Algebra

42 -> (Type -> Type -> Exp Constraint)

67 -> (Type -> Type -> Exp Constraint)

43 -> (Type -> Exp K.HTable)

68 -> (Type -> Exp K.HTable)

@@ -46,12 +71,12 @@ data GGSerialize

46 -> Exp Constraint

71 -> Exp Constraint

49−type instance Eval (GGSerialize 'Product _Serialize _Columns exprs rep) =

74+type instance Eval (GGToExprs 'Product _ToExprs _Columns exprs rep) =

50− GSerialize _Serialize _Columns exprs rep

75+ GToExprs _ToExprs _Columns exprs rep

53−type instance Eval (GGSerialize 'Sum _Serialize _Columns exprs rep) =

78+type instance Eval (GGToExprs 'Sum _ToExprs _Columns exprs rep) =

54− GSerializeADT _Serialize _Columns exprs rep

79+ GToExprsADT _ToExprs _Columns exprs rep

57data GGColumns

82data GGColumns

@@ -67,6 +92,19 @@ type instance Eval (GGColumns 'Product _Columns rep) = GColumns _Columns rep

67type instance Eval (GGColumns 'Sum _Columns rep) = GColumnsADT _Columns rep

92type instance Eval (GGColumns 'Sum _Columns rep) = GColumnsADT _Columns rep

95+data GGContext

96+ :: Algebra

97+ -> (Type -> Exp K.Context)

98+ -> (Type -> Type)

99+ -> Exp K.Context

100+

101+

102+type instance Eval (GGContext 'Product _Context rep) = GContext _Context rep

103+

104+

105+type instance Eval (GGContext 'Sum _Context _rep) = Result

106+

107+

70type GAlgebra :: (Type -> Type) -> Algebra

108type GAlgebra :: (Type -> Type) -> Algebra

71type family GAlgebra rep where

109type family GAlgebra rep where

72 GAlgebra (M1 _ _ rep) = GAlgebra rep

110 GAlgebra (M1 _ _ rep) = GAlgebra rep

@@ -77,27 +115,74 @@ type family GAlgebra rep where

77 GAlgebra (K1 _ _) = 'Product

115 GAlgebra (K1 _ _) = 'Product

116

117

118+ggfromColumns :: forall algebra _Table _Columns rep context x.

119+ ( KnownAlgebra algebra

120+ , Eval (GGTable algebra _Table _Columns context rep)

121+ )

122+ => (forall spec. algebra ~ 'Sum => context spec -> Col Result spec)

123+ -> (forall spec. algebra ~ 'Sum => Col Result spec -> context spec)

124+ -> (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)

125+ -> Eval (GGColumns algebra _Columns rep) context

126+ -> rep x

127+ggfromColumns = case algebraSing @algebra of

128+ SProduct -> \_ _ -> gfromColumns @_Table @_Columns

129+ SSum -> gfromColumnsADT @_Table @_Columns

130+

131+

132+ggtoColumns :: forall algebra _Table _Columns rep context x.

133+ ( KnownAlgebra algebra

134+ , Eval (GGTable algebra _Table _Columns context rep)

135+ )

136+ => (forall spec. algebra ~ 'Sum => context spec -> Col Result spec)

137+ -> (forall spec. algebra ~ 'Sum => Col Result spec -> context spec)

138+ -> (forall a. Eval (_Table a) => a -> Eval (_Columns a) context)

139+ -> rep x

140+ -> Eval (GGColumns algebra _Columns rep) context

141+ggtoColumns = case algebraSing @algebra of

142+ SProduct -> \_ _ -> gtoColumns @_Table @_Columns

143+ SSum -> gtoColumnsADT @_Table @_Columns

144+

145+

146+ggtable :: forall algebra _Table _Columns rep context.

147+ ( KnownAlgebra algebra

148+ , Eval (GGTable algebra _Table _Columns context rep)

149+ )

150+ => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)

151+ -> (forall a labels necessity. ()

152+ => SSpec ('Spec labels necessity a)

153+ -> context ('Spec labels necessity a)

154+ -> context ('Spec labels necessity (Nullify a)))

155+ -> Eval (GGColumns algebra _Columns rep) context

156+ggtable = case algebraSing @algebra of

157+ SProduct -> \table _ -> gtable @_Table @_Columns @_ @rep table

158+ SSum -> gtableADT @_Table @_Columns @_ @rep

159+

160+

80−ggfromResult :: forall algebra _Serialize _Columns exprs rep x.

161+ggfromResult :: forall algebra _ToExprs _Columns exprs rep x.

81 ( KnownAlgebra algebra

162 ( KnownAlgebra algebra

82− , Eval (GGSerialize algebra _Serialize _Columns exprs rep)

163+ , Eval (GGToExprs algebra _ToExprs _Columns exprs rep)

83 )

164 )

84− => (forall expr a proxy. Eval (_Serialize expr a)

165+ => (forall expr a proxy. Eval (_ToExprs expr a)

166+ => proxy expr

85− => proxy expr -> Eval (_Columns expr) Result -> a)

167+ -> Eval (_Columns expr) (Col Result)

168+ -> a)

86− -> Eval (GGColumns algebra _Columns exprs) Result

169+ -> Eval (GGColumns algebra _Columns exprs) (Col Result)

87 -> rep x

170 -> rep x

88−ggfromResult f x = case algebraSing @algebra of

171+ggfromResult = case algebraSing @algebra of

89− SProduct -> gfromResult @_Serialize @_Columns @exprs @rep f x

172+ SProduct -> gfromResult @_ToExprs @_Columns @exprs

90− SSum -> gfromResultADT @_Serialize @_Columns @exprs @rep f x

173+ SSum -> gfromResultADT @_ToExprs @_Columns @exprs

174

175

93−ggtoResult :: forall algebra _Serialize _Columns exprs rep x.

176+ggtoResult :: forall algebra _ToExprs _Columns exprs rep x.

94 ( KnownAlgebra algebra

177 ( KnownAlgebra algebra

95− , Eval (GGSerialize algebra _Serialize _Columns exprs rep)

178+ , Eval (GGToExprs algebra _ToExprs _Columns exprs rep)

96 )

179 )

97− => (forall expr a proxy. Eval (_Serialize expr a)

180+ => (forall expr a proxy. Eval (_ToExprs expr a)

181+ => proxy expr

182+ -> a

98− => proxy expr -> a -> Eval (_Columns expr) Result)

183+ -> Eval (_Columns expr) (Col Result))

99 -> rep x

184 -> rep x

100− -> Eval (GGColumns algebra _Columns exprs) Result

185+ -> Eval (GGColumns algebra _Columns exprs) (Col Result)

101−ggtoResult f x = case algebraSing @algebra of

186+ggtoResult = case algebraSing @algebra of

102− SProduct -> gtoResult @_Serialize @_Columns @exprs @rep f x

187+ SProduct -> gtoResult @_ToExprs @_Columns @exprs

103− SSum -> gtoResultADT @_Serialize @_Columns @exprs @rep f x

188+ SSum -> gtoResultADT @_ToExprs @_Columns @exprs

src/Rel8/Generic/Table/ADT.hs+203−61

@@ -4,6 +4,7 @@

4{-# language FlexibleInstances #-}

5{-# language LambdaCase #-}

6{-# language MultiParamTypeClasses #-}

7+{-# language PolyKinds #-}

7{-# language RankNTypes #-}

8{-# language RankNTypes #-}

8{-# language ScopedTypeVariables #-}

9{-# language ScopedTypeVariables #-}

9{-# language StandaloneKindSignatures #-}

10{-# language StandaloneKindSignatures #-}

@@ -13,13 +14,13 @@

13{-# language UndecidableInstances #-}

14{-# language UndecidableInstances #-}

15module Rel8.Generic.Table.ADT

16module Rel8.Generic.Table.ADT

17+ ( GTableADT, GColumnsADT, gfromColumnsADT, gtoColumnsADT, gtableADT

18+ , GTableADT', GColumnsADT'

16− ( GSerializeADT, GColumnsADT, gfromResultADT, gtoResultADT

19+ , GToExprsADT, gfromResultADT, gtoResultADT

17− , GSerializeADT', GColumnsADT'

18 )

20 )

19where

21where

21-- base

23-- base

22−import Data.Functor.Identity ( Identity( Identity ) )

23import Data.Kind ( Constraint, Type )

24import Data.Kind ( Constraint, Type )

24import Data.Proxy ( Proxy( Proxy ) )

25import Data.Proxy ( Proxy( Proxy ) )

25import GHC.Generics

26import GHC.Generics

@@ -32,14 +33,23 @@ import Prelude hiding ( null )

33-- rel8

34-- rel8

34import Rel8.FCF ( Eval, Exp )

35import Rel8.FCF ( Eval, Exp )

35−import Rel8.Generic.Table.Record ( GSerialize, GColumns, gfromResult, gtoResult )

36+import Rel8.Generic.Table.Record

37+ ( GTable, GColumns, gtable

38+ , GToExprs, gfromResult, gtoResult

39+ )

40+import Rel8.Schema.Context.Label ( HLabelable, hlabeler, labeler, unlabeler )

36−import Rel8.Schema.HTable ( HTable )

41+import Rel8.Schema.HTable ( HTable, hmap )

37−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

42+import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )

38import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )

43import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )

39import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify )

44import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify )

40import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )

45import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )

41import qualified Rel8.Schema.Kind as K

46import qualified Rel8.Schema.Kind as K

47+import Rel8.Schema.Null ( Nullify )

48+import Rel8.Schema.Spec ( Spec( Spec ), SSpec )

49+import Rel8.Schema.Result

50+ ( Col( Result ), Result

42−import Rel8.Schema.Result ( Result, null, nullifier, unnullifier )

51+ , null, nullifier, unnullifier

52+ )

43import Rel8.Type.Tag ( Tag( Tag ) )

53import Rel8.Type.Tag ( Tag( Tag ) )

45-- text

55-- text

@@ -51,7 +61,7 @@ type GColumnsADT

51 -> (Type -> Type) -> K.HTable

61 -> (Type -> Type) -> K.HTable

52type family GColumnsADT _Columns rep where

62type family GColumnsADT _Columns rep where

53 GColumnsADT _Columns (M1 D _ rep) =

63 GColumnsADT _Columns (M1 D _ rep) =

54− GColumnsADT' _Columns (HLabel "tag" (HIdentity Tag)) rep

64+ GColumnsADT' _Columns (HLabel "tag" (HType Tag)) rep

57type GColumnsADT'

67type GColumnsADT'

@@ -65,118 +75,246 @@ type family GColumnsADT' _Columns htable rep where

65 HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))

75 HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))

68−type GSerializeADT

78+type GTableADT

79+ :: (Type -> Exp Constraint)

80+ -> (Type -> Exp K.HTable)

81+ -> K.HContext -> (Type -> Type) -> Constraint

82+class GTableADT _Table _Columns context rep where

83+ gfromColumnsADT :: ()

84+ => (forall spec. context spec -> Col Result spec)

85+ -> (forall spec. Col Result spec -> context spec)

86+ -> (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)

87+ -> GColumnsADT _Columns rep context

88+ -> rep x

89+

90+ gtoColumnsADT :: ()

91+ => (forall spec. context spec -> Col Result spec)

92+ -> (forall spec. Col Result spec -> context spec)

93+ -> (forall a. Eval (_Table a) => a -> Eval (_Columns a) context)

94+ -> rep x

95+ -> GColumnsADT _Columns rep context

96+

97+ gtableADT :: ()

98+ => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)

99+ -> (forall a labels necessity. ()

100+ => SSpec ('Spec labels necessity a)

101+ -> context ('Spec labels necessity a)

102+ -> context ('Spec labels necessity (Nullify a)))

103+ -> GColumnsADT _Columns rep context

104+

105+

106+instance

107+ ( htable ~ HLabel "tag" (HType Tag)

108+ , HTable (GColumnsADT _Columns (M1 D meta rep))

109+ , Eval (_Table (htable context))

110+ , Eval (_Columns (htable context)) ~ htable

111+ , GTableADT' _Table _Columns htable context rep

112+ , GToExprsADT' (Const _Table) _Columns htable rep rep

113+ )

114+ => GTableADT _Table _Columns context (M1 D meta rep)

115+ where

116+ gfromColumnsADT fromContext toContext fromColumns =

117+ gfromResultADT @(Const _Table) @_Columns @(M1 D meta rep) @(M1 D meta rep)

118+ (const (fromColumns . hmap toContext)) .

119+ hmap fromContext

120+

121+ gtoColumnsADT fromContext toContext toColumns =

122+ hmap toContext .

123+ gtoResultADT @(Const _Table) @_Columns @(M1 D meta rep) @(M1 D meta rep)

124+ (const (hmap fromContext . toColumns))

125+

126+ gtableADT table hnullifier =

127+ gtableADT' @_Table @_Columns @htable @context @rep table hnullifier htable

128+ where

129+ htable = table (Proxy @(htable context))

130+

131+

132+type GTableADT'

133+ :: (Type -> Exp Constraint)

134+ -> (Type -> Exp K.HTable)

135+ -> K.HTable -> K.HContext -> (Type -> Type) -> Constraint

136+class GTableADT' _Table _Columns htable context rep where

137+ gtableADT' :: ()

138+ => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)

139+ -> (forall a labels necessity. ()

140+ => SSpec ('Spec labels necessity a)

141+ -> context ('Spec labels necessity a)

142+ -> context ('Spec labels necessity (Nullify a)))

143+ -> htable context

144+ -> GColumnsADT' _Columns htable rep context

145+

146+

147+instance

148+ ( htable' ~ GColumnsADT' _Columns htable a

149+ , GTableADT' _Table _Columns htable context a

150+ , GTableADT' _Table _Columns htable' context b

151+ )

152+ => GTableADT' _Table _Columns htable context (a :+: b)

153+ where

154+ gtableADT' table hnullifier =

155+ gtableADT' @_Table @_Columns @_ @_ @b table hnullifier .

156+ gtableADT' @_Table @_Columns @_ @_ @a table hnullifier

157+

158+

159+instance meta ~ 'MetaCons label _fixity _isRecord =>

160+ GTableADT' _Table _Columns htable context (M1 C meta U1)

161+ where

162+ gtableADT' _ _ = id

163+

164+

165+instance {-# OVERLAPPABLE #-}

166+ ( HTable (GColumns _Columns rep)

167+ , GTable _Table _Columns context rep

168+ , HLabelable context

169+ , meta ~ 'MetaCons label _fixity _isRecord

170+ , KnownSymbol label

171+ , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) rep) ~

172+ HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))

173+ )

174+ => GTableADT' _Table _Columns htable context (M1 C meta rep)

175+ where

176+ gtableADT' table hnullifier htable =

177+ HProduct htable $

178+ hlabel hlabeler $

179+ hnullify hnullifier $

180+ gtable @_Table @_Columns @_ @rep table

181+

182+

183+type GToExprsADT

69 :: (Type -> Type -> Exp Constraint)

184 :: (Type -> Type -> Exp Constraint)

70 -> (Type -> Exp K.HTable)

185 -> (Type -> Exp K.HTable)

71 -> (Type -> Type) -> (Type -> Type) -> Constraint

186 -> (Type -> Type) -> (Type -> Type) -> Constraint

72−class GSerializeADT _Serialize _Columns exprs rep where

187+class GToExprsADT _ToExprs _Columns exprs rep where

73 gfromResultADT :: ()

188 gfromResultADT :: ()

74− => (forall expr a proxy. Eval (_Serialize expr a)

189+ => (forall expr a proxy.

190+ ( Eval (_ToExprs expr a)

191+ , HTable (Eval (_Columns expr))

192+ )

193+ => proxy expr

75− => proxy expr -> Eval (_Columns expr) Result -> a)

194+ -> Eval (_Columns expr) (Col Result)

195+ -> a)

76− -> GColumnsADT _Columns exprs Result

196+ -> GColumnsADT _Columns exprs (Col Result)

77 -> rep x

197 -> rep x

198

79 gtoResultADT :: ()

199 gtoResultADT :: ()

80− => (forall expr a proxy. Eval (_Serialize expr a)

200+ => (forall expr a proxy.

201+ ( Eval (_ToExprs expr a)

202+ , HTable (Eval (_Columns expr))

203+ )

204+ => proxy expr

205+ -> a

81− => proxy expr -> a -> Eval (_Columns expr) Result)

206+ -> Eval (_Columns expr) (Col Result))

82 -> rep x

207 -> rep x

83− -> GColumnsADT _Columns exprs Result

208+ -> GColumnsADT _Columns exprs (Col Result)

209

210

86instance

211instance

87− ( htable ~ HLabel "tag" (HIdentity Tag)

212+ ( htable ~ HLabel "tag" (HType Tag)

88− , GSerializeADT' _Serialize _Columns htable exprs rep

213+ , GToExprsADT' _ToExprs _Columns htable exprs rep

89 )

214 )

90− => GSerializeADT _Serialize _Columns (M1 D meta exprs) (M1 D meta rep)

215+ => GToExprsADT _ToExprs _Columns (M1 D meta exprs) (M1 D meta rep)

91 where

216 where

92 gfromResultADT fromResult columns =

217 gfromResultADT fromResult columns =

93− case gfromResultADT' @_Serialize @_Columns @htable @exprs @rep fromResult tag columns of

218+ case gfromResultADT' @_ToExprs @_Columns @_ @exprs fromResult tag columns of

94 Just rep -> M1 rep

219 Just rep -> M1 rep

95 _ -> error "ADT.fromColumns: mismatch between tag and data"

220 _ -> error "ADT.fromColumns: mismatch between tag and data"

96 where

221 where

97− tag = (\(HIdentity (Identity a)) -> a) . hunlabel @"tag"

222+ tag = (\(HType (Result a)) -> a) . hunlabel @_ @"tag" unlabeler

223

99 gtoResultADT toResult (M1 rep) =

224 gtoResultADT toResult (M1 rep) =

100− gtoResultADT' @_Serialize @_Columns @htable @exprs @rep toResult tag (Just rep)

225+ gtoResultADT' @_ToExprs @_Columns @_ @exprs toResult tag (Just rep)

101 where

226 where

102− tag = hlabel @"tag" . HIdentity . Identity

227+ tag = hlabel @_ @"tag" labeler . HType . Result

103

228

104

229

105−type GSerializeADT'

230+type GToExprsADT'

106 :: (Type -> Type -> Exp Constraint)

231 :: (Type -> Type -> Exp Constraint)

107 -> (Type -> Exp K.HTable)

232 -> (Type -> Exp K.HTable)

108 -> K.HTable -> (Type -> Type) -> (Type -> Type) -> Constraint

233 -> K.HTable -> (Type -> Type) -> (Type -> Type) -> Constraint

109−class GSerializeADT' _Serialize _Columns htable exprs rep where

234+class GToExprsADT' _ToExprs _Columns htable exprs rep where

110− gfromResultADT' :: context ~ Result

235+ gfromResultADT' :: ()

111− => (forall expr a proxy. Eval (_Serialize expr a)

236+ => (forall expr a proxy.

237+ ( Eval (_ToExprs expr a)

238+ , HTable (Eval (_Columns expr))

239+ )

240+ => proxy expr

112− => proxy expr -> Eval (_Columns expr) context -> a)

241+ -> Eval (_Columns expr) (Col Result)

242+ -> a)

113− -> (htable Result -> Tag)

243+ -> (htable (Col Result) -> Tag)

114− -> GColumnsADT' _Columns htable exprs context

244+ -> GColumnsADT' _Columns htable exprs (Col Result)

115 -> Maybe (rep x)

245 -> Maybe (rep x)

116

246

117− gtoResultADT' :: context ~ Result

247+ gtoResultADT' :: ()

118− => (forall expr a proxy. Eval (_Serialize expr a)

248+ => (forall expr a proxy.

249+ ( Eval (_ToExprs expr a)

250+ , HTable (Eval (_Columns expr))

251+ )

252+ => proxy expr

253+ -> a

119− => proxy expr -> a -> Eval (_Columns expr) context)

254+ -> Eval (_Columns expr) (Col Result))

120− -> (Tag -> htable Result)

255+ -> (Tag -> htable (Col Result))

121 -> Maybe (rep x)

256 -> Maybe (rep x)

122− -> GColumnsADT' _Columns htable exprs context

257+ -> GColumnsADT' _Columns htable exprs (Col Result)

123

258

124 extract :: GColumnsADT' _Columns htable exprs context -> htable context

259 extract :: GColumnsADT' _Columns htable exprs context -> htable context

125

260

126

261

127instance

262instance

128− ( htable' ~ GColumnsADT' _Columns htable exprs1

263+ ( htable' ~ GColumnsADT' _Columns htable a

129− , GSerializeADT' _Serialize _Columns htable exprs1 a

264+ , GToExprsADT' _ToExprs _Columns htable a rep1

130− , GSerializeADT' _Serialize _Columns htable' exprs2 b

265+ , GToExprsADT' _ToExprs _Columns htable' b rep2

131 )

266 )

132− => GSerializeADT' _Serialize _Columns htable (exprs1 :+: exprs2) (a :+: b)

267+ => GToExprsADT' _ToExprs _Columns htable (a :+: b) (rep1 :+: rep2)

133 where

268 where

134 gfromResultADT' fromResult f columns =

269 gfromResultADT' fromResult f columns =

135 case ma of

270 case ma of

136 Just a -> Just (L1 a)

271 Just a -> Just (L1 a)

137 Nothing -> R1 <$>

272 Nothing -> R1 <$>

138− gfromResultADT' @_Serialize @_Columns @_ @exprs2 @b

273+ gfromResultADT' @_ToExprs @_Columns @_ @b @rep2

139 fromResult

274 fromResult

140− (f . extract @_Serialize @_Columns @_ @exprs1 @a)

275+ (f . extract @_ToExprs @_Columns @_ @a @rep1)

141 columns

276 columns

142 where

277 where

143 ma =

278 ma =

144− gfromResultADT' @_Serialize @_Columns @_ @exprs1 @a

279+ gfromResultADT' @_ToExprs @_Columns @_ @a @rep1

145 fromResult

280 fromResult

146 f

281 f

147− (extract @_Serialize @_Columns @_ @exprs2 @b columns)

282+ (extract @_ToExprs @_Columns @_ @b @rep2 columns)

148

283

149 gtoResultADT' toResult tag = \case

284 gtoResultADT' toResult tag = \case

150 Just (L1 a) ->

285 Just (L1 a) ->

151− gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b

286+ gtoResultADT' @_ToExprs @_Columns @_ @b @rep2

152 toResult

287 toResult

153− (\_ -> gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a

288+ (\_ -> gtoResultADT' @_ToExprs @_Columns @_ @a @rep1

154 toResult

289 toResult

155 tag

290 tag

156 (Just a))

291 (Just a))

157 Nothing

292 Nothing

158 Just (R1 b) ->

293 Just (R1 b) ->

159− gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b

294+ gtoResultADT' @_ToExprs @_Columns @_ @b @rep2

160 toResult

295 toResult

161 (\tag' ->

296 (\tag' ->

162− gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a

297+ gtoResultADT' @_ToExprs @_Columns @_ @a @rep1

163 toResult

298 toResult

164 (\_ -> tag tag')

299 (\_ -> tag tag')

165 Nothing)

300 Nothing)

166 (Just b)

301 (Just b)

167 Nothing ->

302 Nothing ->

168− gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b

303+ gtoResultADT' @_ToExprs @_Columns @_ @b @rep2

169 toResult

304 toResult

170− (\_ -> gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a toResult tag Nothing)

305+ (\_ -> gtoResultADT' @_ToExprs @_Columns @_ @a @rep1 toResult tag Nothing)

171 Nothing

306 Nothing

172

307

173 extract =

308 extract =

174− extract @_Serialize @_Columns @_ @exprs1 @a .

309+ extract @_ToExprs @_Columns @_ @a @rep1 .

175− extract @_Serialize @_Columns @_ @exprs2 @b

310+ extract @_ToExprs @_Columns @_ @b @rep2

176

311

177

312

313+instance

178−instance (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) =>

314+ ( meta ~ 'MetaCons label _fixity _isRecord

315+ , KnownSymbol label

316+ )

179− GSerializeADT' _Serialize _Columns _htable (M1 C meta U1) (M1 C meta U1)

317+ => GToExprsADT' _ToExprs _Columns htable (M1 C meta U1) (M1 C meta U1)

180 where

318 where

181 gfromResultADT' _ tag columns

319 gfromResultADT' _ tag columns

182 | tag columns == tag' = Just (M1 U1)

320 | tag columns == tag' = Just (M1 U1)

@@ -193,29 +331,33 @@ instance (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) =>

193

331

194instance {-# OVERLAPPABLE #-}

332instance {-# OVERLAPPABLE #-}

195 ( HTable (GColumns _Columns exprs)

333 ( HTable (GColumns _Columns exprs)

196− , GSerialize _Serialize _Columns exprs rep

334+ , GToExprs _ToExprs _Columns exprs rep

197 , meta ~ 'MetaCons label _fixity _isRecord

335 , meta ~ 'MetaCons label _fixity _isRecord

198 , KnownSymbol label

336 , KnownSymbol label

199− , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) exprs) ~

337+ , GColumnsADT' _Columns htable (M1 C meta exprs) ~

200 HProduct htable (HLabel label (HNullify (GColumns _Columns exprs)))

338 HProduct htable (HLabel label (HNullify (GColumns _Columns exprs)))

201 )

339 )

202− => GSerializeADT' _Serialize _Columns htable (M1 C meta exprs) (M1 C meta rep)

340+ => GToExprsADT' _ToExprs _Columns htable (M1 C meta exprs) (M1 C meta rep)

203 where

341 where

204 gfromResultADT' fromResult tag (HProduct a b)

342 gfromResultADT' fromResult tag (HProduct a b)

205 | tag a == tag' =

343 | tag a == tag' =

206− M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult <$>

344+ M1 . gfromResult @_ToExprs @_Columns @exprs fromResult <$>

207− hunnullify unnullifier (hunlabel b)

345+ hunnullify unnullifier (hunlabel unlabeler b)

208 | otherwise = Nothing

346 | otherwise = Nothing

209 where

347 where

210 tag' = Tag $ pack $ symbolVal (Proxy @label)

348 tag' = Tag $ pack $ symbolVal (Proxy @label)

211

349

212 gtoResultADT' toResult tag = \case

350 gtoResultADT' toResult tag = \case

213− Nothing -> HProduct (tag tag') (hlabel (hnulls (const null)))

351+ Nothing -> HProduct (tag tag') (hlabel labeler (hnulls (const null)))

214 Just (M1 rep) -> HProduct (tag tag') $

352 Just (M1 rep) -> HProduct (tag tag') $

215− hlabel $

353+ hlabel labeler $

216 hnullify nullifier $

354 hnullify nullifier $

217− gtoResult @_Serialize @_Columns @exprs @rep toResult rep

355+ gtoResult @_ToExprs @_Columns @exprs toResult rep

218 where

356 where

219 tag' = Tag $ pack $ symbolVal (Proxy @label)

357 tag' = Tag $ pack $ symbolVal (Proxy @label)

220

358

221 extract (HProduct a _) = a

359 extract (HProduct a _) = a

360+

361+

362+data Const :: (a -> Exp Constraint) -> a -> a -> Exp Constraint

363+type instance Eval (Const f x a) = (Eval (f a), x ~ a)

src/Rel8/Generic/Table/Record.hs+99−74

@@ -14,7 +14,7 @@

15module Rel8.Generic.Table.Record

16 ( GTable, GColumns, GContext, gfromColumns, gtoColumns, gtable

17− , GSerialize, gfromResult, gtoResult

17+ , GToExprs, gfromResult, gtoResult

18 )

19where

@@ -26,13 +26,18 @@ import GHC.Generics

26 , C, D, S

27 , Meta( MetaSel )

28 )

29+import GHC.TypeLits ( KnownSymbol )

29import Prelude hiding ( null )

30import Prelude hiding ( null )

31-- rel8

32-- rel8

32import Rel8.FCF ( Eval, Exp )

33import Rel8.FCF ( Eval, Exp )

34+import Rel8.Schema.Context ( Col )

35+import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )

36+import Rel8.Schema.HTable ( HTable )

33import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )

37import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )

34import Rel8.Schema.HTable.Product ( HProduct(..) )

38import Rel8.Schema.HTable.Product ( HProduct(..) )

35import qualified Rel8.Schema.Kind as K

39import qualified Rel8.Schema.Kind as K

40+import Rel8.Schema.Result ( Result )

38type GColumns :: (Type -> Exp K.HTable) -> (Type -> Type) -> K.HTable

43type GColumns :: (Type -> Exp K.HTable) -> (Type -> Type) -> K.HTable

@@ -55,8 +60,8 @@ type family GContext _Context rep where

55type GTable

60type GTable

56 :: (Type -> Exp Constraint)

61 :: (Type -> Exp Constraint)

57 -> (Type -> Exp K.HTable)

62 -> (Type -> Exp K.HTable)

58− -> (Type -> Type) -> Constraint

63+ -> K.HContext -> (Type -> Type) -> Constraint

59−class GTable _Table _Columns rep

64+class GTable _Table _Columns context rep

60 where

65 where

61 gfromColumns :: ()

66 gfromColumns :: ()

62 => (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)

67 => (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)

@@ -73,109 +78,129 @@ class GTable _Table _Columns rep

73 -> GColumns _Columns rep context

78 -> GColumns _Columns rep context

76−type GSerialize

81+instance GTable _Table _Columns context rep =>

77− :: (Type -> Type -> Exp Constraint)

82+ GTable _Table _Columns context (M1 D c rep)

78− -> (Type -> Exp K.HTable)

79− -> (Type -> Type) -> (Type -> Type) -> Constraint

80−class GSerialize _Serialize _Columns exprs rep

81 where

83 where

82− gfromResult :: ()

84+ gfromColumns fromColumns =

83− => (forall expr a proxy. Eval (_Serialize expr a)

85+ M1 . gfromColumns @_Table @_Columns @context @rep fromColumns

84− => proxy expr -> Eval (_Columns expr) context -> a)

86+ gtoColumns toColumns (M1 a) =

85− -> GColumns _Columns exprs context

87+ gtoColumns @_Table @_Columns @context @rep toColumns a

86− -> rep x

87−

88− gtoResult :: ()

89− => (forall expr a proxy. Eval (_Serialize expr a)

90− => proxy expr -> a -> Eval (_Columns expr) context)

88+ gtable = gtable @_Table @_Columns @context @rep

91− -> rep x

92− -> GColumns _Columns exprs context

95−instance GTable _Table _Columns rep => GTable _Table _Columns (M1 D c rep)

91+instance GTable _Table _Columns context rep =>

92+ GTable _Table _Columns context (M1 C c rep)

96 where

93 where

97 gfromColumns fromColumns =

94 gfromColumns fromColumns =

98− M1 . gfromColumns @_Table @_Columns @rep fromColumns

95+ M1 . gfromColumns @_Table @_Columns @context @rep fromColumns

99 gtoColumns toColumns (M1 a) =

96 gtoColumns toColumns (M1 a) =

100− gtoColumns @_Table @_Columns @rep toColumns a

97+ gtoColumns @_Table @_Columns @context @rep toColumns a

101− gtable = gtable @_Table @_Columns @rep

98+ gtable = gtable @_Table @_Columns @context @rep

102

103

100

104−instance GSerialize _Serialize _Columns exprs rep =>

101+instance

105− GSerialize _Serialize _Columns (M1 D c exprs) (M1 D c rep)

102+ ( GTable _Table _Columns context rep1

103+ , GTable _Table _Columns context rep2

104+ )

105+ => GTable _Table _Columns context (rep1 :*: rep2)

106 where

107− gfromResult fromResult =

107+ gfromColumns fromColumns (HProduct a b) =

108− M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult

108+ gfromColumns @_Table @_Columns @context @rep1 fromColumns a :*:

109− gtoResult toResult (M1 a) =

109+ gfromColumns @_Table @_Columns @context @rep2 fromColumns b

110− gtoResult @_Serialize @_Columns @exprs @rep toResult a

110+ gtoColumns toColumns (a :*: b) = HProduct

111+ (gtoColumns @_Table @_Columns @context @rep1 toColumns a)

112+ (gtoColumns @_Table @_Columns @context @rep2 toColumns b)

113+ gtable table = HProduct

114+ (gtable @_Table @_Columns @context @rep1 table)

115+ (gtable @_Table @_Columns @context @rep2 table)

111

116

112

117

118+instance

119+ ( HTable (Eval (_Columns a))

120+ , Eval (_Table a)

121+ , HLabelable context

122+ , KnownSymbol label

123+ , meta ~ 'MetaSel ('Just label) _su _ss _ds

124+ , k1 ~ K1 i a

125+ )

113−instance GTable _Table _Columns rep => GTable _Table _Columns (M1 C c rep)

126+ => GTable _Table _Columns context (M1 S meta k1)

114 where

127 where

115− gfromColumns fromColumns =

128+ gfromColumns fromColumns = M1 . K1 . fromColumns . hunlabel hunlabeler

116− M1 . gfromColumns @_Table @_Columns @rep fromColumns

117− gtoColumns toColumns (M1 a) =

129+ gtoColumns toColumns (M1 (K1 a)) = hlabel hlabeler (toColumns a)

118− gtoColumns @_Table @_Columns @rep toColumns a

130+ gtable table = hlabel hlabeler (table (Proxy @a))

119− gtable = gtable @_Table @_Columns @rep

120

131

121

132

133+type GToExprs

134+ :: (Type -> Type -> Exp Constraint)

135+ -> (Type -> Exp K.HTable)

136+ -> (Type -> Type) -> (Type -> Type) -> Constraint

137+class GToExprs _ToExprs _Columns exprs rep where

138+ gfromResult :: ()

139+ => (forall expr a proxy.

140+ ( Eval (_ToExprs expr a)

141+ , HTable (Eval (_Columns expr))

142+ )

143+ => proxy expr

144+ -> Eval (_Columns expr) (Col Result)

145+ -> a)

146+ -> GColumns _Columns exprs (Col Result)

147+ -> rep x

148+ gtoResult :: ()

149+ => (forall expr a proxy.

150+ ( Eval (_ToExprs expr a)

151+ , HTable (Eval (_Columns expr))

152+ )

153+ => proxy expr

154+ -> a

155+ -> Eval (_Columns expr) (Col Result))

156+ -> rep x

157+ -> GColumns _Columns exprs (Col Result)

158+

159+

122−instance GSerialize _Serialize _Columns exprs rep =>

160+instance GToExprs _ToExprs _Columns exprs rep =>

123− GSerialize _Serialize _Columns (M1 C c exprs) (M1 C c rep)

161+ GToExprs _ToExprs _Columns (M1 D c exprs) (M1 D c rep)

124 where

162 where

125 gfromResult fromResult =

163 gfromResult fromResult =

126− M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult

164+ M1 . gfromResult @_ToExprs @_Columns @exprs fromResult

127 gtoResult toResult (M1 a) =

165 gtoResult toResult (M1 a) =

128− gtoResult @_Serialize @_Columns @exprs @rep toResult a

166+ gtoResult @_ToExprs @_Columns @exprs toResult a

129

167

130

168

131−instance (GTable _Table _Columns rep1, GTable _Table _Columns rep2) =>

169+instance GToExprs _ToExprs _Columns exprs rep =>

132− GTable _Table _Columns (rep1 :*: rep2)

170+ GToExprs _ToExprs _Columns (M1 C c exprs) (M1 C c rep)

133 where

171 where

134− gfromColumns fromColumns (HProduct a b) =

172+ gfromResult fromResult =

135− gfromColumns @_Table @_Columns @rep1 fromColumns a :*:

173+ M1 . gfromResult @_ToExprs @_Columns @exprs fromResult

136− gfromColumns @_Table @_Columns @rep2 fromColumns b

174+ gtoResult toResult (M1 a) =

137− gtoColumns toColumns (a :*: b) = HProduct

175+ gtoResult @_ToExprs @_Columns @exprs toResult a

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

176

144

177

145instance

178instance

146− ( GSerialize _Serialize _Columns expr1 rep1

179+ ( GToExprs _ToExprs _Columns exprs1 rep1

147− , GSerialize _Serialize _Columns expr2 rep2

180+ , GToExprs _ToExprs _Columns exprs2 rep2

148 )

181 )

149− => GSerialize _Serialize _Columns (expr1 :*: expr2) (rep1 :*: rep2)

182+ => GToExprs _ToExprs _Columns (exprs1 :*: exprs2) (rep1 :*: rep2)

150 where

183 where

151 gfromResult fromResult (HProduct a b) =

184 gfromResult fromResult (HProduct a b) =

152− gfromResult @_Serialize @_Columns @expr1 @rep1 fromResult a :*:

185+ gfromResult @_ToExprs @_Columns @exprs1 fromResult a :*:

153− gfromResult @_Serialize @_Columns @expr2 @rep2 fromResult b

186+ gfromResult @_ToExprs @_Columns @exprs2 fromResult b

154 gtoResult toResult (a :*: b) =

187 gtoResult toResult (a :*: b) =

155 HProduct

188 HProduct

156− (gtoResult @_Serialize @_Columns @expr1 @rep1 toResult a)

189+ (gtoResult @_ToExprs @_Columns @exprs1 toResult a)

157− (gtoResult @_Serialize @_Columns @expr2 @rep2 toResult b)

190+ (gtoResult @_ToExprs @_Columns @exprs2 toResult b)

158

191

159

192

160instance

193instance

161− ( Eval (_Table a)

194+ ( Eval (_ToExprs exprs a)

195+ , HTable (Eval (_Columns exprs))

196+ , KnownSymbol label

162 , meta ~ 'MetaSel ('Just label) _su _ss _ds

197 , meta ~ 'MetaSel ('Just label) _su _ss _ds

163− , k1 ~ K1 i a

198+ , k1 ~ K1 i exprs

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

199 , k1' ~ K1 i a

177 )

200 )

178− => GSerialize _Serialize _Columns (M1 S meta k1) (M1 S meta k1')

201+ => GToExprs _ToExprs _Columns (M1 S meta k1) (M1 S meta k1')

179 where

202 where

180− gfromResult fromResult = M1 . K1 . fromResult (Proxy @expr) . hunlabel

203+ gfromResult fromResult =

204+ M1 . K1 . fromResult (Proxy @exprs) . hunlabel hunlabeler

181− gtoResult toResult (M1 (K1 a)) = hlabel (toResult (Proxy @expr) a)

205+ gtoResult toResult (M1 (K1 a)) =

206+ hlabel hlabeler (toResult (Proxy @exprs) a)

src/Rel8/Kind/Context.hs+41−8

@@ -1,11 +1,13 @@

1{-# language DataKinds #-}

2{-# language GADTs #-}

3+{-# language LambdaCase #-}

3{-# language StandaloneKindSignatures #-}

4{-# language StandaloneKindSignatures #-}

4−{-# language TypeSynonymInstances #-}

6module Rel8.Kind.Context

7 ( Reifiable( contextSing )

8 , SContext(..)

9+ , sReifiable

10+ , sLabelable

9 )

11 )

10where

12where

@@ -16,9 +18,13 @@ import Prelude ()

16-- rel8

18-- rel8

17import Rel8.Aggregate ( Aggregate )

19import Rel8.Aggregate ( Aggregate )

18import Rel8.Expr ( Expr )

20import Rel8.Expr ( Expr )

19−import Rel8.Schema.Field ( Field )

21+import Rel8.Schema.Dict ( Dict( Dict ) )

22+import Rel8.Schema.Context ( Interpretation )

23+import Rel8.Schema.Context.Label ( Labelable )

24+import Rel8.Schema.Insert ( Insert )

20import Rel8.Schema.Kind ( Context )

25import Rel8.Schema.Kind ( Context )

21import Rel8.Schema.Name ( Name )

26import Rel8.Schema.Name ( Name )

27+import Rel8.Schema.Reify ( Reify )

22import Rel8.Schema.Result ( Result )

28import Rel8.Schema.Result ( Result )

@@ -26,13 +32,14 @@ type SContext :: Context -> Type

26data SContext context where

32data SContext context where

27 SAggregate :: SContext Aggregate

33 SAggregate :: SContext Aggregate

28 SExpr :: SContext Expr

34 SExpr :: SContext Expr

29− SField :: SContext (Field table)

35+ SInsert :: SContext Insert

30 SName :: SContext Name

36 SName :: SContext Name

31 SResult :: SContext Result

37 SResult :: SContext Result

38+ SReify :: SContext context -> SContext (Reify context)

34type Reifiable :: Context -> Constraint

41type Reifiable :: Context -> Constraint

35−class Reifiable context where

42+class Interpretation context => Reifiable context where

36 contextSing :: SContext context

43 contextSing :: SContext context

@@ -44,13 +51,39 @@ instance Reifiable Expr where

44 contextSing = SExpr

51 contextSing = SExpr

47−instance Reifiable (Field table) where

48− contextSing = SField

49−

50−

51instance Reifiable Result where

54instance Reifiable Result where

52 contextSing = SResult

55 contextSing = SResult

58+instance Reifiable Insert where

59+ contextSing = SInsert

60+

61+

55instance Reifiable Name where

62instance Reifiable Name where

56 contextSing = SName

63 contextSing = SName

64+

65+

66+instance Reifiable context => Reifiable (Reify context) where

67+ contextSing = SReify contextSing

68+

69+

70+sReifiable :: SContext context -> Dict Reifiable context

71+sReifiable = \case

72+ SAggregate -> Dict

73+ SExpr -> Dict

74+ SInsert -> Dict

75+ SName -> Dict

76+ SResult -> Dict

77+ SReify context -> case sReifiable context of

78+ Dict -> Dict

79+

80+

81+sLabelable :: SContext context -> Dict Labelable context

82+sLabelable = \case

83+ SAggregate -> Dict

84+ SExpr -> Dict

85+ SInsert -> Dict

86+ SName -> Dict

87+ SResult -> Dict

88+ SReify context -> case sLabelable context of

89+ Dict -> Dict

src/Rel8/Kind/Labels.hsnew file+57

@@ -0,0 +1,57 @@

1+{-# language DataKinds #-}

2+{-# language FlexibleContexts #-}

3+{-# language FlexibleInstances #-}

4+{-# language GADTs #-}

5+{-# language LambdaCase #-}

6+{-# language StandaloneKindSignatures #-}

7+{-# language TypeOperators #-}

9+module Rel8.Kind.Labels

10+ ( Labels

11+ , SLabels( SNil, SCons )

12+ , KnownLabels( labelsSing )

13+ , renderLabels

14+ )

15+where

16+

17+-- base

18+import Data.Kind ( Constraint, Type )

19+import Data.List.NonEmpty ( NonEmpty, nonEmpty )

20+import Data.Maybe ( fromMaybe )

21+import Data.Proxy ( Proxy( Proxy ) )

22+import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )

23+import Prelude

24+

25+

26+type Labels :: Type

27+type Labels = [Symbol]

28+

29+

30+type SLabels :: Labels -> Type

31+data SLabels labels where

32+ SNil :: SLabels '[]

33+ SCons :: KnownSymbol label => Proxy label -> SLabels labels -> SLabels (label ': labels)

34+

35+

36+type KnownLabels :: Labels -> Constraint

37+class KnownLabels labels where

38+ labelsSing :: SLabels labels

39+

40+

41+instance KnownLabels '[] where

42+ labelsSing = SNil

43+

44+

45+instance (KnownSymbol label, KnownLabels labels) =>

46+ KnownLabels (label ': labels)

47+ where

48+ labelsSing = SCons Proxy labelsSing

49+

50+

51+renderLabels :: SLabels labels -> NonEmpty String

52+renderLabels = fromMaybe (pure "anon") . nonEmpty . go

53+ where

54+ go :: SLabels labels -> [String]

55+ go = \case

56+ SNil -> []

57+ SCons label labels -> symbolVal label : go labels

src/Rel8/Kind/Necessity.hsnew file+38

@@ -0,0 +1,38 @@

1+{-# language DataKinds #-}

2+{-# language FlexibleContexts #-}

3+{-# language GADTs #-}

4+{-# language StandaloneKindSignatures #-}

6+module Rel8.Kind.Necessity

7+ ( Necessity( Optional, Required )

8+ , SNecessity( SOptional, SRequired )

9+ , KnownNecessity( necessitySing )

10+ )

11+where

12+

13+-- base

14+import Data.Kind ( Constraint, Type )

15+import Prelude ()

16+

17+

18+type Necessity :: Type

19+data Necessity = Optional | Required

20+

21+

22+type SNecessity :: Necessity -> Type

23+data SNecessity necessity where

24+ SOptional :: SNecessity 'Optional

25+ SRequired :: SNecessity 'Required

26+

27+

28+type KnownNecessity :: Necessity -> Constraint

29+class KnownNecessity necessity where

30+ necessitySing :: SNecessity necessity

31+

32+

33+instance KnownNecessity 'Optional where

34+ necessitySing = SOptional

35+

36+

37+instance KnownNecessity 'Required where

38+ necessitySing = SRequired

src/Rel8/Order.hs+9−2

@@ -4,6 +4,7 @@

5module Rel8.Order

6 ( Order(..)

7+ , toOrderExprs

7 )

8 )

8where

9where

@@ -16,7 +17,8 @@ import Prelude

16import Data.Functor.Contravariant.Divisible ( Decidable, Divisible )

17import Data.Functor.Contravariant.Divisible ( Decidable, Divisible )

18-- opaleye

19-- opaleye

19−import qualified Opaleye.Order as Opaleye

20+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

21+import qualified Opaleye.Internal.Order as Opaleye

22-- | An ordering expression for @a@. Primitive orderings are defined with

24-- | An ordering expression for @a@. Primitive orderings are defined with

@@ -24,7 +26,12 @@ import qualified Opaleye.Order as Opaleye

24-- instances.

26-- instances.

25--

27--

26-- A common pattern is to use '<>' to combine multiple orderings in sequence,

28-- A common pattern is to use '<>' to combine multiple orderings in sequence,

27−-- and 'Data.Functor.Contravariant.>$<' to select individual columns.

29+-- and '>$<' (from 'Contravariant') to select individual columns.

28type Order :: Type -> Type

30type Order :: Type -> Type

29newtype Order a = Order (Opaleye.Order a)

31newtype Order a = Order (Opaleye.Order a)

30 deriving newtype (Contravariant, Divisible, Decidable, Semigroup, Monoid)

32 deriving newtype (Contravariant, Divisible, Decidable, Semigroup, Monoid)

33+

34+

35+toOrderExprs :: Order a -> a -> [Opaleye.OrderExpr]

36+toOrderExprs (Order (Opaleye.Order order)) a =

37+ uncurry Opaleye.OrderExpr <$> order a

src/Rel8/Query.hs+7−181

@@ -1,6 +1,6 @@

1−{-# language FlexibleContexts #-}

1+{-# language DerivingVia #-}

2+{-# language GeneralizedNewtypeDeriving #-}

2{-# language StandaloneKindSignatures #-}

3{-# language StandaloneKindSignatures #-}

3−{-# language UndecidableInstances #-}

5module Rel8.Query

6 ( Query( Query )

@@ -8,201 +8,37 @@ module Rel8.Query

8where

10-- base

11−import Control.Applicative ( liftA2 )

12−import Control.Monad ( liftM2 )

13import Data.Kind ( Type )

11import Data.Kind ( Type )

14−import Data.Monoid ( Any( Any ) )

15import Prelude

12import Prelude

17-- opaleye

14-- opaleye

18−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

15+import qualified Opaleye.Select as Opaleye

19−import qualified Opaleye.Internal.PackMap as Opaleye

20−import qualified Opaleye.Internal.PrimQuery as Opaleye hiding (lateral)

21−import qualified Opaleye.Internal.QueryArr as Opaleye

22−import qualified Opaleye.Internal.Tag as Opaleye

24-- rel8

17-- rel8

25−import Rel8.Expr ( Expr )

26import Rel8.Query.Set ( unionAll )

18import Rel8.Query.Set ( unionAll )

27−import Rel8.Query.Opaleye ( fromOpaleye )

28import Rel8.Query.Values ( values )

19import Rel8.Query.Values ( values )

29−import Rel8.Table ( Table, fromColumns, toColumns )

30import Rel8.Table.Alternative

20import Rel8.Table.Alternative

31 ( AltTable, (<|>:)

21 ( AltTable, (<|>:)

32 , AlternativeTable, emptyTable

22 , AlternativeTable, emptyTable

33 )

23 )

34−import Rel8.Table.Projection ( Projectable, apply, project )

36-- semigroupoids

25-- semigroupoids

37−import Data.Functor.Apply ( Apply, (<.>) )

26+import Data.Functor.Apply ( Apply, WrappedApplicative(..) )

38import Data.Functor.Bind ( Bind, (>>-) )

27import Data.Functor.Bind ( Bind, (>>-) )

41-- | The @Query@ monad allows you to compose a @SELECT@ query. This monad has

30-- | The @Query@ monad allows you to compose a @SELECT@ query. This monad has

42-- semantics similar to the list (@[]@) monad.

31-- semantics similar to the list (@[]@) monad.

43type Query :: Type -> Type

32type Query :: Type -> Type

44−newtype Query a =

33+newtype Query a = Query (Opaleye.Select a)

45− Query (

34+ deriving newtype (Functor, Applicative, Monad)

46− -- This is based on Opaleye's Select monad, but with two addtions. We

35+ deriving Apply via (WrappedApplicative Opaleye.Select)

47− -- maintain a stack of PrimExprs from parent previous subselects. In

48− -- practice, these are always the results of dummy calls to random().

49− --

50− -- We also return a Bool that indicates to the parent subselect whether

51− -- or not that stack of PrimExprs were used at any point. If they weren't,

52− -- then the call to random() is never added to the query.

53− --

54− -- This is all needed to implement evaluate. Consider the following code:

55− --

56− -- do

57− -- x <- values [lit 'a', lit 'b', lit 'c']

58− -- y <- evaluate $ nextval "user_id_seq"

59− -- pure (x, y)

60− --

61− -- If we just used Opaleye's Select monad directly, the SQL would come out

62− -- like this:

63− --

64− -- SELECT

65− -- a, b

66− -- FROM

67− -- (VALUES ('a'), ('b'), ('c')) Q1(a),

68− -- LATERAL (SELECT nextval('user_id_seq')) Q2(b);

69− --

70− -- From the Haskell code, you would intuitively expect to get back the

71− -- results of three different calls to nextval(), but from Postgres' point

72− -- of view, because the Q2 subquery doesn't reference anything from the Q1

73− -- query, it thinks it only needs to call nextval() once. This is actually

74− -- exactly the same problem you get with the deprecated ListT IO monad from

75− -- the transformers package — *> behaves differently to >>=, so

76− -- using ApplicativeDo can change the results of a program. ApplicativeDo

77− -- is exactly the optimisation Postgres does on a "LATERAL" query that

78− -- doesn't make any references to previous subselects.

79− --

80− -- Rel8's solution is generate the following SQL instead:

81− --

82− -- SELECT

83− -- a, b

84− -- FROM

85− -- (SELECT

86− -- random() AS dummy,

87− -- *

88− -- FROM

89− -- (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1,

90− -- LATERAL (SELECT

91− -- CASE

92− -- WHEN dummy IS NOT NULL

93− -- THEN nextval('user_id_seq')

94− -- END) Q2(b);

95− --

96− -- We use random() here as the dummy value (and not some constant) because

97− -- Postgres will again optimize if it sees that a value is constant

98− -- (and thus only call nextval() once), but because random() is marked as

99− -- VOLATILE, this inhibits Postgres from doing that optimisation.

100− --

101− -- Why not just reference the a column from the previous query directly

102− -- instead of adding a dummy value? Basically, even if we extract out all

103− -- the bindings introduced in a PrimQuery, we can't always be sure which

104− -- ones refer to constant values, so if we end up laterally referencing a

105− -- constant value, then all of this would be for nothing.

106− --

107− -- Why not just add the call to the previous subselect directly, like so:

108− --

109− -- SELECT

110− -- a, b

111− -- FROM

112− -- (SELECT

113− -- nextval('user_id_seq') AS eval,

114− -- *

115− -- FROM

116− -- (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1,

117− -- LATERAL (SELECT eval) Q2(b);

118− --

119− -- That would work in this case. But consider the following Rel8 code:

120− --

121− -- do

122− -- x <- values [lit 'a', lit 'b', lit 'c']

123− -- y <- values [lit 'd', lit 'e', lit 'f']

124− -- z <- evaluate $ nextval "user_id_seq"

125− -- pure (x, y, z)

126− --

127− -- How many calls to nextval should there be? Our Haskell intuition says

128− -- nine. But that's not what you would get if you used the above

129− -- technique. The problem is, which VALUES query should the nextval be

130− -- added to? You can choose one or the other to get three calls to

131− -- nextval, but you still need to make a superfluous LATERAL references to

132− -- the other if you want nine calls. So for the above Rel8 code we generate

133− -- the following SQL:

134− --

135− -- SELECT

136− -- a, b, c

137− -- FROM

138− -- (SELECT

139− -- random() AS dummy,

140− -- *

141− -- FROM

142− -- (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1,

143− -- (SELECT

144− -- random() AS dummy,

145− -- *

146− -- FROM

147− -- (VALUES ('d'), ('e'), ('f')) Q2(b)) Q2,

148− -- LATERAL (SELECT

149− -- CASE

150− -- WHEN Q1.dummy IS NOT NULL AND Q2.dummy IS NOT NULL

151− -- THEN nextval('user_id_seq')

152− -- END) Q3(c);

153− --

154− -- This gives nine calls to nextval() as we would expect.

155− [Opaleye.PrimExpr] -> Opaleye.Select (Any, a)

156− )

157−

158−

159−instance Projectable Query where

160− project f = fmap (fromColumns . apply f . toColumns)

161−

162−

163−instance Functor Query where

164− fmap f (Query a) = Query (fmap (fmap (fmap f)) a)

165−

166−

167−instance Apply Query where

168− (<.>) = (<*>)

169−

170−

171−instance Applicative Query where

172− pure = fromOpaleye . pure

173− liftA2 = liftM2

174

175

176instance Bind Query where

38instance Bind Query where

177 (>>-) = (>>=)

39 (>>-) = (>>=)

178

179

180−instance Monad Query where

181− Query q >>= f = Query $ \dummies -> Opaleye.stateQueryArr $ \_ tag ->

182− let

183− qa = q dummies

184− ((m, a), query, tag') = Opaleye.runStateQueryArr qa () tag

185− Query q' = f a

186− (dummies', query', tag'') =

187− ( dummy : dummies

188− , query <> Opaleye.aRebind bindings

189− , Opaleye.next tag'

190− )

191− where

192− (dummy, bindings) = Opaleye.run $ name random

193− where

194− random = Opaleye.FunExpr "random" []

195− name = Opaleye.extractAttr "dummy" tag'

196− qa' = Opaleye.lateral $ \_ -> q' dummies'

197− ((m'@(Any needsDummies), b), query'', tag''') = Opaleye.runStateQueryArr qa' () tag''

198− query'''

199− | needsDummies = query' <> query''

200− | otherwise = query <> query''

201− m'' = m <> m'

202− in

203− ((m'', b), query''', tag''')

204−

205−

206-- | '<|>:' = 'unionAll'.

42-- | '<|>:' = 'unionAll'.

207instance AltTable Query where

43instance AltTable Query where

208 (<|>:) = unionAll

44 (<|>:) = unionAll

@@ -211,13 +47,3 @@ instance AltTable Query where

211-- | 'emptyTable' = 'values' @[]@.

47-- | 'emptyTable' = 'values' @[]@.

212instance AlternativeTable Query where

48instance AlternativeTable Query where

213 emptyTable = values []

49 emptyTable = values []

214−

215−

216−-- | '<>' = 'unionAll'.

217−instance Table Expr a => Semigroup (Query a) where

218− (<>) = (<|>:)

219−

220−

221−-- | 'mempty' = @'values' []@.

222−instance Table Expr a => Monoid (Query a) where

223− mempty = emptyTable

src/Rel8/Query.hs-boot+1−3

@@ -7,13 +7,11 @@ where

8-- base

9import Data.Kind ( Type )

10−import Data.Monoid ( Any )

11import Prelude ()

10import Prelude ()

13-- opaleye

12-- opaleye

14−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

15import qualified Opaleye.Select as Opaleye

13import qualified Opaleye.Select as Opaleye

18type Query :: Type -> Type

16type Query :: Type -> Type

19−newtype Query a = Query ([Opaleye.PrimExpr] -> Opaleye.Select (Any, a))

17+newtype Query a = Query (Opaleye.Select a)

src/Rel8/Query/Aggregate.hs+2−22

@@ -1,17 +1,12 @@

1{-# language FlexibleContexts #-}

2−{-# language MonoLocalBinds #-}

3−{-# language ScopedTypeVariables #-}

4−{-# language TypeApplications #-}

6module Rel8.Query.Aggregate

3module Rel8.Query.Aggregate

7 ( aggregate

4 ( aggregate

8 , countRows

5 , countRows

9− , mode

10 )

6 )

11where

7where

13-- base

9-- base

14−import Data.Functor.Contravariant ( (>$<) )

15import Data.Int ( Int64 )

10import Data.Int ( Int64 )

16import Prelude

11import Prelude

@@ -19,25 +14,18 @@ import Prelude

19import qualified Opaleye.Aggregate as Opaleye

14import qualified Opaleye.Aggregate as Opaleye

21-- rel8

16-- rel8

22−import Rel8.Aggregate ( Aggregates )

17+import Rel8.Aggregate ( Aggregate )

23import Rel8.Expr ( Expr )

18import Rel8.Expr ( Expr )

24import Rel8.Expr.Aggregate ( countStar )

19import Rel8.Expr.Aggregate ( countStar )

25−import Rel8.Expr.Order ( desc )

26import Rel8.Query ( Query )

20import Rel8.Query ( Query )

27−import Rel8.Query.Limit ( limit )

28import Rel8.Query.Maybe ( optional )

21import Rel8.Query.Maybe ( optional )

29import Rel8.Query.Opaleye ( mapOpaleye )

22import Rel8.Query.Opaleye ( mapOpaleye )

30−import Rel8.Query.Order ( orderBy )

31−import Rel8.Table ( toColumns )

32−import Rel8.Table.Aggregate ( hgroupBy )

33−import Rel8.Table.Cols ( Cols( Cols ), fromCols )

34−import Rel8.Table.Eq ( EqTable, eqTable )

35import Rel8.Table.Opaleye ( aggregator )

23import Rel8.Table.Opaleye ( aggregator )

36import Rel8.Table.Maybe ( maybeTable )

24import Rel8.Table.Maybe ( maybeTable )

39-- | Apply an aggregation to all rows returned by a 'Query'.

27-- | Apply an aggregation to all rows returned by a 'Query'.

40−aggregate :: Aggregates aggregates exprs => Query aggregates -> Query exprs

28+aggregate :: Query (Aggregate exprs) -> Query exprs

41aggregate = mapOpaleye (Opaleye.aggregate aggregator)

29aggregate = mapOpaleye (Opaleye.aggregate aggregator)

@@ -46,11 +34,3 @@ aggregate = mapOpaleye (Opaleye.aggregate aggregator)

46-- will return @0@.

34-- will return @0@.

47countRows :: Query a -> Query (Expr Int64)

35countRows :: Query a -> Query (Expr Int64)

48countRows = fmap (maybeTable 0 id) . optional . aggregate . fmap (const countStar)

36countRows = fmap (maybeTable 0 id) . optional . aggregate . fmap (const countStar)

49−

50−

51−-- | Return the most common row in a query.

52−mode :: forall a. EqTable a => Query a -> Query a

53−mode rows = limit 1 $ fmap (fromCols . snd) $ orderBy (fst >$< desc) $ do

54− aggregate $ do

55− row <- toColumns <$> rows

56− pure (countStar, Cols $ hgroupBy (eqTable @a) row)

src/Rel8/Query/Distinct.hs+9−4

@@ -1,3 +1,5 @@

1+{-# options_ghc -fno-warn-redundant-constraints #-}

1module Rel8.Query.Distinct

3module Rel8.Query.Distinct

2 ( distinct

4 ( distinct

3 , distinctOn

5 , distinctOn

@@ -6,11 +8,12 @@ module Rel8.Query.Distinct

6where

8where

8-- base

10-- base

9−import Prelude ()

11+import Prelude

11-- opaleye

13-- opaleye

12import qualified Opaleye.Distinct as Opaleye

14import qualified Opaleye.Distinct as Opaleye

13−import qualified Opaleye.Order as Opaleye

15+import qualified Opaleye.Internal.Order as Opaleye

16+import qualified Opaleye.Internal.QueryArr as Opaleye

15-- rel8

18-- rel8

16import Rel8.Order ( Order( Order ) )

19import Rel8.Order ( Order( Order ) )

@@ -30,11 +33,13 @@ distinct = mapOpaleye (Opaleye.distinctExplicit distinctspec)

30-- to a projection. If multiple rows have the same projection, it is

33-- to a projection. If multiple rows have the same projection, it is

31-- unspecified which row will be returned. If this matters, use 'distinctOnBy'.

34-- unspecified which row will be returned. If this matters, use 'distinctOnBy'.

32distinctOn :: EqTable b => (a -> b) -> Query a -> Query a

35distinctOn :: EqTable b => (a -> b) -> Query a -> Query a

36+distinctOn proj =

33−distinctOn proj = mapOpaleye (Opaleye.distinctOnExplicit unpackspec proj)

37+ mapOpaleye (\q -> Opaleye.productQueryArr (Opaleye.distinctOn unpackspec proj . Opaleye.runSimpleQueryArr q))

36-- | Select all distinct rows from a query, where rows are equivalent according

40-- | Select all distinct rows from a query, where rows are equivalent according

37-- to a projection. If there are multiple rows with the same projection, the

41-- to a projection. If there are multiple rows with the same projection, the

38-- first row according to the specified 'Order' will be returned.

42-- first row according to the specified 'Order' will be returned.

39distinctOnBy :: EqTable b => (a -> b) -> Order a -> Query a -> Query a

43distinctOnBy :: EqTable b => (a -> b) -> Order a -> Query a -> Query a

40−distinctOnBy proj (Order order) = mapOpaleye (Opaleye.distinctOnByExplicit unpackspec proj order)

44+distinctOnBy proj (Order order) =

45+ mapOpaleye (\q -> Opaleye.productQueryArr (Opaleye.distinctOnBy unpackspec proj order . Opaleye.runSimpleQueryArr q))

src/Rel8/Query/Each.hs+3−3

@@ -17,7 +17,7 @@ import Rel8.Query ( Query )

17import Rel8.Query.Opaleye ( fromOpaleye )

18import Rel8.Schema.Name ( Selects )

19import Rel8.Schema.Table ( TableSchema )

20−import Rel8.Table.Cols ( fromCols, toCols )

20+import Rel8.Table ( fromColumns, toColumns )

21import Rel8.Table.Opaleye ( table, unpackspec )

@@ -25,8 +25,8 @@ import Rel8.Table.Opaleye ( table, unpackspec )

25-- table@.

26each :: Selects names exprs => TableSchema names -> Query exprs

27each =

28− fmap fromCols .

28+ fmap fromColumns .

29 fromOpaleye .

30 Opaleye.selectTableExplicit unpackspec .

31 table .

32− fmap toCols

32+ fmap toColumns

src/Rel8/Query/Either.hs+17−27

@@ -3,22 +3,23 @@

3module Rel8.Query.Either

4 ( keepLeftTable

5 , keepRightTable

6+ , bindEitherTable

6 , bitraverseEitherTable

7 , bitraverseEitherTable

7 )

8 )

8where

9where

10-- base

11-- base

12+import Data.Functor ( (<&>) )

11import Prelude

13import Prelude

13−-- comonad

14−import Control.Comonad ( extract )

15−

16-- rel8

15-- rel8

17import Rel8.Expr ( Expr )

16import Rel8.Expr ( Expr )

18import Rel8.Expr.Eq ( (==.) )

17import Rel8.Expr.Eq ( (==.) )

19import Rel8.Query ( Query )

18import Rel8.Query ( Query )

20import Rel8.Query.Filter ( where_ )

19import Rel8.Query.Filter ( where_ )

21import Rel8.Query.Maybe ( optional )

20import Rel8.Query.Maybe ( optional )

21+import Rel8.Table ( Table )

22+import Rel8.Table.Bool ( bool )

22import Rel8.Table.Either

23import Rel8.Table.Either

23 ( EitherTable( EitherTable )

24 ( EitherTable( EitherTable )

24 , isLeftTable, isRightTable

25 , isLeftTable, isRightTable

@@ -26,41 +27,30 @@ import Rel8.Table.Either

26import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )

27import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )

29−-- | Filter 'EitherTable's, keeping only 'leftTable's.

30−keepLeftTable :: EitherTable Expr a b -> Query a

30+keepLeftTable :: EitherTable a b -> Query a

31keepLeftTable e@(EitherTable _ a _) = do

32 where_ $ isLeftTable e

33− pure (extract a)

33+ pure a

36−-- | Filter 'EitherTable's, keeping only 'rightTable's.

37−keepRightTable :: EitherTable Expr a b -> Query b

36+keepRightTable :: EitherTable a b -> Query b

38keepRightTable e@(EitherTable _ _ b) = do

37keepRightTable e@(EitherTable _ _ b) = do

39 where_ $ isRightTable e

38 where_ $ isRightTable e

40− pure (extract b)

39+ pure b

40+

41+

42+bindEitherTable :: (Table Expr a, Functor m)

43+ => (i -> m (EitherTable a b)) -> EitherTable a i -> m (EitherTable a b)

44+bindEitherTable query e@(EitherTable input a i) = do

45+ query i <&> \(EitherTable output a' b) ->

46+ EitherTable (input <> output) (bool a a' (isRightTable e)) b

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

59bitraverseEitherTable :: ()

49bitraverseEitherTable :: ()

60 => (a -> Query c)

50 => (a -> Query c)

61 -> (b -> Query d)

51 -> (b -> Query d)

62− -> EitherTable Expr a b

52+ -> EitherTable a b

63− -> Query (EitherTable Expr c d)

53+ -> Query (EitherTable c d)

64bitraverseEitherTable f g e@(EitherTable tag _ _) = do

54bitraverseEitherTable f g e@(EitherTable tag _ _) = do

65 mc@(MaybeTable _ c) <- optional (f =<< keepLeftTable e)

55 mc@(MaybeTable _ c) <- optional (f =<< keepLeftTable e)

66 md@(MaybeTable _ d) <- optional (g =<< keepRightTable e)

56 md@(MaybeTable _ d) <- optional (g =<< keepRightTable e)

src/Rel8/Query/Evaluate.hsdeleted−49

@@ -1,49 +0,0 @@

1−{-# language FlexibleContexts #-}

2−{-# language TupleSections #-}

3−

4−module Rel8.Query.Evaluate

5− ( evaluate

6− )

7−where

8−

9−-- base

10−import Control.Monad ( (>=>) )

11−import Data.Foldable ( foldl' )

12−import Data.List.NonEmpty ( NonEmpty( (:|) ), nonEmpty )

13−import Data.Monoid ( Any( Any ) )

14−import Prelude hiding ( undefined )

15−

16−-- opaleye

17−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

18−

19−-- rel8

20−import Rel8.Expr ( Expr )

21−import Rel8.Expr.Bool ( (&&.) )

22−import Rel8.Expr.Opaleye ( fromPrimExpr )

23−import Rel8.Query ( Query( Query ) )

24−import Rel8.Query.Rebind ( rebind )

25−import Rel8.Table ( Table )

26−import Rel8.Table.Bool ( case_ )

27−import Rel8.Table.Undefined ( undefined )

28−

29−

30−-- | 'evaluate' takes expressions that could potentially have side effects and

31−-- \"runs\" them in the 'Query' monad. The returned expressions have no side

32−-- effects and can safely be reused.

33−evaluate :: Table Expr a => a -> Query a

34−evaluate = laterally >=> rebind "eval"

35−

36−

37−laterally :: Table Expr a => a -> Query a

38−laterally a = Query $ \bindings -> pure $ (Any True,) $

39− case nonEmpty bindings of

40− Nothing -> a

41− Just bindings' -> case_ [(condition, a)] undefined

42− where

43− condition = foldl1' (&&.) (fmap go bindings')

44− where

45− go = fromPrimExpr . Opaleye.UnExpr Opaleye.OpIsNotNull

46−

47−

48−foldl1' :: (a -> a -> a) -> NonEmpty a -> a

49−foldl1' f (a :| as) = foldl' f a as

src/Rel8/Query/Exists.hs+17−15

@@ -2,8 +2,8 @@

3module Rel8.Query.Exists

4 ( exists, inQuery

5− , present, with, withBy

5+ , whereExists, with, withBy

6− , absent, without, withoutBy

6+ , whereNotExists, without, withoutBy

7 )

8where

@@ -11,54 +11,56 @@ where

11import Prelude hiding ( filter )

13-- opaleye

14−import qualified Opaleye.Exists as Opaleye

15import qualified Opaleye.Operators as Opaleye

14import qualified Opaleye.Operators as Opaleye

17-- rel8

16-- rel8

18import Rel8.Expr ( Expr )

17import Rel8.Expr ( Expr )

19−import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )

20import Rel8.Query ( Query )

18import Rel8.Query ( Query )

21import Rel8.Query.Filter ( filter )

19import Rel8.Query.Filter ( filter )

20+import Rel8.Query.Maybe ( optional )

22import Rel8.Query.Opaleye ( mapOpaleye )

21import Rel8.Query.Opaleye ( mapOpaleye )

23import Rel8.Table.Eq ( EqTable, (==:) )

22import Rel8.Table.Eq ( EqTable, (==:) )

23+import Rel8.Table.Maybe ( isJustTable )

26-- | Checks if a query returns at least one row.

27exists :: Query a -> Query (Expr Bool)

28−exists = fmap (fromPrimExpr . fromColumn) . mapOpaleye Opaleye.exists

28+exists = fmap isJustTable . optional . whereExists

29+-- FIXME: change this when b7aacc07c6392654cae439fc3b997620c3aa7a87 makes it

30+-- into a release of Opaleye

31inQuery :: EqTable a => a -> Query a -> Query (Expr Bool)

33inQuery :: EqTable a => a -> Query a -> Query (Expr Bool)

32inQuery a = exists . (>>= filter (a ==:))

34inQuery a = exists . (>>= filter (a ==:))

35−-- | Produce the empty query if the given query returns no rows. @present@

37+-- | Produce the empty query if the given query returns no rows. @whereExists@

36-- is equivalent to @WHERE EXISTS@ in SQL.

38-- is equivalent to @WHERE EXISTS@ in SQL.

37−present :: Query a -> Query ()

39+whereExists :: Query a -> Query ()

38−present = mapOpaleye Opaleye.restrictExists

40+whereExists = mapOpaleye Opaleye.restrictExists

41−-- | Produce the empty query if the given query returns rows. @absent@

43+-- | Produce the empty query if the given query returns rows. @whereNotExists@

42-- is equivalent to @WHERE NOT EXISTS@ in SQL.

44-- is equivalent to @WHERE NOT EXISTS@ in SQL.

43−absent :: Query a -> Query ()

45+whereNotExists :: Query a -> Query ()

44−absent = mapOpaleye Opaleye.restrictNotExists

46+whereNotExists = mapOpaleye Opaleye.restrictNotExists

47-- | @with@ is similar to 'filter', but allows the predicate to be a full query.

49-- | @with@ is similar to 'filter', but allows the predicate to be a full query.

48--

50--

49−-- @with f a = a <$ present (f a)@, but this form matches 'filter'.

51+-- @with f a = a <$ whereExists (f a)@, but this form matches 'filter'.

50with :: (a -> Query b) -> a -> Query a

52with :: (a -> Query b) -> a -> Query a

51−with f a = a <$ present (f a)

53+with f a = a <$ whereExists (f a)

54-- | Like @with@, but with a custom membership test.

56-- | Like @with@, but with a custom membership test.

55−withBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a

57+withBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a

56withBy predicate bs = with $ \a -> bs >>= filter (predicate a)

58withBy predicate bs = with $ \a -> bs >>= filter (predicate a)

59-- | Filter rows where @a -> Query b@ yields no rows.

61-- | Filter rows where @a -> Query b@ yields no rows.

60without :: (a -> Query b) -> a -> Query a

62without :: (a -> Query b) -> a -> Query a

61−without f a = a <$ absent (f a)

63+without f a = a <$ whereNotExists (f a)

64-- | Like @without@, but with a custom membership test.

66-- | Like @without@, but with a custom membership test.

src/Rel8/Query/Indexed.hsdeleted−21

@@ -1,21 +0,0 @@

1−module Rel8.Query.Indexed

2− ( indexed

3− )

4−where

5−

6−-- base

7−import Control.Applicative ( liftA2 )

8−import Data.Int ( Int64 )

9−import Prelude

10−

11−-- rel8

12−import Rel8.Expr ( Expr )

13−import Rel8.Expr.Window ( rowNumber )

14−import Rel8.Query ( Query )

15−import Rel8.Query.Window ( window )

16−import Rel8.Table.Window ( currentRow )

17−

18−

19−-- | Pair each row of a query with its index within the query.

20−indexed :: Query a -> Query (Expr Int64, a)

21−indexed = window (liftA2 (,) (subtract 1 <$> rowNumber) currentRow)

src/Rel8/Query/List.hs+14−93

@@ -1,58 +1,23 @@

1{-# language FlexibleContexts #-}

2−{-# language GADTs #-}

3−{-# language NamedFieldPuns #-}

5module Rel8.Query.List

3module Rel8.Query.List

6 ( many, some

4 ( many, some

7− , manyExpr, someExpr

8− , catListTable, catNonEmptyTable

9− , catList, catNonEmpty

10 )

5 )

11where

6where

13-- base

8-- base

14−import Data.Functor.Identity ( runIdentity )

15−import Data.List.NonEmpty ( NonEmpty )

16import Prelude

9import Prelude

18−-- opaleye

19−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

20−

21-- rel8

11-- rel8

22import Rel8.Expr ( Expr )

12import Rel8.Expr ( Expr )

23−import Rel8.Expr.Aggregate ( listAggExpr, nonEmptyAggExpr )

24−import Rel8.Expr.Opaleye ( mapPrimExpr )

25import Rel8.Query ( Query )

13import Rel8.Query ( Query )

26import Rel8.Query.Aggregate ( aggregate )

14import Rel8.Query.Aggregate ( aggregate )

27import Rel8.Query.Maybe ( optional )

15import Rel8.Query.Maybe ( optional )

28−import Rel8.Query.Rebind ( rebind )

16+import Rel8.Table ( Table )

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 )

34import Rel8.Table.Aggregate ( listAgg, nonEmptyAgg )

17import Rel8.Table.Aggregate ( listAgg, nonEmptyAgg )

35−import Rel8.Table.List ( ListTable( ListTable ) )

18+import Rel8.Table.List ( ListTable )

36import Rel8.Table.Maybe ( maybeTable )

19import Rel8.Table.Maybe ( maybeTable )

37−import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )

20+import Rel8.Table.NonEmpty ( NonEmptyTable )

38−import Rel8.Type ( DBType, typeInformation )

39−import Rel8.Type.Array ( extractArrayElement )

40−import Rel8.Type.Information ( TypeInformation )

41−

42−

43−-- | Aggregate a 'Query' into a 'ListTable'. If the supplied query returns 0

44−-- rows, this function will produce a 'Query' that returns one row containing

45−-- the empty @ListTable@. If the supplied @Query@ does return rows, @many@ will

46−-- return exactly one row, with a @ListTable@ collecting all returned rows.

47−--

48−-- @many@ is analogous to 'Control.Applicative.many' from

49−-- @Control.Applicative@.

50−many :: Table Expr a => Query a -> Query (ListTable Expr a)

51−many =

52− fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .

53− optional .

54− aggregate .

55− fmap (listAgg . toCols)

58-- | Aggregate a 'Query' into a 'NonEmptyTable'. If the supplied query returns

23-- | Aggregate a 'Query' into a 'NonEmptyTable'. If the supplied query returns

@@ -63,60 +28,16 @@ many =

63--

28--

64-- @some@ is analogous to 'Control.Applicative.some' from

29-- @some@ is analogous to 'Control.Applicative.some' from

65-- @Control.Applicative@.

30-- @Control.Applicative@.

66−some :: Table Expr a => Query a -> Query (NonEmptyTable Expr a)

31+some :: Table Expr a => Query a -> Query (NonEmptyTable a)

67−some =

68− fmap (\(NonEmptyTable a) -> NonEmptyTable a) .

69− aggregate .

70− fmap (nonEmptyAgg . toCols)

32+some = aggregate . fmap nonEmptyAgg

71−

72−

73−-- | A version of 'many' specialised to single expressions.

74−manyExpr :: Sql DBType a => Query (Expr a) -> Query (Expr [a])

75−manyExpr = fmap (maybeTable mempty id) . optional . aggregate . fmap listAggExpr

76−

77−

78−-- | A version of 'many' specialised to single expressions.

79−someExpr :: Sql DBType a => Query (Expr a) -> Query (Expr (NonEmpty a))

80−someExpr = aggregate . fmap nonEmptyAggExpr

81−

82−

83−-- | Expand a 'ListTable' into a 'Query', where each row in the query is an

84−-- element of the given @ListTable@.

85−--

86−-- @catListTable@ is an inverse to 'many'.

87−catListTable :: Table Expr a => ListTable Expr a -> Query a

88−catListTable (ListTable as) =

89− rebind "unnest" $ fromColumns $ runIdentity $

90− hunvectorize (\Spec {info} -> pure . sunnest info) as

91−

92−

93−-- | Expand a 'NonEmptyTable' into a 'Query', where each row in the query is an

94−-- element of the given @NonEmptyTable@.

95−--

96−-- @catNonEmptyTable@ is an inverse to 'some'.

97−catNonEmptyTable :: Table Expr a => NonEmptyTable Expr a -> Query a

98−catNonEmptyTable (NonEmptyTable as) =

99− rebind "unnest" $ fromColumns $ runIdentity $

100− hunvectorize (\Spec {info} -> pure . sunnest info) as

101−

102−

103−-- | Expand an expression that contains a list into a 'Query', where each row

104−-- in the query is an element of the given list.

105−--

106−-- @catList@ is an inverse to 'manyExpr'.

107−catList :: Sql DBType a => Expr [a] -> Query (Expr a)

108−catList = rebind "unnest" . sunnest typeInformation

109−

110−

111−-- | Expand an expression that contains a non-empty list into a 'Query', where

112−-- each row in the query is an element of the given list.

113−--

114−-- @catNonEmpty@ is an inverse to 'someExpr'.

115−catNonEmpty :: Sql DBType a => Expr (NonEmpty a) -> Query (Expr a)

116−catNonEmpty = rebind "unnest" . sunnest typeInformation

117

118

119−sunnest :: TypeInformation (Unnullify a) -> Expr (list a) -> Expr a

35+-- | Aggregate a 'Query' into a 'ListTable'. If the supplied query returns 0

120−sunnest info = mapPrimExpr $

36+-- rows, this function will produce a 'Query' that returns one row containing

121− extractArrayElement info .

37+-- the empty @ListTable@. If the supplied @Query@ does return rows, @many@ will

122− Opaleye.UnExpr (Opaleye.UnOpOther "UNNEST")

38+-- return exactly one row, with a @ListTable@ collecting all returned rows.

39+--

40+-- @many@ is analogous to 'Control.Applicative.many' from

41+-- @Control.Applicative@.

42+many :: Table Expr a => Query a -> Query (ListTable a)

43+many = fmap (maybeTable mempty id) . optional . aggregate . fmap listAgg

src/Rel8/Query/Maybe.hs+45−26

@@ -1,10 +1,7 @@

1−{-# language GADTs #-}

2−{-# language LambdaCase #-}

3−{-# language NamedFieldPuns #-}

4−

5module Rel8.Query.Maybe

1module Rel8.Query.Maybe

6 ( optional

2 ( optional

7 , catMaybeTable

3 , catMaybeTable

4+ , bindMaybeTable

8 , traverseMaybeTable

5 , traverseMaybeTable

9 )

6 )

10where

7where

@@ -12,20 +9,23 @@ where

12-- base

9-- base

13import Prelude

10import Prelude

15−-- comonad

16−import Control.Comonad ( extract )

17−

18-- opaleye

12-- opaleye

19−import qualified Opaleye.Internal.MaybeFields as Opaleye

13+import qualified Opaleye.Internal.PackMap as Opaleye

14+import qualified Opaleye.Internal.PrimQuery as Opaleye

15+import qualified Opaleye.Internal.QueryArr as Opaleye

16+import qualified Opaleye.Internal.Tag as Opaleye

17+import qualified Opaleye.Internal.Unpackspec as Opaleye

21-- rel8

19-- rel8

22−import Rel8.Expr ( Expr )

20+import Rel8.Expr.Bool ( true )

23import Rel8.Expr.Eq ( (==.) )

21import Rel8.Expr.Eq ( (==.) )

24−import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )

22+import Rel8.Expr.Opaleye ( toPrimExpr )

25import Rel8.Query ( Query )

23import Rel8.Query ( Query )

26import Rel8.Query.Filter ( where_ )

24import Rel8.Query.Filter ( where_ )

27import Rel8.Query.Opaleye ( mapOpaleye )

25import Rel8.Query.Opaleye ( mapOpaleye )

28−import Rel8.Table.Maybe ( MaybeTable(..), isJustTable )

26+import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )

27+import Rel8.Table.Opaleye ( unpackspec )

28+import Rel8.Table.Tag ( Tag(..), fromExpr )

31-- | Convert a query that might return zero rows to a query that always returns

@@ -33,11 +33,18 @@ import Rel8.Table.Maybe ( MaybeTable(..), isJustTable )

33--

34-- To speak in more concrete terms, 'optional' is most useful to write @LEFT

35-- JOIN@s.

36−optional :: Query a -> Query (MaybeTable Expr a)

36+optional :: Query a -> Query (MaybeTable a)

37−optional = mapOpaleye $ Opaleye.optionalInternal $ \tag a -> MaybeTable

37+optional = mapOpaleye $ Opaleye.QueryArr . go

38− { tag = fromPrimExpr $ fromColumn tag

38+ where

39− , just = pure a

39+ go query (i, left, tag) =

40− }

40+ (MaybeTable (fromExpr t') a, join, Opaleye.next tag')

41+ where

42+ (MaybeTable Tag {expr = t} a, right, tag') =

43+ Opaleye.runSimpleQueryArr (pure <$> query) (i, tag)

44+ (t', bindings) = Opaleye.run $

45+ Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr "maybe" tag') t

46+ join = Opaleye.Join Opaleye.LeftJoin condition [] bindings left right

47+ condition = toPrimExpr true

43-- | Filter out 'MaybeTable's, returning only the tables that are not-null.

50-- | Filter out 'MaybeTable's, returning only the tables that are not-null.

@@ -45,24 +52,36 @@ optional = mapOpaleye $ Opaleye.optionalInternal $ \tag a -> MaybeTable

45-- This operation can be used to "undo" the effect of 'optional', which

52-- This operation can be used to "undo" the effect of 'optional', which

46-- operationally is like turning a @LEFT JOIN@ back into a full @JOIN@. You

53-- operationally is like turning a @LEFT JOIN@ back into a full @JOIN@. You

47-- can think of this as analogous to 'Data.Maybe.catMaybes'.

54-- can think of this as analogous to 'Data.Maybe.catMaybes'.

48−catMaybeTable :: MaybeTable Expr a -> Query a

55+catMaybeTable :: MaybeTable a -> Query a

49catMaybeTable ma@(MaybeTable _ a) = do

56catMaybeTable ma@(MaybeTable _ a) = do

50 where_ $ isJustTable ma

57 where_ $ isJustTable ma

51− pure (extract a)

58+ pure a

59+

60+

61+-- | @bindMaybeTable f x@ is similar to the monadic bind (@>>=@) operation. It

62+-- allows you to "extend" an optional query with another query. If either the

63+-- input or output are 'Rel8.nothingTable', then the result is

64+-- 'Rel8.nothingTable'.

65+--

66+-- This is similar to 'traverseMaybeTable', followed by a @join@ on the

67+-- resulting @MaybeTable@s.

68+bindMaybeTable :: Monad m

69+ => (a -> m (MaybeTable b)) -> MaybeTable a -> m (MaybeTable b)

70+bindMaybeTable query (MaybeTable input a) = do

71+ MaybeTable output b <- query a

72+ pure $ MaybeTable (input <> output) b

54-- | Extend an optional query with another query. This is useful if you want

75-- | Extend an optional query with another query. This is useful if you want

55-- to step through multiple @LEFT JOINs@.

76-- to step through multiple @LEFT JOINs@.

56--

77--

57-- Note that @traverseMaybeTable@ takes a @a -> Query b@ function, which means

78-- Note that @traverseMaybeTable@ takes a @a -> Query b@ function, which means

58−-- you also have the ability to "expand" one row into multiple rows. If the

79+-- you also have the ability to "expand" one row into multiple rows. If the

59-- @a -> Query b@ function returns no rows, then the resulting query will also

80-- @a -> Query b@ function returns no rows, then the resulting query will also

60-- have no rows. However, regardless of the given @a -> Query b@ function, if

81-- have no rows. However, regardless of the given @a -> Query b@ function, if

61−-- the input is @nothingTable@, you will always get exactly one @nothingTable@

82+-- the input is @noTable@, you will always get exactly one @noTable@ back.

62−-- back.

63−traverseMaybeTable :: (a -> Query b) -> MaybeTable Expr a -> Query (MaybeTable Expr b)

83+traverseMaybeTable :: (a -> Query b) -> MaybeTable a -> Query (MaybeTable b)

64traverseMaybeTable query ma@(MaybeTable input _) = do

84traverseMaybeTable query ma@(MaybeTable input _) = do

65− optional (query =<< catMaybeTable ma) >>= \case

85+ MaybeTable output b <- optional (query =<< catMaybeTable ma)

66− MaybeTable output b -> do

67− where_ $ output ==. input

86+ where_ $ expr output ==. expr input

68− pure $ MaybeTable input b

87+ pure $ MaybeTable input b

src/Rel8/Query/Null.hs−15

@@ -1,8 +1,5 @@

1−{-# language FlexibleContexts #-}

2−

3module Rel8.Query.Null

1module Rel8.Query.Null

4 ( catNull

2 ( catNull

5− , catNullTable

6 )

3 )

7where

4where

@@ -12,8 +9,6 @@ import Prelude

12-- rel8

9-- rel8

13import Rel8.Expr ( Expr )

10import Rel8.Expr ( Expr )

14import Rel8.Expr.Null ( isNonNull, unsafeUnnullify )

11import Rel8.Expr.Null ( isNonNull, unsafeUnnullify )

15−import Rel8.Table ( Table )

16−import Rel8.Table.Null ( NullTable, isNonNullTable, unsafeUnnullifyTable )

17import Rel8.Query ( Query )

12import Rel8.Query ( Query )

18import Rel8.Query.Filter ( where_ )

13import Rel8.Query.Filter ( where_ )

@@ -26,13 +21,3 @@ catNull :: Expr (Maybe a) -> Query (Expr a)

26catNull a = do

21catNull a = do

27 where_ $ isNonNull a

22 where_ $ isNonNull a

28 pure $ unsafeUnnullify a

23 pure $ unsafeUnnullify a

29−

30−

31−-- | Filter a 'Query' that might return @nullTable@ to a 'Query' without any

32−-- @nullTable@s.

33−--

34−-- Corresponds to 'Data.Maybe.catMaybes'.

35−catNullTable :: Table Expr a => NullTable Expr a -> Query a

36−catNullTable a = do

37− where_ $ isNonNullTable a

38− pure $ unsafeUnnullifyTable a

src/Rel8/Query/Opaleye.hs+5−41

@@ -1,70 +1,34 @@

1−{-# language TupleSections #-}

2−

3module Rel8.Query.Opaleye

1module Rel8.Query.Opaleye

4 ( fromOpaleye

2 ( fromOpaleye

5 , toOpaleye

3 , toOpaleye

6 , mapOpaleye

4 , mapOpaleye

7 , zipOpaleyeWith

5 , zipOpaleyeWith

8− , unsafePeekQuery

9 )

6 )

10where

7where

12-- base

9-- base

13−import Control.Applicative ( liftA2 )

14import Prelude

10import Prelude

16-- opaleye

12-- opaleye

17−import qualified Opaleye.Internal.QueryArr as Opaleye

13+import qualified Opaleye.Select as Opaleye

18−import qualified Opaleye.Internal.Tag as Opaleye

20-- rel8

15-- rel8

21import {-# SOURCE #-} Rel8.Query ( Query( Query ) )

16import {-# SOURCE #-} Rel8.Query ( Query( Query ) )

24fromOpaleye :: Opaleye.Select a -> Query a

19fromOpaleye :: Opaleye.Select a -> Query a

25−fromOpaleye = Query . pure . fmap pure

20+fromOpaleye = Query

28toOpaleye :: Query a -> Opaleye.Select a

23toOpaleye :: Query a -> Opaleye.Select a

29−toOpaleye (Query a) = snd <$> a mempty

24+toOpaleye (Query a) = a

32mapOpaleye :: (Opaleye.Select a -> Opaleye.Select b) -> Query a -> Query b

27mapOpaleye :: (Opaleye.Select a -> Opaleye.Select b) -> Query a -> Query b

33−mapOpaleye f (Query a) = Query (fmap (mapping f) a)

28+mapOpaleye f = fromOpaleye . f . toOpaleye

36zipOpaleyeWith :: ()

31zipOpaleyeWith :: ()

37 => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)

32 => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)

38 -> Query a -> Query b -> Query c

33 -> Query a -> Query b -> Query c

39−zipOpaleyeWith f (Query a) (Query b) = Query $ liftA2 (zipping f) a b

34+zipOpaleyeWith f a b = fromOpaleye $ f (toOpaleye a) (toOpaleye b)

40−

41−

42−unsafePeekQuery :: Query a -> a

43−unsafePeekQuery (Query q) = case q mempty of

44− f -> case Opaleye.runStateQueryArr f () Opaleye.start of

45− ((_, a), _, _) -> a

46−

47−

48−mapping :: ()

49− => (Opaleye.Select a -> Opaleye.Select b)

50− -> Opaleye.Select (m, a) -> Opaleye.Select (m, b)

51−mapping f q = Opaleye.stateQueryArr $ \_ tag ->

52− let

53− ((m, _), _, _) = Opaleye.runStateQueryArr q () tag

54− q' = (m,) <$> f (snd <$> q)

55− in

56− Opaleye.runStateQueryArr q' () tag

57−

58−

59−zipping :: Semigroup m

60− => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)

61− -> Opaleye.Select (m, a) -> Opaleye.Select (m, b) -> Opaleye.Select (m, c)

62−zipping f q q' =

63− Opaleye.stateQueryArr $ \_ tag ->

64− let

65− ((m, _), _, _) = Opaleye.runStateQueryArr q () tag

66− ((m', _), _, _) = Opaleye.runStateQueryArr q' () tag

67− m'' = m <> m'

68− q'' = (m'',) <$> f (snd <$> q) (snd <$> q')

69− in

70− Opaleye.runStateQueryArr q'' () tag

src/Rel8/Query/Rebind.hsdeleted−27

@@ -1,27 +0,0 @@

1−{-# language FlexibleContexts #-}

2−

3−module Rel8.Query.Rebind

4− ( rebind

5− )

6−where

7−

8−-- base

9−import Prelude

10−import Control.Arrow ((<<<))

11−

12−-- opaleye

13−import qualified Opaleye.Internal.Rebind as Opaleye

14−

15−-- rel8

16−import Rel8.Expr ( Expr )

17−import Rel8.Query ( Query )

18−import Rel8.Table ( Table )

19−import Rel8.Table.Opaleye ( unpackspec )

20−import Rel8.Query.Opaleye (fromOpaleye)

21−

22−

23−-- | 'rebind' takes a variable name, some expressions, and binds each of them

24−-- to a new variable in the SQL. The @a@ returned consists only of these

25−-- variables. It's essentially a @let@ binding for Postgres expressions.

26−rebind :: Table Expr a => String -> a -> Query a

27−rebind prefix a = fromOpaleye (Opaleye.rebindExplicitPrefix prefix unpackspec <<< pure a)

src/Rel8/Query/SQL.hs+59−6

@@ -1,21 +1,74 @@

1{-# language FlexibleContexts #-}

2−{-# language MonoLocalBinds #-}

2+{-# language TypeFamilies #-}

3+{-# language ViewPatterns #-}

4module Rel8.Query.SQL

5module Rel8.Query.SQL

5 ( showQuery

6 ( showQuery

7+ , sqlForQuery, sqlForQueryWithNames

6 )

8 )

7where

9where

9-- base

11-- base

12+import Data.Foldable ( fold )

13+import Data.Functor.Const ( Const( Const ), getConst )

14+import Data.Void ( Void )

10import Prelude

15import Prelude

17+-- opaleye

18+import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye

19+import qualified Opaleye.Internal.PrimQuery as Opaleye

20+import qualified Opaleye.Internal.Print as Opaleye

21+import qualified Opaleye.Internal.Optimize as Opaleye

22+import qualified Opaleye.Internal.QueryArr as Opaleye hiding ( Select )

23+import qualified Opaleye.Internal.Sql as Opaleye

24+

12-- rel8

25-- rel8

13−import Rel8.Expr ( Expr )

26+import Rel8.Expr ( Expr, Col(..) )

27+import Rel8.Expr.Opaleye ( toPrimExpr )

14import Rel8.Query ( Query )

28import Rel8.Query ( Query )

15−import Rel8.Statement.Select ( ppSelect )

29+import Rel8.Query.Opaleye ( toOpaleye )

30+import Rel8.Schema.Name ( Selects, Col(..) )

31+import Rel8.Schema.HTable ( htabulateA, hfield )

16−import Rel8.Table ( Table )

32+import Rel8.Table ( Table, toColumns )

33+import Rel8.Table.Name ( namesFromLabels )

34+import Rel8.Table.Opaleye ( castTable )

19−-- | Convert a 'Query' to a 'String' containing a @SELECT@ statement.

37+-- | Convert a query to a 'String' containing the query as a @SELECT@

38+-- statement.

20showQuery :: Table Expr a => Query a -> String

39showQuery :: Table Expr a => Query a -> String

21−showQuery = show . ppSelect

40+showQuery = fold . sqlForQuery

41+

42+

43+sqlForQuery :: Table Expr a

44+ => Query a -> Maybe String

45+sqlForQuery = sqlForQueryWithNames namesFromLabels . fmap toColumns

46+

47+

48+sqlForQueryWithNames :: Selects names exprs

49+ => names -> Query exprs -> Maybe String

50+sqlForQueryWithNames names query =

51+ show . Opaleye.ppSql . selectFrom names exprs <$> optimize primQuery

52+ where

53+ (exprs, primQuery, _) =

54+ Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

55+

56+

57+optimize :: Opaleye.PrimQuery' a -> Maybe (Opaleye.PrimQuery' Void)

58+optimize = Opaleye.removeEmpty . Opaleye.optimize

59+

60+

61+selectFrom :: Selects names exprs

62+ => names -> exprs -> Opaleye.PrimQuery' Void -> Opaleye.Select

63+selectFrom (toColumns -> names) (toColumns . castTable -> exprs) query =

64+ Opaleye.SelectFrom $ Opaleye.newSelect

65+ { Opaleye.attrs = Opaleye.SelectAttrs attributes

66+ , Opaleye.tables = Opaleye.oneTable select

67+ }

68+ where

69+ select = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator query

70+ attributes = getConst $ htabulateA $ \field -> case hfield names field of

71+ NameCol name -> case hfield exprs field of

72+ DB (toPrimExpr -> expr) -> Const (pure (makeAttr name expr))

73+ makeAttr label expr =

74+ (Opaleye.sqlExpr expr, Just (Opaleye.SqlColumn label))

src/Rel8/Query/Set.hs+6−6

@@ -23,36 +23,36 @@ import Rel8.Table.Opaleye ( binaryspec )

25-- | Combine the results of two queries of the same type, collapsing

26−-- duplicates. @union a b@ is the same as the SQL statement @a UNION b@.

26+-- duplicates. @union a b@ is the same as the SQL statement @x UNION b@.

27union :: EqTable a => Query a -> Query a -> Query a

28union = zipOpaleyeWith (Opaleye.unionExplicit binaryspec)

31-- | Combine the results of two queries of the same type, retaining duplicates.

32−-- @unionAll a b@ is the same as the SQL statement @a UNION ALL b@.

32+-- @unionAll a b@ is the same as the SQL statement @x UNION ALL b@.

33unionAll :: Table Expr a => Query a -> Query a -> Query a

34unionAll = zipOpaleyeWith (Opaleye.unionAllExplicit binaryspec)

37-- | Find the intersection of two queries, collapsing duplicates. @intersect a

38−-- b@ is the same as the SQL statement @a INTERSECT b@.

38+-- b@ is the same as the SQL statement @x INTERSECT b@.

39intersect :: EqTable a => Query a -> Query a -> Query a

40intersect = zipOpaleyeWith (Opaleye.intersectExplicit binaryspec)

43-- | Find the intersection of two queries, retaining duplicates. @intersectAll

44−-- a b@ is the same as the SQL statement @a INTERSECT ALL b@.

44+-- a b@ is the same as the SQL statement @x INTERSECT ALL b@.

45intersectAll :: EqTable a => Query a -> Query a -> Query a

46intersectAll = zipOpaleyeWith (Opaleye.intersectAllExplicit binaryspec)

49-- | Find the difference of two queries, collapsing duplicates @except a b@ is

50−-- the same as the SQL statement @a EXCEPT b@.

50+-- the same as the SQL statement @x INTERSECT b@.

51except :: EqTable a => Query a -> Query a -> Query a

52except = zipOpaleyeWith (Opaleye.exceptExplicit binaryspec)

55-- | Find the difference of two queries, retaining duplicates. @exceptAll a b@

56−-- is the same as the SQL statement @a EXCEPT ALL b@.

56+-- is the same as the SQL statement @x EXCEPT ALL b@.

57exceptAll :: EqTable a => Query a -> Query a -> Query a

58exceptAll = zipOpaleyeWith (Opaleye.exceptAllExplicit binaryspec)

src/Rel8/Query/These.hs+45−52

@@ -1,5 +1,4 @@

1{-# language FlexibleContexts #-}

2−{-# language GADTs #-}

4module Rel8.Query.These

3module Rel8.Query.These

5 ( alignBy

4 ( alignBy

@@ -8,6 +7,7 @@ module Rel8.Query.These

8 , keepThisTable, loseThisTable

7 , keepThisTable, loseThisTable

9 , keepThatTable, loseThatTable

8 , keepThatTable, loseThatTable

10 , keepThoseTable, loseThoseTable

9 , keepThoseTable, loseThoseTable

10+ , bindTheseTable

11 , bitraverseTheseTable

12 )

13where

@@ -15,29 +15,27 @@ where

15-- base

16import Prelude

18−-- comonad

19−import Control.Comonad ( extract )

20−

21-- opaleye

18-- opaleye

22−import qualified Opaleye.Internal.PackMap as Opaleye

19+import qualified Opaleye.Internal.Join as Opaleye

23import qualified Opaleye.Internal.PrimQuery as Opaleye

20import qualified Opaleye.Internal.PrimQuery as Opaleye

24−import qualified Opaleye.Internal.QueryArr as Opaleye

25−import qualified Opaleye.Internal.Tag as Opaleye

27-- rel8

22-- rel8

28import Rel8.Expr ( Expr )

23import Rel8.Expr ( Expr )

29import Rel8.Expr.Bool ( boolExpr, not_ )

24import Rel8.Expr.Bool ( boolExpr, not_ )

30import Rel8.Expr.Eq ( (==.) )

25import Rel8.Expr.Eq ( (==.) )

31−import Rel8.Expr.Opaleye ( toPrimExpr, traversePrimExpr )

26+import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )

32import Rel8.Expr.Serialize ( litExpr )

27import Rel8.Expr.Serialize ( litExpr )

33import Rel8.Query ( Query )

28import Rel8.Query ( Query )

34import Rel8.Query.Filter ( where_ )

29import Rel8.Query.Filter ( where_ )

35import Rel8.Query.Maybe ( optional )

30import Rel8.Query.Maybe ( optional )

36import Rel8.Query.Opaleye ( zipOpaleyeWith )

31import Rel8.Query.Opaleye ( zipOpaleyeWith )

32+import Rel8.Table ( Table )

37import Rel8.Table.Either ( EitherTable( EitherTable ) )

33import Rel8.Table.Either ( EitherTable( EitherTable ) )

38import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )

34import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )

35+import Rel8.Table.Opaleye ( unpackspec )

36+import Rel8.Table.Tag ( Tag(..) )

39import Rel8.Table.These

37import Rel8.Table.These

40− ( TheseTable( TheseTable, here, there )

38+ ( TheseTable( TheseTable )

41 , hasHereTable, hasThereTable

39 , hasHereTable, hasThereTable

42 , isThisTable, isThatTable, isThoseTable

40 , isThisTable, isThatTable, isThoseTable

43 )

41 )

@@ -45,91 +43,86 @@ import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) )

47-- | Corresponds to a @FULL OUTER JOIN@ between two queries.

45-- | Corresponds to a @FULL OUTER JOIN@ between two queries.

48−alignBy :: ()

46+alignBy :: (Table Expr a, Table Expr b)

49 => (a -> b -> Expr Bool)

47 => (a -> b -> Expr Bool)

50− -> Query a -> Query b -> Query (TheseTable Expr a b)

48+ -> Query a -> Query b -> Query (TheseTable a b)

51−alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.stateQueryArr $ \_ t -> case t of

49+alignBy condition as bs =

52− tag -> (tab, join', tag''')

50+ uncurry TheseTable <$> zipOpaleyeWith fullOuterJoin as bs

53− where

51+ where

54− (ma, left', tag') = Opaleye.runStateQueryArr (pure <$> left) () tag

52+ fullOuterJoin a b =

55− (mb, right', tag'') = Opaleye.runStateQueryArr (pure <$> right) () tag'

53+ Opaleye.joinExplicit unpackspec unpackspec pure pure full a b on

56− MaybeTable hasHere a = ma

54+ where

57− MaybeTable hasThere b = mb

58− (hasHere', lbindings) = Opaleye.run $ do

59− traversePrimExpr (Opaleye.extractAttr "hasHere" tag'') hasHere

60− (hasThere', rbindings) = Opaleye.run $ do

61− traversePrimExpr (Opaleye.extractAttr "hasThere" tag'') hasThere

62− tag''' = Opaleye.next tag''

63− join = Opaleye.Join Opaleye.FullJoin on left'' right''

55+ full = Opaleye.FullJoin

64− where

56+ on = toColumn . toPrimExpr . uncurry condition

65− on = toPrimExpr $ condition (extract a) (extract b)

57+

66− left'' = (Opaleye.NonLateral, Opaleye.toPrimQuery (left' <> Opaleye.aRebind lbindings))

58+

67− right'' = (Opaleye.NonLateral, Opaleye.toPrimQuery (right' <> Opaleye.aRebind rbindings))

68− ma' = MaybeTable hasHere' a

69− mb' = MaybeTable hasThere' b

70− tab = TheseTable {here = ma', there = mb'}

71− join' = Opaleye.aProduct join

72−

73−

74−keepHereTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)

59+keepHereTable :: TheseTable a b -> Query (a, MaybeTable b)

75keepHereTable = loseThatTable

60keepHereTable = loseThatTable

78−loseHereTable :: TheseTable Expr a b -> Query b

63+loseHereTable :: TheseTable a b -> Query b

79loseHereTable = keepThatTable

64loseHereTable = keepThatTable

82−keepThereTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)

67+keepThereTable :: TheseTable a b -> Query (MaybeTable a, b)

83keepThereTable = loseThisTable

68keepThereTable = loseThisTable

86−loseThereTable :: TheseTable Expr a b -> Query a

71+loseThereTable :: TheseTable a b -> Query a

87loseThereTable = keepThisTable

72loseThereTable = keepThisTable

90−keepThisTable :: TheseTable Expr a b -> Query a

75+keepThisTable :: TheseTable a b -> Query a

91keepThisTable t@(TheseTable (MaybeTable _ a) _) = do

76keepThisTable t@(TheseTable (MaybeTable _ a) _) = do

92 where_ $ isThisTable t

77 where_ $ isThisTable t

93− pure (extract a)

78+ pure a

96−loseThisTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)

81+loseThisTable :: TheseTable a b -> Query (MaybeTable a, b)

97loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do

82loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do

98 where_ $ not_ $ isThisTable t

83 where_ $ not_ $ isThisTable t

99− pure (ma, extract b)

84+ pure (ma, b)

100

101

102−keepThatTable :: TheseTable Expr a b -> Query b

87+keepThatTable :: TheseTable a b -> Query b

103keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do

88keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do

104 where_ $ isThatTable t

89 where_ $ isThatTable t

105− pure (extract b)

90+ pure b

106

107

108−loseThatTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)

93+loseThatTable :: TheseTable a b -> Query (a, MaybeTable b)

109loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do

94loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do

110 where_ $ not_ $ isThatTable t

95 where_ $ not_ $ isThatTable t

111− pure (extract a, mb)

96+ pure (a, mb)

112

113

114−keepThoseTable :: TheseTable Expr a b -> Query (a, b)

99+keepThoseTable :: TheseTable a b -> Query (a, b)

115keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do

100keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do

116 where_ $ isThoseTable t

101 where_ $ isThoseTable t

117− pure (extract a, extract b)

102+ pure (a, b)

118

103

119

104

120−loseThoseTable :: TheseTable Expr a b -> Query (EitherTable Expr a b)

105+loseThoseTable :: TheseTable a b -> Query (EitherTable a b)

121loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do

106loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do

122 where_ $ not_ $ isThoseTable t

107 where_ $ not_ $ isThoseTable t

123− pure $ EitherTable tag a b

108+ pure $ EitherTable result a b

124 where

109 where

125 tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)

110 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)

126

119

127

120

128bitraverseTheseTable :: ()

121bitraverseTheseTable :: ()

129 => (a -> Query c)

122 => (a -> Query c)

130 -> (b -> Query d)

123 -> (b -> Query d)

131− -> TheseTable Expr a b

124+ -> TheseTable a b

132− -> Query (TheseTable Expr c d)

125+ -> Query (TheseTable c d)

133bitraverseTheseTable f g t = do

126bitraverseTheseTable f g t = do

134 mc <- optional (f . fst =<< keepHereTable t)

127 mc <- optional (f . fst =<< keepHereTable t)

135 md <- optional (g . snd =<< keepThereTable t)

128 md <- optional (g . snd =<< keepThereTable t)

src/Rel8/Query/Window.hsdeleted−26

@@ -1,26 +0,0 @@

1−module Rel8.Query.Window

2− ( window

3− )

4−where

5−

6−-- base

7−import Prelude ()

8−

9−-- opaleye

10−import qualified Opaleye.Window as Opaleye

11−

12−-- rel8

13−import Rel8.Query ( Query )

14−import Rel8.Query.Opaleye ( mapOpaleye )

15−import Rel8.Window ( Window( Window ) )

16−

17−

18−-- | 'window' runs a query composed of expressions containing

19−-- [window functions](https://www.postgresql.org/docs/current/tutorial-window.html).

20−-- 'window' is similar to 'Rel8.aggregate', with the main difference being

21−-- that in a window query, each input row corresponds to one output row,

22−-- whereas aggregation queries fold the entire input query down into a single

23−-- row. To put this into a Haskell context, 'Rel8.aggregate' is to 'foldl' as

24−-- 'window' is to 'scanl'.

25−window :: Window a b -> Query a -> Query b

26−window (Window a) = mapOpaleye (Opaleye.runWindows a)

src/Rel8/Schema/Context.hsnew file+20

@@ -0,0 +1,20 @@

1+{-# language DataKinds #-}

2+{-# language StandaloneKindSignatures #-}

3+{-# language TypeFamilies #-}

5+module Rel8.Schema.Context

6+ ( Interpretation( Col )

7+ )

8+where

10+-- base

11+import Data.Kind ( Constraint )

12+import Prelude ()

13+

14+-- rel8

15+import Rel8.Schema.Kind ( Context, HContext )

16+

17+

18+type Interpretation :: Context -> Constraint

19+class Interpretation context where

20+ data Col context :: HContext

src/Rel8/Schema/Context/Label.hsnew file+60

@@ -0,0 +1,60 @@

1+{-# language DataKinds #-}

2+{-# language FlexibleInstances #-}

3+{-# language StandaloneKindSignatures #-}

4+{-# language TypeFamilies #-}

5+{-# language TypeOperators #-}

7+module Rel8.Schema.Context.Label

8+ ( Labelable( labeler, unlabeler )

9+ , HLabelable( hlabeler, hunlabeler )

10+ )

11+where

12+

13+-- base

14+import Data.Kind ( Constraint )

15+import Prelude hiding ( null )

16+

17+-- rel8

18+import Rel8.Schema.Context ( Interpretation )

19+import Rel8.Schema.Dict ( Dict( Dict ) )

20+import Rel8.Schema.Kind ( Context, HContext )

21+import Rel8.Schema.Spec ( Spec( Spec ) )

22+import Rel8.Schema.Result ( Col( Result ), Result )

23+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )

24+

25+

26+type Labelable :: Context -> Constraint

27+class Interpretation context => Labelable context where

28+ labeler :: ()

29+ => Col context ('Spec labels necessity a)

30+ -> Col context ('Spec (label ': labels) necessity a)

31+

32+ unlabeler :: ()

33+ => Col context ('Spec (label ': labels) necessity a)

34+ -> Col context ('Spec labels necessity a)

35+

36+

37+instance Labelable Result where

38+ labeler (Result a) = Result a

39+ unlabeler (Result a) = Result a

40+

41+

42+type HLabelable :: HContext -> Constraint

43+class HLabelable context where

44+ hlabeler :: ()

45+ => context ('Spec labels necessity a)

46+ -> context ('Spec (label ': labels) necessity a)

47+

48+ hunlabeler :: ()

49+ => context ('Spec (label ': labels) necessity a)

50+ -> context ('Spec labels necessity a)

51+

52+

53+instance Labelable context => HLabelable (Col context) where

54+ hlabeler = labeler

55+ hunlabeler = unlabeler

56+

57+

58+instance HLabelable (Dict (ConstrainDBType constraint)) where

59+ hlabeler Dict = Dict

60+ hunlabeler Dict = Dict

src/Rel8/Schema/Context/Nullify.hs+149−105

@@ -1,144 +1,188 @@

1{-# language DataKinds #-}

2−{-# language EmptyCase #-}

3{-# language FlexibleContexts #-}

2{-# language FlexibleContexts #-}

4−{-# language GADTs #-}

3+{-# language FlexibleInstances #-}

5−{-# language LambdaCase #-}

4+{-# language InstanceSigs #-}

5+{-# language MultiParamTypeClasses #-}

6{-# language NamedFieldPuns #-}

7+{-# language ScopedTypeVariables #-}

7{-# language StandaloneKindSignatures #-}

8{-# language StandaloneKindSignatures #-}

9+{-# language TypeFamilies #-}

9module Rel8.Schema.Context.Nullify

11module Rel8.Schema.Context.Nullify

10− ( Nullifiability(..), NonNullifiability(..), nullifiableOrNot, absurd

11− , Nullifiable, nullifiability

12− , guarder, nullifier, unnullifier

12+ ( Nullifiable( ConstrainTag, encodeTag, decodeTag, nullifier, unnullifier )

13− , sguard, snullify

13+ , HNullifiable( HConstrainTag, hencodeTag, hdecodeTag, hnullifier, hunnullifier )

14+ , runTag, unnull

14 )

15 )

15where

16where

17-- base

18-- base

18−import Data.Bool ( bool )

19−import Data.Functor.Identity ( Identity( Identity ) )

20import Data.Kind ( Constraint, Type )

19import Data.Kind ( Constraint, Type )

20+import GHC.TypeLits ( KnownSymbol )

21import Prelude hiding ( null )

23-- opaleye

24import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

26-- rel8

27−import Rel8.Aggregate ( Aggregate(..), zipOutputs )

27+import Rel8.Aggregate

28+ ( Aggregate, Col(..)

29+ , mapInputs

30+ , unsafeMakeAggregate

31+ )

28−import Rel8.Expr ( Expr )

32+import Rel8.Expr ( Expr, Col(..) )

29import Rel8.Expr.Bool ( boolExpr )

33import Rel8.Expr.Bool ( boolExpr )

30import Rel8.Expr.Null ( nullify, unsafeUnnullify )

34import Rel8.Expr.Null ( nullify, unsafeUnnullify )

31−import Rel8.Expr.Opaleye ( fromPrimExpr )

35+import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )

32−import Rel8.Kind.Context ( SContext(..) )

36+import Rel8.Kind.Necessity ( Necessity( Required ) )

33−import Rel8.Schema.Field ( Field )

37+import Rel8.Schema.Context ( Interpretation )

34import qualified Rel8.Schema.Kind as K

38import qualified Rel8.Schema.Kind as K

35−import Rel8.Schema.Name ( Name( Name ) )

39+import Rel8.Schema.Name ( Name( Name ), Col(..) )

36−import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )

40+import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql )

37−import Rel8.Schema.Result ( Result )

41+import Rel8.Schema.Dict ( Dict( Dict ) )

38−import Rel8.Schema.Spec ( Spec(..) )

42+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

39−

43+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )

40−

44+import qualified Rel8.Schema.Spec.ConstrainDBType as ConstrainDBType

41−type Nullifiability :: K.Context -> Type

45+import Rel8.Table.Tag ( Tag(..), Taggable, fromAggregate, fromExpr, fromName )

42−data Nullifiability context where

43− NAggregate :: Nullifiability Aggregate

44− NExpr :: Nullifiability Expr

45− NName :: Nullifiability Name

48type Nullifiable :: K.Context -> Constraint

49−class Nullifiable context where

49+class Interpretation context => Nullifiable context where

50− nullifiability :: Nullifiability context

50+ type ConstrainTag context :: Type -> Constraint

51+ type ConstrainTag _context = DefaultConstrainTag

52+

53+ encodeTag ::

54+ ( Sql (ConstrainTag context) a

55+ , KnownSymbol label

56+ , Taggable a

57+ )

58+ => Tag label a

59+ -> Col context ('Spec labels 'Required a)

60+

61+ decodeTag ::

62+ ( Sql (ConstrainTag context) a

63+ , KnownSymbol label

64+ , Taggable a

65+ )

66+ => Col context ('Spec labels 'Required a)

67+ -> Tag label a

68+

69+ nullifier :: ()

70+ => Tag label a

71+ -> (Expr a -> Expr Bool)

72+ -> SSpec ('Spec labels necessity x)

73+ -> Col context ('Spec labels necessity x)

74+ -> Col context ('Spec labels necessity (Nullify x))

75+

76+ unnullifier :: ()

77+ => SSpec ('Spec labels necessity x)

78+ -> Col context ('Spec labels necessity (Nullify x))

79+ -> Col context ('Spec labels necessity x)

53instance Nullifiable Aggregate where

82instance Nullifiable Aggregate where

54− nullifiability = NAggregate

83+ encodeTag Tag {aggregator, expr} =

84+ Aggregation $ unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr

85+

86+ decodeTag (Aggregation aggregate) = fromAggregate aggregate

87+

88+ nullifier Tag {expr} test SSpec {nullity} (Aggregation aggregate) =

89+ Aggregation $

90+ mapInputs (toPrimExpr . runTag nullity condition . fromPrimExpr) $

91+ runTag nullity condition <$> aggregate

92+ where

93+ condition = test expr

94+

95+ unnullifier SSpec {nullity} (Aggregation aggregate) =

96+ Aggregation $ unnull nullity <$> aggregate

97+

98+ {-# INLINABLE encodeTag #-}

99+ {-# INLINABLE decodeTag #-}

100+ {-# INLINABLE nullifier #-}

101+ {-# INLINABLE unnullifier #-}

102

103

57instance Nullifiable Expr where

104instance Nullifiable Expr where

58− nullifiability = NExpr

105+ encodeTag Tag {expr} = DB expr

106+ decodeTag (DB a) = fromExpr a

107+ nullifier Tag {expr} test SSpec {nullity} (DB a) =

108+ DB $ runTag nullity (test expr) a

109+ unnullifier SSpec {nullity} (DB a) = DB $ unnull nullity a

110+

111+ {-# INLINABLE encodeTag #-}

112+ {-# INLINABLE decodeTag #-}

113+ {-# INLINABLE nullifier #-}

114+ {-# INLINABLE unnullifier #-}

115

116

61instance Nullifiable Name where

117instance Nullifiable Name where

62− nullifiability = NName

118+ encodeTag Tag {name = Name name} = NameCol name

63−

119+ decodeTag (NameCol name) = fromName (Name name)

64−

120+ nullifier _ _ _ (NameCol name) = NameCol name

65−type NonNullifiability :: K.Context -> Type

121+ unnullifier _ (NameCol name) = NameCol name

66−data NonNullifiability context where

122+

67− NField :: NonNullifiability (Field table)

123+ {-# INLINABLE encodeTag #-}

68− NResult :: NonNullifiability Result

124+ {-# INLINABLE decodeTag #-}

69−

125+ {-# INLINABLE nullifier #-}

70−

126+ {-# INLINABLE unnullifier #-}

71−nullifiableOrNot :: ()

127+

72− => SContext context

128+

73− -> Either (NonNullifiability context) (Nullifiability context)

129+runTag :: Nullity a -> Expr Bool -> Expr a -> Expr (Nullify a)

74−nullifiableOrNot = \case

130+runTag nullity tag a = case nullity of

75− SAggregate -> Right NAggregate

131+ Null -> boolExpr null a tag

76− SExpr -> Right NExpr

132+ NotNull -> boolExpr null (nullify a) tag

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

131 where

133 where

132 null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit

134 null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit

133

135

134

136

135−snullify :: Nullity a -> Expr a -> Expr (Nullify a)

137+unnull :: Nullity a -> Expr (Nullify a) -> Expr a

136−snullify nullity a = case nullity of

138+unnull nullity a = case nullity of

137 Null -> a

139 Null -> a

138− NotNull -> nullify a

140+ NotNull -> unsafeUnnullify a

139

141

140

142

141−sunnullify :: Nullity a -> Expr (Nullify a) -> Expr a

143+type HNullifiable :: K.HContext -> Constraint

142−sunnullify nullity a = case nullity of

144+class HNullifiable context where

143− Null -> a

145+ type HConstrainTag context :: Type -> Constraint

144− NotNull -> unsafeUnnullify a

146+ type HConstrainTag _context = DefaultConstrainTag

147+

148+ hencodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)

149+ => Tag label a

150+ -> context ('Spec labels 'Required a)

151+

152+ hdecodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)

153+ => context ('Spec labels 'Required a)

154+ -> Tag label a

155+

156+ hnullifier :: ()

157+ => Tag label a

158+ -> (Expr a -> Expr Bool)

159+ -> SSpec ('Spec labels necessity x)

160+ -> context ('Spec labels necessity x)

161+ -> context ('Spec labels necessity (Nullify x))

162+

163+ hunnullifier :: ()

164+ => SSpec ('Spec labels necessity x)

165+ -> context ('Spec labels necessity (Nullify x))

166+ -> context ('Spec labels necessity x)

167+

168+

169+instance Nullifiable context => HNullifiable (Col context) where

170+ type HConstrainTag (Col context) = ConstrainTag context

171+ hencodeTag = encodeTag

172+ hdecodeTag = decodeTag

173+ hnullifier = nullifier

174+ hunnullifier = unnullifier

175+

176+

177+instance HNullifiable (Dict (ConstrainDBType constraint)) where

178+ type HConstrainTag (Dict (ConstrainDBType constraint)) = constraint

179+

180+ hencodeTag _ = Dict

181+ hdecodeTag = mempty

182+ hnullifier _ _ = ConstrainDBType.nullifier

183+ hunnullifier = ConstrainDBType.unnullifier

184+

185+

186+type DefaultConstrainTag :: Type -> Constraint

187+class DefaultConstrainTag a

188+instance DefaultConstrainTag a

src/Rel8/Schema/Field.hsdeleted−50

@@ -1,50 +0,0 @@

1−{-# language DataKinds #-}

2−{-# language FlexibleContexts #-}

3−{-# language MultiParamTypeClasses #-}

4−{-# language StandaloneKindSignatures #-}

5−{-# language TypeFamilies #-}

6−

7−module Rel8.Schema.Field

8− ( Field(..)

9− , fields

10− )

11−where

12−

13−-- base

14−import Data.Functor.Identity ( Identity( Identity ) )

15−import Data.Kind ( Type )

16−import Prelude

17−

18−-- rel8

19−import Rel8.Schema.HTable ( HField, htabulate )

20−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

21−import Rel8.Schema.Kind as K

22−import Rel8.Schema.Null ( Sql )

23−import Rel8.Table

24− ( Table, Columns, Context, fromColumns, toColumns

25− , FromExprs, fromResult, toResult

26− , Transpose

27− )

28−import Rel8.Table.Transpose ( Transposes )

29−import Rel8.Type ( DBType )

30−

31−

32−-- | A special context used in the construction of 'Rel8.Projection's.

33−type Field :: Type -> K.Context

34−newtype Field table a = Field (HField (Columns table) a)

35−

36−

37−instance Sql DBType a => Table (Field table) (Field table a) where

38− type Columns (Field table a) = HIdentity a

39− type Context (Field table a) = Field table

40− type FromExprs (Field table a) = a

41− type Transpose to (Field table a) = to a

42−

43− toColumns = HIdentity

44− fromColumns (HIdentity a) = a

45− toResult a = HIdentity (Identity a)

46− fromResult (HIdentity (Identity a)) = a

47−

48−

49−fields :: Transposes context (Field table) table fields => fields

50−fields = fromColumns $ htabulate Field

src/Rel8/Schema/HTable.hs+24−51

@@ -16,12 +16,11 @@

16module Rel8.Schema.HTable

17 ( HTable (HField, HConstrainTable)

18 , hfield, htabulate, htraverse, hdicts, hspecs

19− , hfoldMap, hmap, htabulateA, htraverseP, htraversePWithField

19+ , hmap, htabulateA

20 )

21where

23-- base

24−import Data.Functor.Const ( Const( Const ), getConst )

25import Data.Kind ( Constraint, Type )

24import Data.Kind ( Constraint, Type )

26import Data.Functor.Compose ( Compose( Compose ), getCompose )

25import Data.Functor.Compose ( Compose( Compose ), getCompose )

27import Data.Proxy ( Proxy )

26import Data.Proxy ( Proxy )

@@ -33,21 +32,16 @@ import GHC.Generics

33 )

32 )

34import Prelude

33import Prelude

36−-- profunctors

37−import Data.Profunctor ( rmap, Profunctor (lmap) )

38−

39−-- product-profunctors

40−import Data.Profunctor.Product ( ProductProfunctor ((****)) )

41−

42-- rel8

35-- rel8

43import Rel8.Schema.Dict ( Dict )

36import Rel8.Schema.Dict ( Dict )

44−import Rel8.Schema.Spec ( Spec )

37+import Rel8.Schema.Spec ( Spec, SSpec )

45import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )

38import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )

46import qualified Rel8.Schema.Kind as K

39import qualified Rel8.Schema.Kind as K

48-- semigroupoids

41-- semigroupoids

49import Data.Functor.Apply ( Apply, (<.>) )

42import Data.Functor.Apply ( Apply, (<.>) )

44+

51-- | A @HTable@ is a functor-indexed/higher-kinded data type that is

45-- | A @HTable@ is a functor-indexed/higher-kinded data type that is

52-- representable ('htabulate'/'hfield'), constrainable ('hdicts'), and

46-- representable ('htabulate'/'hfield'), constrainable ('hdicts'), and

53-- specified ('hspecs').

47-- specified ('hspecs').

@@ -56,14 +50,14 @@ import Data.Functor.Apply ( Apply, (<.>) )

56-- instances yourself or specify this constraint.

50-- instances yourself or specify this constraint.

57type HTable :: K.HTable -> Constraint

51type HTable :: K.HTable -> Constraint

58class HTable t where

52class HTable t where

59− type HField t = (field :: Type -> Type) | field -> t

53+ type HField t = (field :: Spec -> Type) | field -> t

60− type HConstrainTable t (c :: Type -> Constraint) :: Constraint

54+ type HConstrainTable t (c :: Spec -> Constraint) :: Constraint

62− hfield :: t context -> HField t a -> context a

56+ hfield :: t context -> HField t spec -> context spec

63− htabulate :: (forall a. HField t a -> context a) -> t context

57+ htabulate :: (forall spec. HField t spec -> context spec) -> t context

64− htraverse :: Apply m => (forall a. f a -> m (g a)) -> t f -> m (t g)

58+ htraverse :: Apply m => (forall spec. f spec -> m (g spec)) -> t f -> m (t g)

65 hdicts :: HConstrainTable t c => t (Dict c)

59 hdicts :: HConstrainTable t c => t (Dict c)

66− hspecs :: t Spec

60+ hspecs :: t SSpec

68 type HField t = GHField t

62 type HField t = GHField t

69 type HConstrainTable t c = HConstrainTable (GHColumns (Rep (t Proxy))) c

63 type HConstrainTable t c = HConstrainTable (GHColumns (Rep (t Proxy))) c

@@ -74,7 +68,7 @@ class HTable t where

74 , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))

68 , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))

75 , GHTable context (Rep (t context))

69 , GHTable context (Rep (t context))

76 )

70 )

77− => t context -> HField t a -> context a

71+ => t context -> HField t spec -> context spec

78 hfield table (GHField field) = hfield (toGHColumns (from table)) field

72 hfield table (GHField field) = hfield (toGHColumns (from table)) field

80 default htabulate ::

74 default htabulate ::

@@ -83,7 +77,7 @@ class HTable t where

83 , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))

77 , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))

84 , GHTable context (Rep (t context))

78 , GHTable context (Rep (t context))

85 )

79 )

86− => (forall a. HField t a -> context a) -> t context

80+ => (forall spec. HField t spec -> context spec) -> t context

87 htabulate f = to $ fromGHColumns $ htabulate (f . GHField)

81 htabulate f = to $ fromGHColumns $ htabulate (f . GHField)

89 default htraverse

83 default htraverse

@@ -93,7 +87,7 @@ class HTable t where

93 , Generic (t g), GHTable g (Rep (t g))

87 , Generic (t g), GHTable g (Rep (t g))

94 , GHColumns (Rep (t f)) ~ GHColumns (Rep (t g))

88 , GHColumns (Rep (t f)) ~ GHColumns (Rep (t g))

95 )

89 )

96− => (forall a. f a -> m (g a)) -> t f -> m (t g)

90+ => (forall spec. f spec -> m (g spec)) -> t f -> m (t g)

97 htraverse f = fmap (to . fromGHColumns) . htraverse f . toGHColumns . from

91 htraverse f = fmap (to . fromGHColumns) . htraverse f . toGHColumns . from

99 default hdicts

93 default hdicts

@@ -107,10 +101,10 @@ class HTable t where

107 hdicts = to $ fromGHColumns (hdicts @(GHColumns (Rep (t Proxy))) @c)

101 hdicts = to $ fromGHColumns (hdicts @(GHColumns (Rep (t Proxy))) @c)

108

102

109 default hspecs ::

103 default hspecs ::

110− ( Generic (t Spec)

104+ ( Generic (t SSpec)

111− , GHTable Spec (Rep (t Spec))

105+ , GHTable SSpec (Rep (t SSpec))

112 )

106 )

113− => t Spec

107+ => t SSpec

114 hspecs = to $ fromGHColumns hspecs

108 hspecs = to $ fromGHColumns hspecs

115

109

116 {-# INLINABLE hfield #-}

110 {-# INLINABLE hfield #-}

@@ -120,43 +114,22 @@ class HTable t where

120 {-# INLINABLE hspecs #-}

114 {-# INLINABLE hspecs #-}

121

115

122

116

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−

128hmap :: HTable t

117hmap :: HTable t

129− => (forall a. context a -> context' a) -> t context -> t context'

118+ => (forall spec. context spec -> context' spec) -> t context -> t context'

130hmap f a = htabulate $ \field -> f (hfield a field)

119hmap f a = htabulate $ \field -> f (hfield a field)

131

120

132

121

133htabulateA :: (HTable t, Apply m)

122htabulateA :: (HTable t, Apply m)

134− => (forall a. HField t a -> m (context a)) -> m (t context)

123+ => (forall spec. HField t spec -> m (context spec)) -> m (t context)

135htabulateA f = htraverse getCompose $ htabulate $ Compose . f

124htabulateA f = htraverse getCompose $ htabulate $ Compose . f

136{-# INLINABLE htabulateA #-}

125{-# INLINABLE htabulateA #-}

137

126

138−newtype ApplyP p a b = ApplyP { unApplyP :: p a b }

139−

140−instance Profunctor p => Functor (ApplyP p a) where

141− fmap f = ApplyP . rmap f . unApplyP

142−

143−instance ProductProfunctor p => Apply (ApplyP p a) where

144− ApplyP f <.> ApplyP x = ApplyP (rmap id f **** x)

145−

146−htraverseP :: (HTable t, ProductProfunctor p)

147− => (forall a. p (f a) (g a)) -> p (t f) (t g)

148−htraverseP f = htraversePWithField (const f)

149−

150−htraversePWithField :: (HTable t, ProductProfunctor p)

151− => (forall a. HField t a -> p (f a) (g a)) -> p (t f) (t g)

152−htraversePWithField f = unApplyP $ htabulateA $ \field -> ApplyP $

153− lmap (flip hfield field) (f field)

154

127

155−type GHField :: K.HTable -> Type -> Type

128+type GHField :: K.HTable -> Spec -> Type

156−newtype GHField t a = GHField (HField (GHColumns (Rep (t Proxy))) a)

129+newtype GHField t spec = GHField (HField (GHColumns (Rep (t Proxy))) spec)

157

130

158

131

159−type GHTable :: K.Context -> (Type -> Type) -> Constraint

132+type GHTable :: K.HContext -> (Type -> Type) -> Constraint

160class HTable (GHColumns rep) => GHTable context rep | rep -> context where

133class HTable (GHColumns rep) => GHTable context rep | rep -> context where

161 type GHColumns rep :: K.HTable

134 type GHColumns rep :: K.HTable

162 toGHColumns :: rep x -> GHColumns rep context

135 toGHColumns :: rep x -> GHColumns rep context

@@ -182,10 +155,10 @@ instance (GHTable context a, GHTable context b) => GHTable context (a :*: b) whe

182

155

183

156

184-- | A HField type for indexing into HProduct.

157-- | A HField type for indexing into HProduct.

185−type HProductField :: K.HTable -> K.HTable -> Type -> Type

158+type HProductField :: K.HTable -> K.HTable -> Spec -> Type

186−data HProductField x y a

159+data HProductField x y spec

187− = HFst (HField x a)

160+ = HFst (HField x spec)

188− | HSnd (HField y a)

161+ | HSnd (HField y spec)

189

162

190

163

191instance (HTable x, HTable y) => HTable (HProduct x y) where

164instance (HTable x, HTable y) => HTable (HProduct x y) where

src/Rel8/Schema/HTable/Either.hs+4−2

@@ -14,17 +14,19 @@ import GHC.Generics ( Generic )

14import Prelude ()

16-- rel8

17+import Rel8.Kind.Necessity ( Necessity( Required ) )

17import Rel8.Schema.HTable ( HTable )

18import Rel8.Schema.HTable ( HTable )

18−import Rel8.Schema.HTable.Identity ( HIdentity )

19+import Rel8.Schema.HTable.Identity ( HIdentity(..) )

19import Rel8.Schema.HTable.Label ( HLabel )

20import Rel8.Schema.HTable.Label ( HLabel )

20import Rel8.Schema.HTable.Nullify ( HNullify )

21import Rel8.Schema.HTable.Nullify ( HNullify )

21import qualified Rel8.Schema.Kind as K

22import qualified Rel8.Schema.Kind as K

23+import Rel8.Schema.Spec ( Spec( Spec ) )

22import Rel8.Type.Tag ( EitherTag )

24import Rel8.Type.Tag ( EitherTag )

25type HEitherTable :: K.HTable -> K.HTable -> K.HTable

27type HEitherTable :: K.HTable -> K.HTable -> K.HTable

26data HEitherTable left right context = HEitherTable

28data HEitherTable left right context = HEitherTable

27− { htag :: HLabel "isRight" (HIdentity EitherTag) context

29+ { htag :: HIdentity ('Spec '["isRight"] 'Required EitherTag) context

28 , hleft :: HLabel "Left" (HNullify left) context

30 , hleft :: HLabel "Left" (HNullify left) context

29 , hright :: HLabel "Right" (HNullify right) context

31 , hright :: HLabel "Right" (HNullify right) context

30 }

32 }

src/Rel8/Schema/HTable/Identity.hs+29−16

@@ -1,43 +1,56 @@

1{-# language DataKinds #-}

2−{-# language FlexibleContexts #-}

2+{-# language GADTs #-}

3+{-# language PatternSynonyms #-}

3{-# language StandaloneKindSignatures #-}

4{-# language StandaloneKindSignatures #-}

4{-# language TypeFamilies #-}

5{-# language TypeFamilies #-}

5−{-# language UndecidableInstances #-}

7module Rel8.Schema.HTable.Identity

8− ( HIdentity( HIdentity, unHIdentity )

8+ ( HIdentity( HIdentity, HType, unHIdentity )

9+ , HType

9 )

10 )

10where

11where

12-- base

13-- base

13import Data.Kind ( Type )

14import Data.Kind ( Type )

14−import Data.Type.Equality ( (:~:)( Refl ) )

15import Prelude

17-- rel8

18+import Rel8.Kind.Necessity ( Necessity( Required ) )

18import Rel8.Schema.Dict ( Dict( Dict ) )

19import Rel8.Schema.Dict ( Dict( Dict ) )

19import Rel8.Schema.HTable

20import Rel8.Schema.HTable

20 ( HTable, HConstrainTable, HField

21 ( HTable, HConstrainTable, HField

21 , hfield, htabulate, htraverse, hdicts, hspecs

22 , hfield, htabulate, htraverse, hdicts, hspecs

22 )

23 )

23import qualified Rel8.Schema.Kind as K

24import qualified Rel8.Schema.Kind as K

24−import Rel8.Schema.Null ( Sql )

25+import Rel8.Schema.Spec ( Spec( Spec ), KnownSpec, specSing )

25−import Rel8.Schema.Spec ( specification )

26−import Rel8.Type ( DBType )

29−type HIdentity :: Type -> K.HTable

28+type HType :: Type -> K.HTable

29+type HType a = HIdentity ('Spec '[] 'Required a)

30+

31+

32+pattern HType :: context ('Spec '[] 'Required a) -> HType a context

33+pattern HType a = HIdentity a

34+{-# COMPLETE HType #-}

35+

36+

37+type HIdentity :: Spec -> K.HTable

30−newtype HIdentity a context = HIdentity

38+newtype HIdentity spec context = HIdentity

31− { unHIdentity :: context a

39+ { unHIdentity :: context spec

32 }

40 }

43+type HIdentityField :: Spec -> Spec -> Type

44+data HIdentityField _spec spec where

45+ HIdentityField :: HIdentityField spec spec

46+

47+

35−instance Sql DBType a => HTable (HIdentity a) where

48+instance KnownSpec spec => HTable (HIdentity spec) where

36− type HConstrainTable (HIdentity a) constraint = constraint a

49+ type HConstrainTable (HIdentity spec) c = c spec

37− type HField (HIdentity a) = (:~:) a

50+ type HField (HIdentity spec) = HIdentityField spec

39− hfield (HIdentity a) Refl = a

52+ hfield (HIdentity a) HIdentityField = a

40− htabulate f = HIdentity $ f Refl

53+ htabulate f = HIdentity $ f HIdentityField

41 htraverse f (HIdentity a) = HIdentity <$> f a

54 htraverse f (HIdentity a) = HIdentity <$> f a

42 hdicts = HIdentity Dict

55 hdicts = HIdentity Dict

43− hspecs = HIdentity specification

56+ hspecs = HIdentity specSing

src/Rel8/Schema/HTable/Label.hs+50−37

@@ -1,70 +1,83 @@

1+{-# LANGUAGE DeriveAnyClass #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE DerivingStrategies #-}

4+{-# LANGUAGE LambdaCase #-}

5+{-# language ConstraintKinds #-}

1{-# language DataKinds #-}

6{-# language DataKinds #-}

7+{-# language FlexibleInstances #-}

8+{-# language GADTs #-}

9+{-# language MultiParamTypeClasses #-}

10+{-# language QuantifiedConstraints #-}

2{-# language RankNTypes #-}

11{-# language RankNTypes #-}

3{-# language RecordWildCards #-}

12{-# language RecordWildCards #-}

4{-# language ScopedTypeVariables #-}

13{-# language ScopedTypeVariables #-}

5{-# language StandaloneKindSignatures #-}

14{-# language StandaloneKindSignatures #-}

6−{-# language TypeApplications #-}

7{-# language TypeFamilies #-}

15{-# language TypeFamilies #-}

16+{-# language TypeOperators #-}

17+{-# language UndecidableInstances #-}

9module Rel8.Schema.HTable.Label

19module Rel8.Schema.HTable.Label

20+ ( HLabel, Label

10− ( HLabel, hlabel, hrelabel, hunlabel

21+ , hlabel, hunlabel

11− , hproject

12 )

22 )

13where

23where

15-- base

25-- base

16−import Data.Kind ( Type )

17import Data.Proxy ( Proxy( Proxy ) )

26import Data.Proxy ( Proxy( Proxy ) )

18−import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )

27+import GHC.TypeLits ( KnownSymbol, Symbol )

19import Prelude

28import Prelude

21-- rel8

30-- rel8

31+import Rel8.Kind.Labels ( SLabels( SCons ) )

22import Rel8.Schema.HTable

32import Rel8.Schema.HTable

23− ( HTable, HConstrainTable, HField

33+ ( HTable

24− , htabulate, hfield, htraverse, hdicts, hspecs

34+ , hfield, htabulate, hspecs

25 )

35 )

26import qualified Rel8.Schema.Kind as K

36import qualified Rel8.Schema.Kind as K

27−import Rel8.Schema.Spec ( Spec(..) )

37+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

38+import Rel8.FCF

39+import Rel8.Schema.HTable.MapTable

40+import GHC.Generics (Generic)

30type HLabel :: Symbol -> K.HTable -> K.HTable

43type HLabel :: Symbol -> K.HTable -> K.HTable

31−newtype HLabel label table context = HLabel (table context)

44+newtype HLabel label table context = HLabel (HMapTable (Label label) table context)

45+ deriving stock Generic

46+ deriving anyclass HTable

34−type HLabelField :: Symbol -> K.HTable -> Type -> Type

49+data Label :: Symbol -> Spec -> Exp Spec

35−newtype HLabelField label table a = HLabelField (HField table a)

38−instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where

52+type instance Eval (Label label ('Spec labels necessity a)) = 'Spec (label : labels) necessity a

39− type HField (HLabel label table) = HLabelField label table

40− type HConstrainTable (HLabel label table) constraint =

41− HConstrainTable table constraint

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 #-}

51−

55+instance KnownSymbol l => MapSpec (Label l) where

52−hlabel :: forall label t context. t context -> HLabel label t context

56+ mapInfo = \case

53−hlabel = HLabel

57+ SSpec {..} -> SSpec {labels = SCons Proxy labels, ..}

54−{-# INLINABLE hlabel #-}

60+hlabel :: (HTable t, KnownSymbol label)

61+ => (forall labels necessity a. ()

62+ => context ('Spec labels necessity a)

63+ -> context ('Spec (label ': labels) necessity a))

64+ -> t context

57−hrelabel :: forall label' label t context. HLabel label t context -> HLabel label' t context

65+ -> HLabel label t context

58−hrelabel = hlabel . hunlabel

66+hlabel labeler a = HLabel $ htabulate $ \(HMapTableField field) ->

67+ case hfield hspecs field of

68+ SSpec {} -> labeler (hfield a field)

59−{-# INLINABLE hrelabel #-}

69+{-# INLINABLE hlabel #-}

72+hunlabel :: (HTable t, KnownSymbol label)

73+ => (forall labels necessity a. ()

74+ => context ('Spec (label ': labels) necessity a)

75+ -> context ('Spec labels necessity a))

62−hunlabel :: forall label t context. HLabel label t context -> t context

76+ -> HLabel label t context

77+ -> t context

63−hunlabel (HLabel a) = a

78+hunlabel unlabler (HLabel as) =

79+ htabulate $ \field ->

80+ case hfield hspecs field of

81+ SSpec {} -> case hfield as (HMapTableField field) of

82+ a -> unlabler a

64{-# INLINABLE hunlabel #-}

83{-# 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+12−22

@@ -6,7 +6,7 @@

6{-# language GADTs #-}

7{-# language InstanceSigs #-}

8{-# language MultiParamTypeClasses #-}

9−{-# language RankNTypes #-}

9+{-# language PolyKinds #-}

10{-# language ScopedTypeVariables #-}

11{-# language StandaloneKindSignatures #-}

12{-# language TypeApplications #-}

@@ -19,38 +19,34 @@ module Rel8.Schema.HTable.MapTable

19 , MapSpec(..)

20 , Precompose(..)

21 , HMapTableField(..)

22− , hproject

23 )

22 )

24where

23where

26-- base

25-- base

27import Data.Kind ( Constraint, Type )

26import Data.Kind ( Constraint, Type )

28−import Prelude

27+import Prelude ( ($), (.), (<$>), fmap )

30-- rel8

29-- rel8

31−import Rel8.FCF ( Exp, Eval )

30+import Rel8.FCF

32import Rel8.Schema.HTable

31import Rel8.Schema.HTable

33− ( HTable, HConstrainTable, HField

34− , hfield, htabulate, htraverse, hdicts, hspecs

35− )

36−import Rel8.Schema.Spec ( Spec )

32+import Rel8.Schema.Spec ( Spec, SSpec )

37import qualified Rel8.Schema.Kind as K

33import qualified Rel8.Schema.Kind as K

38import Rel8.Schema.Dict ( Dict( Dict ) )

34import Rel8.Schema.Dict ( Dict( Dict ) )

41−type HMapTable :: (Type -> Exp Type) -> K.HTable -> K.HTable

37+type HMapTable :: (a -> Exp b) -> ((a -> Type) -> Type) -> (b -> Type) -> Type

42−newtype HMapTable f t context = HMapTable

38+newtype HMapTable f t g = HMapTable

43− { unHMapTable :: t (Precompose f context)

39+ { unHMapTable :: t (Precompose f g)

44 }

40 }

47−type Precompose :: (Type -> Exp Type) -> K.Context -> K.Context

43+type Precompose :: (a -> Exp b) -> (b -> Type) -> a -> Type

48newtype Precompose f g x = Precompose

44newtype Precompose f g x = Precompose

49 { precomposed :: g (Eval (f x))

45 { precomposed :: g (Eval (f x))

50 }

46 }

53−type HMapTableField :: (Type -> Exp Type) -> K.HTable -> K.Context

49+type HMapTableField :: (Spec -> Exp a) -> K.HTable -> a -> Type

54data HMapTableField f t x where

50data HMapTableField f t x where

55 HMapTableField :: HField t a -> HMapTableField f t (Eval (f a))

51 HMapTableField :: HField t a -> HMapTableField f t (Eval (f a))

@@ -83,17 +79,11 @@ instance (HTable t, MapSpec f) => HTable (HMapTable f t) where

83 {-# INLINABLE hspecs #-}

79 {-# INLINABLE hspecs #-}

86−type MapSpec :: (Type -> Exp Type) -> Constraint

82+type MapSpec :: (Spec -> Exp Spec) -> Constraint

87class MapSpec f where

83class MapSpec f where

88− mapInfo :: Spec x -> Spec (Eval (f x))

84+ mapInfo :: SSpec x -> SSpec (Eval (f x))

91−type ComposeConstraint :: (Type -> Exp Type) -> (Type -> Constraint) -> Type -> Constraint

87+type ComposeConstraint :: (a -> Exp b) -> (b -> Constraint) -> a -> Constraint

92class c (Eval (f a)) => ComposeConstraint f c a

88class c (Eval (f a)) => ComposeConstraint f c a

93instance c (Eval (f a)) => ComposeConstraint f c a

89instance 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+4−2

@@ -14,17 +14,19 @@ import GHC.Generics ( Generic )

14import Prelude

16-- rel8

17+import Rel8.Kind.Necessity ( Necessity( Required ) )

17import Rel8.Schema.HTable ( HTable )

18import Rel8.Schema.HTable ( HTable )

18−import Rel8.Schema.HTable.Identity ( HIdentity )

19+import Rel8.Schema.HTable.Identity ( HIdentity(..) )

19import Rel8.Schema.HTable.Label ( HLabel )

20import Rel8.Schema.HTable.Label ( HLabel )

20import Rel8.Schema.HTable.Nullify ( HNullify )

21import Rel8.Schema.HTable.Nullify ( HNullify )

21import qualified Rel8.Schema.Kind as K

22import qualified Rel8.Schema.Kind as K

23+import Rel8.Schema.Spec ( Spec( Spec ) )

22import Rel8.Type.Tag ( MaybeTag )

24import Rel8.Type.Tag ( MaybeTag )

25type HMaybeTable :: K.HTable -> K.HTable

27type HMaybeTable :: K.HTable -> K.HTable

26data HMaybeTable table context = HMaybeTable

28data HMaybeTable table context = HMaybeTable

27− { htag :: HLabel "isJust" (HIdentity (Maybe MaybeTag)) context

29+ { htag :: HIdentity ('Spec '["isJust"] 'Required (Maybe MaybeTag)) context

28 , hjust :: HLabel "Just" (HNullify table) context

30 , hjust :: HLabel "Just" (HNullify table) context

29 }

31 }

30 deriving stock Generic

32 deriving stock Generic

src/Rel8/Schema/HTable/Nullify.hs+33−47

@@ -10,7 +10,6 @@

10{-# language NamedFieldPuns #-}

11{-# language QuantifiedConstraints #-}

12{-# language RankNTypes #-}

13−{-# language RecordWildCards #-}

14{-# language ScopedTypeVariables #-}

13{-# language ScopedTypeVariables #-}

15{-# language StandaloneKindSignatures #-}

14{-# language StandaloneKindSignatures #-}

16{-# language TypeFamilies #-}

15{-# language TypeFamilies #-}

@@ -19,34 +18,25 @@

19module Rel8.Schema.HTable.Nullify

18module Rel8.Schema.HTable.Nullify

20 ( HNullify( HNullify )

19 ( HNullify( HNullify )

21 , Nullify

20 , Nullify

22− , hguard

23− , hnulls

24− , hnullify

25− , hunnullify

21+ , hnulls, hnullify, hunnullify

26− , hproject

27 )

22 )

28where

23where

30-- base

25-- base

31−import Data.Kind ( Type )

32−import GHC.Generics ( Generic )

33import Prelude hiding ( null )

26import Prelude hiding ( null )

35-- rel8

28-- rel8

36−import Rel8.FCF ( Eval, Exp )

37import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )

29import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )

38−import Rel8.Schema.HTable.MapTable

39− ( HMapTable, HMapTableField( HMapTableField )

40− , MapSpec, mapInfo

41− )

42−import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )

43import qualified Rel8.Schema.Kind as K

30import qualified Rel8.Schema.Kind as K

44import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

31import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

45import qualified Rel8.Schema.Null as Type ( Nullify )

32import qualified Rel8.Schema.Null as Type ( Nullify )

46−import Rel8.Schema.Spec ( Spec(..) )

33+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

48-- semigroupoids

35-- semigroupoids

49import Data.Functor.Apply ( Apply )

36import Data.Functor.Apply ( Apply )

37+import Rel8.Schema.HTable.MapTable

38+import Rel8.FCF

39+import GHC.Generics (Generic)

52type HNullify :: K.HTable -> K.HTable

42type HNullify :: K.HTable -> K.HTable

@@ -55,63 +45,59 @@ newtype HNullify table context = HNullify (HMapTable Nullify table context)

55 deriving anyclass HTable

45 deriving anyclass HTable

48+

58−-- | Transform a 'Type' by allowing it to be @null@.

49+-- | Transform a 'Spec' by allowing it to be @null@.

59−data Nullify :: Type -> Exp Type

50+data Nullify :: Spec -> Exp Spec

51+

52+

60−type instance Eval (Nullify a) = Type.Nullify a

53+type instance Eval (Nullify ('Spec labels necessity a)) =

54+ 'Spec labels necessity (Type.Nullify a)

63instance MapSpec Nullify where

57instance MapSpec Nullify where

64 mapInfo = \case

58 mapInfo = \case

65− Spec {nullity, ..} -> Spec

59+ SSpec{labels, necessity, info, nullity} -> SSpec

60+ { labels

61+ , necessity

62+ , info

66− { nullity = case nullity of

63+ , nullity = case nullity of

67 Null -> Null

64 Null -> Null

68 NotNull -> Null

65 NotNull -> Null

69− , ..

66+ }

70− }

71−

72−

73−hguard :: HTable t

74− => (forall a. context (Maybe a) -> context (Maybe a))

75− -> HNullify t context -> HNullify t context

76−hguard guarder (HNullify as) = HNullify $ htabulate $ \(HMapTableField field) ->

77− case hfield hspecs field of

78− Spec {nullity} -> case hfield as (HMapTableField field) of

79− a -> case nullity of

80− Null -> guarder a

81− NotNull -> guarder a

84hnulls :: HTable t

69hnulls :: HTable t

70+ => (forall labels necessity a. ()

71+ => SSpec ('Spec labels necessity a)

85− => (forall a. Spec a -> context (Type.Nullify a))

72+ -> context ('Spec labels necessity (Type.Nullify a)))

86 -> HNullify t context

73 -> HNullify t context

87−hnulls null = HNullify $ htabulate $ \(HMapTableField field) ->

74+hnulls null = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of

88− case hfield hspecs field of

89− spec@Spec {} -> null spec

75+ spec@SSpec {} -> null spec

90{-# INLINABLE hnulls #-}

76{-# INLINABLE hnulls #-}

93hnullify :: HTable t

79hnullify :: HTable t

80+ => (forall labels necessity a. ()

81+ => SSpec ('Spec labels necessity a)

82+ -> context ('Spec labels necessity a)

94− => (forall a. Spec a -> context a -> context (Type.Nullify a))

83+ -> context ('Spec labels necessity (Type.Nullify a)))

95 -> t context

84 -> t context

96 -> HNullify t context

85 -> HNullify t context

97hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->

86hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->

98 case hfield hspecs field of

87 case hfield hspecs field of

99− spec@Spec {} -> nullifier spec (hfield a field)

88+ spec@SSpec {} -> nullifier spec (hfield a field)

100{-# INLINABLE hnullify #-}

89{-# INLINABLE hnullify #-}

101

102

103hunnullify :: (HTable t, Apply m)

92hunnullify :: (HTable t, Apply m)

93+ => (forall labels necessity a. ()

94+ => SSpec ('Spec labels necessity a)

104− => (forall a. Spec a -> context (Type.Nullify a) -> m (context a))

95+ -> context ('Spec labels necessity (Type.Nullify a))

96+ -> m (context ('Spec labels necessity a)))

105 -> HNullify t context

97 -> HNullify t context

106 -> m (t context)

98 -> m (t context)

107hunnullify unnullifier (HNullify as) =

99hunnullify unnullifier (HNullify as) =

108 htabulateA $ \field -> case hfield hspecs field of

100 htabulateA $ \field -> case hfield hspecs field of

109− spec@Spec {} -> case hfield as (HMapTableField field) of

101+ spec@SSpec {} -> case hfield as (HMapTableField field) of

110 a -> unnullifier spec a

102 a -> unnullifier spec a

111{-# INLINABLE hunnullify #-}

103{-# INLINABLE hunnullify #-}

112−

113−

114−hproject :: ()

115− => (forall ctx. t ctx -> t' ctx)

116− -> HNullify t context -> HNullify t' context

117−hproject f (HNullify a) = HNullify (HMapTable.hproject f a)

src/Rel8/Schema/HTable/These.hs+4−2

@@ -14,19 +14,21 @@ import GHC.Generics ( Generic )

14import Prelude

16-- rel8

17+import Rel8.Kind.Necessity ( Necessity( Required ) )

17import Rel8.Schema.HTable ( HTable )

18import Rel8.Schema.HTable ( HTable )

18import Rel8.Schema.HTable.Identity ( HIdentity )

19import Rel8.Schema.HTable.Identity ( HIdentity )

19import Rel8.Schema.HTable.Label ( HLabel )

20import Rel8.Schema.HTable.Label ( HLabel )

20import Rel8.Schema.HTable.Nullify ( HNullify )

21import Rel8.Schema.HTable.Nullify ( HNullify )

21import qualified Rel8.Schema.Kind as K

22import qualified Rel8.Schema.Kind as K

23+import Rel8.Schema.Spec ( Spec( Spec ) )

22import Rel8.Type.Tag ( MaybeTag )

24import Rel8.Type.Tag ( MaybeTag )

25type HTheseTable :: K.HTable -> K.HTable -> K.HTable

27type HTheseTable :: K.HTable -> K.HTable -> K.HTable

26data HTheseTable here there context = HTheseTable

28data HTheseTable here there context = HTheseTable

27− { hhereTag :: HLabel "hereTag" (HIdentity (Maybe MaybeTag)) context

29+ { hhereTag :: HIdentity ('Spec '["hasHere"] 'Required (Maybe MaybeTag)) context

28 , hhere :: HLabel "Here" (HNullify here) context

30 , hhere :: HLabel "Here" (HNullify here) context

29− , hthereTag :: HLabel "thereTag" (HIdentity (Maybe MaybeTag)) context

31+ , hthereTag :: HIdentity ('Spec '["hasThere"] 'Required (Maybe MaybeTag)) context

30 , hthere :: HLabel "There" (HNullify there) context

32 , hthere :: HLabel "There" (HNullify there) context

31 }

33 }

32 deriving stock Generic

34 deriving stock Generic

src/Rel8/Schema/HTable/Vectorize.hs+47−39

@@ -9,6 +9,8 @@

9{-# language GADTs #-}

10{-# language LambdaCase #-}

11{-# language MultiParamTypeClasses #-}

12+{-# language NamedFieldPuns #-}

13+{-# language QuantifiedConstraints #-}

12{-# language RankNTypes #-}

14{-# language RankNTypes #-}

13{-# language RecordWildCards #-}

15{-# language RecordWildCards #-}

14{-# language ScopedTypeVariables #-}

16{-# language ScopedTypeVariables #-}

@@ -21,39 +23,34 @@ module Rel8.Schema.HTable.Vectorize

21 ( HVectorize

23 ( HVectorize

22 , hvectorize, hunvectorize

24 , hvectorize, hunvectorize

23 , happend, hempty

25 , happend, hempty

24− , hproject

25− , hcolumn

26 )

27where

29-- base

30−import Data.Kind ( Constraint, Type )

30+import Data.Kind ( Type )

31import Data.List.NonEmpty ( NonEmpty )

32−import GHC.Generics (Generic)

33import Prelude

32import Prelude

35-- rel8

34-- rel8

36−import Rel8.FCF ( Eval, Exp )

35+import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )

37import Rel8.Schema.Dict ( Dict( Dict ) )

36import Rel8.Schema.Dict ( Dict( Dict ) )

38import qualified Rel8.Schema.Kind as K

37import qualified Rel8.Schema.Kind as K

38+import Rel8.Schema.HTable

39+ ( HTable

39−import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )

40+ , hfield, htabulate, htabulateA, hspecs

40−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

41−import Rel8.Schema.HTable.MapTable

42− ( HMapTable( HMapTable ), HMapTableField( HMapTableField )

43− , MapSpec, mapInfo

44− , Precompose( Precompose )

45 )

41 )

46−import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )

47import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )

42import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )

48−import Rel8.Schema.Spec ( Spec(..) )

43+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

49import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )

44import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )

50import Rel8.Type.Information ( TypeInformation )

45import Rel8.Type.Information ( TypeInformation )

52-- semialign

47-- semialign

53−import Data.Zip ( Unzip, Zip, Zippy(..) )

48+import Data.Zip ( Unzip, Repeat, Zippy(..) )

49+import Rel8.FCF

50+import Rel8.Schema.HTable.MapTable

51+import GHC.Generics (Generic)

56−type Vector :: (Type -> Type) -> Constraint

57class Vector list where

54class Vector list where

58 listNotNull :: proxy a -> Dict NotNull (list a)

55 listNotNull :: proxy a -> Dict NotNull (list a)

59 vectorTypeInformation :: ()

56 vectorTypeInformation :: ()

@@ -78,16 +75,16 @@ newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) t

78 deriving anyclass HTable

75 deriving anyclass HTable

81−data Vectorize :: (Type -> Type) -> Type -> Exp Type

78+data Vectorize :: (Type -> Type) -> Spec -> Exp Spec

84−type instance Eval (Vectorize list a) = list a

81+type instance Eval (Vectorize list ('Spec labels necessity a)) = 'Spec labels necessity (list a)

87instance Vector list => MapSpec (Vectorize list) where

84instance Vector list => MapSpec (Vectorize list) where

88 mapInfo = \case

85 mapInfo = \case

89− Spec {..} -> case listNotNull @list nullity of

86+ SSpec {..} -> case listNotNull @list nullity of

90− Dict -> Spec

87+ Dict -> SSpec

91 { nullity = NotNull

88 { nullity = NotNull

92 , info = vectorTypeInformation nullity info

89 , info = vectorTypeInformation nullity info

93 , ..

90 , ..

@@ -95,49 +92,60 @@ instance Vector list => MapSpec (Vectorize list) where

97hvectorize :: (HTable t, Unzip f, Vector list)

94hvectorize :: (HTable t, Unzip f, Vector list)

98− => (forall a. Spec a -> f (context a) -> context' (list a))

95+ => (forall labels necessity a. ()

96+ => SSpec ('Spec labels necessity a)

97+ -> f (context ('Spec labels necessity a))

98+ -> context' ('Spec labels necessity (list a)))

99 -> f (t context)

100 -> HVectorize list t context'

101hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->

102 case hfield hspecs field of

103− spec -> vectorizer spec (fmap (`hfield` field) as)

103+ spec@SSpec {} -> vectorizer spec (fmap (`hfield` field) as)

104{-# INLINABLE hvectorize #-}

105

106

107−hunvectorize :: (HTable t, Zip f, Vector list)

107+hunvectorize :: (HTable t, Repeat f, Vector list)

108− => (forall a. Spec a -> context (list a) -> f (context' a))

108+ => (forall labels necessity a. ()

109+ => SSpec ('Spec labels necessity a)

110+ -> context ('Spec labels necessity (list a))

111+ -> f (context' ('Spec labels necessity a)))

109 -> HVectorize list t context

112 -> HVectorize list t context

110 -> f (t context')

113 -> f (t context')

111hunvectorize unvectorizer (HVectorize table) =

114hunvectorize unvectorizer (HVectorize table) =

112 getZippy $ htabulateA $ \field -> case hfield hspecs field of

115 getZippy $ htabulateA $ \field -> case hfield hspecs field of

113− spec -> case hfield table (HMapTableField field) of

116+ spec@SSpec{} -> case hfield table (HMapTableField field) of

114 a -> Zippy (unvectorizer spec a)

117 a -> Zippy (unvectorizer spec a)

115{-# INLINABLE hunvectorize #-}

118{-# INLINABLE hunvectorize #-}

116

119

117

120

118−happend :: (HTable t, Vector list)

121+happend :: (HTable t, Vector list) =>

119− => (forall a. Spec a -> context (list a) -> context (list a) -> context (list a))

122+ ( forall labels necessity a. ()

123+ => Nullity a

124+ -> TypeInformation (Unnullify a)

125+ -> context ('Spec labels necessity (list a))

126+ -> context ('Spec labels necessity (list a))

127+ -> context ('Spec labels necessity (list a))

128+ )

120 -> HVectorize list t context

129 -> HVectorize list t context

121 -> HVectorize list t context

130 -> HVectorize list t context

122 -> HVectorize list t context

131 -> HVectorize list t context

123happend append (HVectorize as) (HVectorize bs) = HVectorize $

132happend append (HVectorize as) (HVectorize bs) = HVectorize $

124 htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of

133 htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of

125 (a, b) -> case hfield hspecs j of

134 (a, b) -> case hfield hspecs j of

126− spec -> append spec a b

135+ SSpec {nullity, info} -> append nullity info a b

127

136

128

137

129−hempty :: HTable t

138+hempty :: HTable t =>

130− => (forall a. Spec a -> context [a])

139+ ( forall labels necessity a. ()

140+ => Nullity a

141+ -> TypeInformation (Unnullify a)

142+ -> context ('Spec labels necessity [a])

143+ )

131 -> HVectorize [] t context

144 -> HVectorize [] t context

132−hempty empty = HVectorize $ htabulate $ \(HMapTableField field) ->

145+hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of

133− empty (hfield hspecs field)

146+ SSpec {nullity, info} -> empty nullity info

134−

135−

136−hproject :: ()

137− => (forall ctx. t ctx -> t' ctx)

138− -> HVectorize list t context -> HVectorize list t' context

139−hproject f (HVectorize a) = HVectorize (HMapTable.hproject f a)

140

147

141

148

142−hcolumn :: HVectorize list (HIdentity a) context -> context (list a)

149+instance HLabelable g => HLabelable (Precompose (Vectorize list) g) where

143−hcolumn (HVectorize (HMapTable (HIdentity (Precompose a)))) = a

150+ hlabeler = Precompose . hlabeler . precomposed

151+ hunlabeler = Precompose . hunlabeler . precomposed

src/Rel8/Schema/Insert.hsnew file+167

@@ -0,0 +1,167 @@

1+{-# language DataKinds #-}

2+{-# language DuplicateRecordFields #-}

3+{-# language FlexibleContexts #-}

4+{-# language FlexibleInstances #-}

5+{-# language GADTs #-}

6+{-# language LambdaCase #-}

7+{-# language MultiParamTypeClasses #-}

8+{-# language NamedFieldPuns #-}

9+{-# language PolyKinds #-}

10+{-# language StandaloneKindSignatures #-}

11+{-# language TypeFamilies #-}

12+{-# language UndecidableInstances #-}

13+{-# language UndecidableSuperClasses #-}

14+

15+module Rel8.Schema.Insert

16+ ( Insert(..)

17+ , OnConflict(..)

18+ , Col( RequiredInsert, OptionalInsert )

19+ , Inserts

20+ , Insertion(..)

21+ )

22+where

23+

24+-- base

25+import Data.Functor.Identity ( Identity )

26+import Data.Kind ( Constraint, Type )

27+import Prelude

28+

29+-- rel8

30+import Rel8.Aggregate ( Aggregate )

31+import Rel8.Expr ( Expr )

32+import Rel8.Kind.Necessity ( Necessity(Optional, Required) )

33+import Rel8.Schema.Context ( Interpretation(..) )

34+import Rel8.Schema.Context.Label ( Labelable(..) )

35+import Rel8.Schema.Context.Nullify

36+ ( Nullifiable, encodeTag, decodeTag, nullifier, unnullifier

37+ , runTag, unnull

38+ )

39+import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )

40+import Rel8.Schema.Name ( Name, Selects )

41+import Rel8.Schema.Null ( Sql )

42+import Rel8.Schema.Reify ( notReify )

43+import Rel8.Schema.Result ( Result )

44+import Rel8.Schema.Spec ( SSpec(SSpec, nullity), Spec(Spec) )

45+import Rel8.Schema.Table ( TableSchema )

46+import Rel8.Statement.Returning ( Returning )

47+import Rel8.Table

48+ ( Table, Context, Columns, fromColumns, toColumns

49+ , reify, unreify

50+ )

51+import Rel8.Table.Recontextualize ( Recontextualize )

52+import Rel8.Table.Tag ( Tag(..), fromExpr )

53+import Rel8.Type ( DBType )

54+

55+

56+-- | @OnConflict@ allows you to add an @ON CONFLICT@ clause to an @INSERT@

57+-- statement.

58+data OnConflict

59+ = Abort -- ^ @ON CONFLICT ABORT@

60+ | DoNothing -- ^ @ON CONFLICT DO NOTHING@

61+

62+

63+-- | The constituent parts of a SQL @INSERT@ statement.

64+type Insert :: k -> Type

65+data Insert a where

66+ Insert :: (Selects names exprs, Inserts exprs inserts) =>

67+ { into :: TableSchema names

68+ -- ^ Which table to insert into.

69+ , rows :: [inserts]

70+ -- ^ The rows to insert.

71+ , onConflict :: OnConflict

72+ -- ^ What to do if the inserted rows conflict with data already in the

73+ -- table.

74+ , returning :: Returning names a

75+ -- ^ What information to return on completion.

76+ }

77+ -> Insert a

78+

79+

80+instance Interpretation Insert where

81+ data Col Insert _spec where

82+ RequiredInsert :: Expr a -> Col Insert ('Spec labels 'Required a)

83+ OptionalInsert :: Maybe (Expr a) -> Col Insert ('Spec labels 'Optional a)

84+

85+

86+type Insertion :: Type -> Type

87+newtype Insertion a = Insertion (Expr a)

88+

89+

90+instance Sql DBType a => Table Insert (Insertion a) where

91+ type Columns (Insertion a) = HType a

92+ type Context (Insertion a) = Insert

93+

94+ toColumns (Insertion a) = HType (RequiredInsert a)

95+ fromColumns (HType (RequiredInsert a)) = Insertion a

96+ reify = notReify

97+ unreify = notReify

98+

99+

100+instance Sql DBType a =>

101+ Recontextualize Aggregate Insert (Aggregate (Expr a)) (Insertion a)

102+

103+

104+instance Sql DBType a => Recontextualize Expr Insert (Expr a) (Insertion a)

105+

106+

107+instance Sql DBType a =>

108+ Recontextualize Result Insert (Identity a) (Insertion a)

109+

110+

111+instance Sql DBType a =>

112+ Recontextualize Insert Aggregate (Insertion a) (Aggregate (Expr a))

113+

114+

115+instance Sql DBType a => Recontextualize Insert Expr (Insertion a) (Expr a)

116+

117+

118+instance Sql DBType a =>

119+ Recontextualize Insert Result (Insertion a) (Identity a)

120+

121+

122+instance Sql DBType a => Recontextualize Insert Insert (Insertion a) (Insertion a)

123+

124+

125+instance Sql DBType a => Recontextualize Insert Name (Insertion a) (Name a)

126+

127+

128+instance Sql DBType a => Recontextualize Name Insert (Name a) (Insertion a)

129+

130+

131+instance Labelable Insert where

132+ labeler = \case

133+ RequiredInsert a -> RequiredInsert a

134+ OptionalInsert ma -> OptionalInsert ma

135+

136+ unlabeler = \case

137+ RequiredInsert a -> RequiredInsert a

138+ OptionalInsert ma -> OptionalInsert ma

139+

140+

141+instance Nullifiable Insert where

142+ encodeTag = RequiredInsert . expr

143+ decodeTag (RequiredInsert a) = fromExpr a

144+

145+ nullifier Tag {expr} test SSpec {nullity} = \case

146+ RequiredInsert a ->

147+ RequiredInsert $ runTag nullity condition a

148+ OptionalInsert ma ->

149+ OptionalInsert $ runTag nullity condition <$> ma

150+ where

151+ condition = test expr

152+

153+ unnullifier SSpec {nullity} = \case

154+ RequiredInsert a -> RequiredInsert $ unnull nullity a

155+ OptionalInsert ma -> OptionalInsert $ unnull nullity <$> ma

156+

157+ {-# INLINABLE encodeTag #-}

158+ {-# INLINABLE decodeTag #-}

159+ {-# INLINABLE nullifier #-}

160+ {-# INLINABLE unnullifier #-}

161+

162+

163+-- | @Inserts a b@ means that the columns in @a@ are compatible for inserting

164+-- with the table @b@.

165+type Inserts :: Type -> Type -> Constraint

166+class Recontextualize Expr Insert exprs inserts => Inserts exprs inserts

167+instance Recontextualize Expr Insert exprs inserts => Inserts exprs inserts

src/Rel8/Schema/Kind.hs+15−6

@@ -1,9 +1,8 @@

1{-# language StandaloneKindSignatures #-}

3module Rel8.Schema.Kind

4− ( Rel8able

4+ ( Context, Rel8able

5− , Context

6− , HTable

5+ , HContext, HTable

7 )

6 )

8where

7where

@@ -11,13 +10,23 @@ where

11import Data.Kind ( Type )

10import Data.Kind ( Type )

12import Prelude ()

11import Prelude ()

13+-- rel8

14+import Rel8.Schema.Spec ( Spec )

16+

15−type Context :: Type

17+type HContext :: Type

16−type Context = Type -> Type

18+type HContext = Spec -> Type

19type HTable :: Type

21type HTable :: Type

22+type HTable = HContext -> Type

23+

24+

25+data X

26+

27+

28+type Context :: Type

20−type HTable = Context -> Type

29+type Context = X -> Type

23type Rel8able :: Type

32type Rel8able :: Type

src/Rel8/Schema/Name.hs+54−34

@@ -3,44 +3,40 @@

3{-# language FlexibleContexts #-}

4{-# language FlexibleInstances #-}

5{-# language GADTs #-}

6−{-# language GeneralizedNewtypeDeriving #-}

7{-# language MultiParamTypeClasses #-}

6{-# language MultiParamTypeClasses #-}

7+{-# language PolyKinds #-}

8{-# language RankNTypes #-}

9+{-# language StandaloneDeriving #-}

9{-# language StandaloneKindSignatures #-}

10{-# language StandaloneKindSignatures #-}

10{-# language TypeFamilies #-}

11{-# language TypeFamilies #-}

11{-# language UndecidableInstances #-}

12{-# language UndecidableInstances #-}

13+{-# language UndecidableSuperClasses #-}

13module Rel8.Schema.Name

15module Rel8.Schema.Name

14 ( Name(..)

16 ( Name(..)

17+ , Col( NameCol )

15 , Selects

18 , Selects

16− , ppColumn

17 )

19 )

18where

20where

20-- base

22-- base

21−import Data.Functor.Identity ( Identity( Identity ) )

23+import Data.Functor.Identity ( Identity )

22import Data.Kind ( Constraint, Type )

24import Data.Kind ( Constraint, Type )

23−import Data.String ( IsString )

25+import Data.String ( IsString, fromString )

24import Prelude

26import Prelude

26−-- opaleye

27−import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye

28−import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye

29−

30−-- pretty

31−import Text.PrettyPrint ( Doc )

32−

33-- rel8

28-- rel8

34import Rel8.Expr ( Expr )

29import Rel8.Expr ( Expr )

35−import qualified Rel8.Schema.Kind as K

30+import Rel8.Schema.Context ( Interpretation, Col )

31+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )

36−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

32+import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )

37import Rel8.Schema.Null ( Sql )

33import Rel8.Schema.Null ( Sql )

34+import Rel8.Schema.Reify ( notReify )

35+import Rel8.Schema.Result ( Result )

38import Rel8.Table

36import Rel8.Table

39− ( Table, Columns, Context, fromColumns, toColumns

37+ ( Table, Columns, Context, fromColumns, toColumns, reify, unreify

40− , FromExprs, fromResult, toResult

41− , Transpose

42 )

38 )

43−import Rel8.Table.Transpose ( Transposes )

39+import Rel8.Table.Recontextualize ( Recontextualize )

44import Rel8.Type ( DBType )

40import Rel8.Type ( DBType )

@@ -48,30 +44,54 @@ import Rel8.Type ( DBType )

48-- schema definition. You can construct names by using the @OverloadedStrings@

44-- schema definition. You can construct names by using the @OverloadedStrings@

49-- extension and writing string literals. This is typically done when providing

45-- extension and writing string literals. This is typically done when providing

50-- a 'TableSchema' value.

46-- a 'TableSchema' value.

51−type Name :: K.Context

47+type Name :: k -> Type

52−newtype Name a = Name String

48+data Name a where

49+ Name :: k ~ Type => !String -> Name (a :: k)

50+

51+

53− deriving stock Show

52+deriving stock instance Show (Name a)

54− deriving newtype IsString

53+

54+

55+instance k ~ Type => IsString (Name (a :: k)) where

56+ fromString = Name

57instance Sql DBType a => Table Name (Name a) where

59instance Sql DBType a => Table Name (Name a) where

58− type Columns (Name a) = HIdentity a

60+ type Columns (Name a) = HType a

59 type Context (Name a) = Name

61 type Context (Name a) = Name

60− type FromExprs (Name a) = a

61− type Transpose to (Name a) = to a

63− toColumns a = HIdentity a

63+ toColumns (Name a) = HType (NameCol a)

64− fromColumns (HIdentity a) = a

64+ fromColumns (HType (NameCol a)) = Name a

65− toResult a = HIdentity (Identity a)

65+ reify = notReify

66− fromResult (HIdentity (Identity a)) = a

66+ unreify = notReify

67+

68+

69+instance Sql DBType a => Recontextualize Expr Name (Expr a) (Name a)

70+

71+

72+instance Sql DBType a => Recontextualize Result Name (Identity a) (Name a)

73+

74+

75+instance Sql DBType a => Recontextualize Name Expr (Name a) (Expr a)

76+

77+

78+instance Sql DBType a => Recontextualize Name Result (Name a) (Identity a)

79+

80+

81+instance Sql DBType a => Recontextualize Name Name (Name a) (Name a)

82+

83+

84+instance Interpretation Name where

85+ newtype Col Name _spec = NameCol String

86+

87+

88+instance Labelable Name where

89+ labeler (NameCol a) = NameCol a

90+ unlabeler (NameCol a) = NameCol a

69-- | @Selects a b@ means that @a@ is a schema (i.e., a 'Table' of 'Name's) for

93-- | @Selects a b@ means that @a@ is a schema (i.e., a 'Table' of 'Name's) for

70-- the 'Expr' columns in @b@.

94-- the 'Expr' columns in @b@.

71type Selects :: Type -> Type -> Constraint

95type Selects :: Type -> Type -> Constraint

72−class Transposes Name Expr names exprs => Selects names exprs

96+class Recontextualize Name Expr names exprs => Selects names exprs

73−instance Transposes Name Expr names exprs => Selects names exprs

97+instance Recontextualize Name Expr names exprs => Selects names exprs

74−

75−

76−ppColumn :: String -> Doc

77−ppColumn = Opaleye.ppSqlExpr . Opaleye.ColumnSqlExpr . Opaleye.SqlColumn

src/Rel8/Schema/Reify.hsnew file+74

@@ -0,0 +1,74 @@

1+{-# language AllowAmbiguousTypes #-}

2+{-# language EmptyCase #-}

3+{-# language DataKinds #-}

4+{-# language FlexibleInstances #-}

5+{-# language ScopedTypeVariables #-}

6+{-# language StandaloneKindSignatures #-}

7+{-# language TypeApplications #-}

8+{-# language TypeFamilies #-}

9+{-# language TypeOperators #-}

10+{-# language UndecidableInstances #-}

11+

12+module Rel8.Schema.Reify

13+ ( Reify, Col( Reify ), hreify, hunreify

14+ , UnwrapReify

15+ , NotReify, notReify

16+ )

17+where

18+

19+-- base

20+import Data.Kind ( Constraint )

21+import Data.Type.Equality ( (:~:)( Refl ) )

22+import Prelude

23+

24+-- rel8

25+import Rel8.Schema.Context ( Interpretation, Col )

26+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )

27+import Rel8.Schema.HTable ( HTable, hmap )

28+import Rel8.Schema.Kind ( Context )

29+

30+

31+type Reify :: Context -> Context

32+data Reify context a

33+

34+

35+instance Interpretation (Reify context) where

36+ newtype Col (Reify context) spec = Reify (Col context spec)

37+

38+

39+instance Labelable context => Labelable (Reify context) where

40+ labeler (Reify a) = Reify (labeler a)

41+ unlabeler (Reify a) = Reify (unlabeler a)

42+

43+

44+hreify :: HTable t => t (Col context) -> t (Col (Reify context))

45+hreify = hmap Reify

46+

47+

48+hunreify :: HTable t => t (Col (Reify context)) -> t (Col context)

49+hunreify = hmap (\(Reify a) -> a)

50+

51+

52+type UnwrapReify :: Context -> Context

53+type family UnwrapReify context where

54+ UnwrapReify (Reify context) = context

55+

56+

57+type IsReify :: Context -> Bool

58+type family IsReify context where

59+ IsReify (Reify _) = 'True

60+ IsReify _ = 'False

61+

62+

63+type NotReify :: Context -> Constraint

64+class IsReify context ~ 'False => NotReify context

65+instance IsReify context ~ 'False => NotReify context

66+

67+

68+notReify :: forall context ctx a. NotReify context => context :~: Reify ctx -> a

69+notReify refl = case lemma @context of

70+ Refl -> case refl of

71+

72+

73+lemma :: NotReify context => IsReify context :~: 'False

74+lemma = Refl

src/Rel8/Schema/Result.hs+41−20

@@ -5,50 +5,71 @@

5{-# language TypeFamilies #-}

7module Rel8.Schema.Result

8− ( Result

8+ ( Col( Result ), Result

9+ , relabel

9 , null, nullifier, unnullifier

10 , null, nullifier, unnullifier

10 , vectorizer, unvectorizer

11 , vectorizer, unvectorizer

11 )

12 )

12where

13where

14-- base

15-- base

15−import Data.Functor.Identity ( Identity( Identity), runIdentity )

16import Prelude hiding ( null )

18-- rel8

19+import Rel8.Schema.Context ( Interpretation( Col ) )

20+import Rel8.Schema.HTable.Identity ( HIdentity(..) )

19import Rel8.Schema.Kind ( Context )

21import Rel8.Schema.Kind ( Context )

20import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )

22import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )

21−import Rel8.Schema.Spec ( Spec(..) )

23+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

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.

28type Result :: Context

26type Result :: Context

29−type Result = Identity

27+data Result a

32−null :: Result (Maybe a)

30+instance Interpretation Result where

33−null = Identity Nothing

31+ data Col Result _spec where

32+ Result :: a -> Col Result ('Spec labels necessity a)

36−nullifier :: Spec a -> Result a -> Result (Nullify a)

35+relabel :: ()

36+ => HIdentity ('Spec labels necessity a) (Col Result)

37+ -> HIdentity ('Spec relabels necessity a) (Col Result)

38+relabel (HIdentity (Result a)) = HIdentity (Result a)

39+

40+

41+null :: Col Result ('Spec labels necessity (Maybe a))

42+null = Result Nothing

43+

44+

45+nullifier :: ()

46+ => SSpec ('Spec labels necessity a)

47+ -> Col Result ('Spec labels necessity a)

48+ -> Col Result ('Spec labels necessity (Nullify a))

37−nullifier Spec {nullity} (Identity a) = Identity $ case nullity of

49+nullifier SSpec {nullity} (Result a) = Result $ case nullity of

38 Null -> a

50 Null -> a

39 NotNull -> Just a

51 NotNull -> Just a

42−unnullifier :: Spec a -> Result (Nullify a) -> Maybe (Result a)

54+unnullifier :: ()

55+ => SSpec ('Spec labels necessity a)

56+ -> Col Result ('Spec labels necessity (Nullify a))

57+ -> Maybe (Col Result ('Spec labels necessity a))

43−unnullifier Spec {nullity} (Identity a) =

58+unnullifier SSpec {nullity} (Result a) =

44 case nullity of

59 case nullity of

45− Null -> pure $ Identity a

60+ Null -> pure $ Result a

46− NotNull -> Identity <$> a

61+ NotNull -> Result <$> a

49−vectorizer :: Functor f => Spec a -> f (Result a) -> Result (f a)

64+vectorizer :: Functor f

65+ => SSpec ('Spec labels necessity a)

66+ -> f (Col Result ('Spec labels necessity a))

67+ -> Col Result ('Spec labels necessity (f a))

50−vectorizer _ = Identity . fmap runIdentity

68+vectorizer _ = Result . fmap (\(Result a) -> a)

53−unvectorizer :: Functor f => Spec a -> Result (f a) -> f (Result a)

71+unvectorizer :: Functor f

72+ => SSpec ('Spec labels necessity a)

73+ -> Col Result ('Spec labels necessity (f a))

74+ -> f (Col Result ('Spec labels necessity a))

54−unvectorizer _ (Identity results) = Identity <$> results

75+unvectorizer _ (Result results) = Result <$> results

src/Rel8/Schema/Spec.hs+45−17

@@ -1,34 +1,62 @@

1+{-# language DataKinds #-}

1{-# language FlexibleContexts #-}

2{-# language FlexibleContexts #-}

2−{-# language MonoLocalBinds #-}

3+{-# language GADTs #-}

3{-# language StandaloneKindSignatures #-}

4{-# language StandaloneKindSignatures #-}

5+{-# language UndecidableInstances #-}

5module Rel8.Schema.Spec

7module Rel8.Schema.Spec

8+ ( Spec( Spec )

6− ( Spec( Spec, labels, info, nullity )

9+ , SSpec( SSpec, labels, necessity, info, nullity )

7− , specification

10+ , KnownSpec( specSing )

8 )

11 )

9where

12where

11-- base

14-- base

12−import Data.Kind ( Type )

15+import Data.Kind ( Constraint, Type )

13−import Prelude

16+import Prelude ()

15-- rel8

18-- rel8

19+import Rel8.Kind.Labels ( Labels, SLabels, KnownLabels, labelsSing )

20+import Rel8.Kind.Necessity

21+ ( Necessity

22+ , SNecessity

23+ , KnownNecessity, necessitySing

24+ )

16import Rel8.Schema.Null ( Nullity, Sql, Unnullify, nullable )

25import Rel8.Schema.Null ( Nullity, Sql, Unnullify, nullable )

17import Rel8.Type ( DBType, typeInformation )

26import Rel8.Type ( DBType, typeInformation )

18import Rel8.Type.Information ( TypeInformation )

27import Rel8.Type.Information ( TypeInformation )

21−type Spec :: Type -> Type

30+type Spec :: Type

22−data Spec a = Spec

31+data Spec = Spec Labels Necessity Type

23− { labels :: [String]

32+

33+

34+type SSpec :: Spec -> Type

35+data SSpec spec where

36+ SSpec ::

37+ { labels :: SLabels labels

38+ , necessity :: SNecessity necessity

24− , info :: TypeInformation (Unnullify a)

39+ , info :: TypeInformation (Unnullify a)

25− , nullity :: Nullity a

40+ , nullity :: Nullity a

26− }

41+ }

42+ -> SSpec ('Spec labels necessity a)

45+type KnownSpec :: Spec -> Constraint

46+class KnownSpec spec where

47+ specSing :: SSpec spec

48+

49+

50+instance

51+ ( KnownLabels labels

52+ , KnownNecessity necessity

29−specification :: Sql DBType a => Spec a

53+ , Sql DBType a

30−specification = Spec

54+ )

55+ => KnownSpec ('Spec labels necessity a)

56+ where

57+ specSing = SSpec

31− { labels = []

58+ { labels = labelsSing

59+ , necessity = necessitySing

32− , info = typeInformation

60+ , info = typeInformation

33− , nullity = nullable

61+ , nullity = nullable

34− }

62+ }

src/Rel8/Schema/Spec/ConstrainDBType.hsnew file+89

@@ -0,0 +1,89 @@

1+{-# language ConstraintKinds #-}

2+{-# language DataKinds #-}

3+{-# language FlexibleInstances #-}

4+{-# language MultiParamTypeClasses #-}

5+{-# language NamedFieldPuns #-}

6+{-# language QuantifiedConstraints #-}

7+{-# language StandaloneKindSignatures #-}

8+{-# language TypeFamilies #-}

9+{-# language UndecidableInstances #-}

10+

11+module Rel8.Schema.Spec.ConstrainDBType

12+ ( ConstrainDBType

13+ , dbTypeNullity, dbTypeDict

14+ , nullifier, unnullifier

15+ )

16+where

17+

18+-- base

19+import Data.Kind ( Constraint, Type )

20+import Prelude

21+

22+-- rel8

23+import Rel8.Schema.Dict ( Dict( Dict ) )

24+import Rel8.Schema.Null

25+ ( Nullify, Unnullify

26+ , Nullity( Null, NotNull )

27+ , Sql, nullable

28+ )

29+import Rel8.Schema.Spec ( Spec( Spec ), SSpec( SSpec, nullity ) )

30+

31+

32+type ConstrainDBType :: (Type -> Constraint) -> Spec -> Constraint

33+class

34+ ( forall c labels necessity a. ()

35+ => (spec ~ 'Spec labels necessity a)

36+ => (forall x. (constraint x => c x)) => Sql c a

37+ )

38+ => ConstrainDBType constraint spec

39+instance

40+ ( spec ~ 'Spec labels necessity a

41+ , Sql constraint a

42+ )

43+ => ConstrainDBType constraint spec

44+

45+

46+dbTypeNullity :: Dict (ConstrainDBType c) ('Spec l n a) -> Nullity a

47+dbTypeNullity = step2 . step1

48+ where

49+ step1 :: Dict (ConstrainDBType c) ('Spec l n a) -> Dict (Sql c) a

50+ step1 Dict = Dict

51+

52+ step2 :: Dict (Sql c) a -> Nullity a

53+ step2 Dict = nullable

54+

55+

56+dbTypeDict :: Dict (ConstrainDBType c) ('Spec l n a) -> Dict c (Unnullify a)

57+dbTypeDict = step2 . step1

58+ where

59+ step1 :: Dict (ConstrainDBType c) ('Spec l n a) -> Dict (Sql c) a

60+ step1 Dict = Dict

61+

62+ step2 :: Dict (Sql c) a -> Dict c (Unnullify a)

63+ step2 Dict = Dict

64+

65+

66+fromNullityDict :: Nullity a -> Dict c (Unnullify a) -> Dict (ConstrainDBType c) ('Spec l n a)

67+fromNullityDict Null Dict = Dict

68+fromNullityDict NotNull Dict = Dict

69+

70+

71+nullifier :: ()

72+ => SSpec ('Spec labels necessity a)

73+ -> Dict (ConstrainDBType c) ('Spec labels necessity a)

74+ -> Dict (ConstrainDBType c) ('Spec labels necessity (Nullify a))

75+nullifier SSpec {} dict = case dbTypeDict dict of

76+ Dict -> case dbTypeNullity dict of

77+ Null -> Dict

78+ NotNull -> Dict

79+

80+

81+unnullifier :: ()

82+ => SSpec ('Spec labels necessity a)

83+ -> Dict (ConstrainDBType c) ('Spec labels necessity (Nullify a))

84+ -> Dict (ConstrainDBType c) ('Spec labels necessity a)

85+unnullifier SSpec {nullity} dict = case dbTypeDict dict of

86+ Dict -> case nullity of

87+ Null -> Dict

88+ NotNull -> case dbTypeNullity dict of

89+ Null -> fromNullityDict nullity Dict

src/Rel8/Schema/Spec/ConstrainType.hsnew file+31

@@ -0,0 +1,31 @@

1+{-# language ConstraintKinds #-}

2+{-# language DataKinds #-}

3+{-# language FlexibleInstances #-}

4+{-# language MultiParamTypeClasses #-}

5+{-# language QuantifiedConstraints #-}

6+{-# language StandaloneKindSignatures #-}

7+{-# language TypeFamilies #-}

8+{-# language UndecidableInstances #-}

10+module Rel8.Schema.Spec.ConstrainType

11+ ( ConstrainType

12+ )

13+where

14+

15+-- base

16+import Data.Kind ( Constraint, Type )

17+import Prelude ()

18+

19+-- rel8

20+import Rel8.Schema.Spec ( Spec( Spec ) )

21+

22+

23+type ConstrainType :: (Type -> Constraint) -> Spec -> Constraint

24+class

25+ ( forall labels necessity a. ()

26+ => (spec ~ 'Spec labels necessity a)

27+ => constraint a

28+ ) =>

29+ ConstrainType constraint spec

30+instance (spec ~ 'Spec labels necessity a, constraint a) =>

31+ ConstrainType constraint spec

src/Rel8/Schema/Table.hs−20

@@ -1,26 +1,14 @@

1{-# language DeriveFunctor #-}

2{-# language DerivingStrategies #-}

3−{-# language DisambiguateRecordFields #-}

4−{-# language NamedFieldPuns #-}

5−{-# language StandaloneKindSignatures #-}

7module Rel8.Schema.Table

4module Rel8.Schema.Table

8 ( TableSchema(..)

5 ( TableSchema(..)

9− , ppTable

10 )

6 )

11where

7where

13-- base

9-- base

14−import Data.Kind ( Type )

15import Prelude

10import Prelude

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−

25-- | The schema for a table. This is used to specify the name and schema that a

13-- | The schema for a table. This is used to specify the name and schema that a

26-- table belongs to (the @FROM@ part of a SQL query), along with the schema of

14-- table belongs to (the @FROM@ part of a SQL query), along with the schema of

@@ -28,7 +16,6 @@ import Text.PrettyPrint ( Doc )

28--

16--

29-- For each selectable table in your database, you should provide a

17-- For each selectable table in your database, you should provide a

30-- @TableSchema@ in order to interact with the table via Rel8.

18-- @TableSchema@ in order to interact with the table via Rel8.

31−type TableSchema :: Type -> Type

32data TableSchema names = TableSchema

19data TableSchema names = TableSchema

33 { name :: String

20 { name :: String

34 -- ^ The name of the table.

21 -- ^ The name of the table.

@@ -40,10 +27,3 @@ data TableSchema names = TableSchema

40 -- data type here, parameterized by the 'Rel8.ColumnSchema.ColumnSchema' functor.

27 -- data type here, parameterized by the 'Rel8.ColumnSchema.ColumnSchema' functor.

41 }

28 }

42 deriving stock Functor

29 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+48−35

@@ -1,37 +1,40 @@

1{-# language DuplicateRecordFields #-}

2{-# language GADTs #-}

3{-# language NamedFieldPuns #-}

4−{-# language RankNTypes #-}

4+{-# language ScopedTypeVariables #-}

5−{-# language RecordWildCards #-}

6{-# language StandaloneKindSignatures #-}

5{-# language StandaloneKindSignatures #-}

7−{-# language StrictData #-}

6+{-# language TypeApplications #-}

9module Rel8.Statement.Delete

8module Rel8.Statement.Delete

10 ( Delete(..)

9 ( Delete(..)

11 , delete

10 , delete

12− , ppDelete

13 )

11 )

14where

12where

16-- base

14-- base

15+import Control.Exception ( throwIO )

17import Data.Kind ( Type )

16import Data.Kind ( Type )

18import Prelude

17import Prelude

20-- hasql

19-- hasql

20+import Hasql.Connection ( Connection )

21+import qualified Hasql.Decoders as Hasql

21import qualified Hasql.Encoders as Hasql

22import qualified Hasql.Encoders as Hasql

23+import qualified Hasql.Session as Hasql

22import qualified Hasql.Statement as Hasql

24import qualified Hasql.Statement as Hasql

24−-- pretty

26+-- opaleye

25−import Text.PrettyPrint ( Doc, (<+>), ($$), text )

27+import qualified Opaleye.Internal.Manipulation as Opaleye

27-- rel8

29-- rel8

28import Rel8.Expr ( Expr )

30import Rel8.Expr ( Expr )

29−import Rel8.Query ( Query )

31+import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )

30import Rel8.Schema.Name ( Selects )

32import Rel8.Schema.Name ( Selects )

31−import Rel8.Schema.Table ( TableSchema, ppTable )

33+import Rel8.Schema.Table ( TableSchema )

32−import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )

34+import Rel8.Statement.Returning ( Returning( NumberOfRowsAffected, Projection ) )

33−import Rel8.Statement.Using ( ppUsing )

35+import Rel8.Table ( fromColumns, toColumns )

34−import Rel8.Statement.Where ( ppWhere )

36+import Rel8.Table.Opaleye ( castTable, table, unpackspec )

37+import Rel8.Table.Serialize ( Serializable, parse )

36-- text

39-- text

37import qualified Data.Text as Text

40import qualified Data.Text as Text

@@ -44,10 +47,7 @@ data Delete a where

44 Delete :: Selects names exprs =>

47 Delete :: Selects names exprs =>

45 { from :: TableSchema names

48 { from :: TableSchema names

46 -- ^ Which table to delete from.

49 -- ^ Which table to delete from.

47− , using :: Query using

48− -- ^ @USING@ clause — this can be used to join against other tables,

49− -- and its results can be referenced in the @WHERE@ clause

50− , deleteWhere :: using -> exprs -> Expr Bool

50+ , deleteWhere :: exprs -> Expr Bool

51 -- ^ Which rows should be selected for deletion.

52 , returning :: Returning names a

53 -- ^ What to return from the @DELETE@ statement.

@@ -55,25 +55,38 @@ data Delete a where

55 -> Delete a

58−ppDelete :: Delete a -> Doc

58+-- | Run a @DELETE@ statement.

59−ppDelete Delete {..} = case ppUsing using of

59+delete :: Connection -> Delete a -> IO a

60− Nothing ->

60+delete c Delete {from, deleteWhere, returning} =

61− text "DELETE FROM" <+> ppTable from $$

61+ case returning of

62− text "WHERE false"

62+ NumberOfRowsAffected -> Hasql.run session c >>= either throwIO pure

63− Just (usingDoc, i) ->

63+ where

64− text "DELETE FROM" <+> ppTable from $$

64+ session = Hasql.statement () statement

65− usingDoc $$

65+ statement = Hasql.Statement bytes params decode prepare

66− ppWhere from (deleteWhere i) $$

66+ bytes = encodeUtf8 $ Text.pack sql

67− ppReturning from returning

67+ params = Hasql.noParams

68+ decode = Hasql.rowsAffected

69+ prepare = False

70+ sql = Opaleye.arrangeDeleteSql from' where'

71+ where

72+ from' = table $ toColumns <$> from

73+ where' = toColumn . toPrimExpr . deleteWhere . fromColumns

69−

75+ Projection project -> Hasql.run session c >>= either throwIO pure

70−-- | Run a 'Delete' statement.

76+ where

71−delete :: Delete a -> Hasql.Statement () a

77+ session = Hasql.statement () statement

72−delete d@Delete {returning} = Hasql.Statement bytes params decode prepare

78+ statement = Hasql.Statement bytes params decode prepare

79+ bytes = encodeUtf8 $ Text.pack sql

80+ params = Hasql.noParams

81+ decode = decoder project

82+ prepare = False

83+ sql =

84+ Opaleye.arrangeDeleteReturningSql unpackspec from' where' project'

85+ where

86+ from' = table $ toColumns <$> from

87+ where' = toColumn . toPrimExpr . deleteWhere . fromColumns

88+ project' = castTable . toColumns . project . fromColumns

73 where

89 where

74− bytes = encodeUtf8 $ Text.pack sql

90+ decoder :: forall exprs projection a. Serializable projection a

75− params = Hasql.noParams

91+ => (exprs -> projection) -> Hasql.Result [a]

76− decode = decodeReturning returning

92+ decoder _ = Hasql.rowList (parse @projection @a)

77− prepare = False

78− sql = show doc

79− doc = ppDelete d

src/Rel8/Statement/Insert.hs+60−60

@@ -1,89 +1,89 @@

1−{-# language DuplicateRecordFields #-}

2−{-# language FlexibleContexts #-}

3{-# language GADTs #-}

1{-# language GADTs #-}

4{-# language NamedFieldPuns #-}

2{-# language NamedFieldPuns #-}

5−{-# language RecordWildCards #-}

3+{-# language ScopedTypeVariables #-}

6−{-# language StandaloneKindSignatures #-}

4+{-# language TypeApplications #-}

7−{-# language StrictData #-}

9module Rel8.Statement.Insert

6module Rel8.Statement.Insert

10 ( Insert(..)

7 ( Insert(..)

8+ , OnConflict(..)

11 , insert

9 , insert

12− , ppInsert

13− , ppInto

14 )

10 )

15where

11where

17-- base

13-- base

18−import Data.Foldable ( toList )

14+import Control.Exception ( throwIO )

19−import Data.Kind ( Type )

15+import Data.List.NonEmpty ( NonEmpty( (:|) ) )

20import Prelude

16import Prelude

22-- hasql

18-- hasql

19+import Hasql.Connection ( Connection )

20+import qualified Hasql.Decoders as Hasql

23import qualified Hasql.Encoders as Hasql

21import qualified Hasql.Encoders as Hasql

22+import qualified Hasql.Session as Hasql

24import qualified Hasql.Statement as Hasql

23import qualified Hasql.Statement as Hasql

26-- opaleye

25-- opaleye

27−import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye

26+import qualified Opaleye.Internal.Manipulation as Opaleye

28−

27+import qualified Opaleye.Manipulation as Opaleye

29−-- pretty

30−import Text.PrettyPrint ( Doc, (<+>), ($$), parens, text )

32-- rel8

29-- rel8

33−import Rel8.Query ( Query )

30+import Rel8.Schema.Insert ( Insert(..), OnConflict(..) )

34−import Rel8.Schema.Name ( Name, Selects, ppColumn )

35−import Rel8.Schema.Table ( TableSchema(..), ppTable )

36−import Rel8.Statement.OnConflict ( OnConflict, ppOnConflict )

37−import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )

31+import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) )

38−import Rel8.Statement.Select ( ppRows )

32+import Rel8.Table ( fromColumns, toColumns )

39−import Rel8.Table ( Table )

33+import Rel8.Table.Opaleye ( castTable, table, unpackspec )

40−import Rel8.Table.Name ( showNames )

34+import Rel8.Table.Serialize ( Serializable, parse )

42-- text

36-- text

43import qualified Data.Text as Text ( pack )

37import qualified Data.Text as Text ( pack )

44import Data.Text.Encoding ( encodeUtf8 )

38import Data.Text.Encoding ( encodeUtf8 )

47−-- | The constituent parts of a SQL @INSERT@ statement.

41+-- | Run an @INSERT@ statement

48−type Insert :: Type -> Type

42+insert :: Connection -> Insert a -> IO a

49−data Insert a where

43+insert c Insert {into, rows, onConflict, returning} =

50− Insert :: Selects names exprs =>

44+ case (rows, returning) of

51− { into :: TableSchema names

45+ ([], NumberOfRowsAffected) -> pure 0

52− -- ^ Which table to insert into.

46+ ([], Projection _) -> pure []

53− , rows :: Query exprs

54− -- ^ The rows to insert. This can be an arbitrary query — use

55− -- 'Rel8.values' insert a static list of rows.

56− , onConflict :: OnConflict names

57− -- ^ What to do if the inserted rows conflict with data already in the

58− -- table.

59− , returning :: Returning names a

60− -- ^ What information to return on completion.

61− }

62− -> Insert a

63−

64−

65−ppInsert :: Insert a -> Doc

66−ppInsert Insert {..} =

67− text "INSERT INTO" <+>

68− ppInto into $$

69− ppRows rows $$

70− ppOnConflict into onConflict $$

71− ppReturning into returning

48+ (x:xs, NumberOfRowsAffected) -> Hasql.run session c >>= either throwIO pure

49+ where

50+ session = Hasql.statement () statement

51+ statement = Hasql.Statement bytes params decode prepare

52+ bytes = encodeUtf8 $ Text.pack sql

53+ params = Hasql.noParams

54+ decode = Hasql.rowsAffected

55+ prepare = False

56+ sql = Opaleye.arrangeInsertManySql into' rows' onConflict'

57+ where

58+ into' = table $ toColumns <$> into

59+ rows' = toColumns <$> x :| xs

74−ppInto :: Table Name a => TableSchema a -> Doc

61+ (x:xs, Projection project) -> Hasql.run session c >>= either throwIO pure

75−ppInto table@TableSchema {columns} =

62+ where

76− ppTable table <+>

63+ session = Hasql.statement () statement

77− parens (Opaleye.commaV ppColumn (toList (showNames columns)))

64+ statement = Hasql.Statement bytes params decode prepare

65+ bytes = encodeUtf8 $ Text.pack sql

66+ params = Hasql.noParams

67+ decode = decoder project

68+ prepare = False

69+ sql =

70+ Opaleye.arrangeInsertManyReturningSql

71+ unpackspec

72+ into'

73+ rows'

74+ project'

75+ onConflict'

76+ where

77+ into' = table $ toColumns <$> into

78+ rows' = toColumns <$> x :| xs

79+ project' = castTable . toColumns . project . fromColumns

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

81 where

84− bytes = encodeUtf8 $ Text.pack sql

82+ onConflict' =

85− params = Hasql.noParams

83+ case onConflict of

86− decode = decodeReturning returning

84+ DoNothing -> Just Opaleye.DoNothing

87− prepare = False

85+ Abort -> Nothing

88− sql = show doc

86+

89− doc = ppInsert i

87+ decoder :: forall exprs projection a. Serializable projection a

88+ => (exprs -> projection) -> Hasql.Result [a]

89+ decoder _ = Hasql.rowList (parse @projection @a)

src/Rel8/Statement/OnConflict.hsdeleted−106

@@ -1,106 +0,0 @@

1−{-# language DuplicateRecordFields #-}

2−{-# language FlexibleContexts #-}

3−{-# language GADTs #-}

4−{-# language LambdaCase #-}

5−{-# language NamedFieldPuns #-}

6−{-# language RecordWildCards #-}

7−{-# language StandaloneKindSignatures #-}

8−{-# language StrictData #-}

9−

10−module Rel8.Statement.OnConflict

11− ( OnConflict(..)

12− , Upsert(..)

13− , ppOnConflict

14− )

15−where

16−

17−-- base

18−import Data.Foldable ( toList )

19−import Data.Kind ( Type )

20−import Prelude

21−

22−-- opaleye

23−import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye

24−

25−-- pretty

26−import Text.PrettyPrint ( Doc, (<+>), ($$), parens, text )

27−

28−-- rel8

29−import Rel8.Expr ( Expr )

30−import Rel8.Schema.Name ( Name, Selects, ppColumn )

31−import Rel8.Schema.Table ( TableSchema(..) )

32−import Rel8.Statement.Set ( ppSet )

33−import Rel8.Statement.Where ( ppWhere )

34−import Rel8.Table ( Table, toColumns )

35−import Rel8.Table.Cols ( Cols( Cols ) )

36−import Rel8.Table.Name ( showNames )

37−import Rel8.Table.Opaleye ( attributes )

38−import Rel8.Table.Projection ( Projecting, Projection, apply )

39−

40−

41−-- | 'OnConflict' represents the @ON CONFLICT@ clause of an @INSERT@

42−-- statement. This specifies what ought to happen when one or more of the

43−-- rows proposed for insertion conflict with an existing row in the table.

44−type OnConflict :: Type -> Type

45−data OnConflict names

46− = Abort

47− -- ^ Abort the transaction if there are conflicting rows (Postgres' default)

48− | DoNothing

49− -- ^ @ON CONFLICT DO NOTHING@

50− | DoUpdate (Upsert names)

51− -- ^ @ON CONFLICT DO UPDATE@

52−

53−

54−-- | The @ON CONFLICT (...) DO UPDATE@ clause of an @INSERT@ statement, also

55−-- known as \"upsert\".

56−--

57−-- When an existing row conflicts with a row proposed for insertion,

58−-- @ON CONFLICT DO UPDATE@ allows you to instead update this existing row. The

59−-- conflicting row proposed for insertion is then \"excluded\", but its values

60−-- can still be referenced from the @SET@ and @WHERE@ clauses of the @UPDATE@

61−-- statement.

62−--

63−-- Upsert in Postgres requires an explicit set of \"conflict targets\" — the

64−-- set of columns comprising the @UNIQUE@ index from conflicts with which we

65−-- would like to recover.

66−type Upsert :: Type -> Type

67−data Upsert names where

68− Upsert :: (Selects names exprs, Projecting names index, excluded ~ exprs) =>

69− { index :: Projection names index

70− -- ^ The set of conflict targets, projected from the set of columns for

71− -- the whole table

72− , set :: excluded -> exprs -> exprs

73− -- ^ How to update each selected row.

74− , updateWhere :: excluded -> exprs -> Expr Bool

75− -- ^ Which rows to select for update.

76− }

77− -> Upsert names

78−

79−

80−ppOnConflict :: TableSchema names -> OnConflict names -> Doc

81−ppOnConflict schema = \case

82− Abort -> mempty

83− DoNothing -> text "ON CONFLICT DO NOTHING"

84− DoUpdate upsert -> ppUpsert schema upsert

85−

86−

87−ppUpsert :: TableSchema names -> Upsert names -> Doc

88−ppUpsert schema@TableSchema {columns} Upsert {..} =

89− text "ON CONFLICT" <+>

90− ppIndex schema index <+>

91− text "DO UPDATE" $$

92− ppSet schema (set excluded) $$

93− ppWhere schema (updateWhere excluded)

94− where

95− excluded = attributes TableSchema

96− { schema = Nothing

97− , name = "excluded"

98− , columns

99− }

100−

101−

102−ppIndex :: (Table Name names, Projecting names index)

103− => TableSchema names -> Projection names index -> Doc

104−ppIndex TableSchema {columns} index =

105− parens $ Opaleye.commaV ppColumn $ toList $

106− showNames $ Cols $ apply index $ toColumns columns

src/Rel8/Statement/Returning.hs+10−114

@@ -1,133 +1,29 @@

1{-# language GADTs #-}

2−{-# language LambdaCase #-}

3−{-# language NamedFieldPuns #-}

4−{-# language RankNTypes #-}

5−{-# language ScopedTypeVariables #-}

6{-# language StandaloneKindSignatures #-}

2{-# language StandaloneKindSignatures #-}

7−{-# language StrictData #-}

8−{-# language TypeApplications #-}

10module Rel8.Statement.Returning

4module Rel8.Statement.Returning

11− ( Returning( NumberOfRowsAffected, Projection )

5+ ( Returning(..)

12− , decodeReturning

13− , ppReturning

14 )

6 )

15where

7where

17-- base

9-- base

18−import Control.Applicative ( liftA2 )

19−import Data.Foldable ( toList )

20import Data.Int ( Int64 )

10import Data.Int ( Int64 )

21import Data.Kind ( Type )

11import Data.Kind ( Type )

22−import Data.List.NonEmpty ( NonEmpty )

23−import Prelude

12+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 )

36-- rel8

14-- rel8

37import Rel8.Schema.Name ( Selects )

15import Rel8.Schema.Name ( Selects )

38−import Rel8.Schema.Table ( TableSchema(..) )

39−import Rel8.Table.Opaleye ( castTable, exprs, view )

40−import Rel8.Table.Serialize ( Serializable, parse )

16+import Rel8.Table.Serialize ( Serializable )

42−-- semigropuoids

43−import Data.Functor.Apply ( Apply, (<.>) )

45−

46−-- | 'Rel8.Insert', 'Rel8.Update' and 'Rel8.Delete' all support returning either

19+-- | @INSERT@, @UPDATE@ and @DELETE@ all support returning either the number of

47−-- the number of rows affected, or the actual rows modified.

20+-- rows affected, or the actual rows modified. 'Projection' allows you to

21+-- project out of these returned rows, which can be useful if you want to log

22+-- exactly which rows were deleted, or to view a generated id (for example, if

23+-- using a column with an autoincrementing counter as a default value).

48type Returning :: Type -> Type -> Type

24type Returning :: Type -> Type -> Type

49data Returning names a where

25data Returning names a where

50− Pure :: a -> Returning names a

51− Ap :: Returning names (a -> b) -> Returning names a -> Returning names b

52−

53− -- | Return the number of rows affected.

54 NumberOfRowsAffected :: Returning names Int64

26 NumberOfRowsAffected :: Returning names Int64

55−

56− -- | 'Projection' allows you to project out of the affected rows, which can

57− -- be useful if you want to log exactly which rows were deleted, or to view

58− -- a generated id (for example, if using a column with an autoincrementing

59− -- counter via 'Rel8.nextval').

60− Projection :: (Selects names exprs, Serializable returning a)

27+ Projection :: (Selects names exprs, Serializable projection a)

61− => (exprs -> returning)

28+ => (exprs -> projection)

62 -> Returning names [a]

29 -> Returning names [a]

63−

64−

65−instance Functor (Returning names) where

66− fmap f = \case

67− Pure a -> Pure (f a)

68− Ap g a -> Ap (fmap (f .) g) a

69− m -> Ap (Pure f) m

70−

71−

72−instance Apply (Returning names) where

73− (<.>) = Ap

74−

75−

76−instance Applicative (Returning names) where

77− pure = Pure

78− (<*>) = Ap

79−

80−

81−projections :: ()

82− => TableSchema names -> Returning names a -> Maybe (NonEmpty Opaleye.PrimExpr)

83−projections schema@TableSchema {columns} = \case

84− Pure _ -> Nothing

85− Ap f a -> projections schema f <> projections schema a

86− NumberOfRowsAffected -> Nothing

87− Projection f -> Just (exprs (castTable (f (view columns))))

88−

89−

90−runReturning :: ()

91− => ((Int64 -> a) -> r)

92− -> (forall x. Hasql.Row x -> ([x] -> a) -> r)

93− -> Returning names a

94− -> r

95−runReturning rowCount rowList = \case

96− Pure a -> rowCount (const a)

97− Ap fs as ->

98− runReturning

99− (\withCount ->

100− runReturning

101− (\withCount' -> rowCount (withCount <*> withCount'))

102− (\decoder -> rowList decoder . liftA2 withCount length64)

103− as)

104− (\decoder withRows ->

105− runReturning

106− (\withCount -> rowList decoder $ withRows <*> withCount . length64)

107− (\decoder' withRows' ->

108− rowList (liftA2 (,) decoder decoder') $

109− withRows <$> fmap fst <*> withRows' . fmap snd)

110− as)

111− fs

112− NumberOfRowsAffected -> rowCount id

113− Projection (_ :: exprs -> returning) -> rowList decoder' id

114− where

115− decoder' = parse @returning

116− where

117− length64 :: Foldable f => f x -> Int64

118− length64 = fromIntegral . length

119−

120−

121−decodeReturning :: Returning names a -> Hasql.Result a

122−decodeReturning = runReturning

123− (<$> Hasql.rowsAffected)

124− (\decoder withRows -> withRows <$> Hasql.rowList decoder)

125−

126−

127−ppReturning :: TableSchema names -> Returning names a -> Doc

128−ppReturning schema returning = case projections schema returning of

129− Nothing -> mempty

130− Just columns ->

131− text "RETURNING" <+> Opaleye.commaV Opaleye.ppSqlExpr (toList sqlExprs)

132− where

133− sqlExprs = Opaleye.sqlExpr <$> columns

src/Rel8/Statement/SQL.hsdeleted−29

@@ -1,29 +0,0 @@

1−module Rel8.Statement.SQL

2− ( showDelete

3− , showInsert

4− , showUpdate

5− )

6−where

7−

8−-- base

9−import Prelude

10−

11−-- rel8

12−import Rel8.Statement.Delete ( Delete, ppDelete )

13−import Rel8.Statement.Insert ( Insert, ppInsert )

14−import Rel8.Statement.Update ( Update, ppUpdate )

15−

16−

17−-- | Convert a 'Delete' to a 'String' containing a @DELETE@ statement.

18−showDelete :: Delete a -> String

19−showDelete = show . ppDelete

20−

21−

22−-- | Convert an 'Insert' to a 'String' containing an @INSERT@ statement.

23−showInsert :: Insert a -> String

24−showInsert = show . ppInsert

25−

26−

27−-- | Convert an 'Update' to a 'String' containing an @UPDATE@ statement.

28−showUpdate :: Update a -> String

29−showUpdate = show . ppUpdate

src/Rel8/Statement/Select.hs+35−120

@@ -1,147 +1,62 @@

1−{-# language DeriveTraversable #-}

2−{-# language DerivingStrategies #-}

3−{-# language FlexibleContexts #-}

4{-# language MonoLocalBinds #-}

1{-# language MonoLocalBinds #-}

5{-# language ScopedTypeVariables #-}

2{-# language ScopedTypeVariables #-}

6−{-# language StandaloneKindSignatures #-}

7{-# language TypeApplications #-}

3{-# language TypeApplications #-}

9module Rel8.Statement.Select

5module Rel8.Statement.Select

10 ( select

6 ( select

11− , ppSelect

7+ , selectWithNames

12−

13− , Optimized(..)

14− , ppPrimSelect

15− , ppRows

16 )

8 )

17where

9where

19-- base

11-- base

20−import Data.Foldable ( toList )

12+import Control.Exception ( throwIO )

21−import Data.Kind ( Type )

22−import Data.Void ( Void )

23−import Prelude hiding ( undefined )

13+import Prelude

25-- hasql

15-- hasql

16+import Hasql.Connection ( Connection )

26import qualified Hasql.Decoders as Hasql

17import qualified Hasql.Decoders as Hasql

27import qualified Hasql.Encoders as Hasql

18import qualified Hasql.Encoders as Hasql

19+import qualified Hasql.Session as Hasql

28import qualified Hasql.Statement as Hasql

20import qualified Hasql.Statement as Hasql

30−-- opaleye

31−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

32−import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye

33−import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye

34−import qualified Opaleye.Internal.PrimQuery as Opaleye

35−import qualified Opaleye.Internal.Print as Opaleye

36−import qualified Opaleye.Internal.Optimize as Opaleye

37−import qualified Opaleye.Internal.QueryArr as Opaleye hiding ( Select )

38−import qualified Opaleye.Internal.Sql as Opaleye hiding ( Values )

39−import qualified Opaleye.Internal.Tag as Opaleye

40−

41−-- pretty

42−import Text.PrettyPrint ( Doc )

43−

44-- rel8

22-- rel8

45−import Rel8.Expr ( Expr )

46−import Rel8.Expr.Bool ( false )

47−import Rel8.Expr.Opaleye ( toPrimExpr )

48import Rel8.Query ( Query )

23import Rel8.Query ( Query )

49−import Rel8.Query.Opaleye ( toOpaleye )

24+import Rel8.Query.SQL ( sqlForQuery, sqlForQueryWithNames )

50import Rel8.Schema.Name ( Selects )

25import 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

56import Rel8.Table.Serialize ( Serializable, parse )

26import Rel8.Table.Serialize ( Serializable, parse )

57−import Rel8.Table.Undefined ( undefined )

59-- text

28-- text

60import qualified Data.Text as Text

29import qualified Data.Text as Text

61import Data.Text.Encoding ( encodeUtf8 )

30import Data.Text.Encoding ( encodeUtf8 )

64−-- | Run a @SELECT@ statement, returning all rows.

33+-- | Run a @SELECT@ query, returning all rows.

65select :: forall exprs a. Serializable exprs a

34select :: forall exprs a. Serializable exprs a

66− => Query exprs -> Hasql.Statement () [a]

35+ => Connection -> Query exprs -> IO [a]

67−select query = Hasql.Statement bytes params decode prepare

36+select c query = case sqlForQuery query of

68− where

37+ Nothing -> pure []

69− bytes = encodeUtf8 (Text.pack sql)

38+ Just sql -> Hasql.run session c >>= either throwIO pure

70− params = Hasql.noParams

39+ where

71− decode = Hasql.rowList (parse @exprs @a)

40+ session = Hasql.statement () statement

72− prepare = False

41+ statement = Hasql.Statement bytes params decode prepare

73− sql = show doc

42+ bytes = encodeUtf8 (Text.pack sql)

74− doc = ppSelect query

43+ params = Hasql.noParams

75−

44+ decode = Hasql.rowList (parse @exprs @a)

76−

45+ prepare = False

77−ppSelect :: Table Expr a => Query a -> Doc

46+

78−ppSelect query =

47+

79− Opaleye.ppSql $ primSelectWith names (toCols exprs') primQuery'

48+selectWithNames :: forall exprs a names.

80− where

81− names = namesFromLabels

82− (exprs, primQuery, _) =

83− Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

84− (exprs', primQuery') = case optimize primQuery of

85− Empty -> (undefined, Opaleye.Product (pure (pure Opaleye.Unit)) never)

86− Unit -> (exprs, Opaleye.Unit)

87− Optimized pq -> (exprs, pq)

88− never = pure (toPrimExpr false)

89−

90−

91−ppRows :: Table Expr a => Query a -> Doc

92−ppRows query = case optimize primQuery of

93− -- Special case VALUES because we can't use DEFAULT inside a SELECT

94− Optimized (Opaleye.Values symbols rows)

95− | eqSymbols symbols (toList (T.exprs a)) ->

96− Opaleye.ppValues_ (map Opaleye.sqlExpr <$> toList rows)

97− _ -> ppSelect query

98− where

99− (a, primQuery, _) = Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

100−

101− eqSymbols (symbol : symbols) (Opaleye.AttrExpr symbol' : exprs)

102− | eqSymbol symbol symbol' = eqSymbols symbols exprs

103− | otherwise = False

104− eqSymbols [] [] = True

105− eqSymbols _ _ = False

106−

107− eqSymbol

108− (Opaleye.Symbol name (Opaleye.UnsafeTag tag))

109− (Opaleye.Symbol name' (Opaleye.UnsafeTag tag'))

110− = name == name' && tag == tag'

111−

112−

113−ppPrimSelect :: Query a -> (Optimized Doc, a)

114−ppPrimSelect query =

115− (Opaleye.ppSql . primSelect <$> optimize primQuery, a)

116− where

117− (a, primQuery, _) = Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

118−

119−

120−type Optimized :: Type -> Type

121−data Optimized a = Empty | Unit | Optimized a

122− deriving stock (Functor, Foldable, Traversable, Show)

123−

124−

125−optimize :: Opaleye.PrimQuery' a -> Optimized (Opaleye.PrimQuery' Void)

126−optimize query = case Opaleye.removeEmpty (Opaleye.optimize query) of

127− Nothing -> Empty

128− Just Opaleye.Unit -> Unit

129− Just query' -> Optimized query'

130−

131−

132−primSelect :: Opaleye.PrimQuery' Void -> Opaleye.Select

133−primSelect = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator

134−

135−

136−primSelectWith :: Selects names exprs

49+ ( Selects names exprs

137− => names -> exprs -> Opaleye.PrimQuery' Void -> Opaleye.Select

50+ , Serializable exprs a

138−primSelectWith names exprs query =

51+ )

139− Opaleye.SelectFrom $ Opaleye.newSelect

52+ => Connection -> names -> Query exprs -> IO [a]

140− { Opaleye.attrs = Opaleye.SelectAttrs attrs

53+selectWithNames c names query = case sqlForQueryWithNames names query of

141− , Opaleye.tables = Opaleye.oneTable (primSelect query)

54+ Nothing -> pure []

142− }

55+ Just sql -> Hasql.run session c >>= either throwIO pure

143− where

56+ where

144− attrs = makeAttr <$> exprsWithNames names (castTable exprs)

57+ session = Hasql.statement () statement

145− where

58+ statement = Hasql.Statement bytes params decode prepare

146− makeAttr (label, expr) =

59+ bytes = encodeUtf8 (Text.pack sql)

147− (Opaleye.sqlExpr expr, Just (Opaleye.SqlColumn label))

60+ params = Hasql.noParams

61+ decode = Hasql.rowList (parse @exprs @a)

62+ prepare = False

src/Rel8/Statement/Set.hsdeleted−33

@@ -1,33 +0,0 @@

1−{-# language MonoLocalBinds #-}

2−{-# language NamedFieldPuns #-}

3−

4−module Rel8.Statement.Set

5− ( ppSet

6− )

7−where

8−

9−-- base

10−import Data.Foldable ( toList )

11−import Prelude ()

12−

13−-- opaleye

14−import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye

15−import qualified Opaleye.Internal.Sql as Opaleye

16−

17−-- pretty

18−import Text.PrettyPrint ( Doc, (<+>), equals, text )

19−

20−-- rel8

21−import Rel8.Schema.Name ( Selects, ppColumn )

22−import Rel8.Schema.Table ( TableSchema(..) )

23−import Rel8.Table.Opaleye ( attributes, exprsWithNames )

24−

25−

26−ppSet :: Selects names exprs

27− => TableSchema names -> (exprs -> exprs) -> Doc

28−ppSet schema@TableSchema {columns} f =

29− text "SET" <+> Opaleye.commaV ppAssign (toList assigns)

30− where

31− assigns = exprsWithNames columns (f (attributes schema))

32− ppAssign (column, expr) =

33− ppColumn column <+> equals <+> Opaleye.ppSqlExpr (Opaleye.sqlExpr expr)

src/Rel8/Statement/Update.hs+60−38

@@ -1,37 +1,43 @@

1−{-# language DuplicateRecordFields #-}

2{-# language GADTs #-}

1{-# language GADTs #-}

3{-# language NamedFieldPuns #-}

2{-# language NamedFieldPuns #-}

4−{-# language RecordWildCards #-}

3+{-# language ScopedTypeVariables #-}

5{-# language StandaloneKindSignatures #-}

4{-# language StandaloneKindSignatures #-}

6−{-# language StrictData #-}

5+{-# language TypeApplications #-}

8module Rel8.Statement.Update

7module Rel8.Statement.Update

9 ( Update(..)

8 ( Update(..)

10 , update

9 , update

11− , ppUpdate

12 )

10 )

13where

11where

15-- base

13-- base

14+import Control.Exception ( throwIO )

16import Data.Kind ( Type )

15import Data.Kind ( Type )

17import Prelude

16import Prelude

19-- hasql

18-- hasql

19+import Hasql.Connection ( Connection )

20+import qualified Hasql.Decoders as Hasql

20import qualified Hasql.Encoders as Hasql

21import qualified Hasql.Encoders as Hasql

22+import qualified Hasql.Session as Hasql

21import qualified Hasql.Statement as Hasql

23import qualified Hasql.Statement as Hasql

23−-- pretty

25+-- opaleye

24−import Text.PrettyPrint ( Doc, (<+>), ($$), text )

26+import qualified Opaleye.Internal.Manipulation as Opaleye

27+

28+-- profunctors

29+import Data.Profunctor ( lmap )

26-- rel8

31-- rel8

27import Rel8.Expr ( Expr )

32import Rel8.Expr ( Expr )

28−import Rel8.Query ( Query )

33+import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )

29import Rel8.Schema.Name ( Selects )

34import Rel8.Schema.Name ( Selects )

30−import Rel8.Schema.Table ( TableSchema(..), ppTable )

35+import Rel8.Schema.Table ( TableSchema )

31−import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )

36+import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) )

32−import Rel8.Statement.Set ( ppSet )

37+import Rel8.Table ( fromColumns, toColumns )

33−import Rel8.Statement.Using ( ppFrom )

38+import Rel8.Table.Insert ( toInsert )

34−import Rel8.Statement.Where ( ppWhere )

39+import Rel8.Table.Opaleye ( castTable, table, unpackspec )

40+import Rel8.Table.Serialize ( Serializable, parse )

36-- text

42-- text

37import qualified Data.Text as Text

43import qualified Data.Text as Text

@@ -44,12 +50,9 @@ data Update a where

44 Update :: Selects names exprs =>

50 Update :: Selects names exprs =>

45 { target :: TableSchema names

51 { target :: TableSchema names

46 -- ^ Which table to update.

52 -- ^ Which table to update.

47− , from :: Query from

48− -- ^ @FROM@ clause — this can be used to join against other tables,

49− -- and its results can be referenced in the @SET@ and @WHERE@ clauses.

50− , set :: from -> exprs -> exprs

53+ , set :: exprs -> exprs

51 -- ^ How to update each selected row.

54 -- ^ How to update each selected row.

52− , updateWhere :: from -> exprs -> Expr Bool

55+ , updateWhere :: exprs -> Expr Bool

53 -- ^ Which rows to select for update.

56 -- ^ Which rows to select for update.

54 , returning :: Returning names a

57 , returning :: Returning names a

55 -- ^ What to return from the @UPDATE@ statement.

58 -- ^ What to return from the @UPDATE@ statement.

@@ -57,27 +60,46 @@ data Update a where

57 -> Update a

60 -> Update a

60−ppUpdate :: Update a -> Doc

63+-- | Run an @UPDATE@ statement.

61−ppUpdate Update {..} = case ppFrom from of

64+update :: Connection -> Update a -> IO a

62− Nothing ->

65+update c Update {target, set, updateWhere, returning} =

63− text "UPDATE" <+> ppTable target $$

66+ case returning of

64− ppSet target id $$

67+ NumberOfRowsAffected -> Hasql.run session c >>= either throwIO pure

65− text "WHERE false"

68+ where

66− Just (fromDoc, i) ->

69+ session = Hasql.statement () statement

67− text "UPDATE" <+> ppTable target $$

70+ statement = Hasql.Statement bytes params decode prepare

68− ppSet target (set i) $$

71+ bytes = encodeUtf8 $ Text.pack sql

69− fromDoc $$

72+ params = Hasql.noParams

70− ppWhere target (updateWhere i) $$

73+ decode = Hasql.rowsAffected

71− ppReturning target returning

74+ prepare = False

75+ sql = Opaleye.arrangeUpdateSql target' set' where'

76+ where

77+ target' = lmap toInsert $ table $ toColumns <$> target

78+ set' = toColumns . set . fromColumns

79+ where' = toColumn . toPrimExpr . updateWhere . fromColumns

81+ Projection project -> Hasql.run session c >>= either throwIO pure

82+ where

83+ session = Hasql.statement () statement

84+ statement = Hasql.Statement bytes params decode prepare

85+ bytes = encodeUtf8 $ Text.pack sql

86+ params = Hasql.noParams

87+ decode = decoder project

88+ prepare = False

89+ sql =

90+ Opaleye.arrangeUpdateReturningSql

91+ unpackspec

92+ target'

93+ set'

94+ where'

95+ project'

96+ where

97+ target' = lmap toInsert $ table $ toColumns <$> target

98+ set' = toColumns . set . fromColumns

99+ where' = toColumn . toPrimExpr . updateWhere . fromColumns

100+ project' = castTable . toColumns . project . fromColumns

101

74−-- | Run an @UPDATE@ statement.

75−update :: Update a -> Hasql.Statement () a

76−update u@Update {returning} = Hasql.Statement bytes params decode prepare

77 where

102 where

78− bytes = encodeUtf8 $ Text.pack sql

103+ decoder :: forall exprs projection a. Serializable projection a

79− params = Hasql.noParams

104+ => (exprs -> projection) -> Hasql.Result [a]

80− decode = decodeReturning returning

105+ decoder _ = Hasql.rowList (parse @projection @a)

81− prepare = False

82− sql = show doc

83− doc = ppUpdate u

src/Rel8/Statement/Using.hsdeleted−36

@@ -1,36 +0,0 @@

1−module Rel8.Statement.Using

2− ( ppFrom

3− , ppUsing

4− )

5−where

6−

7−-- base

8−import Prelude

9−

10−-- pretty

11−import Text.PrettyPrint ( Doc, (<+>), parens, text )

12−

13−-- rel8

14−import Rel8.Query ( Query )

15−import Rel8.Schema.Table ( TableSchema(..), ppTable )

16−import Rel8.Statement.Select ( Optimized(..), ppPrimSelect )

17−

18−

19−ppFrom :: Query a -> Maybe (Doc, a)

20−ppFrom = ppJoin "FROM"

21−

22−

23−ppUsing :: Query a -> Maybe (Doc, a)

24−ppUsing = ppJoin "USING"

25−

26−

27−ppJoin :: String -> Query a -> Maybe (Doc, a)

28−ppJoin clause join = do

29− doc <- case ofrom of

30− Empty -> Nothing

31− Unit -> Just mempty

32− Optimized doc -> Just $ text clause <+> parens doc <+> ppTable alias

33− pure (doc, a)

34− where

35− alias = TableSchema {name = "T1", schema = Nothing, columns = ()}

36− (ofrom, a) = ppPrimSelect join

src/Rel8/Statement/View.hs+28−43

@@ -3,76 +3,61 @@

4module Rel8.Statement.View

5 ( createView

6− , createOrReplaceView

7 )

6 )

8where

7where

10-- base

9-- base

10+import Control.Exception ( throwIO )

11+import Control.Monad ( (>=>) )

12+import Data.Foldable ( fold )

13+import Data.Maybe ( fromMaybe )

11import Prelude

14import Prelude

13-- hasql

16-- hasql

17+import Hasql.Connection ( Connection )

14import qualified Hasql.Decoders as Hasql

18import qualified Hasql.Decoders as Hasql

15import qualified Hasql.Encoders as Hasql

19import qualified Hasql.Encoders as Hasql

20+import qualified Hasql.Session as Hasql

16import qualified Hasql.Statement as Hasql

21import qualified Hasql.Statement as Hasql

18-- rel8

23-- rel8

19import Rel8.Query ( Query )

24import Rel8.Query ( Query )

25+import Rel8.Query.SQL ( sqlForQueryWithNames )

20import Rel8.Schema.Name ( Selects )

26import Rel8.Schema.Name ( Selects )

21−import Rel8.Schema.Table ( TableSchema )

27+import Rel8.Schema.Table ( TableSchema( TableSchema ) )

22−import Rel8.Statement.Insert ( ppInto )

28+import Rel8.Table.Alternative ( emptyTable )

23−import Rel8.Statement.Select ( ppSelect )

24−

25−-- pretty

26−import Text.PrettyPrint ( Doc, (<+>), ($$), text )

28-- text

30-- text

29import qualified Data.Text as Text

31import qualified Data.Text as Text

30import Data.Text.Encoding ( encodeUtf8 )

32import Data.Text.Encoding ( encodeUtf8 )

33−data CreateView = Create | CreateOrReplace

34−

35−

36-- | Given a 'TableSchema' and 'Query', @createView@ runs a @CREATE VIEW@

35-- | 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

36-- 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.

37-- you want to share Rel8 queries with other applications.

39createView :: Selects names exprs

38createView :: Selects names exprs

40− => TableSchema names -> Query exprs -> Hasql.Statement () ()

39+ => TableSchema names -> Query exprs -> Connection -> IO ()

41−createView =

40+createView (TableSchema name mschema names) query =

42− createViewGeneric Create

41+ Hasql.run session >=> either throwIO pure

43−

44−

45−-- | Given a 'TableSchema' and 'Query', @createOrReplaceView@ runs a

46−-- @CREATE OR REPLACE VIEW@ statement that will save the given query

47−-- as a view, replacing the current view definition if it exists and

48−-- adheres to the restrictions in place for replacing a view in

49−-- PostgreSQL.

50−createOrReplaceView :: Selects names exprs

51− => TableSchema names -> Query exprs -> Hasql.Statement () ()

52−createOrReplaceView =

53− createViewGeneric CreateOrReplace

54−

55−

56−createViewGeneric :: Selects names exprs

57− => CreateView -> TableSchema names -> Query exprs -> Hasql.Statement () ()

58−createViewGeneric replace schema query =

59− Hasql.Statement bytes params decode prepare

60 where

42 where

43+ session = Hasql.statement () statement

44+ statement = Hasql.Statement bytes params decode prepare

61 bytes = encodeUtf8 (Text.pack sql)

45 bytes = encodeUtf8 (Text.pack sql)

62 params = Hasql.noParams

46 params = Hasql.noParams

63 decode = Hasql.noResult

47 decode = Hasql.noResult

64 prepare = False

48 prepare = False

65− sql = show doc

49+ sql = "CREATE VIEW " <> title <> " AS " <> select

66− doc = ppCreateView schema query replace

50+ where

67−

51+ title = case mschema of

68−

52+ Nothing -> quote name

69−ppCreateView :: Selects names exprs

53+ Just schema -> quote schema <> "." <> quote name

70− => TableSchema names -> Query exprs -> CreateView -> Doc

54+ select = fromMaybe fallback $ sqlForQueryWithNames names query

71−ppCreateView schema query replace =

55+ where

72− createOrReplace replace <+>

56+ fallback = fold $ sqlForQueryWithNames names emptyTable

73− ppInto schema $$

57+

74− text "AS" <+>

58+

75− ppSelect query

59+quote :: String -> String

60+quote string = "\"" <> concatMap go string <> "\""

76 where

61 where

77− createOrReplace Create = text "CREATE VIEW"

62+ go '"' = "\"\""

78− createOrReplace CreateOrReplace = text "CREATE OR REPLACE VIEW"

63+ go c = [c]

src/Rel8/Statement/Where.hsdeleted−31

@@ -1,31 +0,0 @@

1−{-# language MonoLocalBinds #-}

2−

3−module Rel8.Statement.Where

4− ( ppWhere

5− )

6−where

7−

8−-- base

9−import Prelude

10−

11−-- opaleye

12−import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye

13−import qualified Opaleye.Internal.Sql as Opaleye

14−

15−-- pretty

16−import Text.PrettyPrint ( Doc, (<+>), text )

17−

18−-- rel8

19−import Rel8.Expr ( Expr )

20−import Rel8.Expr.Opaleye ( toPrimExpr )

21−import Rel8.Schema.Name ( Selects )

22−import Rel8.Schema.Table ( TableSchema )

23−import Rel8.Table.Opaleye ( attributes )

24−

25−

26−ppWhere :: Selects names exprs

27− => TableSchema names -> (exprs -> Expr Bool) -> Doc

28−ppWhere schema where_ = text "WHERE" <+> ppExpr condition

29− where

30− ppExpr = Opaleye.ppSqlExpr . Opaleye.sqlExpr . toPrimExpr

31− condition = where_ (attributes schema)

src/Rel8/Table.hs+252−88

@@ -1,47 +1,77 @@

1{-# language AllowAmbiguousTypes #-}

2{-# language DataKinds #-}

3{-# language DefaultSignatures #-}

4+{-# language DisambiguateRecordFields #-}

4{-# language FlexibleContexts #-}

5{-# language FlexibleContexts #-}

5{-# language FlexibleInstances #-}

6{-# language FlexibleInstances #-}

6{-# language FunctionalDependencies #-}

7{-# language FunctionalDependencies #-}

8+{-# language LambdaCase #-}

9+{-# language NamedFieldPuns #-}

7{-# language ScopedTypeVariables #-}

10{-# language ScopedTypeVariables #-}

8{-# language StandaloneKindSignatures #-}

11{-# language StandaloneKindSignatures #-}

9{-# language TypeApplications #-}

12{-# language TypeApplications #-}

10{-# language TypeFamilies #-}

13{-# language TypeFamilies #-}

14+{-# language TypeOperators #-}

11{-# language UndecidableInstances #-}

15{-# language UndecidableInstances #-}

13module Rel8.Table

17module Rel8.Table

14− ( Table

15− ( Columns, Context, fromColumns, toColumns

18+ ( Table (Columns, Context, Unreify, toColumns, fromColumns, reify, unreify)

16− , FromExprs, fromResult, toResult

17− , Transpose

18− )

19 , Congruent

20− , TTable, TColumns, TContext, TFromExprs, TTranspose

20+ , TTable, TColumns, TContext, TUnreify

21− , TSerialize

22 )

21 )

23where

22where

25-- base

24-- base

25+import Data.Functor ( ($>) )

26import Data.Functor.Identity ( Identity( Identity ) )

27import Data.Kind ( Constraint, Type )

28+import Data.List.NonEmpty ( NonEmpty )

29+import Data.Proxy ( Proxy( Proxy ) )

30+import Data.Type.Equality ( (:~:)( Refl ) )

28import GHC.Generics ( Generic, Rep, from, to )

31import GHC.Generics ( Generic, Rep, from, to )

29import Prelude hiding ( null )

32import Prelude hiding ( null )

31-- rel8

34-- rel8

32import Rel8.FCF ( Eval, Exp )

35import Rel8.FCF ( Eval, Exp )

33−import Rel8.Generic.Map ( Map )

36+import Rel8.Kind.Algebra ( KnownAlgebra )

37+import Rel8.Generic.Map ( GMap, GMappable, gmap, gunmap )

34−import Rel8.Generic.Table.Record

38+import Rel8.Generic.Table

35− ( GTable, GColumns, GContext, gfromColumns, gtoColumns

39+ ( GGTable, GGColumns, GGContext, ggfromColumns, ggtoColumns

36− , GSerialize, gfromResult, gtoResult

40+ , GAlgebra

37 )

41 )

38import Rel8.Generic.Record ( Record(..) )

42import Rel8.Generic.Record ( Record(..) )

43+import Rel8.Generic.Reify ( ARep )

44+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )

39import Rel8.Schema.HTable ( HTable )

45import Rel8.Schema.HTable ( HTable )

40−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

46+import Rel8.Schema.HTable.Either ( HEitherTable(..) )

47+import Rel8.Schema.HTable.Identity ( HIdentity(..), HType )

48+import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

49+import Rel8.Schema.HTable.List ( HListTable )

50+import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )

51+import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )

52+import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify )

53+import Rel8.Schema.HTable.These ( HTheseTable(..) )

54+import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )

41import qualified Rel8.Schema.Kind as K

55import qualified Rel8.Schema.Kind as K

42import Rel8.Schema.Null ( Sql )

56import Rel8.Schema.Null ( Sql )

43−import Rel8.Schema.Result ( Result )

57+import Rel8.Schema.Reify

58+ ( Reify, Col( Reify ), hreify, hunreify

59+ , UnwrapReify

60+ , notReify

61+ )

62+import Rel8.Schema.Result

63+ ( Col( Result ), Result

64+ , relabel

65+ , null, nullifier, unnullifier

66+ , vectorizer, unvectorizer

67+ )

68+import Rel8.Schema.Spec ( KnownSpec )

44import Rel8.Type ( DBType )

69import Rel8.Type ( DBType )

70+import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )

71+

72+-- these

73+import Data.These ( These( This, That, These ) )

74+import Data.These.Combinators ( justHere, justThere )

47-- | @Table@s are one of the foundational elements of Rel8, and describe data

77-- | @Table@s are one of the foundational elements of Rel8, and describe data

@@ -56,102 +86,90 @@ import Rel8.Type ( DBType )

56-- yourself, as anything that's an instance of 'Rel8.Rel8able' is always a

86-- yourself, as anything that's an instance of 'Rel8.Rel8able' is always a

57-- 'Table'.

87-- 'Table'.

58type Table :: K.Context -> Type -> Constraint

88type Table :: K.Context -> Type -> Constraint

59−class

60− ( HTable (Columns a)

61− , context ~ Context a

62− , a ~ Transpose context a

63− )

64− => Table context a | a -> context

89+class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where

65− where

66 -- | The 'HTable' functor that describes the schema of this table.

90 -- | The 'HTable' functor that describes the schema of this table.

67 type Columns a :: K.HTable

91 type Columns a :: K.HTable

69 -- | The common context that all columns use as an interpretation.

93 -- | The common context that all columns use as an interpretation.

70 type Context a :: K.Context

94 type Context a :: K.Context

72− -- | The @FromExprs@ type family maps a type in the @Expr@ context to the

96+ type Unreify a :: Type

73− -- corresponding Haskell type.

74− type FromExprs a :: Type

75−

76− type Transpose (context' :: K.Context) a :: Type

98+ toColumns :: a -> Columns a (Col context)

99+ fromColumns :: Columns a (Col context) -> a

100

79− toColumns :: a -> Columns a context

101+ reify :: context :~: Reify ctx -> Unreify a -> a

80− fromColumns :: Columns a context -> a

102+ unreify :: context :~: Reify ctx -> a -> Unreify a

103

82− fromResult :: Columns a Result -> FromExprs a

104+ type Columns a = Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))

83− toResult :: FromExprs a -> Columns a Result

84−

85− type Columns a = GColumns TColumns (Rep (Record a))

86− type Context a = GContext TContext (Rep (Record a))

105+ type Context a = Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))

87− type FromExprs a = Map TFromExprs a

106+ type Unreify a = DefaultUnreify a

88− type Transpose context a = Map (TTranspose context) a

107

90 default toColumns ::

108 default toColumns ::

91 ( Generic (Record a)

109 ( Generic (Record a)

110+ , KnownAlgebra (GAlgebra (Rep (Record a)))

92− , GTable (TTable context) TColumns (Rep (Record a))

111+ , Eval (GGTable (GAlgebra (Rep (Record a))) (TTable context) TColumns (Col context) (Rep (Record a)))

93− , Columns a ~ GColumns TColumns (Rep (Record a))

112+ , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))

113+ , Context a ~ Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))

94 )

114 )

95− => a -> Columns a context

115+ => a -> Columns a (Col context)

96 toColumns =

116 toColumns =

117+ ggtoColumns

118+ @(GAlgebra (Rep (Record a)))

97− gtoColumns @(TTable context) @TColumns toColumns .

119+ @(TTable context)

120+ @TColumns

121+ id

122+ id

123+ toColumns .

98 from .

124 from .

99 Record

125 Record

100

126

101 default fromColumns ::

127 default fromColumns ::

102 ( Generic (Record a)

128 ( Generic (Record a)

129+ , KnownAlgebra (GAlgebra (Rep (Record a)))

103− , GTable (TTable context) TColumns (Rep (Record a))

130+ , Eval (GGTable (GAlgebra (Rep (Record a))) (TTable context) TColumns (Col context) (Rep (Record a)))

104− , Columns a ~ GColumns TColumns (Rep (Record a))

131+ , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))

132+ , Context a ~ Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))

105 )

133 )

106− => Columns a context -> a

134+ => Columns a (Col context) -> a

107 fromColumns =

135 fromColumns =

108 unrecord .

136 unrecord .

109 to .

137 to .

138+ ggfromColumns

139+ @(GAlgebra (Rep (Record a)))

110− gfromColumns @(TTable context) @TColumns fromColumns

140+ @(TTable context)

141+ @TColumns

142+ id

143+ id

144+ fromColumns

111

145

112− default toResult ::

146+ default reify ::

113− ( Generic (Record (FromExprs a))

147+ ( Generic (Record a)

114− , GSerialize TSerialize TColumns (Rep (Record a)) (Rep (Record (FromExprs a)))

148+ , Generic (Record (Unreify a))

115− , Columns a ~ GColumns TColumns (Rep (Record a))

149+ , GMappable (TTable context) (Rep (Record a))

150+ , Rep (Record (Unreify a)) ~ GMap TUnreify (Rep (Record a))

116 )

151 )

117− => FromExprs a -> Columns a Result

152+ => context :~: Reify ctx -> Unreify a -> a

118− toResult =

153+ reify Refl =

119− gtoResult

154+ unrecord .

120− @TSerialize

155+ to .

121− @TColumns

156+ gunmap @(TTable context) (Proxy @TUnreify) (reify Refl) .

122− @(Rep (Record a))

123− @(Rep (Record (FromExprs a)))

124− (\(_ :: proxy x) -> toResult @(Context x) @x) .

125 from .

157 from .

126 Record

158 Record

127

159

128− default fromResult ::

160+ default unreify ::

129− ( Generic (Record (FromExprs a))

161+ ( Generic (Record a)

130− , GSerialize TSerialize TColumns (Rep (Record a)) (Rep (Record (FromExprs a)))

162+ , Generic (Record (Unreify a))

131− , Columns a ~ GColumns TColumns (Rep (Record a))

163+ , GMappable (TTable context) (Rep (Record a))

164+ , Rep (Record (Unreify a)) ~ GMap TUnreify (Rep (Record a))

132 )

165 )

133− => Columns a Result -> FromExprs a

166+ => context :~: Reify ctx -> a -> Unreify a

134− fromResult =

167+ unreify Refl =

135 unrecord .

168 unrecord .

136 to .

169 to .

137− gfromResult

170+ gmap @(TTable context) (Proxy @TUnreify) (unreify Refl) .

138− @TSerialize

171+ from .

139− @TColumns

172+ Record

140− @(Rep (Record a))

141− @(Rep (Record (FromExprs a)))

142− (\(_ :: proxy x) -> fromResult @(Context x) @x)

143−

144−

145−instance Sql DBType a => Table Result (Identity a) where

146− type Columns (Identity a) = HIdentity a

147− type Context (Identity a) = Result

148− type FromExprs (Identity a) = a

149− type Transpose to (Identity a) = to a

150−

151− toColumns = HIdentity

152− fromColumns (HIdentity a) = a

153− toResult a = HIdentity (Identity a)

154− fromResult (HIdentity (Identity a)) = a

155

173

156

174

157data TTable :: K.Context -> Type -> Exp Constraint

175data TTable :: K.Context -> Type -> Exp Constraint

@@ -166,32 +184,175 @@ data TContext :: Type -> Exp K.Context

166type instance Eval (TContext a) = Context a

184type instance Eval (TContext a) = Context a

167

185

168

186

169−data TFromExprs :: Type -> Exp Type

187+data TUnreify :: Type -> Exp Type

170−type instance Eval (TFromExprs a) = FromExprs a

188+type instance Eval (TUnreify a) = Unreify a

171

189

172

190

173−data TTranspose :: K.Context -> Type -> Exp Type

191+type DefaultUnreify :: Type -> Type

174−type instance Eval (TTranspose context a) = Transpose context a

192+type family DefaultUnreify a where

193+ DefaultUnreify (t a b c d e f g) =

194+ t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e) (Unreify f) (Unreify g)

195+ DefaultUnreify (t a b c d e f) =

196+ t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e) (Unreify f)

197+ DefaultUnreify (t a b c d e) =

198+ t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e)

199+ DefaultUnreify (t a b c d) =

200+ t (Unreify a) (Unreify b) (Unreify c) (Unreify d)

201+ DefaultUnreify (t a b c) = t (Unreify a) (Unreify b) (Unreify c)

202+ DefaultUnreify (t a b) = t (Unreify a) (Unreify b)

203+ DefaultUnreify (t a) = t (Unreify a)

204+ DefaultUnreify a = ARep (GMap TUnreify (Rep a))

175

205

176

206

177−data TSerialize :: Type -> Type -> Exp Constraint

207+-- | Any 'HTable' is also a 'Table'.

178−type instance Eval (TSerialize expr a) =

208+instance HTable t => Table context (t (Col context)) where

179− ( Table (Context expr) expr

209+ type Columns (t (Col context)) = t

180− , a ~ FromExprs expr

210+ type Context (t (Col context)) = context

181− )

211+ type Unreify (t (Col context)) = t (Col (UnwrapReify context))

212+

213+ toColumns = id

214+ fromColumns = id

215+

216+ reify Refl = hreify

217+ unreify Refl = hunreify

182

218

183

219

220+-- | Any context is trivially a table.

221+instance KnownSpec spec => Table context (Col context spec) where

222+ type Columns (Col context spec) = HIdentity spec

223+ type Context (Col context spec) = context

224+ type Unreify (Col context spec) = Col (UnwrapReify context) spec

225+

226+ toColumns = HIdentity

227+ fromColumns = unHIdentity

228+

229+ reify Refl = Reify

230+ unreify Refl (Reify a) = a

231+

232+

233+instance Sql DBType a => Table Result (Identity a) where

234+ type Columns (Identity a) = HType a

235+ type Context (Identity a) = Result

236+

237+ toColumns (Identity a) = HType (Result a)

238+ fromColumns (HType (Result a)) = Identity a

239+

240+ reify = notReify

241+ unreify = notReify

242+

243+

244+instance (Table Result a, Table Result b) => Table Result (Either a b) where

245+ type Columns (Either a b) = HEitherTable (Columns a) (Columns b)

246+ type Context (Either a b) = Result

247+

248+ toColumns = \case

249+ Left table -> HEitherTable

250+ { htag = HIdentity (Result IsLeft)

251+ , hleft = hlabel labeler (hnullify nullifier (toColumns table))

252+ , hright = hlabel labeler (hnulls (const null))

253+ }

254+ Right table -> HEitherTable

255+ { htag = HIdentity (Result IsRight)

256+ , hleft = hlabel labeler (hnulls (const null))

257+ , hright = hlabel labeler (hnullify nullifier (toColumns table))

258+ }

259+

260+ fromColumns HEitherTable {htag, hleft, hright} = case htag of

261+ HIdentity (Result tag) -> case tag of

262+ IsLeft -> maybe err (Left . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hleft)

263+ IsRight -> maybe err (Right . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hright)

264+ where

265+ err = error "Either.fromColumns: mismatch between tag and data"

266+

267+

268+instance Table Result a => Table Result [a] where

269+ type Columns [a] = HListTable (Columns a)

270+ type Context [a] = Result

271+

272+ toColumns = hvectorize vectorizer . fmap toColumns

273+ fromColumns = fmap fromColumns . hunvectorize unvectorizer

274+

275+

276+instance Table Result a => Table Result (Maybe a) where

277+ type Columns (Maybe a) = HMaybeTable (Columns a)

278+ type Context (Maybe a) = Result

279+

280+ toColumns = \case

281+ Nothing -> HMaybeTable

282+ { htag = HIdentity (Result Nothing)

283+ , hjust = hlabel labeler (hnulls (const null))

284+ }

285+ Just table -> HMaybeTable

286+ { htag = HIdentity (Result (Just IsJust))

287+ , hjust = hlabel labeler (hnullify nullifier (toColumns table))

288+ }

289+

290+ fromColumns HMaybeTable {htag, hjust} = case htag of

291+ HIdentity (Result tag) -> tag $>

292+ case hunnullify unnullifier (hunlabel unlabeler hjust) of

293+ Nothing -> error "Maybe.fromColumns: mismatch between tag and data"

294+ Just just -> fromColumns just

295+

296+

297+instance Table Result a => Table Result (NonEmpty a) where

298+ type Columns (NonEmpty a) = HNonEmptyTable (Columns a)

299+ type Context (NonEmpty a) = Result

300+

301+ toColumns = hvectorize vectorizer . fmap toColumns

302+ fromColumns = fmap fromColumns . hunvectorize unvectorizer

303+

304+

305+instance (Table Result a, Table Result b) => Table Result (These a b) where

306+ type Columns (These a b) = HTheseTable (Columns a) (Columns b)

307+ type Context (These a b) = Result

308+

309+ toColumns tables = HTheseTable

310+ { hhereTag = relabel hhereTag

311+ , hhere = hlabel labeler (hunlabel unlabeler (toColumns hhere))

312+ , hthereTag = relabel hthereTag

313+ , hthere = hlabel labeler (hunlabel unlabeler (toColumns hthere))

314+ }

315+ where

316+ HMaybeTable

317+ { htag = hhereTag

318+ , hjust = hhere

319+ } = toColumns (justHere tables)

320+ HMaybeTable

321+ { htag = hthereTag

322+ , hjust = hthere

323+ } = toColumns (justThere tables)

324+

325+ fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} =

326+ case (fromColumns mhere, fromColumns mthere) of

327+ (Just a, Nothing) -> This (fromColumns a)

328+ (Nothing, Just b) -> That (fromColumns b)

329+ (Just a, Just b) -> These (fromColumns a) (fromColumns b)

330+ _ -> error "These.fromColumns: mismatch between tags and data"

331+ where

332+ mhere = HMaybeTable

333+ { htag = relabel hhereTag

334+ , hjust = hlabel labeler (hunlabel unlabeler hhere)

335+ }

336+ mthere = HMaybeTable

337+ { htag = relabel hthereTag

338+ , hjust = hlabel labeler (hunlabel unlabeler hthere)

339+ }

340+

341+

184−instance (Table context a, Table context b) => Table context (a, b)

342+instance (Table context a, Table context b, Labelable context)

343+ => Table context (a, b)

185

344

186

345

187instance

346instance

188 ( Table context a, Table context b, Table context c

347 ( Table context a, Table context b, Table context c

348+ , Labelable context

189 )

349 )

190 => Table context (a, b, c)

350 => Table context (a, b, c)

191

351

192

352

193instance

353instance

194 ( Table context a, Table context b, Table context c, Table context d

354 ( Table context a, Table context b, Table context c, Table context d

355+ , Labelable context

195 )

356 )

196 => Table context (a, b, c, d)

357 => Table context (a, b, c, d)

197

358

@@ -199,6 +360,7 @@ instance

199instance

360instance

200 ( Table context a, Table context b, Table context c, Table context d

361 ( Table context a, Table context b, Table context c, Table context d

201 , Table context e

362 , Table context e

363+ , Labelable context

202 )

364 )

203 => Table context (a, b, c, d, e)

365 => Table context (a, b, c, d, e)

204

366

@@ -206,6 +368,7 @@ instance

206instance

368instance

207 ( Table context a, Table context b, Table context c, Table context d

369 ( Table context a, Table context b, Table context c, Table context d

208 , Table context e, Table context f

370 , Table context e, Table context f

371+ , Labelable context

209 )

372 )

210 => Table context (a, b, c, d, e, f)

373 => Table context (a, b, c, d, e, f)

211

374

@@ -213,6 +376,7 @@ instance

213instance

376instance

214 ( Table context a, Table context b, Table context c, Table context d

377 ( Table context a, Table context b, Table context c, Table context d

215 , Table context e, Table context f, Table context g

378 , Table context e, Table context f, Table context g

379+ , Labelable context

216 )

380 )

217 => Table context (a, b, c, d, e, f, g)

381 => Table context (a, b, c, d, e, f, g)

218

382

src/Rel8/Table/ADT.hs+84−64

@@ -2,23 +2,21 @@

2{-# language DataKinds #-}

3{-# language FlexibleContexts #-}

4{-# language FlexibleInstances #-}

5−{-# language MultiParamTypeClasses #-}

6{-# language RankNTypes #-}

5{-# language RankNTypes #-}

7{-# language ScopedTypeVariables #-}

6{-# language ScopedTypeVariables #-}

8{-# language StandaloneKindSignatures #-}

7{-# language StandaloneKindSignatures #-}

9{-# language TypeApplications #-}

8{-# language TypeApplications #-}

10−{-# language TypeFamilyDependencies #-}

9+{-# language TypeFamilies #-}

11{-# language UndecidableInstances #-}

10{-# language UndecidableInstances #-}

12{-# language UndecidableSuperClasses #-}

11{-# language UndecidableSuperClasses #-}

14module Rel8.Table.ADT

13module Rel8.Table.ADT

15 ( ADT( ADT )

14 ( ADT( ADT )

16− , ADTable

15+ , ADTable, fromADT, toADT

17− , BuildableADT

18− , BuildADT, buildADT

19 , ConstructableADT

16 , ConstructableADT

20 , ConstructADT, constructADT

17 , ConstructADT, constructADT

21 , DeconstructADT, deconstructADT

18 , DeconstructADT, deconstructADT

19+ , InsertADT, insertADT

22 , NameADT, nameADT

20 , NameADT, nameADT

23 , AggregateADT, aggregateADT

21 , AggregateADT, aggregateADT

24 , ADTRep

22 , ADTRep

@@ -27,8 +25,9 @@ where

28-- base

26-- base

29import Data.Kind ( Constraint, Type )

27import Data.Kind ( Constraint, Type )

28+import Data.Proxy ( Proxy( Proxy ) )

29+import Data.Type.Equality ( (:~:)( Refl ) )

30−import GHC.Generics ( Generic, from, to )

30+import GHC.Generics ( Generic, Rep, from, to )

31−import GHC.TypeLits ( Symbol )

32import Prelude

31import Prelude

34-- rel8

33-- rel8

@@ -36,104 +35,118 @@ import Rel8.Aggregate ( Aggregate )

36import Rel8.Expr ( Expr )

35import Rel8.Expr ( Expr )

37import Rel8.FCF ( Eval, Exp )

36import Rel8.FCF ( Eval, Exp )

38import Rel8.Generic.Construction

37import Rel8.Generic.Construction

39− ( GGBuildable

40− , GGBuild, ggbuild

41− , GGConstructable

38+ ( GGConstructable

42 , GGConstruct, ggconstruct

39 , GGConstruct, ggconstruct

43 , GGDeconstruct, ggdeconstruct

40 , GGDeconstruct, ggdeconstruct

41+ , GGInsert, gginsert

44 , GGName, ggname

42 , GGName, ggname

45 , GGAggregate, ggaggregate

43 , GGAggregate, ggaggregate

46 )

44 )

47−import Rel8.Generic.Record ( Record( Record ), unrecord )

45+import Rel8.Generic.Map ( GMappable, GMap, gmap, gunmap )

46+import Rel8.Generic.Record ( GRecordable, GRecord, grecord, gunrecord )

48import Rel8.Generic.Rel8able

47import Rel8.Generic.Rel8able

49 ( Rel8able

48 ( Rel8able

50 , GRep, GColumns, gfromColumns, gtoColumns

49 , GRep, GColumns, gfromColumns, gtoColumns

51− , GFromExprs, gfromResult, gtoResult

50+ , greify, gunreify

52− , TSerialize, deserialize, serialize

53 )

51 )

54import qualified Rel8.Generic.Table.ADT as G

52import qualified Rel8.Generic.Table.ADT as G

55import qualified Rel8.Kind.Algebra as K

53import qualified Rel8.Kind.Algebra as K

54+import Rel8.Schema.Context ( Col )

56import Rel8.Schema.HTable ( HTable )

55import Rel8.Schema.HTable ( HTable )

56+import Rel8.Schema.Insert ( Insert )

57import qualified Rel8.Schema.Kind as K

58import Rel8.Schema.Name ( Name )

59+import Rel8.Schema.Reify ( Col( Reify ), Reify, hreify, hunreify )

59import Rel8.Schema.Result ( Result )

60import Rel8.Schema.Result ( Result )

60−import Rel8.Table ( Table, TColumns )

61+import Rel8.Table

62+ ( Table

63+ , fromColumns, toColumns, reify, unreify

64+ , TTable, TColumns, TUnreify

65+ )

63type ADT :: K.Rel8able -> K.Rel8able

68type ADT :: K.Rel8able -> K.Rel8able

64−newtype ADT t context = ADT (GColumnsADT t context)

69+newtype ADT t context = ADT (GColumnsADT t (Col context))

67instance ADTable t => Rel8able (ADT t) where

72instance ADTable t => Rel8able (ADT t) where

68 type GColumns (ADT t) = GColumnsADT t

73 type GColumns (ADT t) = GColumnsADT t

69− type GFromExprs (ADT t) = t Result

71− gfromColumns _ = ADT

75+ gfromColumns = ADT

72− gtoColumns _ (ADT a) = a

76+ gtoColumns (ADT a) = a

77+

78+ greify (ADT a) = ADT (hreify a)

79+ gunreify (ADT a) = ADT (hunreify a)

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)

84− gtoResult =

82+instance (ADTable t, context ~ Result) => Generic (ADT t context) where

85− G.gtoResultADT

83+ type Rep (ADT t context) = Rep (t context)

86− @TSerialize

84+

85+ from =

86+ gmap @(TTable (Reify Result)) (Proxy @TUnreify) (unreify Refl) .

87+ gunrecord @(Rep (t (Reify Result))) .

88+ G.gfromColumnsADT

89+ @(TTable (Reify Result))

90+ @TColumns

91+ (\(Reify a) -> a)

92+ Reify

93+ fromColumns .

94+ hreify .

95+ (\(ADT a) -> a)

96+

97+ to =

98+ ADT .

99+ hunreify .

100+ G.gtoColumnsADT

101+ @(TTable (Reify Result))

87 @TColumns

102 @TColumns

88− @(Eval (ADTRep t Expr))

103+ (\(Reify a) -> a)

89− @(Eval (ADTRep t Result))

104+ Reify

90− (\(_ :: proxy x) -> serialize @_ @x) .

105+ toColumns .

91− from .

106+ grecord @(Rep (t (Reify Result))) .

92− Record

107+ gunmap @(TTable (Reify Result)) (Proxy @TUnreify) (reify Refl)

108+

109+

110+fromADT :: ADTable t => ADT t Result -> t Result

111+fromADT = to . from

112+

113+

114+toADT :: ADTable t => t Result -> ADT t Result

115+toADT = to . from

116

117

95type ADTable :: K.Rel8able -> Constraint

118type ADTable :: K.Rel8able -> Constraint

96class

119class

97− ( Generic (Record (t Result))

120+ ( Generic (t Result)

98 , HTable (GColumnsADT t)

121 , HTable (GColumnsADT t)

99− , G.GSerializeADT TSerialize TColumns (Eval (ADTRep t Expr)) (Eval (ADTRep t Result))

122+ , G.GTableADT (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRecord (Rep (t (Reify Result))))

123+ , GRecordable (Rep (t (Reify Result)))

124+ , GMappable (TTable (Reify Result)) (Rep (t (Reify Result)))

125+ , GMap TUnreify (Rep (t (Reify Result))) ~ Rep (t Result)

100 )

126 )

101 => ADTable t

127 => ADTable t

102instance

128instance

103− ( Generic (Record (t Result))

129+ ( Generic (t Result)

104 , HTable (GColumnsADT t)

130 , HTable (GColumnsADT t)

105− , G.GSerializeADT TSerialize TColumns (Eval (ADTRep t Expr)) (Eval (ADTRep t Result))

131+ , G.GTableADT (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRecord (Rep (t (Reify Result))))

132+ , GRecordable (Rep (t (Reify Result)))

133+ , GMappable (TTable (Reify Result)) (Rep (t (Reify Result)))

134+ , GMap TUnreify (Rep (t (Reify Result))) ~ Rep (t Result)

106 )

135 )

107 => ADTable t

136 => ADTable t

108

137

109

138

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−

124type ConstructableADT :: K.Rel8able -> Constraint

139type ConstructableADT :: K.Rel8able -> Constraint

125class GGConstructable 'K.Sum (ADTRep t) => ConstructableADT t

140class GGConstructable 'K.Sum (ADTRep t) => ConstructableADT t

126instance GGConstructable 'K.Sum (ADTRep t) => ConstructableADT t

141instance GGConstructable 'K.Sum (ADTRep t) => ConstructableADT t

127

142

128

143

129type ConstructADT :: K.Rel8able -> Type

144type ConstructADT :: K.Rel8able -> Type

130−type ConstructADT t = forall r. GGConstruct 'K.Sum (ADTRep t) r

145+type ConstructADT t = GGConstruct 'K.Sum (ADTRep t) (ADT t Expr)

131

146

132

147

133−constructADT :: forall t. ConstructableADT t => ConstructADT t -> ADT t Expr

148+constructADT :: forall t. ConstructableADT t => ConstructADT t

134−constructADT f =

135− ggconstruct @'K.Sum @(ADTRep t) @(ADT t Expr) ADT

149+constructADT = ggconstruct @'K.Sum @(ADTRep t) @(ADT t Expr) ADT

136− (f @(ADT t Expr))

137

150

138

151

139type DeconstructADT :: K.Rel8able -> Type -> Type

152type DeconstructADT :: K.Rel8able -> Type -> Type

@@ -142,8 +155,15 @@ type DeconstructADT t r = GGDeconstruct 'K.Sum (ADTRep t) (ADT t Expr) r

142

155

143deconstructADT :: forall t r. (ConstructableADT t, Table Expr r)

156deconstructADT :: forall t r. (ConstructableADT t, Table Expr r)

144 => DeconstructADT t r

157 => DeconstructADT t r

145−deconstructADT =

146− ggdeconstruct @'K.Sum @(ADTRep t) @(ADT t Expr) @r (\(ADT a) -> a)

158+deconstructADT = ggdeconstruct @'K.Sum @(ADTRep t) @(ADT t Expr) @r (\(ADT a) -> a)

159+

160+

161+type InsertADT :: K.Rel8able -> Type

162+type InsertADT t = GGInsert 'K.Sum (ADTRep t) (ADT t Insert)

163+

164+

165+insertADT :: forall t. ConstructableADT t => InsertADT t

166+insertADT = gginsert @'K.Sum @(ADTRep t) @(ADT t Insert) ADT

147

167

148

168

149type NameADT :: K.Rel8able -> Type

169type NameADT :: K.Rel8able -> Type

@@ -159,10 +179,10 @@ type AggregateADT t = forall r. GGAggregate 'K.Sum (ADTRep t) r

159

179

160

180

161aggregateADT :: forall t. ConstructableADT t

181aggregateADT :: forall t. ConstructableADT t

162− => AggregateADT t -> ADT t Expr -> ADT t Aggregate

182+ => AggregateADT t -> ADT t Expr -> Aggregate (ADT t Expr)

163aggregateADT f =

183aggregateADT f =

164− ggaggregate @'K.Sum @(ADTRep t) @(ADT t Expr) @(ADT t Aggregate) ADT (\(ADT a) -> a)

184+ ggaggregate @'K.Sum @(ADTRep t) @(ADT t Expr) ADT (\(ADT a) -> a)

165− (f @(ADT t Aggregate))

185+ (f @(Aggregate (ADT t Expr)))

166

186

167

187

168data ADTRep :: K.Rel8able -> K.Context -> Exp (Type -> Type)

188data ADTRep :: K.Rel8able -> K.Context -> Exp (Type -> Type)

@@ -170,4 +190,4 @@ type instance Eval (ADTRep t context) = GRep t context

170

190

171

191

172type GColumnsADT :: K.Rel8able -> K.HTable

192type GColumnsADT :: K.Rel8able -> K.HTable

173−type GColumnsADT t = G.GColumnsADT TColumns (GRep t Expr)

193+type GColumnsADT t = G.GColumnsADT TColumns (GRep t (Reify Result))

src/Rel8/Table/Aggregate.hs+36−37

@@ -1,13 +1,13 @@

1{-# language FlexibleContexts #-}

2−{-# language NamedFieldPuns #-}

3{-# language ScopedTypeVariables #-}

2{-# language ScopedTypeVariables #-}

4{-# language TypeApplications #-}

3{-# language TypeApplications #-}

5{-# language TypeFamilies #-}

4{-# language TypeFamilies #-}

6{-# language ViewPatterns #-}

5{-# language ViewPatterns #-}

8module Rel8.Table.Aggregate

7module Rel8.Table.Aggregate

9− ( groupBy, hgroupBy

8+ ( groupBy

10 , listAgg, nonEmptyAgg

9 , listAgg, nonEmptyAgg

10+ , listAggWithOrder, nonEmptyAggWithOrder

11 )

12where

@@ -16,49 +16,32 @@ import Data.Functor.Identity ( Identity( Identity ) )

16import Prelude

18-- rel8

19−import Rel8.Aggregate ( Aggregate, Aggregates )

19+import Rel8.Aggregate ( Aggregate, Col(..) )

20−import Rel8.Expr ( Expr )

20+import Rel8.Expr ( Expr, Col(..) )

21import Rel8.Expr.Aggregate

22 ( groupByExpr

23− , slistAggExpr

23+ , listAggExpr

24− , snonEmptyAggExpr

24+ , listAggExprWithOrder

25+ , nonEmptyAggExpr

26+ , nonEmptyAggExprWithOrder

25 )

27 )

28+import Rel8.Order ( Order )

26import Rel8.Schema.Dict ( Dict( Dict ) )

29import Rel8.Schema.Dict ( Dict( Dict ) )

27−import Rel8.Schema.HTable ( HTable, hfield, htabulate )

30+import Rel8.Schema.HTable ( htabulate, hfield )

28import Rel8.Schema.HTable.Vectorize ( hvectorize )

31import Rel8.Schema.HTable.Vectorize ( hvectorize )

29−import Rel8.Schema.Null ( Sql )

30−import Rel8.Schema.Spec ( Spec( Spec, info ) )

31−import Rel8.Table ( toColumns, fromColumns )

32+import Rel8.Table ( Table, toColumns, fromColumns )

32import Rel8.Table.Eq ( EqTable, eqTable )

33import Rel8.Table.Eq ( EqTable, eqTable )

33import Rel8.Table.List ( ListTable )

34import Rel8.Table.List ( ListTable )

34import Rel8.Table.NonEmpty ( NonEmptyTable )

35import Rel8.Table.NonEmpty ( NonEmptyTable )

35−import Rel8.Type.Eq ( DBEq )

38-- | Group equal tables together. This works by aggregating each column in the

39-- given table with 'groupByExpr'.

40−--

41−-- For example, if we have a table of items, we could group the items by the

42−-- order they belong to:

43−--

44−-- @

45−-- itemsByOrder :: Query (OrderId Expr, ListTable Expr (Item Expr))

46−-- itemsByOrder = aggregate $ do

47−-- item <- each itemSchema

48−-- let orderId = groupBy (itemOrderId item)

49−-- let orderItems = listAgg item

50−-- pure (orderId, orderItems)

51−-- @

52−groupBy :: forall exprs aggregates. (EqTable exprs, Aggregates aggregates exprs)

40+groupBy :: forall exprs. EqTable exprs => exprs -> Aggregate exprs

53− => exprs -> aggregates

41+groupBy (toColumns -> exprs) = fromColumns $ htabulate $ \field ->

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

42+ case hfield (eqTable @exprs) field of

60 Dict -> case hfield exprs field of

43 Dict -> case hfield exprs field of

61− expr -> groupByExpr expr

44+ DB expr -> Aggregation $ groupByExpr expr

64-- | Aggregate rows into a single row containing an array of all aggregated

47-- | Aggregate rows into a single row containing an array of all aggregated

@@ -71,22 +54,38 @@ hgroupBy eqs exprs = htabulate $ \field ->

71-- items:

54-- items:

72--

55--

73-- @

56-- @

74−-- ordersWithItems :: Query (Order Expr, ListTable Expr (Item Expr))

57+-- ordersWithItems :: Query (Order Expr, ListTable (Item Expr))

75-- ordersWithItems = do

58-- ordersWithItems = do

76-- order <- each orderSchema

59-- order <- each orderSchema

77-- items <- aggregate $ listAgg <$> itemsFromOrder order

60-- items <- aggregate $ listAgg <$> itemsFromOrder order

78-- return (order, items)

61-- return (order, items)

79-- @

62-- @

80−listAgg :: Aggregates aggregates exprs => exprs -> ListTable Aggregate aggregates

63+listAgg :: Table Expr a => a -> Aggregate (ListTable a)

81listAgg (toColumns -> exprs) = fromColumns $

64listAgg (toColumns -> exprs) = fromColumns $

82 hvectorize

65 hvectorize

83− (\Spec {info} (Identity a) -> slistAggExpr info a)

66+ (\_ (Identity (DB a)) -> Aggregation $ listAggExpr a)

84 (pure exprs)

67 (pure exprs)

87-- | Like 'listAgg', but the result is guaranteed to be a non-empty list.

70-- | Like 'listAgg', but the result is guaranteed to be a non-empty list.

88−nonEmptyAgg :: Aggregates aggregates exprs => exprs -> NonEmptyTable Aggregate aggregates

71+nonEmptyAgg :: Table Expr a => a -> Aggregate (NonEmptyTable a)

89nonEmptyAgg (toColumns -> exprs) = fromColumns $

72nonEmptyAgg (toColumns -> exprs) = fromColumns $

90 hvectorize

73 hvectorize

91− (\Spec {info} (Identity a) -> snonEmptyAggExpr info a)

74+ (\_ (Identity (DB a)) -> Aggregation $ nonEmptyAggExpr a)

75+ (pure exprs)

76+

77+

78+listAggWithOrder :: Table Expr a

79+ => Order o -> o -> a -> Aggregate (ListTable a)

80+listAggWithOrder order o (toColumns -> exprs) = fromColumns $

81+ hvectorize

82+ (\_ (Identity (DB x)) -> Aggregation $ listAggExprWithOrder order o x)

83+ (pure exprs)

84+

85+

86+nonEmptyAggWithOrder :: Table Expr a

87+ => Order o -> o -> a -> Aggregate (NonEmptyTable a)

88+nonEmptyAggWithOrder order o (toColumns -> exprs) = fromColumns $

89+ hvectorize

90+ (\_ (Identity (DB x)) -> Aggregation $ nonEmptyAggExprWithOrder order o x)

92 (pure exprs)

91 (pure exprs)

src/Rel8/Table/Bool.hs+6−12

@@ -5,7 +5,6 @@

5module Rel8.Table.Bool

6 ( bool

7 , case_

8− , nullable

9 )

8 )

10where

9where

@@ -13,9 +12,8 @@ where

13import Prelude

12import Prelude

15-- rel8

14-- rel8

16−import Rel8.Expr ( Expr )

15+import Rel8.Expr ( Expr, Col(..) )

17import Rel8.Expr.Bool ( boolExpr, caseExpr )

16import Rel8.Expr.Bool ( boolExpr, caseExpr )

18−import Rel8.Expr.Null ( isNull, unsafeUnnullify )

19import Rel8.Schema.HTable ( htabulate, hfield )

17import Rel8.Schema.HTable ( htabulate, hfield )

20import Rel8.Table ( Table, fromColumns, toColumns )

18import Rel8.Table ( Table, fromColumns, toColumns )

@@ -28,7 +26,8 @@ bool :: Table Expr a => a -> a -> Expr Bool -> a

28bool (toColumns -> false) (toColumns -> true) condition =

26bool (toColumns -> false) (toColumns -> true) condition =

29 fromColumns $ htabulate $ \field ->

27 fromColumns $ htabulate $ \field ->

30 case (hfield false field, hfield true field) of

28 case (hfield false field, hfield true field) of

29+ (DB falseExpr, DB trueExpr) ->

31− (falseExpr, trueExpr) -> boolExpr falseExpr trueExpr condition

30+ DB (boolExpr falseExpr trueExpr condition)

32{-# INLINABLE bool #-}

31{-# INLINABLE bool #-}

@@ -38,11 +37,6 @@ bool (toColumns -> false) (toColumns -> true) condition =

38case_ :: Table Expr a => [(Expr Bool, a)] -> a -> a

37case_ :: Table Expr a => [(Expr Bool, a)] -> a -> a

39case_ (map (fmap toColumns) -> branches) (toColumns -> fallback) =

38case_ (map (fmap toColumns) -> branches) (toColumns -> fallback) =

40 fromColumns $ htabulate $ \field -> case hfield fallback field of

39 fromColumns $ htabulate $ \field -> case hfield fallback field of

41− fallbackExpr ->

40+ DB fallbackExpr ->

42− case map (fmap (`hfield` field)) branches of

41+ case map (fmap (unDB . (`hfield` field))) branches of

43− branchExprs -> caseExpr branchExprs fallbackExpr

42+ branchExprs -> DB (caseExpr branchExprs fallbackExpr)

44−

45−

46−-- | Like 'maybe', but to eliminate @null@.

47−nullable :: Table Expr b => b -> (Expr a -> b) -> Expr (Maybe a) -> b

48−nullable b f ma = bool (f (unsafeUnnullify ma)) b (isNull ma)

src/Rel8/Table/Cols.hsdeleted−50

@@ -1,50 +0,0 @@

1−{-# language DataKinds #-}

2−{-# language FlexibleInstances #-}

3−{-# language MultiParamTypeClasses #-}

4−{-# language StandaloneKindSignatures #-}

5−{-# language TypeFamilies #-}

6−{-# language UndecidableInstances #-}

7−

8−module Rel8.Table.Cols

9− ( Cols( Cols )

10− , fromCols

11− , toCols

12− )

13−where

14−

15−-- base

16−import Data.Kind ( Type )

17−import Prelude

18−

19−-- rel8

20−import qualified Rel8.Schema.Kind as K

21−import Rel8.Schema.HTable ( HTable )

22−import Rel8.Schema.Result ( Result )

23−import Rel8.Table ( Table(..) )

24−

25−

26−type Cols :: K.Context -> K.HTable -> Type

27−newtype Cols context columns = Cols (columns context)

28−

29−

30−instance (HTable columns, context ~ context') =>

31− Table context' (Cols context columns)

32− where

33− type Columns (Cols context columns) = columns

34− type Context (Cols context columns) = context

35− type FromExprs (Cols context columns) = Cols Result columns

36− type Transpose to (Cols context columns) = Cols to columns

37−

38− toColumns (Cols a) = a

39− fromColumns = Cols

40−

41− toResult (Cols a) = a

42− fromResult = Cols

43−

44−

45−fromCols :: Table context a => Cols context (Columns a) -> a

46−fromCols (Cols a) = fromColumns a

47−

48−

49−toCols :: Table context a => a -> Cols context (Columns a)

50−toCols = Cols . toColumns

src/Rel8/Table/Either.hs+152−147

@@ -18,226 +18,231 @@ module Rel8.Table.Either

18 ( EitherTable(..)

19 , eitherTable, leftTable, rightTable

20 , isLeftTable, isRightTable

21− , aggregateEitherTable

21+ , aggregateEitherTable, insertEitherTable, nameEitherTable

22− , nameEitherTable

23 )

22 )

24where

23where

26-- base

25-- base

26+import Control.Applicative ( liftA2 )

27import Data.Bifunctor ( Bifunctor, bimap )

28−import Data.Functor.Identity ( Identity( Identity ) )

28+import Data.Functor.Identity ( runIdentity )

29import Data.Kind ( Type )

30import Prelude hiding ( undefined )

32−-- comonad

33−import Control.Comonad ( extract )

34−

35-- rel8

32-- rel8

36−import Rel8.Aggregate ( Aggregate )

33+import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )

37import Rel8.Expr ( Expr )

34import Rel8.Expr ( Expr )

38−import Rel8.Expr.Aggregate ( groupByExpr )

35+import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )

39import Rel8.Expr.Serialize ( litExpr )

36import Rel8.Expr.Serialize ( litExpr )

40−import Rel8.Kind.Context ( Reifiable )

37+import Rel8.Schema.Context.Label

38+ ( Labelable

39+ , HLabelable, hlabeler, hunlabeler

40+ )

41−import Rel8.Schema.Context.Nullify ( Nullifiable )

41+import Rel8.Schema.Context.Nullify

42+ ( Nullifiable, ConstrainTag

43+ , HNullifiable, HConstrainTag

44+ , hencodeTag, hdecodeTag

45+ , hnullifier, hunnullifier

46+ )

42−import Rel8.Schema.Dict ( Dict( Dict ) )

47+import Rel8.Schema.HTable ( HTable )

43import Rel8.Schema.HTable.Either ( HEitherTable(..) )

48import Rel8.Schema.HTable.Either ( HEitherTable(..) )

44import Rel8.Schema.HTable.Identity ( HIdentity(..) )

49import Rel8.Schema.HTable.Identity ( HIdentity(..) )

45import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

50import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

46−import qualified Rel8.Schema.Kind as K

51+import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )

52+import Rel8.Schema.Insert ( Insert )

47import Rel8.Schema.Name ( Name )

53import Rel8.Schema.Name ( Name )

48import Rel8.Table

54import Rel8.Table

49 ( Table, Columns, Context, fromColumns, toColumns

55 ( Table, Columns, Context, fromColumns, toColumns

50− , FromExprs, fromResult, toResult

56+ , reify, unreify

51− , Transpose

52 )

57 )

53import Rel8.Table.Bool ( bool )

58import Rel8.Table.Bool ( bool )

54import Rel8.Table.Eq ( EqTable, eqTable )

59import Rel8.Table.Eq ( EqTable, eqTable )

55−import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )

60+import Rel8.Table.Insert ( toInsert )

56import Rel8.Table.Ord ( OrdTable, ordTable )

61import Rel8.Table.Ord ( OrdTable, ordTable )

57−import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )

62+import Rel8.Table.Recontextualize ( Recontextualize )

58−import Rel8.Table.Serialize ( ToExprs )

63+import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )

64+import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )

59import Rel8.Table.Undefined ( undefined )

65import Rel8.Table.Undefined ( undefined )

60import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )

66import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )

62-- semigroupoids

68-- semigroupoids

63−import Data.Functor.Apply ( Apply, (<.>) )

69+import Data.Functor.Apply ( Apply, (<.>), liftF3 )

64import Data.Functor.Bind ( Bind, (>>-) )

70import Data.Functor.Bind ( Bind, (>>-) )

67−-- | An @EitherTable a b@ is a Rel8 table that contains either the table @a@ or

68−-- the table @b@. You can construct an @EitherTable@ using 'leftTable' and

69−-- 'rightTable', and eliminate/pattern match using 'eitherTable'.

70−--

71−-- An @EitherTable@ is operationally the same as Haskell's 'Either' type, but

72−-- adapted to work with Rel8.

73−type EitherTable :: K.Context -> Type -> Type -> Type

73+type EitherTable :: Type -> Type -> Type

74−data EitherTable context a b = EitherTable

74+data EitherTable a b = EitherTable

75− { tag :: context EitherTag

75+ { tag :: Tag "isRight" EitherTag

76− , left :: Nullify context a

76+ , left :: a

77− , right :: Nullify context b

77+ , right :: b

78 }

79 deriving stock Functor

82−instance Biprojectable (EitherTable context) where

83− biproject f g (EitherTable tag a b) =

84− EitherTable tag (project f a) (project g b)

85−

86−

87−instance Nullifiable context => Bifunctor (EitherTable context) where

82+instance Bifunctor EitherTable where

88− bimap f g (EitherTable tag a b) = EitherTable tag (fmap f a) (fmap g b)

83+ bimap f g (EitherTable tag a b) = EitherTable tag (f a) (g b)

89−

90−

91−instance Projectable (EitherTable context a) where

92− project f (EitherTable tag a b) = EitherTable tag a (project f b)

95−instance (context ~ Expr, Table Expr a) => Apply (EitherTable context a) where

86+instance Table Expr a => Apply (EitherTable a) where

96 EitherTable tag l1 f <.> EitherTable tag' l2 a =

87 EitherTable tag l1 f <.> EitherTable tag' l2 a =

97− EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f <.> a)

88+ EitherTable (tag <> tag') (bool l1 l2 (isLeft (expr tag))) (f a)

100−instance (context ~ Expr, Table Expr a) => Applicative (EitherTable context a) where

91+instance Table Expr a => Applicative (EitherTable a) where

101 pure = rightTable

92 pure = rightTable

102 (<*>) = (<.>)

93 (<*>) = (<.>)

103

104

105−instance (context ~ Expr, Table Expr a) => Bind (EitherTable context a) where

96+instance Table Expr a => Bind (EitherTable a) where

106− EitherTable tag l1 a >>- f = case f (extract a) of

97+ EitherTable tag l1 a >>- f = case f a of

107 EitherTable tag' l2 b ->

98 EitherTable tag' l2 b ->

108− EitherTable (tag <> tag') (bool l1 l2 (isRight tag)) b

99+ EitherTable (tag <> tag') (bool l1 l2 (isRight (expr tag))) b

109

100

110

101

111−instance (context ~ Expr, Table Expr a) => Monad (EitherTable context a) where

102+instance Table Expr a => Monad (EitherTable a) where

112 (>>=) = (>>-)

103 (>>=) = (>>-)

113

104

114

105

115−instance (context ~ Expr, Table Expr a, Table Expr b) =>

106+instance (Table Expr a, Table Expr b) => Semigroup (EitherTable a b) where

116− Semigroup (EitherTable context a b)

117− where

118 a <> b = bool a b (isRightTable a)

107 a <> b = bool a b (isRightTable a)

119

108

120

109

121instance

110instance

122 ( Table context a, Table context b

111 ( Table context a, Table context b

123− , Reifiable context, context ~ context'

112+ , Labelable context, Nullifiable context, ConstrainTag context EitherTag

124− )

113+ ) =>

125− => Table context' (EitherTable context a b)

114+ Table context (EitherTable a b)

126− where

127− type Columns (EitherTable context a b) = HEitherTable (Columns a) (Columns b)

128− type Context (EitherTable context a b) = Context a

129− type FromExprs (EitherTable context a b) = Either (FromExprs a) (FromExprs b)

130− type Transpose to (EitherTable context a b) =

131− EitherTable to (Transpose to a) (Transpose to b)

132−

133− toColumns EitherTable {tag, left, right} = HEitherTable

134− { htag = hlabel $ HIdentity tag

135− , hleft = hlabel $ guard tag (== IsLeft) isLeft $ toColumns left

136− , hright = hlabel $ guard tag (== IsRight) isRight $ toColumns right

137− }

138−

139− fromColumns HEitherTable {htag, hleft, hright} = EitherTable

140− { tag = unHIdentity $ hunlabel htag

141− , left = fromColumns $ hunlabel hleft

142− , right = fromColumns $ hunlabel hright

143− }

144−

145− toResult = \case

146− Left table -> HEitherTable

147− { htag = hlabel (HIdentity (Identity IsLeft))

148− , hleft = hlabel (toResult @_ @(Nullify context a) (Just table))

149− , hright = hlabel (toResult @_ @(Nullify context b) Nothing)

150− }

151− Right table -> HEitherTable

152− { htag = hlabel (HIdentity (Identity IsRight))

153− , hleft = hlabel (toResult @_ @(Nullify context a) Nothing)

154− , hright = hlabel (toResult @_ @(Nullify context b) (Just table))

155− }

156−

157− fromResult HEitherTable {htag, hleft, hright} = case hunlabel htag of

158− HIdentity (Identity tag) -> case tag of

159− IsLeft -> maybe err Left $ fromResult @_ @(Nullify context a) (hunlabel hleft)

160− IsRight -> maybe err Right $ fromResult @_ @(Nullify context b) (hunlabel hright)

161− where

162− err = error "Either.fromColumns: mismatch between tag and data"

163−

164−

165−instance (EqTable a, EqTable b, context ~ Expr) =>

166− EqTable (EitherTable context a b)

167 where

115 where

168− eqTable = HEitherTable

116+ type Columns (EitherTable a b) = HEitherTable (Columns a) (Columns b)

169− { htag = hlabel (HIdentity Dict)

117+ type Context (EitherTable a b) = Context a

170− , hleft = hlabel (eqTable @(Nullify context a))

171− , hright = hlabel (eqTable @(Nullify context b))

172− }

173

118

119+ toColumns = toColumns2 toColumns toColumns

120+ fromColumns = fromColumns2 fromColumns fromColumns

121+ reify = liftA2 bimap reify reify

122+ unreify = liftA2 bimap unreify unreify

174

123

175−instance (OrdTable a, OrdTable b, context ~ Expr) =>

124+

176− OrdTable (EitherTable context a b)

125+instance

177− where

126+ ( Nullifiable from, Labelable from, ConstrainTag from EitherTag

178− ordTable = HEitherTable

127+ , Nullifiable to, Labelable to, ConstrainTag to EitherTag

179− { htag = hlabel (HIdentity Dict)

128+ , Recontextualize from to a1 b1

180− , hleft = hlabel (ordTable @(Nullify context a))

129+ , Recontextualize from to a2 b2

181− , hright = hlabel (ordTable @(Nullify context b))

130+ )

182− }

131+ => Recontextualize from to (EitherTable a1 a2) (EitherTable b1 b2)

132+

133+

134+instance (EqTable a, EqTable b) => EqTable (EitherTable a b) where

135+ eqTable = toColumns2 id id (rightTableWith (eqTable @a) (eqTable @b))

136+

137+

138+instance (OrdTable a, OrdTable b) => OrdTable (EitherTable a b) where

139+ ordTable = toColumns2 id id (rightTableWith (ordTable @a) (ordTable @b))

140+

141+

142+type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)

183

143

184

144

185−instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable Expr exprs1 exprs2) =>

145+instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable exprs1 exprs2) =>

186 ToExprs x (Either a b)

146 ToExprs x (Either a b)

147+ where

148+ fromResult =

149+ bimap (fromResult @exprs1) (fromResult @exprs2) .

150+ fromColumns

151+ toResult =

152+ toColumns .

153+ bimap (toResult @exprs1) (toResult @exprs2)

187

154

188

155

189−-- | Test if an 'EitherTable' is a 'leftTable'.

190−isLeftTable :: EitherTable Expr a b -> Expr Bool

156+isLeftTable :: EitherTable a b -> Expr Bool

191−isLeftTable EitherTable {tag} = isLeft tag

157+isLeftTable = isLeft . expr . tag

192

158

193

159

194−-- | Test if an 'EitherTable' is a 'rightTable'.

195−isRightTable :: EitherTable Expr a b -> Expr Bool

160+isRightTable :: EitherTable a b -> Expr Bool

196−isRightTable EitherTable {tag} = isRight tag

161+isRightTable = isRight . expr . tag

197

162

198

163

199−-- | Pattern match/eliminate an 'EitherTable', by providing mappings from a

200−-- 'leftTable' and 'rightTable'.

201eitherTable :: Table Expr c

164eitherTable :: Table Expr c

202− => (a -> c) -> (b -> c) -> EitherTable Expr a b -> c

165+ => (a -> c) -> (b -> c) -> EitherTable a b -> c

203eitherTable f g EitherTable {tag, left, right} =

166eitherTable f g EitherTable {tag, left, right} =

204− bool (f (extract left)) (g (extract right)) (isRight tag)

167+ bool (f left) (g right) (isRight (expr tag))

168+

169+

170+leftTable :: Table Expr b => a -> EitherTable a b

171+leftTable a = EitherTable (fromExpr (litExpr IsLeft)) a undefined

205

172

206

173

207−-- | Construct a left 'EitherTable'. Like 'Left'.

208−leftTable :: Table Expr b => a -> EitherTable Expr a b

174+rightTable :: Table Expr a => b -> EitherTable a b

209−leftTable a = EitherTable (litExpr IsLeft) (pure a) undefined

175+rightTable = rightTableWith undefined

210

176

211

177

212−-- | Construct a right 'EitherTable'. Like 'Right'.

213−rightTable :: Table Expr a => b -> EitherTable Expr a b

178+rightTableWith :: a -> b -> EitherTable a b

214−rightTable = EitherTable (litExpr IsRight) undefined . pure

179+rightTableWith = EitherTable (fromExpr (litExpr IsRight))

215

180

216

181

217−-- | Lift a pair of aggregating functions to operate on an 'EitherTable'.

218−-- @leftTable@s and @rightTable@s are grouped separately.

219aggregateEitherTable :: ()

182aggregateEitherTable :: ()

220− => (exprs -> aggregates)

183+ => (a -> Aggregate c)

221− -> (exprs' -> aggregates')

184+ -> (b -> Aggregate d)

222− -> EitherTable Expr exprs exprs'

185+ -> EitherTable a b

223− -> EitherTable Aggregate aggregates aggregates'

186+ -> Aggregate (EitherTable c d)

224−aggregateEitherTable f g (EitherTable tag a b) = EitherTable

187+aggregateEitherTable f g EitherTable {tag, left, right} =

225− { tag = groupByExpr tag

188+ liftF3 EitherTable (tag <$ aggregate) (f left) (g right)

226− , left = aggregateNullify f a

189+ where

227− , right = aggregateNullify g b

190+ Tag {aggregator, expr} = tag

191+ aggregate = unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr

192+

193+

194+insertEitherTable :: (Table Insert a, Table Insert b)

195+ => Either a b -> EitherTable a b

196+insertEitherTable = \case

197+ Left a -> EitherTable (fromExpr (litExpr IsLeft)) a (fromColumns (toInsert undefined))

198+ Right b -> EitherTable (fromExpr (litExpr IsRight)) (fromColumns (toInsert undefined)) b

199+

200+

201+nameEitherTable :: Name EitherTag -> a -> b -> EitherTable a b

202+nameEitherTable = EitherTable . fromName

203+

204+

205+toColumns2 ::

206+ ( HTable t

207+ , HTable u

208+ , HConstrainTag context EitherTag

209+ , HLabelable context

210+ , HNullifiable context

211+ )

212+ => (a -> t context)

213+ -> (b -> u context)

214+ -> EitherTable a b

215+ -> HEitherTable t u context

216+toColumns2 f g EitherTable {tag, left, right} = HEitherTable

217+ { htag

218+ , hleft = hlabel hlabeler $ hnullify (hnullifier tag isLeft) $ f left

219+ , hright = hlabel hlabeler $ hnullify (hnullifier tag isRight) $ g right

228 }

220 }

221+ where

222+ htag = HIdentity (hencodeTag tag)

229

223

230

224

231−-- | Construct a 'EitherTable' in the 'Name' context. This can be useful if you

225+fromColumns2 ::

232−-- have a 'EitherTable' that you are storing in a table and need to construct a

226+ ( HTable t

233−-- 'TableSchema'.

227+ , HTable u

234−nameEitherTable

235− :: Name EitherTag

228+ , HConstrainTag context EitherTag

236− -- ^ The name of the column to track whether a row is a 'leftTable' or

229+ , HLabelable context

237− -- 'rightTable'.

230+ , HNullifiable context

238− -> a

231+ )

239− -- ^ Names of the columns in the @a@ table.

232+ => (t context -> a)

240− -> b

233+ -> (u context -> b)

241− -- ^ Names of the columns in the @b@ table.

234+ -> HEitherTable t u context

242− -> EitherTable Name a b

235+ -> EitherTable a b

243−nameEitherTable tag left right = EitherTable tag (pure left) (pure right)

236+fromColumns2 f g HEitherTable {htag, hleft, hright} = EitherTable

237+ { tag

238+ , left = f $ runIdentity $

239+ hunnullify (\a -> pure . hunnullifier a) $

240+ hunlabel hunlabeler

241+ hleft

242+ , right = g $ runIdentity $

243+ hunnullify (\a -> pure . hunnullifier a) $

244+ hunlabel hunlabeler

245+ hright

246+ }

247+ where

248+ tag = hdecodeTag $ unHIdentity htag

src/Rel8/Table/Eq.hs+39−12

@@ -11,6 +11,7 @@

11{-# language TypeFamilies #-}

12{-# language TypeOperators #-}

13{-# language UndecidableInstances #-}

14+{-# language UndecidableSuperClasses #-}

14{-# language ViewPatterns #-}

15{-# language ViewPatterns #-}

16module Rel8.Table.Eq

17module Rel8.Table.Eq

@@ -27,16 +28,24 @@ import GHC.Generics ( Rep )

27import Prelude

28import Prelude

29-- rel8

30-- rel8

30−import Rel8.Expr ( Expr )

31+import Rel8.Expr ( Expr, Col(..) )

31import Rel8.Expr.Bool ( (||.), (&&.) )

32import Rel8.Expr.Bool ( (||.), (&&.) )

32import Rel8.Expr.Eq ( (==.), (/=.) )

33import Rel8.Expr.Eq ( (==.), (/=.) )

33import Rel8.FCF ( Eval, Exp )

34import Rel8.FCF ( Eval, Exp )

34import Rel8.Generic.Record ( Record )

35import Rel8.Generic.Record ( Record )

35−import Rel8.Generic.Table.Record ( GTable, GColumns, gtable )

36+import Rel8.Generic.Table

37+ ( GGTable, GGColumns, ggtable

38+ , GAlgebra

39+ )

40+import Rel8.Kind.Algebra ( KnownAlgebra )

36import Rel8.Schema.Dict ( Dict( Dict ) )

41import Rel8.Schema.Dict ( Dict( Dict ) )

37−import Rel8.Schema.HTable ( htabulateA, hfield )

42+import Rel8.Schema.HTable

43+ ( HTable, HConstrainTable

44+ , htabulateA, hfield, hdicts

45+ )

38−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

46+import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )

39import Rel8.Schema.Null ( Sql )

47import Rel8.Schema.Null ( Sql )

48+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType, nullifier )

40import Rel8.Table ( Table, Columns, toColumns, TColumns )

49import Rel8.Table ( Table, Columns, toColumns, TColumns )

41import Rel8.Type.Eq ( DBEq )

50import Rel8.Type.Eq ( DBEq )

@@ -46,14 +55,22 @@ import Rel8.Type.Eq ( DBEq )

46-- means "all columns in a 'Table' have an instance of 'DBEq'".

55-- means "all columns in a 'Table' have an instance of 'DBEq'".

47type EqTable :: Type -> Constraint

56type EqTable :: Type -> Constraint

48class Table Expr a => EqTable a where

57class Table Expr a => EqTable a where

49− eqTable :: Columns a (Dict (Sql DBEq))

58+ eqTable :: Columns a (Dict (ConstrainDBType DBEq))

51 default eqTable ::

60 default eqTable ::

61+ ( KnownAlgebra (GAlgebra (Rep (Record a)))

52− ( GTable TEqTable TColumns (Rep (Record a))

62+ , Eval (GGTable (GAlgebra (Rep (Record a))) TEqTable TColumns (Dict (ConstrainDBType DBEq)) (Rep (Record a)))

53− , Columns a ~ GColumns TColumns (Rep (Record a))

63+ , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))

54 )

64 )

55− => Columns a (Dict (Sql DBEq))

65+ => Columns a (Dict (ConstrainDBType DBEq))

56− eqTable = gtable @TEqTable @TColumns @(Rep (Record a)) table

66+ eqTable =

67+ ggtable

68+ @(GAlgebra (Rep (Record a)))

69+ @TEqTable

70+ @TColumns

71+ @(Rep (Record a))

72+ table

73+ nullifier

57 where

74 where

58 table (_ :: proxy x) = eqTable @x

75 table (_ :: proxy x) = eqTable @x

@@ -62,8 +79,18 @@ data TEqTable :: Type -> Exp Constraint

62type instance Eval (TEqTable a) = EqTable a

79type instance Eval (TEqTable a) = EqTable a

82+instance

83+ ( HTable t

84+ , f ~ Col Expr

85+ , HConstrainTable t (ConstrainDBType DBEq)

86+ )

87+ => EqTable (t f)

88+ where

89+ eqTable = hdicts @(Columns (t f)) @(ConstrainDBType DBEq)

90+

91+

65instance Sql DBEq a => EqTable (Expr a) where

92instance Sql DBEq a => EqTable (Expr a) where

66− eqTable = HIdentity Dict

93+ eqTable = HType Dict

69instance (EqTable a, EqTable b) => EqTable (a, b)

96instance (EqTable a, EqTable b) => EqTable (a, b)

@@ -97,7 +124,7 @@ instance

97(toColumns -> as) ==: (toColumns -> bs) =

124(toColumns -> as) ==: (toColumns -> bs) =

98 foldl1' (&&.) $ getConst $ htabulateA $ \field ->

125 foldl1' (&&.) $ getConst $ htabulateA $ \field ->

99 case (hfield as field, hfield bs field) of

126 case (hfield as field, hfield bs field) of

100− (a, b) -> case hfield (eqTable @a) field of

127+ (DB a, DB b) -> case hfield (eqTable @a) field of

101 Dict -> Const (pure (a ==. b))

128 Dict -> Const (pure (a ==. b))

102infix 4 ==:

129infix 4 ==:

103

130

@@ -109,7 +136,7 @@ infix 4 ==:

109(toColumns -> as) /=: (toColumns -> bs) =

136(toColumns -> as) /=: (toColumns -> bs) =

110 foldl1' (||.) $ getConst $ htabulateA $ \field ->

137 foldl1' (||.) $ getConst $ htabulateA $ \field ->

111 case (hfield as field, hfield bs field) of

138 case (hfield as field, hfield bs field) of

112− (a, b) -> case hfield (eqTable @a) field of

139+ (DB a, DB b) -> case hfield (eqTable @a) field of

113 Dict -> Const (pure (a /=. b))

140 Dict -> Const (pure (a /=. b))

114infix 4 /=:

141infix 4 /=:

115

142

src/Rel8/Table/HKD.hs+109−91

@@ -13,12 +13,11 @@

14module Rel8.Table.HKD

15 ( HKD( HKD )

16− , HKDable

16+ , HKDable, fromHKD, toHKD, HKDT(..)

17− , BuildableHKD

18− , BuildHKD, buildHKD

19 , ConstructableHKD

17 , ConstructableHKD

20 , ConstructHKD, constructHKD

18 , ConstructHKD, constructHKD

21 , DeconstructHKD, deconstructHKD

19 , DeconstructHKD, deconstructHKD

20+ , InsertHKD, insertHKD

22 , NameHKD, nameHKD

21 , NameHKD, nameHKD

23 , AggregateHKD, aggregateHKD

22 , AggregateHKD, aggregateHKD

24 , HKDRep

23 , HKDRep

@@ -27,8 +26,9 @@ where

28-- base

27-- base

29import Data.Kind ( Constraint, Type )

28import Data.Kind ( Constraint, Type )

29+import Data.Proxy ( Proxy( Proxy ) )

30+import Data.Type.Equality ( (:~:)( Refl ) )

30import GHC.Generics ( Generic, Rep, from, to )

31import GHC.Generics ( Generic, Rep, from, to )

31−import GHC.TypeLits ( Symbol )

32import Prelude

34-- rel8

@@ -38,146 +38,158 @@ import Rel8.Expr ( Expr )

38import Rel8.FCF ( Eval, Exp )

39import Rel8.Kind.Algebra ( KnownAlgebra )

40import Rel8.Generic.Construction

41− ( GGBuildable

42− , GGBuild, ggbuild

43− , GGConstructable

41+ ( GGConstructable

44 , GGConstruct, ggconstruct

42 , GGConstruct, ggconstruct

45 , GGDeconstruct, ggdeconstruct

43 , GGDeconstruct, ggdeconstruct

44+ , GGInsert, gginsert

46 , GGName, ggname

45 , GGName, ggname

47 , GGAggregate, ggaggregate

46 , GGAggregate, ggaggregate

48 )

47 )

49−import Rel8.Generic.Map ( GMap )

48+import Rel8.Generic.Map ( GMap, GMappable, gmap, gunmap )

50−import Rel8.Generic.Record

51− ( GRecord, GRecordable, grecord, gunrecord

49+import Rel8.Generic.Record ( GRecord, GRecordable, grecord, gunrecord )

52− , Record( Record ), unrecord

53− )

54import Rel8.Generic.Rel8able

50import Rel8.Generic.Rel8able

55 ( Rel8able

51 ( Rel8able

56 , GColumns, gfromColumns, gtoColumns

52 , GColumns, gfromColumns, gtoColumns

57− , GFromExprs, gfromResult, gtoResult

53+ , greify, gunreify

54+ , TUnreifyContext

58 )

55 )

59import Rel8.Generic.Table

56import Rel8.Generic.Table

60− ( GGSerialize, GGColumns, GAlgebra, ggfromResult, ggtoResult

57+ ( GGTable, GGColumns, GGContext, ggfromColumns, ggtoColumns

58+ , GAlgebra

61 )

59 )

62−import Rel8.Generic.Table.Record ( GTable, GContext )

60+import Rel8.Schema.Context ( Col )

63−import qualified Rel8.Generic.Table.Record as G

64import qualified Rel8.Schema.Kind as K

61import qualified Rel8.Schema.Kind as K

65import Rel8.Schema.HTable ( HTable )

62import Rel8.Schema.HTable ( HTable )

63+import Rel8.Schema.Insert ( Insert )

66import Rel8.Schema.Name ( Name )

64import Rel8.Schema.Name ( Name )

65+import Rel8.Schema.Reify ( Col( Reify ), Reify, hreify, hunreify )

67import Rel8.Schema.Result ( Result )

66import Rel8.Schema.Result ( Result )

68import Rel8.Table

67import Rel8.Table

68+ ( Table, Columns

69− ( Table, fromColumns, toColumns, fromResult, toResult

69+ , fromColumns, toColumns, reify, unreify

70− , TTable, TColumns, TContext

70+ , TTable, TColumns, TUnreify

71− , TSerialize

72 )

71 )

72+import Rel8.Table.Serialize ( ToExprs, fromResult, toResult )

75type GColumnsHKD :: Type -> K.HTable

76type GColumnsHKD a =

77− Eval (GGColumns (GAlgebra (Rep a)) TColumns (GRecord (GMap (TColumn Expr) (Rep a))))

77+ Eval (GGColumns (GAlgebra (Rep a)) TColumns (GRecord (GMap (TColumn (Reify Result)) (Rep a))))

80type HKD :: Type -> K.Rel8able

81−newtype HKD a f = HKD (GColumnsHKD a f)

81+newtype HKD a f = HKD (GColumnsHKD a (Col f))

84instance 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

91− gfromResult =

87+ gfromColumns = HKD

92− unrecord .

88+ gtoColumns (HKD a) = a

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 =

90+ greify (HKD a) = HKD (hreify a)

103− ggtoResult

91+ gunreify (HKD a) = HKD (hunreify a)

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

114instance

94instance

95+ ( KnownAlgebra (GAlgebra (Rep a))

96+ , HTable (GColumnsHKD a)

115− ( GTable (TTable f) TColumns (GRecord (GMap (TColumn f) (Rep a)))

97+ , Eval (GGTable (GAlgebra (Rep a)) (TTable (Reify f)) TColumns (Col (Reify f)) (GRecord (GMap (TColumn (Reify f)) (Rep a))))

116− , G.GColumns TColumns (GRecord (GMap (TColumn f) (Rep a))) ~ GColumnsHKD a

98+ , Eval (GGColumns (GAlgebra (Rep a)) TColumns (GRecord (GMap (TColumn (Reify f)) (Rep a)))) ~ GColumnsHKD a

117− , GContext TContext (GRecord (GMap (TColumn f) (Rep a))) ~ f

99+ , Eval (GGContext (GAlgebra (Rep a)) TUnreifyContext (GRecord (GMap (TColumn (Reify f)) (Rep a)))) ~ f

118− , GRecordable (GMap (TColumn f) (Rep a))

100+ , GRecordable (GMap (TColumn (Reify f)) (Rep a))

101+ , GMappable (TTable (Reify f)) (GMap (TColumn (Reify f)) (Rep a))

102+ , GMap TUnreify (GMap (TColumn (Reify f)) (Rep a)) ~ GMap (TColumn f) (Rep a)

119 )

103 )

120 => Generic (HKD a f)

104 => Generic (HKD a f)

121 where

105 where

122 type Rep (HKD a f) = GMap (TColumn f) (Rep a)

106 type Rep (HKD a f) = GMap (TColumn f) (Rep a)

123

107

124 from =

108 from =

109+ gmap @(TTable (Reify f)) (Proxy @TUnreify) (unreify Refl) .

125− gunrecord @(GMap (TColumn f) (Rep a)) .

110+ gunrecord @(GMap (TColumn (Reify f)) (Rep a)) .

126− G.gfromColumns

111+ ggfromColumns

112+ @(GAlgebra (Rep a))

127− @(TTable f)

113+ @(TTable (Reify f))

128 @TColumns

114 @TColumns

115+ (\(Reify a) -> a)

116+ Reify

129 fromColumns .

117 fromColumns .

118+ hreify .

130 (\(HKD a) -> a)

119 (\(HKD a) -> a)

131

120

132 to =

121 to =

133 HKD .

122 HKD .

134− G.gtoColumns

123+ hunreify .

124+ ggtoColumns

125+ @(GAlgebra (Rep a))

135− @(TTable f)

126+ @(TTable (Reify f))

136 @TColumns

127 @TColumns

128+ (\(Reify a) -> a)

129+ Reify

137 toColumns .

130 toColumns .

138− grecord @(GMap (TColumn f) (Rep a))

131+ grecord @(GMap (TColumn (Reify f)) (Rep a)) .

132+ gunmap @(TTable (Reify f)) (Proxy @TUnreify) (reify Refl)

133+

134+

135+type HKDT :: Type -> Type

136+newtype HKDT a = HKDT

137+ { unHKDT :: a

138+ }

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

150instance

141instance

151− ( Generic (Record a)

142+ ( Table Expr (HKD a Expr)

152− , HTable (GColumns (HKD a))

143+ , Columns (HKD a Expr) ~ GColumns (HKD a)

153− , KnownAlgebra (GAlgebra (Rep a))

144+ , HKDable a

154− , Eval (GGSerialize (GAlgebra (Rep a)) TSerialize TColumns (Eval (HKDRep a Expr)) (Eval (HKDRep a Result)))

145+ , x ~ HKD a Expr

155− , GRecord (GMap (TColumn Result) (Rep a)) ~ Rep (Record a)

156 )

146 )

157− => HKDable a

147+ => ToExprs x (HKDT a)

148+ where

149+ toResult = (\(HKD a) -> a) . toHKD . (\(HKDT a) -> a)

150+ fromResult = HKDT . fromHKD . HKD

158

151

159

152

160−type Top_ :: Constraint

153+fromHKD :: HKDable a => HKD a Result -> a

161−class Top_

154+fromHKD = to . gunmap @Top (Proxy @(TColumn Result)) id . from

162−instance Top_

163

155

164

156

165−data Top :: Type -> Exp Constraint

157+toHKD :: HKDable a => a -> HKD a Result

166−type instance Eval (Top _) = Top_

158+toHKD = to . gmap @Top (Proxy @(TColumn Result)) id . from

167

159

168

160

169−type BuildableHKD :: Type -> Symbol -> Constraint

161+class Top_

170−class GGBuildable (GAlgebra (Rep a)) name (HKDRep a) => BuildableHKD a name

162+instance Top_

171−instance GGBuildable (GAlgebra (Rep a)) name (HKDRep a) => BuildableHKD a name

172

163

173

164

174−type BuildHKD :: Type -> Symbol -> Type

165+data Top :: Type -> Exp Constraint

175−type BuildHKD a name = GGBuild (GAlgebra (Rep a)) name (HKDRep a) (HKD a Expr)

166+type instance Eval (Top _) = Top_

176

167

177

168

178−buildHKD :: forall a name. BuildableHKD a name => BuildHKD a name

169+class

179−buildHKD =

170+ ( Generic a

180− ggbuild @(GAlgebra (Rep a)) @name @(HKDRep a) @(HKD a Expr) HKD

171+ , HTable (GColumns (HKD a))

172+ , KnownAlgebra (GAlgebra (Rep a))

173+ , Eval (GGTable (GAlgebra (Rep a)) (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRecord (GMap (TColumn (Reify Result)) (Rep a))))

174+ , Eval (GGContext (GAlgebra (Rep a)) TUnreifyContext (GRecord (GMap (TColumn (Reify Result)) (Rep a)))) ~ Result

175+ , GRecordable (GMap (TColumn (Reify Result)) (Rep a))

176+ , GMappable Top (Rep a)

177+ , GMappable (TTable (Reify Result)) (GMap (TColumn (Reify Result)) (Rep a))

178+ , GMap TUnreify (GMap (TColumn (Reify Result)) (Rep a)) ~ GMap (TColumn Result) (Rep a)

179+ )

180+ => HKDable a

181+instance

182+ ( Generic a

183+ , HTable (GColumns (HKD a))

184+ , KnownAlgebra (GAlgebra (Rep a))

185+ , Eval (GGTable (GAlgebra (Rep a)) (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRecord (GMap (TColumn (Reify Result)) (Rep a))))

186+ , Eval (GGContext (GAlgebra (Rep a)) TUnreifyContext (GRecord (GMap (TColumn (Reify Result)) (Rep a)))) ~ Result

187+ , GRecordable (GMap (TColumn (Reify Result)) (Rep a))

188+ , GMappable Top (Rep a)

189+ , GMappable (TTable (Reify Result)) (GMap (TColumn (Reify Result)) (Rep a))

190+ , GMap TUnreify (GMap (TColumn (Reify Result)) (Rep a)) ~ GMap (TColumn Result) (Rep a)

191+ )

192+ => HKDable a

181

193

182

194

183type ConstructableHKD :: Type -> Constraint

195type ConstructableHKD :: Type -> Constraint

@@ -186,13 +198,11 @@ instance GGConstructable (GAlgebra (Rep a)) (HKDRep a) => ConstructableHKD a

186

198

187

199

188type ConstructHKD :: Type -> Type

200type ConstructHKD :: Type -> Type

189−type ConstructHKD a = forall r. GGConstruct (GAlgebra (Rep a)) (HKDRep a) r

201+type ConstructHKD a = GGConstruct (GAlgebra (Rep a)) (HKDRep a) (HKD a Expr)

190

202

191

203

192−constructHKD :: forall a. ConstructableHKD a => ConstructHKD a -> HKD a Expr

204+constructHKD :: forall a. ConstructableHKD a => ConstructHKD a

193−constructHKD f =

194− ggconstruct @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) HKD

205+constructHKD = ggconstruct @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) HKD

195− (f @(HKD a Expr))

196

206

197

207

198type DeconstructHKD :: Type -> Type -> Type

208type DeconstructHKD :: Type -> Type -> Type

@@ -204,6 +214,14 @@ deconstructHKD :: forall a r. (ConstructableHKD a, Table Expr r)

204deconstructHKD = ggdeconstruct @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) @r (\(HKD a) -> a)

214deconstructHKD = ggdeconstruct @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) @r (\(HKD a) -> a)

205

215

206

216

217+type InsertHKD :: Type -> Type

218+type InsertHKD a = GGInsert (GAlgebra (Rep a)) (HKDRep a) (HKD a Insert)

219+

220+

221+insertHKD :: forall a. ConstructableHKD a => InsertHKD a

222+insertHKD = gginsert @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Insert) HKD

223+

224+

207type NameHKD :: Type -> Type

225type NameHKD :: Type -> Type

208type NameHKD a = GGName (GAlgebra (Rep a)) (HKDRep a) (HKD a Name)

226type NameHKD a = GGName (GAlgebra (Rep a)) (HKDRep a) (HKD a Name)

209

227

@@ -217,10 +235,10 @@ type AggregateHKD a = forall r. GGAggregate (GAlgebra (Rep a)) (HKDRep a) r

217

235

218

236

219aggregateHKD :: forall a. ConstructableHKD a

237aggregateHKD :: forall a. ConstructableHKD a

220− => AggregateHKD a -> HKD a Expr -> HKD a Aggregate

238+ => AggregateHKD a -> HKD a Expr -> Aggregate (HKD a Expr)

221aggregateHKD f =

239aggregateHKD f =

222− ggaggregate @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) @(HKD a Aggregate) HKD (\(HKD a) -> a)

240+ ggaggregate @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) HKD (\(HKD a) -> a)

223− (f @(HKD a Aggregate))

241+ (f @(Aggregate (HKD a Expr)))

224

242

225

243

226data HKDRep :: Type -> K.Context -> Exp (Type -> Type)

244data HKDRep :: Type -> K.Context -> Exp (Type -> Type)

src/Rel8/Table/Insert.hsnew file+51

@@ -0,0 +1,51 @@

1+{-# language FlexibleContexts #-}

2+{-# language NamedFieldPuns #-}

3+{-# language TypeFamilies #-}

4+{-# language ViewPatterns #-}

6+module Rel8.Table.Insert

7+ ( toInsert

8+ , toInsertDefaults

9+ )

10+where

11+

12+-- base

13+import Prelude

14+

15+-- rel8

16+import Rel8.Expr ( Col(..) )

17+import Rel8.Kind.Necessity ( SNecessity( SOptional, SRequired ) )

18+import Rel8.Schema.HTable ( hfield, htabulate, hspecs )

19+import Rel8.Schema.Insert ( Inserts, Col(..) )

20+import Rel8.Schema.Spec ( SSpec(..) )

21+import Rel8.Table ( fromColumns, toColumns )

22+

23+

24+-- | @toInsert@ converts a 'Table' of 'Expr's into a 'Table' that can be used

25+-- with 'Rel8.insert'. This will override any columns that have default values

26+-- to use exactly what is given. If you want to use default values, you can

27+-- either override the result of @toInsert@, or use 'toInsertDefaults'.

28+toInsert :: Inserts exprs inserts => exprs -> inserts

29+toInsert (toColumns -> exprs) = fromColumns $ htabulate $ \field ->

30+ case hfield hspecs field of

31+ SSpec {necessity} -> case hfield exprs field of

32+ DB expr -> case necessity of

33+ SRequired -> RequiredInsert expr

34+ SOptional -> OptionalInsert (Just expr)

35+

36+

37+-- | @toInsertDefaults@ converts a 'Table' of 'Expr's into a 'Table' that can

38+-- be used with 'Rel8.insert'. Any columns that have a default value will

39+-- override whatever is in the input expression.

40+--

41+-- One example where this is useful is for any table that has a special @id@

42+-- column, which has a default value to draw a new value from a sequence. If we

43+-- use 'toInsertDefaults', we can provide a dummy value that will be replaced

44+-- with a call to @DEFAULT@.

45+toInsertDefaults :: Inserts exprs inserts => exprs -> inserts

46+toInsertDefaults (toColumns -> exprs) = fromColumns $ htabulate $ \field ->

47+ case hfield hspecs field of

48+ SSpec {necessity} -> case hfield exprs field of

49+ DB expr -> case necessity of

50+ SRequired -> RequiredInsert expr

51+ SOptional -> OptionalInsert Nothing

src/Rel8/Table/List.hs+66−71

@@ -1,4 +1,3 @@

1−{-# language DataKinds #-}

2{-# language FlexibleContexts #-}

1{-# language FlexibleContexts #-}

3{-# language FlexibleInstances #-}

2{-# language FlexibleInstances #-}

4{-# language MultiParamTypeClasses #-}

3{-# language MultiParamTypeClasses #-}

@@ -11,36 +10,32 @@

12module Rel8.Table.List

11module Rel8.Table.List

13 ( ListTable(..)

12 ( ListTable(..)

14− , ($*)

15− , listTable

16− , nameListTable

13+ , listTable, insertListTable, nameListTable

17 )

14 )

18where

15where

20-- base

17-- base

21import Data.Functor.Identity ( Identity( Identity ) )

18import Data.Functor.Identity ( Identity( Identity ) )

22import Data.Kind ( Type )

19import Data.Kind ( Type )

20+import Data.Type.Equality ( (:~:)( Refl ) )

23import Prelude

21import Prelude

25-- rel8

23-- rel8

26−import Rel8.Expr ( Expr )

24+import Rel8.Expr ( Expr, Col(..) )

27import Rel8.Expr.Array ( sappend, sempty, slistOf )

25import Rel8.Expr.Array ( sappend, sempty, slistOf )

26+import Rel8.Kind.Necessity ( SNecessity( SOptional, SRequired ) )

28import Rel8.Schema.Dict ( Dict( Dict ) )

27import Rel8.Schema.Dict ( Dict( Dict ) )

29import Rel8.Schema.HTable.List ( HListTable )

28import Rel8.Schema.HTable.List ( HListTable )

30−import Rel8.Schema.HTable.Vectorize

29+import Rel8.Schema.HTable.Vectorize ( happend, hempty, hvectorize )

31− ( hvectorize, hunvectorize

30+import Rel8.Schema.Insert ( Col( OptionalInsert, RequiredInsert ), Insert )

32− , happend, hempty

33− , hproject, hcolumn

34− )

35−import qualified Rel8.Schema.Kind as K

36−import Rel8.Schema.Name ( Name( Name ) )

31+import Rel8.Schema.Name ( Col( NameCol ), Name )

37import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

32import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

38−import Rel8.Schema.Result ( vectorizer, unvectorizer )

33+import Rel8.Schema.Spec ( SSpec(..) )

39−import Rel8.Schema.Spec ( Spec(..) )

34+import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullity )

35+import Rel8.Schema.Reify ( hreify, hunreify )

40import Rel8.Table

36import Rel8.Table

41 ( Table, Context, Columns, fromColumns, toColumns

37 ( Table, Context, Columns, fromColumns, toColumns

42− , FromExprs, fromResult, toResult

38+ , reify, unreify

43− , Transpose

44 )

39 )

45import Rel8.Table.Alternative

40import Rel8.Table.Alternative

46 ( AltTable, (<|>:)

41 ( AltTable, (<|>:)

@@ -48,102 +43,102 @@ import Rel8.Table.Alternative

48 )

43 )

49import Rel8.Table.Eq ( EqTable, eqTable )

44import Rel8.Table.Eq ( EqTable, eqTable )

50import Rel8.Table.Ord ( OrdTable, ordTable )

45import Rel8.Table.Ord ( OrdTable, ordTable )

51−import Rel8.Table.Projection

46+import Rel8.Table.Recontextualize ( Recontextualize )

52− ( Projectable, Projecting, Projection, project, apply

53− )

54−import Rel8.Table.Serialize ( ToExprs )

47+import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )

48+import Rel8.Table.Unreify ( Unreifies )

57-- | A @ListTable@ value contains zero or more instances of @a@. You construct

51-- | A @ListTable@ value contains zero or more instances of @a@. You construct

58-- @ListTable@s with 'Rel8.many' or 'Rel8.listAgg'.

52-- @ListTable@s with 'Rel8.many' or 'Rel8.listAgg'.

59−type ListTable :: K.Context -> Type -> Type

53+type ListTable :: Type -> Type

60−newtype ListTable context a =

61− ListTable (HListTable (Columns a) (Context a))

54+newtype ListTable a = ListTable (HListTable (Columns a) (Col (Context a)))

62−

63−

64−instance Projectable (ListTable context) where

65− project f (ListTable a) = ListTable (hproject (apply f) a)

68−instance (Table context a, context ~ context') =>

57+instance (Table context a, Unreifies context a) =>

69− Table context' (ListTable context a)

58+ Table context (ListTable a)

70 where

59 where

71− type Columns (ListTable context a) = HListTable (Columns a)

60+ type Columns (ListTable a) = HListTable (Columns a)

72− type Context (ListTable context a) = Context a

61+ type Context (ListTable a) = Context a

73− type FromExprs (ListTable context a) = [FromExprs a]

74− type Transpose to (ListTable context a) = ListTable to (Transpose to a)

76 fromColumns = ListTable

63 fromColumns = ListTable

77 toColumns (ListTable a) = a

64 toColumns (ListTable a) = a

78− fromResult = fmap (fromResult @_ @a) . hunvectorize unvectorizer

65+

79− toResult = hvectorize vectorizer . fmap (toResult @_ @a)

66+ reify Refl (ListTable a) = ListTable (hreify a)

67+ unreify Refl (ListTable a) = ListTable (hunreify a)

68+

69+

70+instance

71+ ( Unreifies from a, Unreifies to b

72+ , Recontextualize from to a b

73+ )

74+ => Recontextualize from to (ListTable a) (ListTable b)

82−instance (EqTable a, context ~ Expr) => EqTable (ListTable context a) where

77+instance EqTable a => EqTable (ListTable a) where

83 eqTable =

78 eqTable =

84 hvectorize

79 hvectorize

85− (\Spec {nullity} (Identity Dict) -> case nullity of

80+ (\SSpec {} (Identity dict) -> case dbTypeDict dict of

81+ Dict -> case dbTypeNullity dict of

86− Null -> Dict

82+ Null -> Dict

87− NotNull -> Dict)

83+ NotNull -> Dict)

88 (Identity (eqTable @a))

84 (Identity (eqTable @a))

91−instance (OrdTable a, context ~ Expr) => OrdTable (ListTable context a) where

87+instance OrdTable a => OrdTable (ListTable a) where

92 ordTable =

88 ordTable =

93 hvectorize

89 hvectorize

94− (\Spec {nullity} (Identity Dict) -> case nullity of

90+ (\SSpec {} (Identity dict) -> case dbTypeDict dict of

91+ Dict -> case dbTypeNullity dict of

95− Null -> Dict

92+ Null -> Dict

96− NotNull -> Dict)

93+ NotNull -> Dict)

97 (Identity (ordTable @a))

94 (Identity (ordTable @a))

100−instance (ToExprs exprs a, context ~ Expr) =>

97+type instance FromExprs (ListTable a) = [FromExprs a]

101− ToExprs (ListTable context exprs) [a]

102

103

100+instance ToExprs exprs a => ToExprs (ListTable exprs) [a] where

101+ fromResult = fmap (fromResult @exprs) . fromColumns

102+ toResult = toColumns . fmap (toResult @exprs)

103+

104+

104−instance context ~ Expr => AltTable (ListTable context) where

105+instance AltTable ListTable where

105 (<|>:) = (<>)

106 (<|>:) = (<>)

106

107

108

108−instance context ~ Expr => AlternativeTable (ListTable context) where

109+instance AlternativeTable ListTable where

109 emptyTable = mempty

110 emptyTable = mempty

110

111

112

112−instance (context ~ Expr, Table Expr a) => Semigroup (ListTable context a)

113+instance Table Expr a => Semigroup (ListTable a) where

113− where

114− ListTable as <> ListTable bs = ListTable $ happend (const sappend) as bs

114+ ListTable as <> ListTable bs = ListTable $

115+ happend (\_ _ (DB a) (DB b) -> DB (sappend a b)) as bs

115

116

117

117−instance (context ~ Expr, Table Expr a) =>

118+instance Table Expr a => Monoid (ListTable a) where

118− Monoid (ListTable context a)

119− where

120− mempty = ListTable $ hempty $ \Spec {info} -> sempty info

119+ mempty = ListTable $ hempty $ \nullability info ->

120+ DB (sempty nullability info)

121

122

123−-- | Project a single expression out of a 'ListTable'.

123+listTable :: Table Expr a => [a] -> ListTable a

124−($*) :: Projecting a (Expr b)

124+listTable =

125− => Projection a (Expr b) -> ListTable Expr a -> Expr [b]

125+ ListTable .

126−f $* ListTable a = hcolumn $ hproject (apply f) a

126+ hvectorize (\SSpec {info} -> DB . slistOf info . fmap unDB) .

127−infixl 4 $*

127+ fmap toColumns

128

129

130−-- | Construct a @ListTable@ from a list of expressions.

131−listTable :: Table Expr a => [a] -> ListTable Expr a

130+insertListTable :: Table Insert a => [a] -> ListTable a

132−listTable =

131+insertListTable =

133 ListTable .

132 ListTable .

134− hvectorize (\Spec {info} -> slistOf info) .

133+ hvectorize (\SSpec {necessity, info} -> case necessity of

134+ SRequired -> RequiredInsert . slistOf info . fmap (\(RequiredInsert a) -> a)

135+ SOptional -> OptionalInsert . fmap (slistOf info) . traverse (\(OptionalInsert a) -> a)) .

135 fmap toColumns

136 fmap toColumns

136

137

138

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

139+nameListTable :: Table Name a => a -> ListTable a

142− :: Table Name a

143− => a -- ^ The names of the columns of elements of the list.

144− -> ListTable Name a

145nameListTable =

140nameListTable =

146 ListTable .

141 ListTable .

147− hvectorize (\_ (Identity (Name a)) -> Name a) .

142+ hvectorize (\_ (Identity (NameCol a)) -> NameCol a) .

148 pure .

143 pure .

149 toColumns

144 toColumns

src/Rel8/Table/Maybe.hs+139−121

@@ -3,6 +3,7 @@

3{-# language DerivingStrategies #-}

4{-# language FlexibleContexts #-}

5{-# language FlexibleInstances #-}

6+{-# language LambdaCase #-}

6{-# language MultiParamTypeClasses #-}

7{-# language MultiParamTypeClasses #-}

7{-# language NamedFieldPuns #-}

8{-# language NamedFieldPuns #-}

8{-# language ScopedTypeVariables #-}

9{-# language ScopedTypeVariables #-}

@@ -15,42 +16,42 @@ module Rel8.Table.Maybe

15 ( MaybeTable(..)

16 ( MaybeTable(..)

16 , maybeTable, nothingTable, justTable

17 , maybeTable, nothingTable, justTable

17 , isNothingTable, isJustTable

18 , isNothingTable, isJustTable

18− , fromMaybeTable

19 , ($?)

20− , aggregateMaybeTable

20+ , aggregateMaybeTable, insertMaybeTable, nameMaybeTable

21− , nameMaybeTable

22 )

21 )

23where

22where

25-- base

24-- base

26−import Data.Functor ( ($>) )

25+import Data.Functor.Identity ( runIdentity )

27−import Data.Functor.Identity ( Identity( Identity ) )

28import Data.Kind ( Type )

26import Data.Kind ( Type )

29−import Data.Maybe ( fromMaybe, isJust )

30import Prelude hiding ( null, undefined )

27import Prelude hiding ( null, undefined )

32−-- comonad

33−import Control.Comonad ( extract )

34−

35-- rel8

29-- rel8

36−import Rel8.Aggregate ( Aggregate )

30+import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )

37import Rel8.Expr ( Expr )

31import Rel8.Expr ( Expr )

38−import Rel8.Expr.Aggregate ( groupByExpr )

39import Rel8.Expr.Bool ( boolExpr )

32import Rel8.Expr.Bool ( boolExpr )

40import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )

33import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )

41−import Rel8.Kind.Context ( Reifiable )

34+import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )

42−import Rel8.Schema.Dict ( Dict( Dict ) )

35+import Rel8.Schema.Context.Label

36+ ( Labelable, HLabelable, hlabeler, hunlabeler

37+ )

38+import Rel8.Schema.Context.Nullify

39+ ( Nullifiable, ConstrainTag

40+ , HNullifiable, HConstrainTag

41+ , hencodeTag, hdecodeTag

42+ , hnullifier, hunnullifier

43+ )

43−import qualified Rel8.Schema.Kind as K

44+import Rel8.Schema.HTable ( HTable )

44import Rel8.Schema.HTable.Identity ( HIdentity(..) )

45import Rel8.Schema.HTable.Identity ( HIdentity(..) )

45import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

46import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

46import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )

47import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )

48+import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )

49+import Rel8.Schema.Insert ( Insert )

47import Rel8.Schema.Name ( Name )

50import Rel8.Schema.Name ( Name )

48−import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )

51+import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql, nullable )

49−import qualified Rel8.Schema.Null as N

50import Rel8.Table

52import Rel8.Table

51 ( Table, Columns, Context, fromColumns, toColumns

53 ( Table, Columns, Context, fromColumns, toColumns

52− , FromExprs, fromResult, toResult

54+ , reify, unreify

53− , Transpose

54 )

55 )

55import Rel8.Table.Alternative

56import Rel8.Table.Alternative

56 ( AltTable, (<|>:)

57 ( AltTable, (<|>:)

@@ -58,16 +59,17 @@ import Rel8.Table.Alternative

58 )

59 )

59import Rel8.Table.Bool ( bool )

60import Rel8.Table.Bool ( bool )

60import Rel8.Table.Eq ( EqTable, eqTable )

61import Rel8.Table.Eq ( EqTable, eqTable )

62+import Rel8.Table.Insert ( toInsert )

61import Rel8.Table.Ord ( OrdTable, ordTable )

63import Rel8.Table.Ord ( OrdTable, ordTable )

62−import Rel8.Table.Projection ( Projectable, project )

64+import Rel8.Table.Recontextualize ( Recontextualize )

63−import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )

64−import Rel8.Table.Serialize ( ToExprs )

65+import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )

66+import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )

65import Rel8.Table.Undefined ( undefined )

67import Rel8.Table.Undefined ( undefined )

66import Rel8.Type ( DBType )

68import Rel8.Type ( DBType )

67−import Rel8.Type.Tag ( MaybeTag( IsJust ) )

69+import Rel8.Type.Tag ( MaybeTag )

69-- semigroupoids

71-- semigroupoids

70−import Data.Functor.Apply ( Apply, (<.>) )

72+import Data.Functor.Apply ( Apply, (<.>), liftF2 )

71import Data.Functor.Bind ( Bind, (>>-) )

73import Data.Functor.Bind ( Bind, (>>-) )

@@ -79,168 +81,184 @@ import Data.Functor.Bind ( Bind, (>>-) )

79-- entirely of nulls, you can't distinguish if you matched an all null row, or

81-- entirely of nulls, you can't distinguish if you matched an all null row, or

80-- if the match failed. For this reason @MaybeTable@ contains an extra field -

82-- if the match failed. For this reason @MaybeTable@ contains an extra field -

81-- a "nullTag" - to track whether or not the outer join produced any rows.

83-- a "nullTag" - to track whether or not the outer join produced any rows.

82−type MaybeTable :: K.Context -> Type -> Type

84+type MaybeTable :: Type -> Type

83−data MaybeTable context a = MaybeTable

85+data MaybeTable a = MaybeTable

84− { tag :: context (Maybe MaybeTag)

86+ { tag :: Tag "isJust" (Maybe MaybeTag)

85− , just :: Nullify context a

87+ , just :: a

86 }

88 }

87 deriving stock Functor

89 deriving stock Functor

90−instance Projectable (MaybeTable context) where

91− project f (MaybeTable tag a) = MaybeTable tag (project f a)

92−

93−

94−instance context ~ Expr => Apply (MaybeTable context) where

92+instance Apply MaybeTable where

95− MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f <.> a)

93+ MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f a)

98-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:

96-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:

99-- 'Rel8.traverseMaybeTable'.

97-- 'Rel8.traverseMaybeTable'.

100−instance context ~ Expr => Applicative (MaybeTable context) where

98+instance Applicative MaybeTable where

101 (<*>) = (<.>)

99 (<*>) = (<.>)

102 pure = justTable

100 pure = justTable

103

101

104

102

105−instance context ~ Expr => Bind (MaybeTable context) where

103+instance Bind MaybeTable where

106− MaybeTable tag a >>- f = case f (extract a) of

104+ MaybeTable tag a >>- f = case f a of

107 MaybeTable tag' b -> MaybeTable (tag <> tag') b

105 MaybeTable tag' b -> MaybeTable (tag <> tag') b

108

106

109

107

110−-- | Has the same behavior as the @Monad@ instance for @Maybe@.

108+-- | Has the same behavior as the @Monad@ instance for @Maybe@. See also:

109+-- 'Rel8.bindMaybeTable'.

111−instance context ~ Expr => Monad (MaybeTable context) where

110+instance Monad MaybeTable where

112 (>>=) = (>>-)

111 (>>=) = (>>-)

113

112

114

113

115−instance context ~ Expr => AltTable (MaybeTable context) where

114+instance AltTable MaybeTable where

115+ ma@(MaybeTable tag a) <|>: MaybeTable tag' b = MaybeTable

116+ { tag = (tag <> tag')

117+ { expr = boolExpr (expr tag) (expr tag') condition

118+ }

119+ , just = bool a b condition

120+ }

121+ where

116− ma <|>: mb = bool ma mb (isNothingTable ma)

122+ condition = isNothingTable ma

117

123

118

124

119−instance context ~ Expr => AlternativeTable (MaybeTable context) where

125+instance AlternativeTable MaybeTable where

120 emptyTable = nothingTable

126 emptyTable = nothingTable

121

127

122

128

123−instance (context ~ Expr, Table Expr a, Semigroup a) =>

129+instance (Table Expr a, Semigroup a) => Semigroup (MaybeTable a) where

124− Semigroup (MaybeTable context a)

125− where

126 ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma

130 ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma

127

131

128

132

129−instance (context ~ Expr, Table Expr a, Semigroup a) =>

133+instance (Table Expr a, Semigroup a) => Monoid (MaybeTable a) where

130− Monoid (MaybeTable context a)

131− where

132 mempty = nothingTable

134 mempty = nothingTable

133

135

134

136

137+instance

135−instance (Table context a, Reifiable context, context ~ context') =>

138+ ( Table context a

139+ , Labelable context, Nullifiable context

140+ , ConstrainTag context MaybeTag

136− Table context' (MaybeTable context a)

141+ ) => Table context (MaybeTable a)

137 where

142 where

138− type Columns (MaybeTable context a) = HMaybeTable (Columns a)

143+ type Columns (MaybeTable a) = HMaybeTable (Columns a)

139− type Context (MaybeTable context a) = Context a

144+ type Context (MaybeTable a) = Context a

140− type FromExprs (MaybeTable context a) = Maybe (FromExprs a)

141− type Transpose to (MaybeTable context a) = MaybeTable to (Transpose to a)

142−

143− toColumns MaybeTable {tag, just} = HMaybeTable

144− { htag = hlabel $ HIdentity tag

145− , hjust = hlabel $ guard tag isJust isNonNull $ toColumns just

146− }

147

145

148− fromColumns HMaybeTable {htag, hjust} = MaybeTable

146+ toColumns = toColumns1 toColumns

149− { tag = unHIdentity $ hunlabel htag

147+ fromColumns = fromColumns1 fromColumns

150− , just = fromColumns $ hunlabel hjust

148+ reify = fmap fmap reify

151− }

149+ unreify = fmap fmap unreify

152

150

153− toResult ma = HMaybeTable

154− { htag = hlabel (HIdentity (Identity (IsJust <$ ma)))

155− , hjust = hlabel (toResult @_ @(Nullify context a) ma)

156− }

157

151

158− fromResult HMaybeTable {htag, hjust} = case hunlabel htag of

152+instance

159− HIdentity (Identity tag) -> tag $>

153+ ( Labelable from, Nullifiable from, ConstrainTag from MaybeTag

160− fromMaybe err (fromResult @_ @(Nullify context a) (hunlabel hjust))

154+ , Labelable to, Nullifiable to, ConstrainTag to MaybeTag

161− where

155+ , Recontextualize from to a b

162− err = error "Maybe.fromColumns: mismatch between tag and data"

156+ )

157+ => Recontextualize from to (MaybeTable a) (MaybeTable b)

163

158

164

159

165−instance (EqTable a, context ~ Expr) => EqTable (MaybeTable context a) where

160+instance EqTable a => EqTable (MaybeTable a) where

166− eqTable = HMaybeTable

161+ eqTable = toColumns1 id (justTable (eqTable @a))

167− { htag = hlabel (HIdentity Dict)

168− , hjust = hlabel (eqTable @(Nullify context a))

169− }

170

162

171

163

172−instance (OrdTable a, context ~ Expr) => OrdTable (MaybeTable context a) where

164+instance OrdTable a => OrdTable (MaybeTable a) where

173− ordTable = HMaybeTable

165+ ordTable = toColumns1 id (justTable (ordTable @a))

174− { htag = hlabel (HIdentity Dict)

175− , hjust = hlabel (ordTable @(Nullify context a))

176− }

177

166

178

167

179−instance (ToExprs exprs a, context ~ Expr) =>

168+type instance FromExprs (MaybeTable a) = Maybe (FromExprs a)

169+

170+

180− ToExprs (MaybeTable context exprs) (Maybe a)

171+instance ToExprs exprs a => ToExprs (MaybeTable exprs) (Maybe a) where

172+ fromResult = fmap (fromResult @exprs) . fromColumns

173+ toResult = toColumns . fmap (toResult @exprs)

181

174

182

175

183-- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.

176-- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.

184−isNothingTable :: MaybeTable Expr a -> Expr Bool

177+isNothingTable :: MaybeTable a -> Expr Bool

185−isNothingTable (MaybeTable tag _) = isNull tag

178+isNothingTable (MaybeTable tag _) = isNull (expr tag)

186

179

187

180

188-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.

181-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.

189−isJustTable :: MaybeTable Expr a -> Expr Bool

182+isJustTable :: MaybeTable a -> Expr Bool

190−isJustTable (MaybeTable tag _) = isNonNull tag

183+isJustTable (MaybeTable tag _) = isNonNull (expr tag)

191

184

192

185

193-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.

186-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.

194−maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable Expr a -> b

187+maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable a -> b

195−maybeTable b f ma@(MaybeTable _ a) = bool (f (extract a)) b (isNothingTable ma)

188+maybeTable b f ma@(MaybeTable _ a) = bool (f a) b (isNothingTable ma)

196{-# INLINABLE maybeTable #-}

189{-# INLINABLE maybeTable #-}

197

190

198

191

199-- | The null table. Like 'Nothing'.

192-- | The null table. Like 'Nothing'.

200−nothingTable :: Table Expr a => MaybeTable Expr a

193+nothingTable :: Table Expr a => MaybeTable a

201−nothingTable = MaybeTable null (pure undefined)

194+nothingTable = MaybeTable (fromExpr null) undefined

202

195

203

196

204-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use

197-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use

205-- 'pure'.

198-- 'pure'.

206−justTable :: a -> MaybeTable Expr a

199+justTable :: a -> MaybeTable a

207−justTable = MaybeTable mempty . pure

200+justTable = MaybeTable (fromExpr mempty)

208−

209−

210−-- | 'Data.Maybe.fromMaybe' for 'MaybeTable's.

211−fromMaybeTable :: Table Expr a => a -> MaybeTable Expr a -> a

212−fromMaybeTable fallback = maybeTable fallback id

213

201

214

202

215-- | Project a single expression out of a 'MaybeTable'. You can think of this

203-- | Project a single expression out of a 'MaybeTable'. You can think of this

216-- operator like the '$' operator, but it also has the ability to return

204-- operator like the '$' operator, but it also has the ability to return

217-- @null@.

205-- @null@.

218($?) :: forall a b. Sql DBType b

206($?) :: forall a b. Sql DBType b

219− => (a -> Expr b) -> MaybeTable Expr a -> Expr (N.Nullify b)

207+ => (a -> Expr b) -> MaybeTable a -> Expr (Nullify b)

220f $? ma@(MaybeTable _ a) = case nullable @b of

208f $? ma@(MaybeTable _ a) = case nullable @b of

221− Null -> boolExpr (f (extract a)) null (isNothingTable ma)

209+ Null -> boolExpr (f a) null (isNothingTable ma)

222− NotNull -> boolExpr (nullify (f (extract a))) null (isNothingTable ma)

210+ NotNull -> boolExpr (nullify (f a)) null (isNothingTable ma)

223infixl 4 $?

211infixl 4 $?

224

212

225

213

226−-- | Lift an aggregating function to operate on a 'MaybeTable'.

227−-- @nothingTable@s and @justTable@s are grouped separately.

228aggregateMaybeTable :: ()

214aggregateMaybeTable :: ()

229− => (exprs -> aggregates)

215+ => (a -> Aggregate b) -> MaybeTable a -> Aggregate (MaybeTable b)

230− -> MaybeTable Expr exprs

231− -> MaybeTable Aggregate aggregates

232−aggregateMaybeTable f (MaybeTable tag a) =

216+aggregateMaybeTable f MaybeTable {tag = tag@Tag {aggregator, expr}, just} =

233− MaybeTable (groupByExpr tag) (aggregateNullify f a)

217+ liftF2 MaybeTable (tag <$ aggregate) (f just)

234−

218+ where

235−

219+ aggregate = unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr

236−-- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you

220+

237−-- have a 'MaybeTable' that you are storing in a table and need to construct a

221+

238−-- 'TableSchema'.

222+insertMaybeTable :: Table Insert a => Maybe a -> MaybeTable a

239−nameMaybeTable

223+insertMaybeTable = \case

240− :: Name (Maybe MaybeTag)

224+ Nothing -> MaybeTable (fromExpr null) (fromColumns (toInsert undefined))

241− -- ^ The name of the column to track whether a row is a 'justTable' or

225+ Just a -> justTable a

242− -- 'nothingTable'.

226+

243− -> a

227+

244− -- ^ Names of the columns in @a@.

228+nameMaybeTable :: Name (Maybe MaybeTag) -> a -> MaybeTable a

245− -> MaybeTable Name a

229+nameMaybeTable = MaybeTable . fromName

246−nameMaybeTable tag = MaybeTable tag . pure

230+

231+

232+toColumns1 ::

233+ ( HTable t

234+ , HConstrainTag context MaybeTag

235+ , HLabelable context

236+ , HNullifiable context

237+ )

238+ => (a -> t context)

239+ -> MaybeTable a

240+ -> HMaybeTable t context

241+toColumns1 f MaybeTable {tag, just} = HMaybeTable

242+ { htag

243+ , hjust = hlabel hlabeler $ hnullify (hnullifier tag isNonNull) $ f just

244+ }

245+ where

246+ htag = HIdentity (hencodeTag tag)

247+

248+

249+fromColumns1 ::

250+ ( HTable t

251+ , HConstrainTag context MaybeTag

252+ , HLabelable context

253+ , HNullifiable context

254+ )

255+ => (t context -> a)

256+ -> HMaybeTable t context

257+ -> MaybeTable a

258+fromColumns1 f HMaybeTable {htag = HIdentity htag, hjust} = MaybeTable

259+ { tag

260+ , just = f $ runIdentity $

261+ hunnullify (\a -> pure . hunnullifier a) (hunlabel hunlabeler hjust)

262+ }

263+ where

264+ tag = hdecodeTag htag

src/Rel8/Table/Name.hs+26−37

@@ -1,17 +1,14 @@

1−{-# language DataKinds #-}

2{-# language FlexibleContexts #-}

1{-# language FlexibleContexts #-}

3−{-# language FlexibleInstances #-}

4−{-# language MultiParamTypeClasses #-}

5{-# language NamedFieldPuns #-}

2{-# language NamedFieldPuns #-}

6{-# language ScopedTypeVariables #-}

3{-# language ScopedTypeVariables #-}

7{-# language TypeApplications #-}

4{-# language TypeApplications #-}

8{-# language TypeFamilies #-}

5{-# language TypeFamilies #-}

9−{-# language UndecidableInstances #-}

10{-# language ViewPatterns #-}

6{-# language ViewPatterns #-}

12module Rel8.Table.Name

8module Rel8.Table.Name

13 ( namesFromLabels

9 ( namesFromLabels

14 , namesFromLabelsWith

10 , namesFromLabelsWith

11+ , showExprs

15 , showLabels

12 , showLabels

16 , showNames

13 , showNames

17 )

14 )

@@ -20,60 +17,52 @@ where

20-- base

17-- base

21import Data.Foldable ( fold )

18import Data.Foldable ( fold )

22import Data.Functor.Const ( Const( Const ), getConst )

19import Data.Functor.Const ( Const( Const ), getConst )

23−import Data.List.NonEmpty ( NonEmpty, intersperse, nonEmpty )

20+import Data.List.NonEmpty ( NonEmpty, intersperse )

24−import Data.Maybe ( fromMaybe )

25import Prelude

21import Prelude

23+-- casing

24+import Text.Casing ( quietSnake )

25+

26+-- opaleye

27+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

28+

27-- rel8

29-- rel8

30+import Rel8.Expr ( Expr, Col(..) )

31+import Rel8.Expr.Opaleye ( toPrimExpr )

32+import Rel8.Kind.Labels ( renderLabels )

28import Rel8.Schema.HTable ( htabulate, htabulateA, hfield, hspecs )

33import Rel8.Schema.HTable ( htabulate, htabulateA, hfield, hspecs )

29−import Rel8.Schema.Name ( Name( Name ) )

34+import Rel8.Schema.Name ( Name, Col(..) )

30−import Rel8.Schema.Spec ( Spec(..) )

35+import Rel8.Schema.Spec ( SSpec(..) )

31−import Rel8.Table ( Table(..) )

36+import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )

34−-- | Construct a table in the 'Name' context containing the names of all

35−-- columns. Nested column names will be combined with @/@.

36−--

37−-- See also: 'namesFromLabelsWith'.

38namesFromLabels :: Table Name a => a

39namesFromLabels :: Table Name a => a

39namesFromLabels = namesFromLabelsWith go

40namesFromLabels = namesFromLabelsWith go

40 where

41 where

41− go = fold . intersperse "/"

42+ go = fold . intersperse "/" . fmap quietSnake

44−-- | Construct a table in the 'Name' context containing the names of all

45−-- columns. The supplied function can be used to transform column names.

46−--

47−-- This function can be used to generically derive the columns for a

48−-- 'TableSchema'. For example,

49−--

50−-- @

51−-- myTableSchema :: TableSchema (MyTable Name)

52−-- myTableSchema = TableSchema

53−-- { columns = namesFromLabelsWith last

54−-- }

55−-- @

56−--

57−-- will construct a 'TableSchema' where each columns names exactly corresponds

58−-- to the name of the Haskell field.

59namesFromLabelsWith :: Table Name a

45namesFromLabelsWith :: Table Name a

60 => (NonEmpty String -> String) -> a

46 => (NonEmpty String -> String) -> a

61namesFromLabelsWith f = fromColumns $ htabulate $ \field ->

47namesFromLabelsWith f = fromColumns $ htabulate $ \field ->

62 case hfield hspecs field of

48 case hfield hspecs field of

63− Spec {labels} -> Name (f (renderLabels labels))

49+ SSpec {labels} -> NameCol (f (renderLabels labels))

50+

51+

52+showExprs :: Table Expr a => a -> [(String, Opaleye.PrimExpr)]

53+showExprs as = case (namesFromLabels, toColumns as) of

54+ (names, exprs) -> getConst $ htabulateA $ \field ->

55+ case (hfield names field, hfield exprs field) of

56+ (NameCol name, DB expr) -> Const [(name, toPrimExpr expr)]

66showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]

59showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]

67showLabels _ = getConst $

60showLabels _ = getConst $

68 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

61 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

69− Spec {labels} -> Const (pure (renderLabels labels))

62+ SSpec {labels} -> Const [renderLabels labels]

72−showNames :: forall a. Table Name a => a -> NonEmpty String

65+showNames :: forall a. Table Name a => a -> [String]

73showNames (toColumns -> names) = getConst $

66showNames (toColumns -> names) = getConst $

74 htabulateA @(Columns a) $ \field -> case hfield names field of

67 htabulateA @(Columns a) $ \field -> case hfield names field of

75− Name name -> Const (pure name)

68+ NameCol name -> Const [name]

76−

77−

78−renderLabels :: [String] -> NonEmpty String

79−renderLabels labels = fromMaybe (pure "anon") (nonEmpty labels )

src/Rel8/Table/NonEmpty.hs+64−72

@@ -1,4 +1,3 @@

1−{-# language DataKinds #-}

2{-# language FlexibleContexts #-}

1{-# language FlexibleContexts #-}

3{-# language FlexibleInstances #-}

2{-# language FlexibleInstances #-}

4{-# language MultiParamTypeClasses #-}

3{-# language MultiParamTypeClasses #-}

@@ -11,9 +10,7 @@

12module Rel8.Table.NonEmpty

11module Rel8.Table.NonEmpty

13 ( NonEmptyTable(..)

12 ( NonEmptyTable(..)

14− , ($+)

15− , nonEmptyTable

16− , nameNonEmptyTable

13+ , nonEmptyTable, insertNonEmptyTable, nameNonEmptyTable

17 )

14 )

18where

15where

@@ -21,123 +18,118 @@ where

21import Data.Functor.Identity ( Identity( Identity ) )

18import Data.Functor.Identity ( Identity( Identity ) )

22import Data.Kind ( Type )

19import Data.Kind ( Type )

23import Data.List.NonEmpty ( NonEmpty )

20import Data.List.NonEmpty ( NonEmpty )

21+import Data.Type.Equality ( (:~:)( Refl ) )

24−import Prelude hiding ( id )

22+import Prelude

26-- rel8

24-- rel8

27−import Rel8.Expr ( Expr )

25+import Rel8.Expr ( Expr, Col(..) )

28import Rel8.Expr.Array ( sappend1, snonEmptyOf )

26import Rel8.Expr.Array ( sappend1, snonEmptyOf )

27+import Rel8.Kind.Necessity ( SNecessity( SOptional, SRequired ) )

29import Rel8.Schema.Dict ( Dict( Dict ) )

28import Rel8.Schema.Dict ( Dict( Dict ) )

30import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )

29import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )

31−import Rel8.Schema.HTable.Vectorize

30+import Rel8.Schema.HTable.Vectorize ( happend, hvectorize )

32− ( hvectorize, hunvectorize

31+import Rel8.Schema.Insert ( Col( OptionalInsert, RequiredInsert ), Insert )

33− , happend

34− , hproject, hcolumn

35− )

36−import qualified Rel8.Schema.Kind as K

37−import Rel8.Schema.Name ( Name( Name ) )

32+import Rel8.Schema.Name ( Col( NameCol ), Name )

38import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

33import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

39−import Rel8.Schema.Result ( vectorizer, unvectorizer )

34+import Rel8.Schema.Reify ( hreify, hunreify )

40−import Rel8.Schema.Spec ( Spec(..) )

35+import Rel8.Schema.Spec ( SSpec(..) )

36+import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullity )

41import Rel8.Table

37import Rel8.Table

42 ( Table, Context, Columns, fromColumns, toColumns

38 ( Table, Context, Columns, fromColumns, toColumns

43− , FromExprs, fromResult, toResult

39+ , reify, unreify

44− , Transpose

45 )

40 )

46import Rel8.Table.Alternative ( AltTable, (<|>:) )

41import Rel8.Table.Alternative ( AltTable, (<|>:) )

47import Rel8.Table.Eq ( EqTable, eqTable )

42import Rel8.Table.Eq ( EqTable, eqTable )

48import Rel8.Table.Ord ( OrdTable, ordTable )

43import Rel8.Table.Ord ( OrdTable, ordTable )

49−import Rel8.Table.Projection

44+import Rel8.Table.Recontextualize ( Recontextualize )

50− ( Projectable, Projecting, Projection, project, apply

51− )

52−import Rel8.Table.Serialize ( ToExprs )

45+import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )

46+import Rel8.Table.Unreify ( Unreifies )

55-- | A @NonEmptyTable@ value contains one or more instances of @a@. You

49-- | A @NonEmptyTable@ value contains one or more instances of @a@. You

56-- construct @NonEmptyTable@s with 'Rel8.some' or 'nonEmptyAgg'.

50-- construct @NonEmptyTable@s with 'Rel8.some' or 'nonEmptyAgg'.

57−type NonEmptyTable :: K.Context -> Type -> Type

51+type NonEmptyTable :: Type -> Type

58−newtype NonEmptyTable context a =

52+newtype NonEmptyTable a =

59− NonEmptyTable (HNonEmptyTable (Columns a) (Context a))

53+ NonEmptyTable (HNonEmptyTable (Columns a) (Col (Context a)))

60−

62−instance Projectable (NonEmptyTable context) where

63− project f (NonEmptyTable a) = NonEmptyTable (hproject (apply f) a)

65−

66−instance (Table context a, context ~ context') =>

56+instance (Table context a, Unreifies context a) =>

67− Table context' (NonEmptyTable context a)

57+ Table context (NonEmptyTable a)

68 where

58 where

69− type Columns (NonEmptyTable context a) = HNonEmptyTable (Columns a)

59+ type Columns (NonEmptyTable a) = HNonEmptyTable (Columns a)

70− type Context (NonEmptyTable context a) = Context a

60+ type Context (NonEmptyTable 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)

75 fromColumns = NonEmptyTable

62 fromColumns = NonEmptyTable

76 toColumns (NonEmptyTable a) = a

63 toColumns (NonEmptyTable a) = a

77− fromResult = fmap (fromResult @_ @a) . hunvectorize unvectorizer

78− toResult = hvectorize vectorizer . fmap (toResult @_ @a)

65+ reify Refl (NonEmptyTable a) = NonEmptyTable (hreify a)

66+ unreify Refl (NonEmptyTable a) = NonEmptyTable (hunreify a)

68+

81−instance (EqTable a, context ~ Expr) =>

69+instance

82− EqTable (NonEmptyTable context a)

70+ ( Unreifies from a, Unreifies to b

83− where

71+ , Recontextualize from to a b

72+ )

73+ => Recontextualize from to (NonEmptyTable a) (NonEmptyTable b)

74+

75+

76+instance EqTable a => EqTable (NonEmptyTable a) where

84 eqTable =

77 eqTable =

85 hvectorize

78 hvectorize

86− (\Spec {nullity} (Identity Dict) -> case nullity of

79+ (\SSpec {} (Identity dict) -> case dbTypeDict dict of

80+ Dict -> case dbTypeNullity dict of

87− Null -> Dict

81+ Null -> Dict

88− NotNull -> Dict)

82+ NotNull -> Dict)

89 (Identity (eqTable @a))

83 (Identity (eqTable @a))

92−instance (OrdTable a, context ~ Expr) =>

93− OrdTable (NonEmptyTable context a)

86+instance OrdTable a => OrdTable (NonEmptyTable a) where

94− where

95 ordTable =

87 ordTable =

96 hvectorize

88 hvectorize

97− (\Spec {nullity} (Identity Dict) -> case nullity of

89+ (\SSpec {} (Identity dict) -> case dbTypeDict dict of

90+ Dict -> case dbTypeNullity dict of

98− Null -> Dict

91+ Null -> Dict

99− NotNull -> Dict)

92+ NotNull -> Dict)

100 (Identity (ordTable @a))

93 (Identity (ordTable @a))

101

102

103−instance (ToExprs exprs a, context ~ Expr) =>

104− ToExprs (NonEmptyTable context exprs) (NonEmpty a)

96+type instance FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)

97+

105

99+instance ToExprs exprs a => ToExprs (NonEmptyTable exprs) (NonEmpty a)

100+ where

101+ fromResult = fmap (fromResult @exprs) . fromColumns

102+ toResult = toColumns . fmap (toResult @exprs)

106

103

104+

107−instance context ~ Expr => AltTable (NonEmptyTable context) where

105+instance AltTable NonEmptyTable where

108 (<|>:) = (<>)

106 (<|>:) = (<>)

109

107

110

108

111−instance (Table Expr a, context ~ Expr) => Semigroup (NonEmptyTable context a)

109+instance Table Expr a => Semigroup (NonEmptyTable a) where

112− where

113 NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $

110 NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $

114− happend (const sappend1) as bs

111+ happend (\_ _ (DB a) (DB b) -> DB (sappend1 a b)) as bs

115

112

116

113

117−-- | Project a single expression out of a 'NonEmptyTable'.

114+nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable a

118−($+) :: Projecting a (Expr b)

115+nonEmptyTable =

119− => Projection a (Expr b) -> NonEmptyTable Expr a -> Expr (NonEmpty b)

116+ NonEmptyTable .

120−f $+ NonEmptyTable a = hcolumn $ hproject (apply f) a

117+ hvectorize (\SSpec {info} -> DB . snonEmptyOf info . fmap unDB) .

121−infixl 4 $+

118+ fmap toColumns

122

119

123

120

124−-- | Construct a @NonEmptyTable@ from a non-empty list of expressions.

125−nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable Expr a

121+insertNonEmptyTable :: Table Insert a => NonEmpty a -> NonEmptyTable a

126−nonEmptyTable =

122+insertNonEmptyTable =

127 NonEmptyTable .

123 NonEmptyTable .

128− hvectorize (\Spec {info} -> snonEmptyOf info) .

124+ hvectorize (\SSpec {necessity, info} -> case necessity of

125+ SRequired -> RequiredInsert . snonEmptyOf info . fmap (\(RequiredInsert a) -> a)

126+ SOptional -> OptionalInsert . fmap (snonEmptyOf info) . traverse (\(OptionalInsert a) -> a)) .

129 fmap toColumns

127 fmap toColumns

130

128

131

129

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

130+nameNonEmptyTable :: Table Name a => a -> NonEmptyTable a

136− :: Table Name a

137− => a -- ^ The names of the columns of elements of the list.

138− -> NonEmptyTable Name a

139nameNonEmptyTable =

131nameNonEmptyTable =

140 NonEmptyTable .

132 NonEmptyTable .

141− hvectorize (\_ (Identity (Name a)) -> Name a) .

133+ hvectorize (\_ (Identity (NameCol a)) -> NameCol a) .

142 pure .

134 pure .

143 toColumns

135 toColumns

src/Rel8/Table/Null.hsdeleted−147

@@ -1,147 +0,0 @@

1−{-# language DataKinds #-}

2−{-# language FlexibleContexts #-}

3−{-# language FlexibleInstances #-}

4−{-# language MultiParamTypeClasses #-}

5−{-# language ScopedTypeVariables #-}

6−{-# language StandaloneKindSignatures #-}

7−{-# language TypeApplications #-}

8−{-# language TypeFamilies #-}

9−{-# language UndecidableInstances #-}

10−

11−module Rel8.Table.Null

12− ( NullTable(..)

13− , nullableTable, nullTable, nullifyTable, unsafeUnnullifyTable

14− , isNullTable, isNonNullTable

15− , nameNullTable

16− , toMaybeTable, toNullTable

17− )

18−where

19−

20−-- base

21−import Data.Kind ( Type )

22−import Prelude hiding ( null, undefined )

23−

24−-- comonad

25−import Control.Comonad ( extract )

26−

27−-- rel8

28−import Rel8.Expr ( Expr )

29−import Rel8.Expr.Bool ( not_ )

30−import Rel8.Kind.Context ( Reifiable )

31−import qualified Rel8.Schema.Kind as K

32−import Rel8.Schema.Name ( Name )

33−import Rel8.Table

34− ( Table, Columns, Context, fromColumns, toColumns

35− , FromExprs, fromResult, toResult

36− , Transpose

37− )

38−import Rel8.Table.Alternative

39− ( AltTable, (<|>:)

40− , AlternativeTable, emptyTable

41− )

42−import Rel8.Table.Bool ( bool )

43−import Rel8.Table.Eq ( EqTable, eqTable )

44−import Rel8.Table.Maybe ( MaybeTable, justTable, maybeTable, nothingTable )

45−import Rel8.Table.Nullify ( Nullify, isNull )

46−import Rel8.Table.Ord ( OrdTable, ordTable )

47−import Rel8.Table.Projection ( Projectable, project )

48−import Rel8.Table.Serialize ( ToExprs )

49−import Rel8.Table.Undefined ( undefined )

50−

51−

52−-- | @NullTable t@ is the table @t@, but where all the columns in @t@ have the

53−-- possibility of being 'Rel8.null'. This is very similar to

54−-- 'Rel8.MaybeTable', except that it does not use an extra tag field, so it

55−-- cannot distinguish between @Nothing@ and @Just Nothing@ if nested. In other

56−-- words, if all of the columns of the @t@ passed to @NullTable@ are already

57−-- nullable, then @NullTable@ has no effect.

58−type NullTable :: K.Context -> Type -> Type

59−newtype NullTable context a = NullTable (Nullify context a)

60−

61−

62−instance Projectable (NullTable context) where

63− project f (NullTable a) = NullTable (project f a)

64−

65−

66−instance context ~ Expr => AltTable (NullTable context) where

67− ma <|>: mb = bool ma mb (isNullTable ma)

68−

69−

70−instance context ~ Expr => AlternativeTable (NullTable context) where

71− emptyTable = nullTable

72−

73−

74−instance (Table context a, Reifiable context, context ~ context') =>

75− Table context' (NullTable context a)

76− where

77− type Columns (NullTable context a) = Columns (Nullify context a)

78− type Context (NullTable context a) = Context (Nullify context a)

79− type FromExprs (NullTable context a) = FromExprs (Nullify context a)

80− type Transpose to (NullTable context a) = NullTable to (Transpose to a)

81−

82− toColumns (NullTable a) = toColumns a

83− fromColumns = NullTable . fromColumns

84−

85− toResult = toResult @_ @(Nullify context a)

86− fromResult = fromResult @_ @(Nullify context a)

87−

88−

89−instance (EqTable a, context ~ Expr) => EqTable (NullTable context a) where

90− eqTable = eqTable @(Nullify context a)

91−

92−

93−instance (OrdTable a, context ~ Expr) => OrdTable (NullTable context a) where

94− ordTable = ordTable @(Nullify context a)

95−

96−

97−instance (ToExprs exprs a, context ~ Expr) =>

98− ToExprs (NullTable context exprs) (Maybe a)

99−

100−

101−-- | Check if any of the non-nullable fields of @a@ are 'Rel8.null' under the

102−-- 'NullTable'. Returns 'Rel8.false' if @a@ has no non-nullable fields.

103−isNullTable :: Table Expr a => NullTable Expr a -> Expr Bool

104−isNullTable (NullTable a) = isNull a

105−

106−

107−-- | The inverse of 'isNullTable'.

108−isNonNullTable :: Table Expr a => NullTable Expr a -> Expr Bool

109−isNonNullTable = not_ . isNullTable

110−

111−

112−-- | Like 'Rel8.nullable'.

113−nullableTable :: (Table Expr a, Table Expr b)

114− => b -> (a -> b) -> NullTable Expr a -> b

115−nullableTable b f ma@(NullTable a) = bool (f (extract a)) b (isNullTable ma)

116−

117−

118−-- | The null table. Like 'Rel8.null'.

119−nullTable :: Table Expr a => NullTable Expr a

120−nullTable = NullTable (pure undefined)

121−

122−

123−-- | Lift any table into 'NullTable'. Like 'Rel8.nullify'.

124−nullifyTable :: a -> NullTable Expr a

125−nullifyTable = NullTable . pure

126−

127−

128−unsafeUnnullifyTable :: NullTable Expr a -> a

129−unsafeUnnullifyTable (NullTable a) = extract a

130−

131−

132−-- | Construct a 'NullTable' in the 'Name' context. This can be useful if you

133−-- have a 'NullTable' that you are storing in a table and need to construct a

134−-- 'TableSchema'.

135−nameNullTable :: a -> NullTable Name a

136−nameNullTable = NullTable . pure

137−

138−

139−-- | Convert a 'NullTable' to a 'MaybeTable'.

140−toMaybeTable :: Table Expr a => NullTable Expr a -> MaybeTable Expr a

141−toMaybeTable = nullableTable nothingTable justTable

142−

143−

144−-- | Convert a 'MaybeTable' to a 'NullTable'. Note that if the underlying @a@

145−-- has no non-nullable fields, this is a lossy conversion.

146−toNullTable :: Table Expr a => MaybeTable Expr a -> NullTable Expr a

147−toNullTable = maybeTable nullTable nullifyTable

src/Rel8/Table/Nullify.hsdeleted−211

@@ -1,211 +0,0 @@

1−{-# language DataKinds #-}

2−{-# language FlexibleContexts #-}

3−{-# language FlexibleInstances #-}

4−{-# language LambdaCase #-}

5−{-# language MultiParamTypeClasses #-}

6−{-# language NamedFieldPuns #-}

7−{-# language ScopedTypeVariables #-}

8−{-# language StandaloneKindSignatures #-}

9−{-# language TypeApplications #-}

10−{-# language TypeFamilies #-}

11−{-# language UndecidableInstances #-}

12−

13−module Rel8.Table.Nullify

14− ( Nullify

15− , aggregateNullify

16− , guard

17− , isNull

18− )

19−where

20−

21−-- base

22−import Control.Applicative ( liftA2 )

23−import Data.Functor.Const ( Const( Const ), getConst )

24−import Data.Functor.Identity ( runIdentity )

25−import Data.Kind ( Type )

26−import Prelude

27−

28−-- comonad

29−import Control.Comonad ( Comonad, duplicate, extract, ComonadApply, (<@>) )

30−

31−-- rel8

32−import Rel8.Aggregate ( Aggregate )

33−import Rel8.Expr ( Expr )

34−import Rel8.Expr.Bool ( (||.), false )

35−import qualified Rel8.Expr.Null as Expr

36−import Rel8.Kind.Context ( Reifiable, contextSing )

37−import Rel8.Schema.Context.Nullify

38− ( Nullifiability( NAggregate, NExpr )

39− , NonNullifiability

40− , Nullifiable, nullifiability

41− , nullifiableOrNot, absurd

42− , guarder

43− , nullifier

44− , unnullifier

45− )

46−import Rel8.Schema.Dict ( Dict( Dict ) )

47−import Rel8.Schema.HTable ( HTable )

48−import Rel8.Schema.HTable.Nullify

49− ( HNullify, hnulls, hnullify, hunnullify

50− , hguard

51− , hproject

52− )

53−import qualified Rel8.Schema.Kind as K

54−import Rel8.Schema.Null ( Nullity( NotNull, Null ) )

55−import qualified Rel8.Schema.Result as R

56−import Rel8.Table

57− ( Table, Columns, Context, toColumns, fromColumns

58− , FromExprs, fromResult, toResult

59− , Transpose

60− )

61−import Rel8.Schema.Spec ( Spec( Spec, nullity ) )

62−import Rel8.Table.Eq ( EqTable, eqTable )

63−import Rel8.Table.Ord ( OrdTable, ordTable )

64−import Rel8.Table.Projection ( Projectable, apply, project )

65−

66−-- semigroupoids

67−import Data.Functor.Apply ( Apply, (<.>), liftF2 )

68−import Data.Functor.Bind ( Bind, (>>-) )

69−import Data.Functor.Extend ( Extend, duplicated )

70−

71−

72−type Nullify :: K.Context -> Type -> Type

73−data Nullify context a

74− = Table (Nullifiability context) a

75− | Fields (NonNullifiability context) (HNullify (Columns a) (Context a))

76−

77−

78−instance Projectable (Nullify context) where

79− project f = \case

80− Table nullifiable a -> Table nullifiable (fromColumns (apply f (toColumns a)))

81− Fields nonNullifiable a -> Fields nonNullifiable (hproject (apply f) a)

82−

83−

84−instance Nullifiable context => Functor (Nullify context) where

85− fmap f = \case

86− Table nullifiable a -> Table nullifiable (f a)

87− Fields notNullifiable _ -> absurd nullifiability notNullifiable

88−

89−

90−instance Nullifiable context => Foldable (Nullify context) where

91− foldMap f = \case

92− Table _ a -> f a

93− Fields notNullifiable _ -> absurd nullifiability notNullifiable

94−

95−

96−instance Nullifiable context => Traversable (Nullify context) where

97− traverse f = \case

98− Table nullifiable a -> Table nullifiable <$> f a

99− Fields notNullifiable _ -> absurd nullifiability notNullifiable

100−

101−

102−instance Nullifiable context => Apply (Nullify context) where

103− liftF2 f = \case

104− Table nullifiable a -> \case

105− Table _ b -> Table nullifiable (f a b)

106− Fields notNullifiable _ -> absurd nullifiable notNullifiable

107− Fields notNullifiable _ -> absurd nullifiability notNullifiable

108−

109−

110−instance Nullifiable context => Applicative (Nullify context) where

111− pure = Table nullifiability

112− liftA2 = liftF2

113−

114−

115−instance Nullifiable context => Bind (Nullify context) where

116− Table _ a >>- f = f a

117− Fields notNullifiable _ >>- _ = absurd nullifiability notNullifiable

118−

119−

120−instance Nullifiable context => Monad (Nullify context) where

121− (>>=) = (>>-)

122−

123−

124−instance Nullifiable context => Extend (Nullify context) where

125− duplicated = \case

126− Table nullifiable a -> Table nullifiable (Table nullifiable a)

127− Fields notNullifiable _ -> absurd nullifiability notNullifiable

128−

129−

130−instance Nullifiable context => Comonad (Nullify context) where

131− extract = \case

132− Table _ a -> a

133− Fields notNullifiable _ -> absurd nullifiability notNullifiable

134− duplicate = duplicated

135−

136−

137−instance Nullifiable context => ComonadApply (Nullify context) where

138− (<@>) = (<.>)

139−

140−

141−instance (Table context a, Reifiable context, context ~ context') =>

142− Table context' (Nullify context a)

143− where

144− type Columns (Nullify context a) = HNullify (Columns a)

145− type Context (Nullify context a) = Context a

146− type FromExprs (Nullify context a) = Maybe (FromExprs a)

147− type Transpose to (Nullify context a) = Nullify to (Transpose to a)

148−

149− fromColumns = case nullifiableOrNot contextSing of

150− Left notNullifiable -> Fields notNullifiable

151− Right nullifiable ->

152− Table nullifiable .

153− fromColumns .

154− runIdentity .

155− hunnullify (\spec -> pure . unnullifier nullifiable spec)

156−

157− toColumns = \case

158− Table nullifiable a -> hnullify (nullifier nullifiable) (toColumns a)

159− Fields _ a -> a

160−

161− fromResult = fmap (fromResult @_ @a) . hunnullify R.unnullifier

162−

163− toResult =

164− maybe (hnulls (const R.null)) (hnullify R.nullifier) .

165− fmap (toResult @_ @a)

166−

167−

168−instance (EqTable a, context ~ Expr) => EqTable (Nullify context a) where

169− eqTable = hnullify (\_ Dict -> Dict) (eqTable @a)

170−

171−

172−instance (OrdTable a, context ~ Expr) => OrdTable (Nullify context a) where

173− ordTable = hnullify (\_ Dict -> Dict) (ordTable @a)

174−

175−

176−aggregateNullify :: ()

177− => (exprs -> aggregates)

178− -> Nullify Expr exprs

179− -> Nullify Aggregate aggregates

180−aggregateNullify f = \case

181− Table _ a -> Table NAggregate (f a)

182− Fields notNullifiable _ -> absurd NExpr notNullifiable

183−

184−

185−guard :: (Reifiable context, HTable t)

186− => context tag

187− -> (tag -> Bool)

188− -> (Expr tag -> Expr Bool)

189− -> HNullify t context

190− -> HNullify t context

191−guard tag isNonNull isNonNullExpr =

192− hguard (guarder contextSing tag isNonNull isNonNullExpr)

193−

194−

195−isNull :: forall a. Table Expr a => Nullify Expr a -> Expr Bool

196−isNull =

197− maybe false getAny .

198− getConst .

199− hunnullify (\Spec {nullity} a -> Const $ case nullity of

200− NotNull -> Just $ Any $ Expr.isNull a

201− Null -> Nothing) .

202− toColumns

203−

204−

205−newtype Any = Any

206− { getAny :: Expr Bool

207− }

208−

209−

210−instance Semigroup Any where

211− Any a <> Any b = Any (a ||. b)

src/Rel8/Table/Opaleye.hs+75−84

@@ -1,150 +1,141 @@

1{-# language BlockArguments #-}

2−{-# language DataKinds #-}

3{-# language DisambiguateRecordFields #-}

2{-# language DisambiguateRecordFields #-}

4{-# language FlexibleContexts #-}

3{-# language FlexibleContexts #-}

5{-# language NamedFieldPuns #-}

4{-# language NamedFieldPuns #-}

6−{-# language RankNTypes #-}

7{-# language TypeFamilies #-}

5{-# language TypeFamilies #-}

8{-# language ViewPatterns #-}

6{-# language ViewPatterns #-}

10−{-# options_ghc -Wno-deprecations #-}

11−

12module Rel8.Table.Opaleye

8module Rel8.Table.Opaleye

13 ( aggregator

9 ( aggregator

14− , attributes

15 , binaryspec

10 , binaryspec

16 , distinctspec

11 , distinctspec

17− , exprs

18− , exprsWithNames

19 , table

12 , table

20 , tableFields

13 , tableFields

21 , unpackspec

14 , unpackspec

22 , valuesspec

15 , valuesspec

23− , view

24 , castTable

16 , castTable

25 )

17 )

26where

18where

28-- base

20-- base

29−import Data.Functor.Const ( Const( Const ), getConst )

21+import Prelude hiding ( undefined )

30−import Data.List.NonEmpty ( NonEmpty )

31−import Prelude

33-- opaleye

23-- opaleye

34−import qualified Opaleye.Adaptors as Opaleye

35−import qualified Opaleye.Field as Opaleye ( Field_ )

36import qualified Opaleye.Internal.Aggregate as Opaleye

24import qualified Opaleye.Internal.Aggregate as Opaleye

25+import qualified Opaleye.Internal.Binary as Opaleye

26+import qualified Opaleye.Internal.Distinct as Opaleye

37import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

27import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

28+import qualified Opaleye.Internal.PackMap as Opaleye

29+import qualified Opaleye.Internal.Unpackspec as Opaleye

38import qualified Opaleye.Internal.Values as Opaleye

30import qualified Opaleye.Internal.Values as Opaleye

39−import qualified Opaleye.Table as Opaleye

31+import qualified Opaleye.Internal.Table as Opaleye

41-- profunctors

33-- profunctors

42import Data.Profunctor ( dimap, lmap )

34import Data.Profunctor ( dimap, lmap )

44-- rel8

36-- rel8

45−import Rel8.Aggregate ( Aggregate( Aggregate ), Aggregates )

37+import Rel8.Aggregate ( Aggregate( Aggregate ) )

46−import Rel8.Expr ( Expr )

38+import Rel8.Expr ( Expr, Col(..) )

47import Rel8.Expr.Opaleye

39import Rel8.Expr.Opaleye

48 ( fromPrimExpr, toPrimExpr

40 ( fromPrimExpr, toPrimExpr

41+ , traversePrimExpr

42+ , fromColumn, toColumn

49− , scastExpr, traverseFieldP

43+ , scastExpr

50 )

44 )

45+import Rel8.Kind.Necessity ( SNecessity( SRequired, SOptional ) )

51−import Rel8.Schema.HTable ( htabulateA, hfield, hspecs, htabulate,

46+import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs, htabulate )

52− htraverseP, htraversePWithField )

47+import Rel8.Schema.Insert ( Insert, Inserts, Col(..) )

53−import Rel8.Schema.Name ( Name( Name ), Selects, ppColumn )

48+import Rel8.Schema.Name ( Name, Selects, Col(..) )

54−import Rel8.Schema.Spec ( Spec(..) )

49+import Rel8.Schema.Spec ( SSpec(..) )

55−import Rel8.Schema.Table ( TableSchema(..), ppTable )

50+import Rel8.Schema.Table ( TableSchema(..) )

56import Rel8.Table ( Table, fromColumns, toColumns )

51import Rel8.Table ( Table, fromColumns, toColumns )

57−import Rel8.Type.Information ( typeName )

52+import Rel8.Table.Undefined ( undefined )

59-- semigroupoids

54-- semigroupoids

60import Data.Functor.Apply ( WrappedApplicative(..) )

55import 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

70−attributes :: Selects names exprs => TableSchema names -> exprs

58+aggregator :: Opaleye.Aggregator (Aggregate exprs) exprs

71−attributes schema@TableSchema {columns} = fromColumns $ htabulate $ \field ->

59+aggregator = Opaleye.Aggregator $ Opaleye.PackMap $

72− case hfield (toColumns columns) field of

60+ \f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner))) -> inner f ()

73− Name column -> fromPrimExpr $ Opaleye.ConstExpr $

74− Opaleye.OtherLit $

75− show (ppTable schema) <> "." <> show (ppColumn column)

76−

77−

78−fromOpaleyespec :: (ProductProfunctor p, Table Expr a)

79− => p (Opaleye.Field_ n x) (Opaleye.Field_ n x)

80− -> p a a

81−fromOpaleyespec x =

82− dimap toColumns fromColumns (htraverseP (traverseFieldP x))

85binaryspec :: Table Expr a => Opaleye.Binaryspec a a

63binaryspec :: Table Expr a => Opaleye.Binaryspec a a

86−binaryspec = fromOpaleyespec Opaleye.binaryspecField

64+binaryspec = Opaleye.Binaryspec $ Opaleye.PackMap $ \f (as, bs) ->

65+ fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->

66+ WrapApplicative $

67+ case (hfield (toColumns as) field, hfield (toColumns bs) field) of

68+ (DB a, DB b) -> DB . fromPrimExpr <$> f (toPrimExpr a, toPrimExpr b)

89distinctspec :: Table Expr a => Opaleye.Distinctspec a a

71distinctspec :: Table Expr a => Opaleye.Distinctspec a a

90−distinctspec = fromOpaleyespec Opaleye.distinctspecField

72+distinctspec =

91−

73+ Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap $ \f ->

92−

74+ fmap fromColumns .

93−exprs :: Table Expr a => a -> NonEmpty Opaleye.PrimExpr

75+ unwrapApplicative .

94−exprs (toColumns -> as) = getConst $ htabulateA $ \field ->

76+ htraverse

95− case hfield as field of

77+ (\(DB a) ->

96− expr -> Const (pure (toPrimExpr expr))

78+ WrapApplicative $ DB . fromPrimExpr <$> f (Nothing, toPrimExpr a)) .

97−

79+ toColumns

98−

80+

99−exprsWithNames :: Selects names exprs

81+

100− => names -> exprs -> NonEmpty (String, Opaleye.PrimExpr)

82+table ::(Selects names exprs, Inserts exprs inserts)

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

83+ => TableSchema names -> Opaleye.Table inserts exprs

107table (TableSchema name schema columns) =

84table (TableSchema name schema columns) =

108 case schema of

85 case schema of

109− Nothing -> Opaleye.table name (tableFields columns)

86+ Nothing -> Opaleye.Table name (tableFields columns)

110− Just schemaName -> Opaleye.tableWithSchema schemaName name (tableFields columns)

87+ Just schemaName -> Opaleye.TableWithSchema schemaName name (tableFields columns)

111

112

113−tableFields :: Selects names exprs

90+tableFields :: (Selects names exprs, Inserts exprs inserts)

114− => names -> Opaleye.TableFields exprs exprs

91+ => names -> Opaleye.TableFields inserts exprs

115tableFields (toColumns -> names) = dimap toColumns fromColumns $

92tableFields (toColumns -> names) = dimap toColumns fromColumns $

116 unwrapApplicative $ htabulateA $ \field -> WrapApplicative $

93 unwrapApplicative $ htabulateA $ \field -> WrapApplicative $

94+ case hfield hspecs field of

117− case hfield names field of

95+ specs -> case hfield names field of

118− name -> lmap (`hfield` field) (go name)

96+ name -> lmap (`hfield` field) (go specs name)

119 where

97 where

120− go :: Name a -> Opaleye.TableFields (Expr a) (Expr a)

98+ go :: SSpec spec -> Col Name spec -> Opaleye.TableFields (Col Insert spec) (Col Expr spec)

121− go (Name name) =

99+ go SSpec {necessity} (NameCol name) = case necessity of

122− traverseFieldP $

100+ SRequired ->

101+ lmap (\(RequiredInsert a) -> toColumn $ toPrimExpr a) $

102+ DB . fromPrimExpr . fromColumn <$>

123− Opaleye.requiredTableField name

103+ Opaleye.requiredTableField name

104+ SOptional ->

105+ lmap (\(OptionalInsert ma) -> toColumn . toPrimExpr <$> ma) $

106+ DB . fromPrimExpr . fromColumn <$>

107+ Opaleye.optionalTableField name

124

108

125

109

126unpackspec :: Table Expr a => Opaleye.Unpackspec a a

110unpackspec :: Table Expr a => Opaleye.Unpackspec a a

127−unpackspec = fromOpaleyespec Opaleye.unpackspecField

111+unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->

112+ fmap fromColumns .

113+ unwrapApplicative .

114+ htraverse (\(DB a) -> WrapApplicative $ DB <$> traversePrimExpr f a) .

115+ toColumns

128{-# INLINABLE unpackspec #-}

116{-# INLINABLE unpackspec #-}

129

117

130

118

131−valuesspec :: Table Expr a => Opaleye.Valuesspec a a

119+valuesspec :: Table Expr a => Opaleye.ValuesspecSafe a a

132−valuesspec = dimap toColumns fromColumns $

120+valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec

133− htraversePWithField (traverseFieldP . Opaleye.valuesspecFieldType . typeName)

134− where typeName = Rel8.Type.Information.typeName . info . hfield hspecs

135

121

136

122

137−view :: Selects names exprs => names -> exprs

123+toPackMap :: Table Expr a

124+ => a -> Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () a

125+toPackMap as = Opaleye.PackMap $ \f () ->

138−view columns = fromColumns $ htabulate $ \field ->

126+ fmap fromColumns $

127+ unwrapApplicative .

128+ htraverse (\(DB a) -> WrapApplicative $ DB <$> traversePrimExpr f a) $

139− case hfield (toColumns columns) field of

129+ toColumns as

140− Name column -> fromPrimExpr $ Opaleye.BaseTableAttrExpr column

141

130

142

131

143-- | Transform a table by adding 'CAST' to all columns. This is most useful for

132-- | Transform a table by adding 'CAST' to all columns. This is most useful for

144-- finalising a SELECT or RETURNING statement, guaranteed that the output

133-- finalising a SELECT or RETURNING statement, guaranteed that the output

145-- matches what is encoded in each columns TypeInformation.

134-- matches what is encoded in each columns TypeInformation.

146castTable :: Table Expr a => a -> a

135castTable :: Table Expr a => a -> a

147−castTable (toColumns -> as) = fromColumns $ htabulate \field ->

136+castTable (toColumns -> as) = fromColumns $ htabulate \i ->

148− case hfield hspecs field of

137+ case hfield hspecs i of

138+ SSpec{info} ->

149− Spec {info} -> case hfield as field of

139+ case hfield as i of

140+ DB expr ->

150− expr -> scastExpr info expr

141+ DB (scastExpr info expr)

src/Rel8/Table/Ord.hs+45−16

@@ -10,6 +10,7 @@

10{-# language TypeFamilies #-}

11{-# language TypeOperators #-}

12{-# language UndecidableInstances #-}

13+{-# language UndecidableSuperClasses #-}

13{-# language ViewPatterns #-}

14{-# language ViewPatterns #-}

15module Rel8.Table.Ord

16module Rel8.Table.Ord

@@ -24,20 +25,29 @@ import GHC.Generics ( Rep )

24import Prelude hiding ( seq )

25import Prelude hiding ( seq )

26-- rel8

27-- rel8

27−import Rel8.Expr ( Expr )

28+import Rel8.Expr ( Expr, Col(..) )

28import Rel8.Expr.Bool ( (||.), (&&.), false, true )

29import Rel8.Expr.Bool ( (||.), (&&.), false, true )

29import Rel8.Expr.Eq ( (==.) )

30import Rel8.Expr.Eq ( (==.) )

30import Rel8.Expr.Ord ( (<.), (>.) )

31import Rel8.Expr.Ord ( (<.), (>.) )

31import Rel8.FCF ( Eval, Exp )

32import Rel8.FCF ( Eval, Exp )

32import Rel8.Generic.Record ( Record )

33import Rel8.Generic.Record ( Record )

33−import Rel8.Generic.Table.Record ( GTable, GColumns, gtable )

34+import Rel8.Generic.Table

35+ ( GGTable, GGColumns, ggtable

36+ , GAlgebra

37+ )

38+import Rel8.Kind.Algebra ( KnownAlgebra )

34import Rel8.Schema.Dict ( Dict( Dict ) )

39import Rel8.Schema.Dict ( Dict( Dict ) )

35−import Rel8.Schema.HTable ( htabulateA, hfield )

40+import Rel8.Schema.HTable

41+ ( HTable, HConstrainTable

42+ , htabulateA, hfield, hdicts

43+ )

36−import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

44+import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )

37import Rel8.Schema.Null (Sql)

45import Rel8.Schema.Null (Sql)

46+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType, nullifier )

38import Rel8.Table ( Columns, toColumns, TColumns )

47import Rel8.Table ( Columns, toColumns, TColumns )

39import Rel8.Table.Bool ( bool )

48import Rel8.Table.Bool ( bool )

40import Rel8.Table.Eq ( EqTable )

49import Rel8.Table.Eq ( EqTable )

50+import Rel8.Type.Eq ( DBEq )

41import Rel8.Type.Ord ( DBOrd )

51import Rel8.Type.Ord ( DBOrd )

@@ -46,14 +56,22 @@ import Rel8.Type.Ord ( DBOrd )

46-- columns in a 'Table' have an instance of 'DBOrd'".

56-- columns in a 'Table' have an instance of 'DBOrd'".

47type OrdTable :: Type -> Constraint

57type OrdTable :: Type -> Constraint

48class EqTable a => OrdTable a where

58class EqTable a => OrdTable a where

49− ordTable :: Columns a (Dict (Sql DBOrd))

59+ ordTable :: Columns a (Dict (ConstrainDBType DBOrd))

51 default ordTable ::

61 default ordTable ::

62+ ( KnownAlgebra (GAlgebra (Rep (Record a)))

52− ( GTable TOrdTable TColumns (Rep (Record a))

63+ , Eval (GGTable (GAlgebra (Rep (Record a))) TOrdTable TColumns (Dict (ConstrainDBType DBOrd)) (Rep (Record a)))

53− , Columns a ~ GColumns TColumns (Rep (Record a))

64+ , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))

54 )

65 )

55− => Columns a (Dict (Sql DBOrd))

66+ => Columns a (Dict (ConstrainDBType DBOrd))

56− ordTable = gtable @TOrdTable @TColumns @(Rep (Record a)) table

67+ ordTable =

68+ ggtable

69+ @(GAlgebra (Rep (Record a)))

70+ @TOrdTable

71+ @TColumns

72+ @(Rep (Record a))

73+ table

74+ nullifier

57 where

75 where

58 table (_ :: proxy x) = ordTable @x

76 table (_ :: proxy x) = ordTable @x

@@ -62,8 +80,19 @@ data TOrdTable :: Type -> Exp Constraint

62type instance Eval (TOrdTable a) = OrdTable a

80type instance Eval (TOrdTable a) = OrdTable a

83+instance

84+ ( HTable t

85+ , f ~ Col Expr

86+ , HConstrainTable t (ConstrainDBType DBEq)

87+ , HConstrainTable t (ConstrainDBType DBOrd)

88+ )

89+ => OrdTable (t f)

90+ where

91+ ordTable = hdicts @(Columns (t f)) @(ConstrainDBType DBOrd)

92+

93+

65instance Sql DBOrd a => OrdTable (Expr a) where

94instance Sql DBOrd a => OrdTable (Expr a) where

66− ordTable = HIdentity Dict

95+ ordTable = HType Dict

69instance (OrdTable a, OrdTable b) => OrdTable (a, b)

98instance (OrdTable a, OrdTable b) => OrdTable (a, b)

@@ -98,7 +127,7 @@ instance

98(toColumns -> as) <: (toColumns -> bs) =

127(toColumns -> as) <: (toColumns -> bs) =

99 foldr @[] go false $ getConst $ htabulateA $ \field ->

128 foldr @[] go false $ getConst $ htabulateA $ \field ->

100 case (hfield as field, hfield bs field) of

129 case (hfield as field, hfield bs field) of

101− (a, b) -> case hfield (ordTable @a) field of

130+ (DB a, DB b) -> case hfield (ordTable @a) field of

102 Dict -> Const [(a <. b, a ==. b)]

131 Dict -> Const [(a <. b, a ==. b)]

103 where

132 where

104 go (lt, eq) a = lt ||. (eq &&. a)

133 go (lt, eq) a = lt ||. (eq &&. a)

@@ -111,7 +140,7 @@ infix 4 <:

111(toColumns -> as) <=: (toColumns -> bs) =

140(toColumns -> as) <=: (toColumns -> bs) =

112 foldr @[] go true $ getConst $ htabulateA $ \field ->

141 foldr @[] go true $ getConst $ htabulateA $ \field ->

113 case (hfield as field, hfield bs field) of

142 case (hfield as field, hfield bs field) of

114− (a, b) -> case hfield (ordTable @a) field of

143+ (DB a, DB b) -> case hfield (ordTable @a) field of

115 Dict -> Const [(a <. b, a ==. b)]

144 Dict -> Const [(a <. b, a ==. b)]

116 where

145 where

117 go (lt, eq) a = lt ||. (eq &&. a)

146 go (lt, eq) a = lt ||. (eq &&. a)

@@ -124,7 +153,7 @@ infix 4 <=:

124(toColumns -> as) >: (toColumns -> bs) =

153(toColumns -> as) >: (toColumns -> bs) =

125 foldr @[] go false $ getConst $ htabulateA $ \field ->

154 foldr @[] go false $ getConst $ htabulateA $ \field ->

126 case (hfield as field, hfield bs field) of

155 case (hfield as field, hfield bs field) of

127− (a, b) -> case hfield (ordTable @a) field of

156+ (DB a, DB b) -> case hfield (ordTable @a) field of

128 Dict -> Const [(a >. b, a ==. b)]

157 Dict -> Const [(a >. b, a ==. b)]

129 where

158 where

130 go (gt, eq) a = gt ||. (eq &&. a)

159 go (gt, eq) a = gt ||. (eq &&. a)

@@ -137,7 +166,7 @@ infix 4 >:

137(toColumns -> as) >=: (toColumns -> bs) =

166(toColumns -> as) >=: (toColumns -> bs) =

138 foldr @[] go true $ getConst $ htabulateA $ \field ->

167 foldr @[] go true $ getConst $ htabulateA $ \field ->

139 case (hfield as field, hfield bs field) of

168 case (hfield as field, hfield bs field) of

140− (a, b) -> case hfield (ordTable @a) field of

169+ (DB a, DB b) -> case hfield (ordTable @a) field of

141 Dict -> Const [(a >. b, a ==. b)]

170 Dict -> Const [(a >. b, a ==. b)]

142 where

171 where

143 go (gt, eq) a = gt ||. (eq &&. a)

172 go (gt, eq) a = gt ||. (eq &&. a)

@@ -146,9 +175,9 @@ infix 4 >=:

146

175

147-- | Given two 'Table's, return the table that sorts before the other.

176-- | Given two 'Table's, return the table that sorts before the other.

148least :: OrdTable a => a -> a -> a

177least :: OrdTable a => a -> a -> a

149−least a b = bool b a (a <: b)

178+least a b = bool a b (a <: b)

150

179

151

180

152-- | Given two 'Table's, return the table that sorts after the other.

181-- | Given two 'Table's, return the table that sorts after the other.

153greatest :: OrdTable a => a -> a -> a

182greatest :: OrdTable a => a -> a -> a

154−greatest a b = bool b a (a >: b)

183+greatest a b = bool a b (a >: b)

src/Rel8/Table/Order.hs+16−13

@@ -1,5 +1,4 @@

1{-# language DataKinds #-}

2−{-# language NamedFieldPuns #-}

3{-# language ScopedTypeVariables #-}

2{-# language ScopedTypeVariables #-}

4{-# language TypeApplications #-}

3{-# language TypeApplications #-}

5{-# language TypeFamilies #-}

4{-# language TypeFamilies #-}

@@ -16,14 +15,16 @@ import Data.Functor.Contravariant ( (>$<), contramap )

16import Prelude

15import Prelude

18-- rel8

17-- rel8

18+import Rel8.Expr ( unDB )

19import Rel8.Expr.Order ( asc, desc, nullsFirst, nullsLast )

20import Rel8.Order ( Order )

21import Rel8.Schema.Dict ( Dict( Dict ) )

22import Rel8.Schema.HTable (htabulateA, hfield, hspecs)

23import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

24−import Rel8.Schema.Spec ( Spec( Spec, nullity ) )

24+import Rel8.Schema.Spec ( SSpec( SSpec ) )

25+import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullity )

25import Rel8.Table ( Columns, toColumns )

26import Rel8.Table ( Columns, toColumns )

26−import Rel8.Table.Ord ( OrdTable, ordTable )

27+import Rel8.Table.Ord

29-- | Construct an 'Order' for a 'Table' by sorting all columns into ascending

30-- | Construct an 'Order' for a 'Table' by sorting all columns into ascending

@@ -31,11 +32,12 @@ import Rel8.Table.Ord ( OrdTable, ordTable )

31ascTable :: forall a. OrdTable a => Order a

32ascTable :: forall a. OrdTable a => Order a

32ascTable = contramap toColumns $ getConst $

33ascTable = contramap toColumns $ getConst $

33 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

34 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

34− Spec {nullity} -> case hfield (ordTable @a) field of

35+ SSpec {} -> case hfield (ordTable @a) field of

36+ dict@Dict -> case dbTypeDict dict of

35− Dict -> Const $ (`hfield` field) >$<

37+ Dict -> Const $ unDB . (`hfield` field) >$<

36− case nullity of

38+ case dbTypeNullity dict of

37− Null -> nullsFirst asc

39+ Null -> nullsFirst asc

38− NotNull -> asc

40+ NotNull -> asc

41-- | Construct an 'Order' for a 'Table' by sorting all columns into descending

43-- | Construct an 'Order' for a 'Table' by sorting all columns into descending

@@ -43,8 +45,9 @@ ascTable = contramap toColumns $ getConst $

43descTable :: forall a. OrdTable a => Order a

45descTable :: forall a. OrdTable a => Order a

44descTable = contramap toColumns $ getConst $

46descTable = contramap toColumns $ getConst $

45 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

47 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

46− Spec {nullity} -> case hfield (ordTable @a) field of

48+ SSpec {} -> case hfield (ordTable @a) field of

49+ dict@Dict -> case dbTypeDict dict of

47− Dict -> Const $ (`hfield` field) >$<

50+ Dict -> Const $ unDB . (`hfield` field) >$<

48− case nullity of

51+ case dbTypeNullity dict of

49− Null -> nullsLast desc

52+ Null -> nullsLast desc

50− NotNull -> desc

53+ NotNull -> desc

src/Rel8/Table/Projection.hsdeleted−73

@@ -1,73 +0,0 @@

1−{-# language FlexibleContexts #-}

2−{-# language FlexibleInstances #-}

3−{-# language MonoLocalBinds #-}

4−{-# language MultiParamTypeClasses #-}

5−{-# language StandaloneKindSignatures #-}

6−{-# language UndecidableInstances #-}

7−

8−module Rel8.Table.Projection

9− ( Projection

10− , Projectable( project )

11− , Biprojectable( biproject )

12− , Projecting

13− , apply

14− )

15−where

16−

17−-- base

18−import Data.Kind ( Constraint, Type )

19−import Prelude

20−

21−-- rel8

22−import Rel8.Schema.Field ( Field( Field ), fields )

23−import Rel8.Schema.HTable ( hfield, htabulate )

24−import Rel8.Table ( Columns, Context, Transpose, toColumns )

25−import Rel8.Table.Transpose ( Transposes )

26−

27−

28−-- | The constraint @'Projecting' a b@ ensures that @'Projection' a b@ is a

29−-- usable 'Projection'.

30−type Projecting :: Type -> Type -> Constraint

31−class

32− ( Transposes (Context a) (Field a) a (Transpose (Field a) a)

33− , Transposes (Context a) (Field a) b (Transpose (Field a) b)

34− )

35− => Projecting a b

36−instance

37− ( Transposes (Context a) (Field a) a (Transpose (Field a) a)

38− , Transposes (Context a) (Field a) b (Transpose (Field a) b)

39− )

40− => Projecting a b

41−

42−

43−-- | A @'Projection' a b@s is a special type of function @a -> b@ whereby the

44−-- resulting @b@ is guaranteed to be composed only from columns contained in

45−-- @a@.

46−type Projection :: Type -> Type -> Type

47−type Projection a b = Transpose (Field a) a -> Transpose (Field a) b

48−

49−

50−-- | @'Projectable' f@ means that @f@ is a kind of functor on 'Rel8.Table's

51−-- that allows the mapping of a 'Projection' over its underlying columns.

52−type Projectable :: (Type -> Type) -> Constraint

53−class Projectable f where

54− -- | Map a 'Projection' over @f@.

55− project :: Projecting a b

56− => Projection a b -> f a -> f b

57−

58−

59−-- | @'Biprojectable' p@ means that @p@ is a kind of bifunctor on

60−-- 'Rel8.Table's that allows the mapping of a pair of 'Projection's over its

61−-- underlying columns.

62−type Biprojectable :: (Type -> Type -> Type) -> Constraint

63−class Biprojectable p where

64− -- | Map a pair of 'Projection's over @p@.

65− biproject :: (Projecting a b, Projecting c d)

66− => Projection a b -> Projection c d -> p a c -> p b d

67−

68−

69−apply :: Projecting a b

70− => Projection a b -> Columns a context -> Columns b context

71−apply f a = case toColumns (f fields) of

72− bs -> htabulate $ \field -> case hfield bs field of

73− Field field' -> hfield a field'

src/Rel8/Table/Recontextualize.hsnew file+87

@@ -0,0 +1,87 @@

1+{-# language DataKinds #-}

2+{-# language FlexibleInstances #-}

3+{-# language FunctionalDependencies #-}

4+{-# language StandaloneKindSignatures #-}

5+{-# language TypeFamilies #-}

6+{-# language UndecidableInstances #-}

7+{-# language UndecidableSuperClasses #-}

9+module Rel8.Table.Recontextualize

10+ ( Recontextualize

11+ )

12+where

13+

14+-- base

15+import Data.Functor.Identity ( Identity )

16+import Data.Kind ( Constraint, Type )

17+import Prelude ()

18+

19+-- rel8

20+import Rel8.Schema.Context ( Col )

21+import Rel8.Schema.Context.Label ( Labelable )

22+import Rel8.Schema.HTable ( HTable )

23+import qualified Rel8.Schema.Kind as K

24+import Rel8.Schema.Null ( Sql )

25+import Rel8.Schema.Result ( Result )

26+import Rel8.Table ( Table, Congruent )

27+import Rel8.Type ( DBType )

28+

29+

30+type Recontextualize :: K.Context -> K.Context -> Type -> Type -> Constraint

31+class

32+ ( Table from a

33+ , Table to b

34+ , Congruent a b

35+ , Recontextualize from from a a

36+ , Recontextualize to to b b

37+ , Recontextualize to from b a

38+ ) => Recontextualize from to a b

39+ | a -> from

40+ , b -> to

41+ , a to -> b

42+ , b from -> a

43+

44+

45+instance Sql DBType a => Recontextualize Result Result (Identity a) (Identity a)

46+

47+

48+instance HTable t => Recontextualize from to (t (Col from)) (t (Col to))

49+

50+

51+instance

52+ ( Recontextualize from to a1 b1

53+ , Recontextualize from to a2 b2

54+ , Labelable from

55+ , Labelable to

56+ )

57+ => Recontextualize from to (a1, a2) (b1, b2)

58+

59+

60+instance

61+ ( Recontextualize from to a1 b1

62+ , Recontextualize from to a2 b2

63+ , Recontextualize from to a3 b3

64+ , Labelable from, Labelable to

65+ )

66+ => Recontextualize from to (a1, a2, a3) (b1, b2, b3)

67+

68+

69+instance

70+ ( Recontextualize from to a1 b1

71+ , Recontextualize from to a2 b2

72+ , Recontextualize from to a3 b3

73+ , Recontextualize from to a4 b4

74+ , Labelable from, Labelable to

75+ )

76+ => Recontextualize from to (a1, a2, a3, a4) (b1, b2, b3, b4)

77+

78+

79+instance

80+ ( Recontextualize from to a1 b1

81+ , Recontextualize from to a2 b2

82+ , Recontextualize from to a3 b3

83+ , Recontextualize from to a4 b4

84+ , Recontextualize from to a5 b5

85+ , Labelable from, Labelable to

86+ )

87+ => Recontextualize from to (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5)

src/Rel8/Table/Rel8able.hs+85−29

@@ -1,6 +1,6 @@

1{-# language DataKinds #-}

2{-# language FlexibleInstances #-}

3−{-# language MultiParamTypeClasses #-}

3+{-# language FunctionalDependencies #-}

4{-# language ScopedTypeVariables #-}

5{-# language StandaloneKindSignatures #-}

6{-# language TypeApplications #-}

@@ -15,78 +15,134 @@ module Rel8.Table.Rel8able

15where

17-- base

18+import Data.Kind ( Constraint, Type )

19+import Data.Type.Equality ( (:~:)( Refl ) )

18−import Prelude ()

20+import Prelude

20-- rel8

22-- rel8

21import Rel8.Expr ( Expr )

23import Rel8.Expr ( Expr )

22import qualified Rel8.Kind.Algebra as K

24import qualified Rel8.Kind.Algebra as K

23−import Rel8.Kind.Context ( Reifiable, contextSing )

25+import Rel8.Kind.Context

26+ ( SContext( SReify )

27+ , Reifiable, contextSing

28+ , sLabelable, sReifiable

29+ )

24import Rel8.Generic.Rel8able

30import Rel8.Generic.Rel8able

25 ( Rel8able, Algebra

31 ( Rel8able, Algebra

26 , GColumns, gfromColumns, gtoColumns

32 , GColumns, gfromColumns, gtoColumns

27− , GFromExprs, gfromResult, gtoResult

33+ , greify, gunreify

28 )

34 )

35+import Rel8.Schema.Context ( Col )

36+import Rel8.Schema.Context.Label ( Labelable )

37+import Rel8.Schema.Dict ( Dict( Dict ) )

29import qualified Rel8.Schema.Kind as K

38import qualified Rel8.Schema.Kind as K

30import Rel8.Schema.HTable ( HConstrainTable, hdicts )

39import Rel8.Schema.HTable ( HConstrainTable, hdicts )

31−import Rel8.Schema.Null ( Sql )

40+import Rel8.Schema.Reify ( hreify, hunreify, UnwrapReify )

32import Rel8.Schema.Result ( Result )

41import Rel8.Schema.Result ( Result )

33import Rel8.Table

42import Rel8.Table

34− ( Table, Columns, Context, fromColumns, toColumns

43+ ( Table, Columns, Context, Congruent, fromColumns, toColumns

35− , FromExprs, fromResult, toResult

44+ , Unreify, reify, unreify

36− , Transpose

37 )

45 )

38−import Rel8.Table.ADT ( ADT )

46+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )

47+import Rel8.Table.ADT ( ADT( ADT ), ADTable, fromADT, toADT )

39import Rel8.Table.Eq ( EqTable, eqTable )

48import Rel8.Table.Eq ( EqTable, eqTable )

49+import Rel8.Table.HKD ( HKD )

40import Rel8.Table.Ord ( OrdTable, ordTable )

50import Rel8.Table.Ord ( OrdTable, ordTable )

41−import Rel8.Table.Serialize ( ToExprs )

51+import Rel8.Table.Recontextualize ( Recontextualize )

52+import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )

42import Rel8.Type.Eq ( DBEq )

53import Rel8.Type.Eq ( DBEq )

43import Rel8.Type.Ord ( DBOrd )

54import Rel8.Type.Ord ( DBOrd )

46−instance (Rel8able t, Reifiable context, context ~ context') =>

57+instance (Rel8able t, Labelable context, Reifiable context) =>

47− Table context' (t context)

58+ Table context (t context)

48 where

59 where

49 type Columns (t context) = GColumns t

60 type Columns (t context) = GColumns t

50 type Context (t context) = context

61 type Context (t context) = context

51− type FromExprs (t context) = GFromExprs t

62+ type Unreify (t context) = t (UnwrapReify context)

52− type Transpose to (t context) = t to

63+

64+ fromColumns = gunreify . gfromColumns . hreify

65+ toColumns = hunreify . gtoColumns . greify

66+

67+ reify Refl = case contextSing @context of

68+ SReify context -> case sLabelable context of

69+ Dict -> case sReifiable context of

70+ Dict -> greify

71+

72+ unreify Refl = case contextSing @context of

73+ SReify context -> case sLabelable context of

74+ Dict -> case sReifiable context of

75+ Dict -> gunreify

76+

54− fromColumns = gfromColumns contextSing

78+instance

55− toColumns = gtoColumns contextSing

79+ ( Rel8able t

56− fromResult = gfromResult @t

80+ , Labelable from, Reifiable from

57− toResult = gtoResult @t

81+ , Labelable to, Reifiable to

82+ , Congruent (t from) (t to)

83+ )

84+ => Recontextualize from to (t from) (t to)

60instance

87instance

61 ( context ~ Expr

88 ( context ~ Expr

62 , Rel8able t

89 , Rel8able t

63− , HConstrainTable (Columns (t context)) (Sql DBEq)

90+ , HConstrainTable (Columns (t context)) (ConstrainDBType DBEq)

64 )

91 )

65 => EqTable (t context)

92 => EqTable (t context)

66 where

93 where

67− eqTable = hdicts @(Columns (t context)) @(Sql DBEq)

94+ eqTable = hdicts @(Columns (t context)) @(ConstrainDBType DBEq)

70instance

97instance

71 ( context ~ Expr

98 ( context ~ Expr

72 , Rel8able t

99 , Rel8able t

73− , HConstrainTable (Columns (t context)) (Sql DBEq)

100+ , HConstrainTable (Columns (t context)) (ConstrainDBType DBEq)

74− , HConstrainTable (Columns (t context)) (Sql DBOrd)

101+ , HConstrainTable (Columns (t context)) (ConstrainDBType DBOrd)

75 )

102 )

76 => OrdTable (t context)

103 => OrdTable (t context)

77 where

104 where

78− ordTable = hdicts @(Columns (t context)) @(Sql DBOrd)

105+ ordTable = hdicts @(Columns (t context)) @(ConstrainDBType DBOrd)

106+

107+

108+type instance FromExprs (t Expr) = FromExprs' t

109

110

81instance

111instance

82− ( Rel8able t', t' ~ Choose (Algebra t) t

83− , x ~ t' Expr

112+ ( x ~ t' Expr

84 , result ~ Result

113 , result ~ Result

114+ , ToExprs' (Algebra t) t' t

85 )

115 )

86 => ToExprs x (t result)

116 => ToExprs x (t result)

117+ where

118+ fromResult = fromResult' @(Algebra t) @t'

119+ toResult = toResult' @(Algebra t) @t'

120

121

89−type Choose :: K.Algebra -> K.Rel8able -> K.Rel8able

122+type FromExprs' :: K.Rel8able -> Type

90−type family Choose algebra t where

123+type family FromExprs' t where

91− Choose 'K.Sum t = ADT t

124+ FromExprs' (ADT t) = t Result

92− Choose 'K.Product t = t

125+ FromExprs' (HKD a) = a

126+ FromExprs' t = t Result

127+

128+

129+type ToExprs' :: K.Algebra -> K.Rel8able -> K.Rel8able -> Constraint

130+class (algebra ~ Algebra t, Rel8able t') =>

131+ ToExprs' algebra t' t | algebra t -> t'

132+ where

133+ fromResult' :: GColumns t' (Col Result) -> t Result

134+ toResult' :: t Result -> GColumns t' (Col Result)

135+

136+

137+instance (Algebra t ~ 'K.Product, Rel8able t, t ~ t') =>

138+ ToExprs' 'K.Product t' t

139+ where

140+ fromResult' = fromColumns

141+ toResult' = toColumns

142+

143+

144+instance (Algebra t ~ 'K.Sum, ADTable t, t' ~ ADT t) =>

145+ ToExprs' 'K.Sum t' t

146+ where

147+ fromResult' = fromADT . ADT

148+ toResult' = (\(ADT a) -> a) . toADT

src/Rel8/Table/Serialize.hs+119−24

@@ -1,4 +1,7 @@

1{-# language AllowAmbiguousTypes #-}

2+{-# language DataKinds #-}

3+{-# language DefaultSignatures #-}

4+{-# language DisambiguateRecordFields #-}

2{-# language FlexibleContexts #-}

5{-# language FlexibleContexts #-}

3{-# language FlexibleInstances #-}

6{-# language FlexibleInstances #-}

4{-# language FunctionalDependencies #-}

7{-# language FunctionalDependencies #-}

@@ -7,54 +10,111 @@

7{-# language StandaloneKindSignatures #-}

10{-# language StandaloneKindSignatures #-}

8{-# language TypeApplications #-}

11{-# language TypeApplications #-}

9{-# language TypeFamilies #-}

12{-# language TypeFamilies #-}

13+{-# language TypeOperators #-}

10{-# language UndecidableInstances #-}

14{-# language UndecidableInstances #-}

12module Rel8.Table.Serialize

16module Rel8.Table.Serialize

13− ( Serializable, lit, litHTable, parse

17+ ( Serializable, lit, parse

14− , ToExprs

18+ , ToExprs(..), FromExprs

19+ , TToExprs

15 )

20 )

16where

21where

18-- base

23-- base

19−import Data.Functor.Identity ( Identity( Identity ) )

20import Data.Kind ( Constraint, Type )

24import Data.Kind ( Constraint, Type )

21import Data.List.NonEmpty ( NonEmpty )

25import Data.List.NonEmpty ( NonEmpty )

26+import GHC.Generics ( Generic, Rep, from, to )

22import Prelude

27import Prelude

24-- hasql

29-- hasql

25import qualified Hasql.Decoders as Hasql

30import qualified Hasql.Decoders as Hasql

27-- rel8

32-- rel8

28−import Rel8.Expr ( Expr )

33+import Rel8.Expr ( Expr, Col(..) )

29import Rel8.Expr.Serialize ( slitExpr, sparseValue )

34import Rel8.Expr.Serialize ( slitExpr, sparseValue )

35+import Rel8.FCF ( Eval, Exp )

36+import Rel8.Generic.Record ( Record(..) )

37+import Rel8.Generic.Table

38+ ( GGToExprs, GGColumns, ggfromResult, ggtoResult

39+ , GAlgebra

40+ )

41+import Rel8.Kind.Algebra ( KnownAlgebra )

30import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )

42import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )

43+import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )

31import Rel8.Schema.Null ( NotNull, Sql )

44import Rel8.Schema.Null ( NotNull, Sql )

32−import Rel8.Schema.Result ( Result )

45+import Rel8.Schema.Result ( Col( Result ), Result )

33−import Rel8.Schema.Spec ( Spec(..) )

46+import Rel8.Schema.Spec ( SSpec(..), KnownSpec )

34−import Rel8.Table ( Table, fromColumns, FromExprs, fromResult, toResult )

47+import Rel8.Table ( Table, Columns, fromColumns, toColumns, TColumns )

35import Rel8.Type ( DBType )

48import Rel8.Type ( DBType )

37-- semigroupoids

50-- semigroupoids

38import Data.Functor.Apply ( WrappedApplicative(..) )

51import Data.Functor.Apply ( WrappedApplicative(..) )

41−-- | @ToExprs exprs a@ is evidence that the types @exprs@ and @a@ describe

42−-- essentially the same type, but @exprs@ is in the 'Expr' context, and @a@ is

43−-- a normal Haskell type.

44type ToExprs :: Type -> Type -> Constraint

54type ToExprs :: Type -> Type -> Constraint

45−class Table Expr exprs => ToExprs exprs a

55+class Table Expr exprs => ToExprs exprs a where

46−

56+ fromResult :: Columns exprs (Col Result) -> a

47−

57+ toResult :: a -> Columns exprs (Col Result)

58+

59+ default fromResult ::

60+ ( Generic (Record a)

61+ , KnownAlgebra (GAlgebra (Rep (Record exprs)))

62+ , Eval (GGToExprs (GAlgebra (Rep (Record exprs))) TToExprs TColumns (Rep (Record exprs)) (Rep (Record a)))

63+ , Columns exprs ~ Eval (GGColumns (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs)))

64+ )

65+ => Columns exprs (Col Result) -> a

66+ fromResult =

67+ unrecord .

68+ to .

69+ ggfromResult

70+ @(GAlgebra (Rep (Record exprs)))

71+ @TToExprs

72+ @TColumns

73+ @(Rep (Record exprs))

74+ (\(_ :: proxy expr) -> fromResult @expr)

75+

76+ default toResult ::

77+ ( Generic (Record a)

78+ , KnownAlgebra (GAlgebra (Rep (Record exprs)))

79+ , Eval (GGToExprs (GAlgebra (Rep (Record exprs))) TToExprs TColumns (Rep (Record exprs)) (Rep (Record a)))

80+ , Columns exprs ~ Eval (GGColumns (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs)))

81+ )

82+ => a -> Columns exprs (Col Result)

83+ toResult =

84+ ggtoResult

85+ @(GAlgebra (Rep (Record exprs)))

86+ @TToExprs

87+ @TColumns

88+ @(Rep (Record exprs))

89+ (\(_ :: proxy expr) -> toResult @expr) .

90+ from .

91+ Record

92+

93+

94+data TToExprs :: Type -> Type -> Exp Constraint

95+type instance Eval (TToExprs exprs a) = ToExprs exprs a

96+

97+

48−instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a

98+instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a where

49−

99+ fromResult (HType (Result a)) = a

50−

100+ toResult = HType . Result

101+

102+

51−instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a]

103+instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a] where

104+ fromResult (HType (Result a)) = a

105+ toResult = HType . Result

106

107

54instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a)

108instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a)

109+ where

110+ fromResult (HType (Result a)) = a

111+ toResult = HType . Result

112

113

57instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a)

114instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a)

115+ where

116+ fromResult (HType (Result a)) = a

117+ toResult = HType . Result

118

119

60instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>

120instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>

@@ -116,6 +176,41 @@ instance

116 => ToExprs x (a, b, c, d, e, f, g)

176 => ToExprs x (a, b, c, d, e, f, g)

117

177

118

178

179+instance (HTable t, result ~ Col Result, x ~ t (Col Expr)) =>

180+ ToExprs x (t result)

181+ where

182+ fromResult = id

183+ toResult = id

184+

185+

186+instance (KnownSpec spec, x ~ Col Expr spec) =>

187+ ToExprs x (Col Result spec)

188+ where

189+ fromResult = fromColumns

190+ toResult = toColumns

191+

192+

193+type FromExprs :: Type -> Type

194+type family FromExprs a

195+type instance FromExprs (Expr a) = a

196+type instance FromExprs (Col Expr spec) = Col Result spec

197+type instance FromExprs (a, b) = (FromExprs a, FromExprs b)

198+type instance FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)

199+type instance FromExprs (a, b, c, d) =

200+ (FromExprs a, FromExprs b, FromExprs c, FromExprs d)

201+type instance FromExprs (a, b, c, d, e) =

202+ (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)

203+type instance FromExprs (a, b, c, d, e, f) =

204+ ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e

205+ , FromExprs f

206+ )

207+type instance FromExprs (a, b, c, d, e, f, g) =

208+ ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e

209+ , FromExprs f, FromExprs g

210+ )

211+type instance FromExprs (t (Col Expr)) = t (Col Result)

212+

213+

119-- | @Serializable@ witnesses the one-to-one correspondence between the type

214-- | @Serializable@ witnesses the one-to-one correspondence between the type

120-- @sql@, which contains SQL expressions, and the type @haskell@, which

215-- @sql@, which contains SQL expressions, and the type @haskell@, which

121-- contains the Haskell decoding of rows containing @sql@ SQL expressions.

216-- contains the Haskell decoding of rows containing @sql@ SQL expressions.

@@ -128,21 +223,21 @@ instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a

128-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is

223-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is

129-- capable of lifting single @Expr@s to full tables.

224-- capable of lifting single @Expr@s to full tables.

130lit :: forall exprs a. Serializable exprs a => a -> exprs

225lit :: forall exprs a. Serializable exprs a => a -> exprs

131−lit = fromColumns . litHTable . toResult @_ @exprs

226+lit = fromColumns . litHTable . toResult @exprs

132

227

133

228

134parse :: forall exprs a. Serializable exprs a => Hasql.Row a

229parse :: forall exprs a. Serializable exprs a => Hasql.Row a

135−parse = fromResult @_ @exprs <$> parseHTable

230+parse = fromResult @exprs <$> parseHTable

136

231

137

232

138−litHTable :: HTable t => t Result -> t Expr

233+litHTable :: HTable t => t (Col Result) -> t (Col Expr)

139litHTable as = htabulate $ \field ->

234litHTable as = htabulate $ \field ->

140 case hfield hspecs field of

235 case hfield hspecs field of

141− Spec {nullity, info} -> case hfield as field of

236+ SSpec {nullity, info} -> case hfield as field of

142− Identity value -> slitExpr nullity info value

237+ Result value -> DB (slitExpr nullity info value)

143

238

144

239

145−parseHTable :: HTable t => Hasql.Row (t Result)

240+parseHTable :: HTable t => Hasql.Row (t (Col Result))

146parseHTable = unwrapApplicative $ htabulateA $ \field ->

241parseHTable = unwrapApplicative $ htabulateA $ \field ->

147 WrapApplicative $ case hfield hspecs field of

242 WrapApplicative $ case hfield hspecs field of

148− Spec {nullity, info} -> Identity <$> sparseValue nullity info

243+ SSpec {nullity, info} -> Result <$> sparseValue nullity info

src/Rel8/Table/Tag.hsnew file+97

@@ -0,0 +1,97 @@

1+{-# language DataKinds #-}

2+{-# language FlexibleInstances #-}

3+{-# language GADTs #-}

4+{-# language InstanceSigs #-}

5+{-# language NamedFieldPuns #-}

6+{-# language ScopedTypeVariables #-}

7+{-# language StandaloneKindSignatures #-}

8+{-# language TypeApplications #-}

9+{-# language UndecidableInstances #-}

10+

11+module Rel8.Table.Tag

12+ ( Tag(..), Taggable

13+ , fromAggregate

14+ , fromExpr

15+ , fromName

16+ )

17+where

18+

19+-- base

20+import Control.Applicative ( (<|>), empty )

21+import Data.Kind ( Constraint, Type )

22+import Data.Foldable ( fold )

23+import Data.Monoid ( getFirst )

24+import Data.Proxy ( Proxy( Proxy ) )

25+import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )

26+import Prelude

27+

28+-- rel8

29+import Rel8.Aggregate ( Aggregate, Aggregator, foldInputs )

30+import Rel8.Expr ( Expr )

31+import Rel8.Expr.Opaleye ( fromPrimExpr )

32+import Rel8.Schema.Name ( Name( Name ) )

33+import Rel8.Schema.Null ( Sql )

34+import Rel8.Type.Monoid ( DBMonoid )

35+

36+

37+type Tag :: Symbol -> Type -> Type

38+data Tag label a = Tag

39+ { expr :: Expr a

40+ , aggregator :: Maybe Aggregator

41+ , name :: Name a

42+ }

43+

44+

45+type Taggable :: Type -> Constraint

46+class Taggable a where

47+ tappend :: KnownSymbol label => Tag label a -> Tag label a -> Tag label a

48+ tempty :: KnownSymbol label => Tag label a

49+

50+

51+instance Sql DBMonoid a => Taggable a where

52+ tappend :: forall label. KnownSymbol label

53+ => Tag label a -> Tag label a -> Tag label a

54+ tappend a b = Tag

55+ { expr = expr a <> expr b

56+ , aggregator = aggregator a <|> aggregator b

57+ , name = case (name a, symbolVal (Proxy @label)) of

58+ (Name x, y)

59+ | x == y -> name b

60+ | otherwise -> name a

61+ }

62+ {-# INLINABLE tappend #-}

63+

64+ tempty :: forall label. KnownSymbol label => Tag label a

65+ tempty = Tag

66+ { expr = mempty

67+ , aggregator = empty

68+ , name = Name (symbolVal (Proxy @label))

69+ }

70+ {-# INLINABLE tempty #-}

71+

72+

73+instance (KnownSymbol label, Taggable a) => Semigroup (Tag label a) where

74+ (<>) = tappend

75+

76+

77+instance (KnownSymbol label, Taggable a) => Monoid (Tag label a) where

78+ mempty = tempty

79+

80+

81+fromAggregate :: forall a label. (KnownSymbol label, Taggable a)

82+ => Aggregate (Expr a) -> Tag label a

83+fromAggregate = fold . getFirst . foldInputs go

84+ where

85+ go aggregator primExpr = pure $ (tempty @a @label)

86+ { expr = fromPrimExpr primExpr

87+ , aggregator

88+ }

89+

90+

91+fromExpr :: forall label a. (KnownSymbol label, Taggable a)

92+ => Expr a -> Tag label a

93+fromExpr expr = (tempty @a @label) {expr}

94+

95+

96+fromName :: forall a label. Taggable a => Name a -> Tag label a

97+fromName name = (tempty @a @"") {name}

src/Rel8/Table/These.hs+164−201

@@ -5,6 +5,7 @@

5{-# language FlexibleInstances #-}

6{-# language MultiParamTypeClasses #-}

7{-# language NamedFieldPuns #-}

8+{-# language RecordWildCards #-}

8{-# language ScopedTypeVariables #-}

9{-# language ScopedTypeVariables #-}

9{-# language StandaloneKindSignatures #-}

10{-# language StandaloneKindSignatures #-}

10{-# language TupleSections #-}

11{-# language TupleSections #-}

@@ -20,107 +21,92 @@ module Rel8.Table.These

20 , isThisTable, isThatTable, isThoseTable

21 , isThisTable, isThatTable, isThoseTable

21 , hasHereTable, hasThereTable

22 , hasHereTable, hasThereTable

22 , justHereTable, justThereTable

23 , justHereTable, justThereTable

23− , alignMaybeTable

24− , aggregateTheseTable

24+ , aggregateTheseTable, insertTheseTable, nameTheseTable

25− , nameTheseTable

26 )

25 )

27where

26where

29-- base

28-- base

29+import Control.Applicative ( liftA2 )

30import Data.Bifunctor ( Bifunctor, bimap )

31+import Data.Functor.Identity ( runIdentity )

31import Data.Kind ( Type )

32import Data.Kind ( Type )

32−import Data.Maybe ( isJust )

33−import Prelude hiding ( null, undefined )

33+import Prelude hiding ( undefined )

35-- rel8

36import Rel8.Aggregate ( Aggregate )

37import Rel8.Expr ( Expr )

38−import Rel8.Expr.Bool ( (&&.), (||.), boolExpr, not_ )

38+import Rel8.Expr.Bool ( (&&.), not_ )

39−import Rel8.Expr.Null ( null, isNonNull )

39+import Rel8.Expr.Null ( isNonNull )

40−import Rel8.Kind.Context ( Reifiable )

40+import Rel8.Schema.Context.Label

41+ ( Labelable

42+ , HLabelable, hlabeler, hunlabeler

43+ )

41−import Rel8.Schema.Context.Nullify ( Nullifiable )

44+import Rel8.Schema.Context.Nullify

45+ ( Nullifiable, ConstrainTag

46+ , HNullifiable, HConstrainTag

47+ , hencodeTag, hdecodeTag

48+ , hnullifier, hunnullifier

49+ )

42−import Rel8.Schema.Dict ( Dict( Dict ) )

50+import Rel8.Schema.HTable ( HTable )

43−import Rel8.Schema.HTable.Label ( hlabel, hrelabel, hunlabel )

51+import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

44import Rel8.Schema.HTable.Identity ( HIdentity(..) )

52import Rel8.Schema.HTable.Identity ( HIdentity(..) )

45−import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )

53+import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )

46import Rel8.Schema.HTable.These ( HTheseTable(..) )

54import Rel8.Schema.HTable.These ( HTheseTable(..) )

47−import qualified Rel8.Schema.Kind as K

55+import Rel8.Schema.Insert ( Insert )

48import Rel8.Schema.Name ( Name )

56import Rel8.Schema.Name ( Name )

49import Rel8.Table

57import Rel8.Table

50 ( Table, Columns, Context, fromColumns, toColumns

58 ( Table, Columns, Context, fromColumns, toColumns

51− , FromExprs, fromResult, toResult

59+ , reify, unreify

52− , Transpose

53 )

60 )

54import Rel8.Table.Eq ( EqTable, eqTable )

61import Rel8.Table.Eq ( EqTable, eqTable )

55import Rel8.Table.Maybe

62import Rel8.Table.Maybe

56 ( MaybeTable(..)

63 ( MaybeTable(..)

57 , maybeTable, justTable, nothingTable

64 , maybeTable, justTable, nothingTable

58 , isJustTable

65 , isJustTable

59− , aggregateMaybeTable

66+ , aggregateMaybeTable, insertMaybeTable, nameMaybeTable

60− , nameMaybeTable

61 )

67 )

62−import Rel8.Table.Nullify ( Nullify, guard )

63import Rel8.Table.Ord ( OrdTable, ordTable )

68import Rel8.Table.Ord ( OrdTable, ordTable )

64−import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )

69+import Rel8.Table.Recontextualize ( Recontextualize )

65−import Rel8.Table.Serialize ( ToExprs )

70+import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )

71+import Rel8.Table.Tag ( Tag(..) )

66import Rel8.Table.Undefined ( undefined )

72import Rel8.Table.Undefined ( undefined )

67import Rel8.Type.Tag ( MaybeTag )

73import Rel8.Type.Tag ( MaybeTag )

69-- semigroupoids

75-- semigroupoids

70−import Data.Functor.Apply ( Apply, (<.>) )

76+import Data.Functor.Apply ( Apply, (<.>), liftF2 )

71import Data.Functor.Bind ( Bind, (>>-) )

77import Data.Functor.Bind ( Bind, (>>-) )

73-- these

79-- these

74−import Data.These ( These( This, That, These ) )

80+import Data.These ( These )

75import Data.These.Combinators ( justHere, justThere )

81import Data.These.Combinators ( justHere, justThere )

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

84+type TheseTable :: Type -> Type -> Type

86−data TheseTable context a b = TheseTable

85+data TheseTable a b = TheseTable

87− { here :: MaybeTable context a

86+ { here :: MaybeTable a

88− , there :: MaybeTable context b

87+ , there :: MaybeTable b

89 }

88 }

90 deriving stock Functor

89 deriving stock Functor

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

92+instance Bifunctor TheseTable where

98 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)

93 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)

100

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) =>

96+instance (Table Expr a, Semigroup a) => Apply (TheseTable a) where

106− Apply (TheseTable context a)

107− where

108 fs <.> as = TheseTable

97 fs <.> as = TheseTable

109 { here = here fs <> here as

98 { here = here fs <> here as

110 , there = there fs <.> there as

99 , there = there fs <.> there as

111 }

100 }

112

101

113

102

114−instance (context ~ Expr, Table Expr a, Semigroup a) =>

103+instance (Table Expr a, Semigroup a) => Applicative (TheseTable a)

115− Applicative (TheseTable context a)

116 where

104 where

117 pure = thatTable

105 pure = thatTable

118 (<*>) = (<.>)

106 (<*>) = (<.>)

119

107

120

108

121−instance (context ~ Expr, Table Expr a, Semigroup a) =>

109+instance (Table Expr a, Semigroup a) => Bind (TheseTable a) where

122− Bind (TheseTable context a)

123− where

124 TheseTable here1 ma >>- f = case ma >>- f' of

110 TheseTable here1 ma >>- f = case ma >>- f' of

125 mtb -> TheseTable

111 mtb -> TheseTable

126 { here = maybeTable here1 ((here1 <>) . fst) mtb

112 { here = maybeTable here1 ((here1 <>) . fst) mtb

@@ -131,14 +117,12 @@ instance (context ~ Expr, Table Expr a, Semigroup a) =>

131 TheseTable here2 mb -> (here2,) <$> mb

117 TheseTable here2 mb -> (here2,) <$> mb

132

118

133

119

134−instance (context ~ Expr, Table Expr a, Semigroup a) =>

120+instance (Table Expr a, Semigroup a) => Monad (TheseTable a) where

135− Monad (TheseTable context a)

136− where

137 (>>=) = (>>-)

121 (>>=) = (>>-)

138

122

139

123

140−instance (context ~ Expr, Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>

124+instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>

141− Semigroup (TheseTable context a b)

125+ Semigroup (TheseTable a b)

142 where

126 where

143 a <> b = TheseTable

127 a <> b = TheseTable

144 { here = here a <> here b

128 { here = here a <> here b

@@ -148,175 +132,99 @@ instance (context ~ Expr, Table Expr a, Table Expr b, Semigroup a, Semigroup b)

148

132

149instance

133instance

150 ( Table context a, Table context b

134 ( Table context a, Table context b

151− , Reifiable context, context ~ context'

135+ , Labelable context, Nullifiable context, ConstrainTag context MaybeTag

152− )

153− => Table context' (TheseTable context a b)

136+ ) => Table context (TheseTable a b)

154 where

137 where

155− type Columns (TheseTable context a b) = HTheseTable (Columns a) (Columns b)

138+ type Columns (TheseTable a b) = HTheseTable (Columns a) (Columns b)

156− type Context (TheseTable context a b) = Context a

139+ type Context (TheseTable a b) = Context a

157− type FromExprs (TheseTable context a b) =

158− These (FromExprs a) (FromExprs b)

159− type Transpose to (TheseTable context a b) =

160− TheseTable to (Transpose to a) (Transpose to b)

161−

162− toColumns TheseTable {here, there} = HTheseTable

163− { hhereTag = hlabel $ HIdentity $ tag here

164− , hhere =

165− hlabel $ guard (tag here) isJust isNonNull $ toColumns $ just here

166− , hthereTag = hlabel $ HIdentity $ tag there

167− , hthere =

168− hlabel $ guard (tag there) isJust isNonNull $ toColumns $ just there

169− }

170

140

171− fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable

141+ toColumns = toColumns2 toColumns toColumns

172− { here = MaybeTable

142+ fromColumns = fromColumns2 fromColumns fromColumns

173− { tag = unHIdentity $ hunlabel hhereTag

143+ reify = liftA2 bimap reify reify

174− , just = fromColumns $ hunlabel hhere

144+ unreify = liftA2 bimap unreify unreify

175− }

176− , there = MaybeTable

177− { tag = unHIdentity $ hunlabel hthereTag

178− , just = fromColumns $ hunlabel hthere

179− }

180− }

181

145

182− toResult tables = HTheseTable

183− { hhereTag = hrelabel hhereTag

184− , hhere = hrelabel hhere

185− , hthereTag = hrelabel hthereTag

186− , hthere = hrelabel hthere

187− }

188− where

189− HMaybeTable

190− { htag = hhereTag

191− , hjust = hhere

192− } = toResult @_ @(MaybeTable context a) (justHere tables)

193− HMaybeTable

194− { htag = hthereTag

195− , hjust = hthere

196− } = toResult @_ @(MaybeTable context b) (justThere tables)

197−

198− fromResult HTheseTable {hhereTag, hhere, hthereTag, hthere} =

199− case (here, there) of

200− (Just a, Nothing) -> This a

201− (Nothing, Just b) -> That b

202− (Just a, Just b) -> These a b

203− _ -> error "These.fromColumns: mismatch between tags and data"

204− where

205− here = fromResult @_ @(MaybeTable context a) mhere

206− there = fromResult @_ @(MaybeTable context b) mthere

207− mhere = HMaybeTable

208− { htag = hrelabel hhereTag

209− , hjust = hrelabel hhere

210− }

211− mthere = HMaybeTable

212− { htag = hrelabel hthereTag

213− , hjust = hrelabel hthere

214− }

215−

216−

217−instance (EqTable a, EqTable b, context ~ Expr) =>

218− EqTable (TheseTable context a b)

219− where

220− eqTable = HTheseTable

221− { hhereTag = hlabel (HIdentity Dict)

222− , hhere = hlabel (eqTable @(Nullify context a))

223− , hthereTag = hlabel (HIdentity Dict)

224− , hthere = hlabel (eqTable @(Nullify context b))

225− }

226

146

147+instance

148+ ( Labelable from, Nullifiable from, ConstrainTag from MaybeTag

149+ , Labelable to, Nullifiable to, ConstrainTag to MaybeTag

150+ , Recontextualize from to a1 b1

151+ , Recontextualize from to a2 b2

152+ ) =>

153+ Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2)

154+

155+

156+instance (EqTable a, EqTable b) => EqTable (TheseTable a b) where

157+ eqTable = toColumns2 id id (thoseTable (eqTable @a) (eqTable @b))

227

158

228−instance (OrdTable a, OrdTable b, context ~ Expr) =>

229− OrdTable (TheseTable context a b)

230− where

231− ordTable = HTheseTable

232− { hhereTag = hlabel (HIdentity Dict)

233− , hhere = hlabel (ordTable @(Nullify context a))

234− , hthereTag = hlabel (HIdentity Dict)

235− , hthere = hlabel (ordTable @(Nullify context b))

236− }

237

159

160+instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where

161+ ordTable = toColumns2 id id (thoseTable (ordTable @a) (ordTable @b))

238

162

163+

164+type instance FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)

165+

166+

239−instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable Expr exprs1 exprs2) =>

167+instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable exprs1 exprs2) =>

240 ToExprs x (These a b)

168 ToExprs x (These a b)

169+ where

170+ fromResult =

171+ bimap (fromResult @exprs1) (fromResult @exprs2) .

172+ fromColumns

173+ toResult =

174+ toColumns .

175+ bimap (toResult @exprs1) (toResult @exprs2)

176+

177+

178+toHereTag :: Tag "isJust" a -> Tag "hasHere" a

179+toHereTag Tag {..} = Tag {..}

241

180

242

181

243−-- | Test if a 'TheseTable' was constructed with 'thisTable'.

182+toThereTag :: Tag "isJust" a -> Tag "hasThere" a

244−--

183+toThereTag Tag {..} = Tag {..}

245−-- Corresponds to 'Data.These.Combinators.isThis'.

184+

185+

246−isThisTable :: TheseTable Expr a b -> Expr Bool

186+isThisTable :: TheseTable a b -> Expr Bool

247isThisTable a = hasHereTable a &&. not_ (hasThereTable a)

187isThisTable a = hasHereTable a &&. not_ (hasThereTable a)

248

188

249

189

250−-- | Test if a 'TheseTable' was constructed with 'thatTable'.

251−--

252−-- Corresponds to 'Data.These.Combinators.isThat'.

253−isThatTable :: TheseTable Expr a b -> Expr Bool

190+isThatTable :: TheseTable a b -> Expr Bool

254isThatTable a = not_ (hasHereTable a) &&. hasThereTable a

191isThatTable a = not_ (hasHereTable a) &&. hasThereTable a

255

192

256

193

257−-- | Test if a 'TheseTable' was constructed with 'thoseTable'.

258−--

259−-- Corresponds to 'Data.These.Combinators.isThese'.

260−isThoseTable :: TheseTable Expr a b -> Expr Bool

194+isThoseTable :: TheseTable a b -> Expr Bool

261isThoseTable a = hasHereTable a &&. hasThereTable a

195isThoseTable a = hasHereTable a &&. hasThereTable a

262

196

263

197

264−-- | Test if the @a@ side of @TheseTable a b@ is present.

265−--

266−-- Corresponds to 'Data.These.Combinators.hasHere'.

267−hasHereTable :: TheseTable Expr a b -> Expr Bool

198+hasHereTable :: TheseTable a b -> Expr Bool

268hasHereTable TheseTable {here} = isJustTable here

199hasHereTable TheseTable {here} = isJustTable here

269

200

270

201

271−-- | Test if the @b@ table of @TheseTable a b@ is present.

272−--

273−-- Corresponds to 'Data.These.Combinators.hasThere'.

274−hasThereTable :: TheseTable Expr a b -> Expr Bool

202+hasThereTable :: TheseTable a b -> Expr Bool

275hasThereTable TheseTable {there} = isJustTable there

203hasThereTable TheseTable {there} = isJustTable there

276

204

277

205

278−-- | Attempt to project out the @a@ table of a @TheseTable a b@.

279−--

280−-- Corresponds to 'Data.These.Combinators.justHere'.

281−justHereTable :: TheseTable context a b -> MaybeTable context a

206+justHereTable :: TheseTable a b -> MaybeTable a

282justHereTable = here

207justHereTable = here

283

208

284

209

285−-- | Attempt to project out the @b@ table of a @TheseTable a b@.

286−--

287−-- Corresponds to 'Data.These.Combinators.justThere'.

288−justThereTable :: TheseTable context a b -> MaybeTable context b

210+justThereTable :: TheseTable a b -> MaybeTable b

289justThereTable = there

211justThereTable = there

290

212

291

213

292−-- | Construct a @TheseTable@ from two 'MaybeTable's.

293−alignMaybeTable :: ()

294− => MaybeTable Expr a

295− -> MaybeTable Expr b

296− -> MaybeTable Expr (TheseTable Expr a b)

297−alignMaybeTable a b = MaybeTable tag (pure (TheseTable a b))

298− where

299− tag = boolExpr null mempty (isJustTable a ||. isJustTable b)

300−

301−

302−-- | Construct a @TheseTable@. Corresponds to 'This'.

303−thisTable :: Table Expr b => a -> TheseTable Expr a b

214+thisTable :: Table Expr b => a -> TheseTable a b

304thisTable a = TheseTable (justTable a) nothingTable

215thisTable a = TheseTable (justTable a) nothingTable

305

216

306

217

307−-- | Construct a @TheseTable@. Corresponds to 'That'.

308−thatTable :: Table Expr a => b -> TheseTable Expr a b

218+thatTable :: Table Expr a => b -> TheseTable a b

309thatTable b = TheseTable nothingTable (justTable b)

219thatTable b = TheseTable nothingTable (justTable b)

310

220

311

221

312−-- | Construct a @TheseTable@. Corresponds to 'These'.

313−thoseTable :: a -> b -> TheseTable Expr a b

222+thoseTable :: a -> b -> TheseTable a b

314thoseTable a b = TheseTable (justTable a) (justTable b)

223thoseTable a b = TheseTable (justTable a) (justTable b)

315

224

316

225

317−-- | Pattern match on a 'TheseTable'. Corresponds to 'these'.

318theseTable :: Table Expr c

226theseTable :: Table Expr c

319− => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable Expr a b -> c

227+ => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable a b -> c

320theseTable f g h TheseTable {here, there} =

228theseTable f g h TheseTable {here, there} =

321 maybeTable

229 maybeTable

322 (maybeTable undefined f here)

230 (maybeTable undefined f here)

@@ -324,34 +232,89 @@ theseTable f g h TheseTable {here, there} =

324 there

232 there

325

233

326

234

327−-- | Lift a pair of aggregating functions to operate on an 'TheseTable'.

328−-- @thisTable@s, @thatTable@s and @thoseTable@s are grouped separately.

329aggregateTheseTable :: ()

235aggregateTheseTable :: ()

330− => (exprs -> aggregates)

236+ => (a -> Aggregate c)

331− -> (exprs' -> aggregates')

237+ -> (b -> Aggregate d)

332− -> TheseTable Expr exprs exprs'

238+ -> TheseTable a b

333− -> TheseTable Aggregate aggregates aggregates'

239+ -> Aggregate (TheseTable c d)

334−aggregateTheseTable f g (TheseTable here there) = TheseTable

240+aggregateTheseTable f g TheseTable {here, there} =

335− { here = aggregateMaybeTable f here

241+ liftF2 TheseTable (aggregateMaybeTable f here) (aggregateMaybeTable g there)

336− , there = aggregateMaybeTable g there

242+

337− }

243+

244+insertTheseTable :: (Table Insert a, Table Insert b)

245+ => These a b -> TheseTable a b

246+insertTheseTable =

247+ TheseTable <$> insertMaybeTable . justHere <*> insertMaybeTable . justThere

338

248

339

249

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'.

343nameTheseTable :: ()

250nameTheseTable :: ()

344 => Name (Maybe MaybeTag)

251 => Name (Maybe MaybeTag)

345− -- ^ The name of the column to track the presence of the @a@ table.

346 -> Name (Maybe MaybeTag)

252 -> Name (Maybe MaybeTag)

347− -- ^ The name of the column to track the presence of the @b@ table.

348 -> a

253 -> a

349− -- ^ Names of the columns in the @a@ table.

350 -> b

254 -> b

351− -- ^ Names of the columns in the @b@ table.

352− -> TheseTable Name a b

255+ -> TheseTable a b

353nameTheseTable here there a b =

256nameTheseTable here there a b =

354 TheseTable

257 TheseTable

355 { here = nameMaybeTable here a

258 { here = nameMaybeTable here a

356 , there = nameMaybeTable there b

259 , there = nameMaybeTable there b

357 }

260 }

261+

262+

263+toColumns2 ::

264+ ( HTable t

265+ , HTable u

266+ , HConstrainTag context MaybeTag

267+ , HLabelable context

268+ , HNullifiable context

269+ )

270+ => (a -> t context)

271+ -> (b -> u context)

272+ -> TheseTable a b

273+ -> HTheseTable t u context

274+toColumns2 f g TheseTable {here, there} = HTheseTable

275+ { hhereTag = HIdentity $ hencodeTag (toHereTag (tag here))

276+ , hhere =

277+ hlabel hlabeler $ hnullify (hnullifier (tag here) isNonNull) $ f (just here)

278+ , hthereTag = HIdentity $ hencodeTag (toThereTag (tag there))

279+ , hthere =

280+ hlabel hlabeler $ hnullify (hnullifier (tag there) isNonNull) $ g (just there)

281+ }

282+

283+

284+fromColumns2 ::

285+ ( HTable t

286+ , HTable u

287+ , HConstrainTag context MaybeTag

288+ , HLabelable context

289+ , HNullifiable context

290+ )

291+ => (t context -> a)

292+ -> (u context -> b)

293+ -> HTheseTable t u context

294+ -> TheseTable a b

295+fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable

296+ { here =

297+ let

298+ tag = hdecodeTag $ unHIdentity hhereTag

299+ in

300+ MaybeTable

301+ { tag

302+ , just = f $

303+ runIdentity $

304+ hunnullify (\a -> pure . hunnullifier a) $

305+ hunlabel hunlabeler

306+ hhere

307+ }

308+ , there =

309+ let

310+ tag = hdecodeTag $ unHIdentity hthereTag

311+ in

312+ MaybeTable

313+ { tag

314+ , just = g $

315+ runIdentity $

316+ hunnullify (\a -> pure . hunnullifier a) $

317+ hunlabel hunlabeler

318+ hthere

319+ }

320+ }

src/Rel8/Table/Transpose.hsdeleted−46

@@ -1,46 +0,0 @@

1−{-# language DataKinds #-}

2−{-# language FlexibleInstances #-}

3−{-# language FunctionalDependencies #-}

4−{-# language StandaloneKindSignatures #-}

5−{-# language TypeFamilies #-}

6−{-# language UndecidableInstances #-}

7−

8−module Rel8.Table.Transpose

9− ( Transposes

10− )

11−where

12−

13−-- base

14−import Data.Kind ( Constraint, Type )

15−import Prelude ()

16−

17−-- rel8

18−import qualified Rel8.Schema.Kind as K

19−import Rel8.Table ( Table, Transpose, Congruent )

20−

21−

22−-- | @'Transposes' from to a b@ means that @a@ and @b@ are 'Table's, in the

23−-- @from@ and @to@ contexts respectively, which share the same underlying

24−-- structure. In other words, @b@ is a version of @a@ transposed from the

25−-- @from@ context to the @to@ context (and vice versa).

26−type Transposes :: K.Context -> K.Context -> Type -> Type -> Constraint

27−class

28− ( Table from a

29− , Table to b

30− , Congruent a b

31− , b ~ Transpose to a

32− , a ~ Transpose from b

33− )

34− => Transposes from to a b

35− | a -> from

36− , b -> to

37− , a to -> b

38− , b from -> a

39−instance

40− ( Table from a

41− , Table to b

42− , Congruent a b

43− , b ~ Transpose to a

44− , a ~ Transpose from b

45− )

46− => Transposes from to a b

src/Rel8/Table/Undefined.hs+5−5

@@ -11,16 +11,16 @@ where

11import Prelude hiding ( undefined )

13-- rel8

14−import Rel8.Expr ( Expr )

14+import Rel8.Expr ( Expr, Col(..) )

15import Rel8.Expr.Null ( snull, unsafeUnnullify )

16import Rel8.Schema.HTable ( htabulate, hfield, hspecs )

17import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

18−import Rel8.Schema.Spec ( Spec(..) )

18+import Rel8.Schema.Spec ( SSpec(..) )

19import Rel8.Table ( Table, fromColumns )

22undefined :: Table Expr a => a

23undefined = fromColumns $ htabulate $ \field -> case hfield hspecs field of

24− Spec {nullity, info} -> case nullity of

24+ SSpec {nullity, info} -> case nullity of

25− Null -> snull info

25+ Null -> DB (snull info)

26− NotNull -> unsafeUnnullify (snull info)

26+ NotNull -> DB (unsafeUnnullify (snull info))

src/Rel8/Table/Unreify.hsnew file+109

@@ -0,0 +1,109 @@

1+{-# language DataKinds #-}

2+{-# language FlexibleContexts #-}

3+{-# language FlexibleInstances #-}

4+{-# language GADTs #-}

5+{-# language LambdaCase #-}

6+{-# language MultiParamTypeClasses #-}

7+{-# language QuantifiedConstraints #-}

8+{-# language RankNTypes #-}

9+{-# language StandaloneKindSignatures #-}

10+{-# language TypeFamilies #-}

11+{-# language UndecidableInstances #-}

12+

13+-- | This module implements some machinery for implementing methods of the

14+-- 'Table' class for a particular special (but important) class of polymorphic

15+-- @Table@ types.

16+--

17+-- This special case is characterised by a @newtype@ wrapper around a bare

18+-- 'HTable' which is constructed by applying a type family to the polymorphic

19+-- type variable.

20+--

21+-- Examples of this class of @Table@ include @ListTable@ and @NonEmptyTable@.

22+--

23+-- The tricky part about implementing @Table@ for these types is 'reify' and

24+-- 'unreify'. There is no guarantee in general that @'Unreify' a@ is itself

25+-- a @Table@, let alone a @Table@ with the same 'Columns' as @a@

26+-- (e.g., @Unreify (AColumn Result Bool) = Bool@, and @Bool@ is not a

27+-- @Table@)

28+

29+module Rel8.Table.Unreify

30+ ( Unreifiable, Unreifiability( Unreifiability ), unreifiability

31+ , Unreifies

32+ )

33+where

34+

35+-- base

36+import Data.Kind ( Constraint, Type )

37+import Prelude ()

38+

39+-- rel8

40+import Rel8.Aggregate ( Aggregate )

41+import Rel8.Expr ( Expr )

42+import Rel8.Kind.Context ( SContext(..), Reifiable, sReifiable )

43+import Rel8.Schema.Dict ( Dict( Dict ) )

44+import Rel8.Schema.Insert ( Insert )

45+import qualified Rel8.Schema.Kind as K

46+import Rel8.Schema.Name ( Name )

47+import Rel8.Schema.Reify ( Reify )

48+import Rel8.Schema.Result ( Result )

49+import Rel8.Table ( Table, Context, Congruent, Unreify )

50+

51+

52+type Unreifies :: K.Context -> Type -> Constraint

53+type family Unreifies context a where

54+ Unreifies (Reify context) a = Unreifier context a

55+ Unreifies _ _ = ()

56+

57+

58+type Unreifiable :: Type -> Constraint

59+class

60+ ( Context a ~ Reify Aggregate => Unreifier Aggregate a

61+ , Context a ~ Reify Expr => Unreifier Expr a

62+ , Context a ~ Reify Insert => Unreifier Insert a

63+ , Context a ~ Reify Name => Unreifier Name a

64+ , Context a ~ Reify Result => Unreifier Result a

65+ , (forall ctx. (Context a ~ Reify (Reify ctx), Reifiable ctx) => Unreifier (Reify ctx) a)

66+ )

67+ => Unreifiable a

68+instance

69+ ( Context a ~ Reify Aggregate => Unreifier Aggregate a

70+ , Context a ~ Reify Expr => Unreifier Expr a

71+ , Context a ~ Reify Insert => Unreifier Insert a

72+ , Context a ~ Reify Name => Unreifier Name a

73+ , Context a ~ Reify Result => Unreifier Result a

74+ , (forall ctx. (Context a ~ Reify (Reify ctx), Reifiable ctx) => Unreifier (Reify ctx) a)

75+ )

76+ => Unreifiable a

77+

78+

79+type Unreifier :: K.Context -> Type -> Constraint

80+class

81+ ( Table (Reify context) a

82+ , Table context (Unreify a)

83+ , Congruent a (Unreify a)

84+ )

85+ => Unreifier context a

86+instance

87+ ( Table (Reify context) a

88+ , Table context (Unreify a)

89+ , Congruent a (Unreify a)

90+ )

91+ => Unreifier context a

92+

93+

94+type Unreifiability :: K.Context -> Type -> Type

95+data Unreifiability context a where

96+ Unreifiability :: Unreifier context a

97+ => SContext context -> Unreifiability context a

98+

99+

100+unreifiability :: (Context a ~ Reify context, Unreifiable a)

101+ => SContext context -> Unreifiability context a

102+unreifiability = \case

103+ SAggregate -> Unreifiability SAggregate

104+ SExpr -> Unreifiability SExpr

105+ SInsert -> Unreifiability SInsert

106+ SName -> Unreifiability SName

107+ SResult -> Unreifiability SResult

108+ SReify context -> case sReifiable context of

109+ Dict -> Unreifiability (SReify context)

src/Rel8/Table/Window.hsdeleted−43

@@ -1,43 +0,0 @@

1−{-# language MonoLocalBinds #-}

2−

3−module Rel8.Table.Window

4− ( cumulative

5− , cumulative_

6− , currentRow

7− )

8−where

9−

10−-- base

11−import Prelude

12−

13−-- opaleye

14−import qualified Opaleye.Window as Opaleye

15−

16−-- rel8

17−import Rel8.Aggregate ( Aggregates )

18−import qualified Rel8.Expr.Window as Expr

19−import Rel8.Schema.HTable ( hfield, htabulateA )

20−import Rel8.Table ( fromColumns, toColumns )

21−import Rel8.Window ( Window( Window ) )

22−

23−

24−-- | 'cumulative' allows the use of aggregation functions in 'Window'

25−-- expressions. In particular, @'cumulative' 'Rel8.sum'@

26−-- (when combined with 'Rel8.Window.orderPartitionBy') gives a running total,

27−-- also known as a \"cumulative sum\", hence the name @cumulative@.

28−cumulative :: Aggregates aggregates exprs => (a -> aggregates) -> Window a exprs

29−cumulative f =

30− fmap fromColumns $

31− htabulateA $ \field ->

32− Expr.cumulative ((`hfield` field) . toColumns . f)

33−

34−

35−-- | A version of 'cumulative' for use with nullary aggregators like

36−-- 'Rel8.Expr.Aggregate.countStar'.

37−cumulative_ :: Aggregates aggregates exprs => aggregates -> Window a exprs

38−cumulative_ = cumulative . const

39−

40−

41−-- | Return every column of the current row of a window query.

42−currentRow :: Window a a

43−currentRow = Window $ Opaleye.over (Opaleye.noWindowFunction id) mempty mempty

src/Rel8/Tabulate.hs+228−530

@@ -1,640 +1,338 @@

1+{-# language DeriveFunctor #-}

2+{-# language DerivingStrategies #-}

1{-# language FlexibleContexts #-}

3{-# language FlexibleContexts #-}

2−{-# language MonoLocalBinds #-}

3−{-# language ScopedTypeVariables #-}

4−{-# language StandaloneKindSignatures #-}

5−{-# language TypeApplications #-}

6{-# language TupleSections #-}

4{-# 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').

12module Rel8.Tabulate

6module Rel8.Tabulate

13− (

14− Tabulation

7+ ( Tabulation

15−

8+ , runTabulation

16− -- * Interfacing with 'Query's

9+ , tabulate

10+ , tabulateA

17 , fromQuery

11 , fromQuery

18− , toQuery

19 , liftQuery

12 , liftQuery

20− , through

13+ , prebind

14+ , postbind

15+ , indexed

16+ , ifilter

21 , lookup

17 , lookup

22−

23− -- * Aggregation and Ordering

24− , aggregate

25− , distinct

26− , order

27−

28− -- ** Magic 'Tabulation's

29− -- $magic

30− , count

31− , optional

32− , many

33− , some

34− , exists

35− , present

36− , absent

37−

38− -- * Natural joins

39 , align

18 , align

40 , alignWith

19 , alignWith

41 , leftAlign

20 , leftAlign

42 , leftAlignWith

21 , leftAlignWith

43− , rightAlign

44− , rightAlignWith

45 , zip

22 , zip

46 , zipWith

23 , zipWith

47 , similarity

24 , similarity

48 , difference

25 , difference

26+ , aggregateTabulation

27+ , optionalTabulation

49 )

28 )

50where

29where

52-- base

31-- base

53−import Control.Applicative ( (<|>), empty, liftA2 )

32+import Control.Applicative ( liftA2 )

54−import Control.Monad ( liftM2 )

33+import Control.Monad ( join, liftM2 )

55−import Data.Bifunctor ( Bifunctor, bimap, first, second )

34+import Data.Bifunctor ( bimap, first )

56import Data.Foldable ( traverse_ )

35import Data.Foldable ( traverse_ )

57−import Data.Function ( on )

58−import Data.Functor.Contravariant ( Contravariant, (>$<), contramap )

59−import Data.Int ( Int64 )

60−import Data.Kind ( Type )

61−import Data.Maybe ( fromJust, fromMaybe )

36+import Data.Maybe ( fromMaybe )

62−import Prelude hiding ( lookup, zip, zipWith )

37+import Prelude hiding ( filter, lookup, undefined, 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

84-- rel8

39-- rel8

85−import Rel8.Aggregate ( Aggregates )

40+import Rel8.Aggregate ( Aggregate )

86import Rel8.Expr ( Expr )

41import Rel8.Expr ( Expr )

87−import Rel8.Expr.Aggregate ( countStar )

42+import Rel8.Expr.Bool ( not_, true )

88−import Rel8.Expr.Bool ( true )

89−import Rel8.Order ( Order( Order ) )

90import Rel8.Query ( Query )

43import Rel8.Query ( Query )

91−import qualified Rel8.Query.Exists as Q ( exists, present, absent )

44+import Rel8.Query.Aggregate ( aggregate )

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 )

97import Rel8.Query.These ( alignBy )

48import Rel8.Query.These ( alignBy )

98−import Rel8.Table ( Table, fromColumns, toColumns )

49+import Rel8.Table ( Table )

99−import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )

50+import Rel8.Table.Aggregate ( groupBy )

100−import Rel8.Table.Alternative

101− ( AltTable, (<|>:)

102− , AlternativeTable, emptyTable

103− )

104−import Rel8.Table.Cols ( fromCols, toCols )

105−import Rel8.Table.Eq ( EqTable, (==:), eqTable )

51+import Rel8.Table.Eq ( EqTable, (==:) )

106−import Rel8.Table.List ( ListTable( ListTable ) )

107−import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), maybeTable )

52+import Rel8.Table.Maybe ( 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 )

53+import Rel8.Table.These ( TheseTable, theseTable )

54+import Rel8.Table.Undefined ( undefined )

118

119-- semigroupoids

56-- semigroupoids

120import Data.Functor.Apply ( Apply, liftF2 )

57import Data.Functor.Apply ( Apply, liftF2 )

121−import Data.Functor.Bind ( Bind, (>>-) )

58+import Data.Functor.Bind ( Bind )

122−

59+import qualified Data.Functor.Bind

123−

60+import Data.Semigroup.Traversable.Class ( bitraverse1 )

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

63+-- | @'Tabulation' k a@ is denotionally a @MultiMap k a@ — a @Map@ where each

170−-- has a key @k@ in addition to the value @a@. 'Tabulation's can be composed

64+-- key @k@ corresponds to potentially multiple @a@ (i.e., @'Query' a@). This

171−-- monadically just like 'Query's, but the resulting join is more like a

65+-- @MultiMap@ supports 'lookup' and other operations you would expect it to.

172−-- @NATURAL JOIN@ (based on the common key column(s) @k@) than the

173−-- @CROSS JOIN@ given by 'Query'.

174--

66--

175−-- Another way to think of @'Tabulation' k a@ is as analogous to @Map k a@ in

67+-- \"Identity\" 'Tabulation's are created using 'tabulate'. 'Tabulation's can

176−-- the same way @'Query' a@ is analogous to @[a]@. However, there's nothing

68+-- be composed with 'Query's with 'prebind' or 'postbind' to form new

177−-- stopping a 'Tabulation' from containing multiple rows with the same key, so

69+-- 'Tabulation's.

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))

70+newtype Tabulation k a = Tabulation (k -> Query (Maybe k, a))

185−

71+ deriving stock Functor

186−

187−instance Biprojectable Tabulation where

188− biproject f g =

189− bimap

190− (fromColumns . apply f . toColumns)

191− (fromColumns . apply g . toColumns)

192−

193−

194−instance Bifunctor Tabulation where

195− bimap f g (Tabulation a) = Tabulation $ \p ->

196− bimap (fmap f) g <$> a (f >$< p)

197−

198−

199−instance Functor (Tabulation k) where

200− fmap = second

201

202

203−instance Projectable (Tabulation k) where

204− project f = fmap (fromColumns . apply f . toColumns)

205−

206−

207−-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<.>)@ is

208−-- @intersectionWith (liftA2 (<*>))@

209instance EqTable k => Apply (Tabulation k) where

74instance EqTable k => Apply (Tabulation k) where

210 liftF2 = liftA2

75 liftF2 = liftA2

211

212

213−-- | @pure = 'liftQuery' . pure@

214instance EqTable k => Applicative (Tabulation k) where

78instance EqTable k => Applicative (Tabulation k) where

215 pure = liftQuery . pure

79 pure = liftQuery . pure

216 liftA2 = liftM2

80 liftA2 = liftM2

217

218

219instance EqTable k => Bind (Tabulation k) where

83instance EqTable k => Bind (Tabulation k) where

220− Tabulation as >>- f = Tabulation $ \p -> do

84+ join = join

221− (k, a) <- as p

222− case f a of

223− Tabulation bs -> do

224− let p' = match k

225− (k', b) <- bs (p' <> p)

226− ensure p' k'

227− pure (k' <|> k, b)

228

229

230instance EqTable k => Monad (Tabulation k) where

87instance EqTable k => Monad (Tabulation k) where

231− (>>=) = (>>-)

88+ Tabulation as >>= f = Tabulation $ \i -> do

232−

89+ (mk, a) <- as i

233−

90+ case mk of

234−-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<|>:)@ is

91+ Nothing -> case f a of

235−-- @unionWith (<>)@.

92+ Tabulation bs -> bs i

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

93+ Just k -> case f a of

241− (Left as, Left bs) -> liftQuery $ as <|>: bs

94+ Tabulation bs -> do

242− (Right as, Right bs) -> fromQuery $ as <|>: bs

95+ (mk', b) <- bs k

243− _ -> catNonEmptyTable `through` ((<>) `on` some) tas tbs

96+ case mk' of

244−

97+ Nothing -> pure (mk, b)

245−

98+ Just k' -> do

246−instance EqTable k => AlternativeTable (Tabulation k) where

99+ where_ $ k ==: k'

247− emptyTable = Tabulation $ const $ fmap (empty,) emptyTable

100+ pure (mk', b)

248−

101+

249−

102+

250−-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<>)@ is

103+-- | This "undoes" 'fromQuery'.

251−-- @unionWith (liftA2 (<>))@.

252−instance (EqTable k, Table Expr a, Semigroup a) => Semigroup (Tabulation k a)

253− where

254− (<>) = alignWith (theseTable id id (<>))

255−

256−

257−instance (EqTable k, Table Expr a, Semigroup a) => Monoid (Tabulation k a)

258− where

259− mempty = emptyTable

260−

261−

262−-- | Any 'Query' of key-value pairs @(k, a)@ can be a @'Tabulation' k a@.

263−fromQuery :: Query (k, a) -> Tabulation k a

264−fromQuery = Tabulation . const . fmap (first pure)

265−

266−

267−-- | Convert a @'Tabulation' k a@ back into a 'Query' of key-value pairs.

268−--

269−-- Note that the result of a 'toQuery' is undefined (will always return zero

270−-- rows) on 'Tabulation's constructed with 'liftQuery' or 'pure'. So while

271−-- @toQuery . fromQuery@ is always @id@, @fromQuery . toQuery@ is not.

272−--

273−-- A safer, more predictable alternative to 'toQuery' is to use 'lookup' with

274−-- an explicit set of keys:

275--

104--

276-- @

105-- @

277−-- do

106+-- 'runTabulation' . 'fromQuery' = id

278−-- k <- keys

107+-- 'fromQuery' . 'runTabulation' = id

279−-- a <- lookup k tabulation

280−-- pure (k, a)

281-- @

108-- @

282--

109--

283−-- Having said that, in practice, most legitimate uses of 'Tabulation' will

110+-- Note however that it produces nonsense when passed a 'Tabulation' that was

284−-- have a well-defined 'toQuery'. It would be possible in theory to encode

111+-- made with from 'liftQuery' or 'pure'. In such cases the returned 'Query'

285−-- the necessary invariants at the type level using an indexed monad, but we

112+-- will always produce zero rows.

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)

113+runTabulation :: EqTable k => Tabulation k a -> Query (k, a)

296−toQuery (Tabulation f) = do

114+runTabulation (Tabulation f) = do

297− (mk, a) <- f mempty

115+ (mk, a) <- f i

298− k <- cat mk

116+ case mk of

299− pure (k, a)

117+ Nothing -> do

300−

118+ -- Opaleye tries to be too clever optimising "WHERE FALSE" and generates

301−

119+ -- invalid SQL, so we use "WHERE NOT TRUE" instead

302−-- | A @'Query' a@ can be treated as a @'Tabulation' k a@ where the given @a@

120+ where_ $ not_ true

303−-- values exist at every possible key @k@.

121+ pure (i, a)

122+ Just k -> pure (k, a)

123+ where

124+ i = undefined

125+

126+

304liftQuery :: Query a -> Tabulation k a

127liftQuery :: Query a -> Tabulation k a

305−liftQuery = Tabulation . const . fmap (empty,)

128+liftQuery query = Tabulation $ const $ fmap (Nothing,) query

306

129

307

130

308−-- | Run a Kleisli arrow in the the 'Query' monad \"through\" a 'Tabulation'.

131+-- | 'tabulate' creates an \"identity\" @'Tabulation' k a@ that allows @a@ be

309−-- Useful for 'Rel8.filter'ing a 'Tabulation'.

132+-- indexed by one or more of its columns @k@. Some examples:

310--

133--

311−-- @

134+-- [Tabulation by primary key]:

312−-- 'Rel8.filter' ((>=. 30) . userAge) `'through'` usersById

135+-- @

136+-- projectsById :: Project 'Expr' -> 'Tabulation' ('Expr' ProjectId) (Project 'Expr')

137+-- projectsById = 'tabulate' projectId

138+-- @

139+--

140+-- Note: the nature of primary keys means that each key will be mapped to a

141+-- singleton value in this case.

142+--

143+-- [Tabulation by other unique key]:

144+-- @

145+-- projectsByName :: Project 'Expr' -> 'Tabulation' ('Expr' Text) (Project 'Expr')

146+-- projectsByName = 'tabulate' projectName

313−-- @

147+-- @

148+--

149+-- [Tabulation by foreign key (tabulate a child table by parent key)]:

150+-- @

151+-- revisionsByProjectId :: Revision 'Expr' -> 'Tabulation' ('Expr' ProjectId) (Revision 'Expr')

152+-- revisionsByProjectId = 'tabulate' revisionProjectId

153+-- @

314−through :: (a -> Query b) -> Tabulation k a -> Tabulation k b

154+tabulate :: (a -> k) -> a -> Tabulation k a

315−through f (Tabulation as) = Tabulation $ \p -> do

155+tabulate key a = fromQuery $ pure (key a, a)

316− (k, a) <- as p

317− b <- f a

318− pure (k, b)

319−infixr 1 `through`

320

156

321

157

322−-- | @'lookup' k t@ returns the value(s) at the key @k@ in the tabulation @t@.

158+-- | Like 'tabulate' but takes a monadic 'Query' function instead of a pure

159+-- one. This means you can filter rows while calculating the key, which is

160+-- useful in conjunction with 'Rel8.Extra.catNulls'.

323−lookup :: EqTable k => k -> Tabulation k a -> Query a

161+tabulateA :: (a -> Query k) -> a -> Tabulation k a

324−lookup k (Tabulation f) = do

162+tabulateA key a = fromQuery $ (,a) <$> key a

325− (k', a) <- f p

326− ensure p k'

327− pure a

328− where

329− p = match (pure k)

330

163

331

164

332−-- | 'aggregate' aggregates the values within each key of a

165+-- | Analgous to 'Data.Map.Strict.fromList'.

333−-- 'Tabulation'. There is an implicit @GROUP BY@ on all the key columns.

166+fromQuery :: Query (k, a) -> Tabulation k a

334−aggregate :: forall k aggregates exprs.

167+fromQuery = Tabulation . const . fmap (first Just)

335− ( EqTable k

336− , Aggregates aggregates exprs

337− )

338− => Tabulation k aggregates -> Tabulation k exprs

339−aggregate (Tabulation f) = Tabulation $

340− mapOpaleye (Opaleye.aggregate (keyed haggregator aggregator)) .

341− fmap (first (fmap (hgroupBy (eqTable @k) . toColumns))) .

342− f

343− where

344− haggregator = dimap fromColumns fromCols aggregator

345

168

346

169

347−-- | 'distinct' ensures a 'Tabulation' has at most one value for

348−-- each key, i.e., it drops duplicates. In general it keeps only the

349−-- \"first\" value it encounters for each key, but note that \"first\" is

350−-- undefined unless you first call 'order'.

351−distinct :: EqTable k => Tabulation k a -> Tabulation k a

170+indexed :: Tabulation k a -> Tabulation k (k, a)

352−distinct (Tabulation f) = Tabulation $

171+indexed (Tabulation query) = Tabulation $ \i ->

353− mapOpaleye (Opaleye.distinctOnExplicit (key unpackspec) fst) . f

172+ (\(mk, a) -> (mk, (fromMaybe i mk, a))) <$> query i

354

173

355

174

356−-- | 'order' orders the /values/ of a 'Tabulation' within their

357−-- respective keys. This specifies a defined order for 'distinct'.

358−-- It also defines the order of the lists produced by 'many' and

359−-- 'some'.

360−order :: OrdTable k => Order a -> Tabulation k a -> Tabulation k a

175+ifilter :: (k -> a -> Expr Bool) -> Tabulation k a -> Tabulation k a

361−order ordering (Tabulation f) =

176+ifilter f tabulation = snd <$> do

362− Tabulation $ mapOpaleye (Opaleye.orderBy ordering') . f

177+ filter (uncurry f) `postbind` indexed tabulation

363− where

364− Order ordering' = runClown (keyed (Clown ascTable) (Clown ordering))

365

178

366

179

367−-- $magic

180+-- | Map a 'Query' over the input side of a 'Tabulation'.

368−--

181+prebind :: (a -> Tabulation k b) -> Query a -> Tabulation k b

369−-- Some of the following combinators produce \"magic\" 'Tabulation's. Let's

182+prebind f as = Tabulation $ \k -> do

370−-- use 'count' as an example to demonstrate this concept. Consider

183+ a <- as

371−-- the following:

184+ case f a of

372−--

185+ Tabulation query -> query k

373−-- @

186+infixr 1 `prebind`

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

187

404

188

405−-- | 'count' returns a count of how many entries are in the given

189+-- | Map a 'Query' over the output side of a 'Tabulation'.

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 ()

190+postbind :: (a -> Query b) -> Tabulation k a -> Tabulation k b

477−present (Tabulation f) = Tabulation $ \p -> do

191+postbind f (Tabulation as) = Tabulation $ \i -> do

478− Q.present $ do

192+ (k, a) <- as i

479− (k, _) <- f p

193+ case f a of

480− ensure p k

194+ bs -> do

195+ b <- bs

481− pure (empty, ())

196+ pure (k, b)

197+infixr 1 `postbind`

482

198

483

199

484−-- | 'absent' produces a 'Tabulation' where a single @()@ row exists

200+-- | Note that because 'Tabulation' is a @MultiMap@, the 'Query' returned by

485−-- at every possible key that absent from the given 'Tabulation'.

201+-- 'lookup' can and often does contain multiple results.

486−--

202+lookup :: EqTable k => k -> Tabulation k a -> Query a

487−-- This is used to implement 'difference'.

488−absent :: Tabulation k a -> Tabulation k ()

489−absent (Tabulation f) = Tabulation $ \p -> do

203+lookup key (Tabulation query) = do

490− Q.absent $ do

204+ (mk, a) <- query key

491− (k, _) <- f p

205+ traverse_ (where_ . (key ==:)) mk

492− ensure p k

493− pure (empty, ())

206+ pure a

494

207

495

208

496−-- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns.

209+-- | Analagous to

210+-- [@align@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:align).

497--

211--

498−-- Analogous to 'Data.Semialign.align'.

212+-- If 'zip' makes an @INNER JOIN@, then 'align' makes a @FULL OUTER JOIN@.

499−align :: EqTable k

213+align :: (EqTable k, Table Expr a, Table Expr b)

500− => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable Expr a b)

214+ => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable a b)

501align = alignWith id

215align = alignWith id

502

216

503

217

504−-- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns.

218+-- | Analagous to

219+-- [@alignWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:alignWith).

505--

220--

506−-- Analogous to 'Data.Semialign.alignWith'.

221+-- See 'zipWith' and 'align'.

507−alignWith :: EqTable k

222+alignWith :: (EqTable k, Table Expr a, Table Expr b)

508− => (TheseTable Expr a b -> c)

223+ => (TheseTable a b -> c)

509 -> Tabulation k a -> Tabulation k b -> Tabulation k c

224 -> Tabulation k a -> Tabulation k b -> Tabulation k c

510−alignWith f (Tabulation as) (Tabulation bs) = Tabulation $ \p -> do

225+alignWith f kas kbs = do

226+ as <- toQuery kas

227+ bs <- toQuery kbs

228+ fromQuery $ do

511− tkab <- liftF2 (alignBy condition) as bs p

229+ tkab <- alignBy (\(l, _) (m, _) -> l ==: m) as bs

512− k <- traverse (rebind "key") $ recover $ bimap fst fst tkab

513− let

230+ let

514− tab = bimap snd snd tkab

231+ k' = theseTable fst fst (const fst) tkab

515− pure (k, f tab)

232+ tab = bimap snd snd tkab

516− where

233+ pure (k', f tab)

517− condition (k, _) (k', _) = fromMaybe true (liftA2 (==:) k k')

234+

518− recover (TheseTable mma@(MaybeTable _ ma) mmb@(MaybeTable _ mb)) =

235+

519− case extract ma of

236+-- | If 'zip' makes an @INNER JOIN@, then 'leftAlign' makes a @LEFT JOIN@.

520− Nothing -> extract mb

237+-- This means it will return at least one row for every row in the left

521− Just a -> case extract mb of

238+-- 'Tabulation', even if there is no corresponding row in the right (hence the

522− Nothing -> extract ma

239+-- 'Rel8.MaybeTable').

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

240+--

529−-- Analogous to 'Data.Semialign.rpadZip'.

241+-- Analagous to

530−--

242+-- [@rpadZip@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:rpadZip).

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.

535leftAlign :: EqTable k

243leftAlign :: EqTable k

536− => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable Expr b)

244+ => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable b)

537leftAlign = leftAlignWith (,)

245leftAlign = leftAlignWith (,)

538

246

539

247

540−-- | Performs a @NATURAL LEFT OUTER JOIN@ based on the common key columns.

248+-- | See 'zipWith' and 'leftAlign'.

541--

249--

250+-- Analagous to

542−-- Analogous to 'Data.Semialign.rpadZipWith'.

251+-- [@rpadZipWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v: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.

548leftAlignWith :: EqTable k

252leftAlignWith :: EqTable k

549− => (a -> MaybeTable Expr b -> c)

253+ => (a -> MaybeTable b -> c)

550 -> Tabulation k a -> Tabulation k b -> Tabulation k c

254 -> Tabulation k a -> Tabulation k b -> Tabulation k c

551−leftAlignWith f left right = liftA2 f left (optional right)

255+leftAlignWith f left right = liftA2 f left (optionalTabulation right)

552

256

553

257

554−-- | Performs a @NATURAL RIGHT OUTER JOIN@ based on the common key columns.

258+-- | Analagous to

555−--

259+-- [@zip@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:zip).

556−-- Analogous to 'Data.Semialign.lpadZip'.

557--

260--

558−-- Note that you can achieve the same effect with 'optional' and the

261+-- There are multiple correct ways of understanding what this does.

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

262--

569−-- Analogous to 'Data.Semialign.lpadZipWith'.

263+-- You can think of it as @'Data.Map.Strict.intersectionWith'

264+-- ('Control.Applicative.liftA2' (,))@. That is, @intersect@ the two

265+-- `Tabulation`s by matching their keys together (with 'Rel8.==:'), and combine

266+-- their values (remembering that 'Tabulation' is a 'MultiMap' so that the

267+-- values are keys) by getting their cartesian product.

570--

268--

571−-- Note that you can achieve the same effect with 'optional' and the

269+-- You can think of it as performing a cross product of the underlying 'Query's

572−-- 'Applicative' instance for 'Tabulation', i.e., this is just

270+-- of the given 'Tabulation's and filtering the results for 'match'ing keys.

573−-- @\f left right -> liftA2 (flip f) right (optional left). You can

574−-- also use @do@-notation.

575−rightAlignWith :: EqTable k

576− => (MaybeTable Expr a -> b -> c)

577− -> Tabulation k a -> Tabulation k b -> Tabulation k c

578−rightAlignWith f left right = liftA2 (flip f) right (optional left)

579−

580−

581−-- | Performs a @NATURAL INNER JOIN@ based on the common key columns.

582--

271--

583−-- Analagous to 'Data.Semialign.zip'.

272+-- You can think of it as a natural join in SQL terms.

584--

273--

585−-- Note that you can achieve the same effect with the 'Applicative' instance

274+-- The size of the resulting 'Tabulation' will be $\sum_{k} min(n_k, m_k) $

586−-- of 'Tabulation', i.e., this is just @'liftA2 (,)'@. You can also use

275+-- in terms of the number of keys, but $\sum_{k} n_k \times m_k$ in terms of

587−-- @do@-notation.

276+-- the number of values.

588zip :: EqTable k

277zip :: EqTable k

589 => Tabulation k a -> Tabulation k b -> Tabulation k (a, b)

278 => Tabulation k a -> Tabulation k b -> Tabulation k (a, b)

590zip = zipWith (,)

279zip = zipWith (,)

591

280

592

281

593−-- | Performs a @NATURAL INNER JOIN@ based on the common key columns.

282+-- | Analagous to

283+-- [@zipWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:zipWith).

594--

284--

595−-- Analagous to 'Data.Semialign.zipWith'.

285+-- See 'zip'.

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.

600zipWith :: EqTable k

286zipWith :: EqTable k

601 => (a -> b -> c) -> Tabulation k a -> Tabulation k b -> Tabulation k c

287 => (a -> b -> c) -> Tabulation k a -> Tabulation k b -> Tabulation k c

602zipWith = liftA2

288zipWith = liftA2

603

289

604

290

605−-- | Performs a [@NATURAL SEMI JOIN@](https://en.wikipedia.org/wiki/Relational_algebra#Semijoin_%28%E2%8B%89%29%28%E2%8B%8A%29)

291+-- | 'similarity' returns all the entries in the left 'Tabulation' that have a

606−-- based on the common key columns.

292+-- corresponding entry in the right 'Tabulation'. This corresponds to a

293+-- semijoin in relational algebra.

607--

294--

608−-- The result is a subset of the left tabulation where only entries which have

295+-- This differs from @'zipWith' const x y@ when the right 'Tabulation' @y@

609−-- a corresponding entry in the right tabulation are kept.

296+-- contains an entry with multiple rows. For 'similarity', the entries in the

297+-- resulting 'Tabulation' will contain the same number of rows as their

298+-- respective entries in the left 'Tabulation' @x@. With `zipWith const x y`,

299+-- each entry would contain the /product/ of the number of rows of their

300+-- respective entries in @x@ and @y@.

610--

301--

611−-- Note that you can achieve a similar effect with 'present' and the

302+-- See 'Rel8.with'.

612−-- 'Applicative' instance of 'Tabulation', i.e., this is just

613−-- @\left right -> left <* present right@. You can also use

614−-- @do@-notation.

615similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a

303similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a

616−similarity a b = a <* present b

304+similarity kas kbs = do

305+ as <- toQuery kas

306+ bs <- toQuery kbs

307+ fromQuery $ as >>= withBy (\(k, _) (l, _) -> k ==: l) bs

617

308

618

309

619−-- | Performs a [@NATURAL ANTI JOIN@](https://en.wikipedia.org/wiki/Relational_algebra#Antijoin_%28%E2%96%B7%29)

310+-- | 'difference' returns all the entries in the left 'Tabulation' that don't

620−-- based on the common key columns.

311+-- exist in the right 'Tabulation'. This corresponds to an antijoin in

621−--

312+-- relational algebra.

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

313--

625−-- Note that you can achieve a similar effect with 'absent' and the

314+-- See 'Rel8.without'.

626−-- 'Applicative' instance of 'Tabulation', i.e., this is just

627−-- @\left right -> left <* absent right@. You can also use

628−-- @do@-notation.

629difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a

315difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a

630−difference a b = a <* absent b

316+difference kas kbs = do

317+ as <- toQuery kas

318+ bs <- toQuery kbs

319+ fromQuery $ as >>= withoutBy (\(k, _) (l, _) -> k ==: l) bs

320+

321+

322+aggregateTabulation :: EqTable k

323+ => Tabulation k (Aggregate a) -> Tabulation k a

324+aggregateTabulation kas = do

325+ as <- toQuery kas

326+ fromQuery $ aggregate $ bitraverse1 groupBy id <$> as

327+

328+

329+optionalTabulation :: EqTable k

330+ => Tabulation k a -> Tabulation k (MaybeTable a)

331+optionalTabulation as = Tabulation $ \k -> do

332+ ma <- optional $ lookup k as

333+ pure (Just k, ma)

631

334

632

335

633−-- | 'Tabulation's can be produced with either 'fromQuery' or 'liftQuery', and

634−-- in some cases we might want to treat these differently. 'peek' uses

635−-- 'unsafePeekQuery' to determine which type of 'Tabulation' we have.

636−peek :: Tabulation k a -> Tabulation k (Either (Query a) (Query (k, a)))

336+toQuery :: Tabulation k a -> Tabulation k (Query (k, a))

637−peek (Tabulation f) = Tabulation $ \p ->

337+toQuery (Tabulation as) = Tabulation $ \k ->

638− pure $ (empty,) $ case unsafePeekQuery (f p) of

338+ pure (Nothing, first (fromMaybe k) <$> as k)

639− (Nothing, _) -> Left $ fmap snd (f p)

640− (Just _, _) -> Right $ fmap (first fromJust) (f p)

src/Rel8/Type.hs+8−9

@@ -1,4 +1,3 @@

1−{-# language FlexibleContexts #-}

2{-# language FlexibleInstances #-}

1{-# language FlexibleInstances #-}

3{-# language MonoLocalBinds #-}

2{-# language MonoLocalBinds #-}

4{-# language MultiWayIf #-}

3{-# language MultiWayIf #-}

@@ -128,10 +127,10 @@ instance DBType Int64 where

128instance DBType Float where

127instance DBType Float where

129 typeInformation = TypeInformation

128 typeInformation = TypeInformation

130 { encode = \x -> Opaleye.ConstExpr

129 { encode = \x -> Opaleye.ConstExpr

131− if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'"

130+ if | x == (1 /0) -> Opaleye.OtherLit "'Infinity'"

132− | isNaN x -> Opaleye.OtherLit "'NaN'"

131+ | isNaN x -> Opaleye.OtherLit "'NaN'"

133− | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"

132+ | x == (-1/0) -> Opaleye.OtherLit "'-Infinity'"

134− | otherwise -> Opaleye.NumericLit $ realToFrac x

133+ | otherwise -> Opaleye.NumericLit $ realToFrac x

135 , decode = Hasql.float4

134 , decode = Hasql.float4

136 , typeName = "float4"

135 , typeName = "float4"

137 }

136 }

@@ -141,10 +140,10 @@ instance DBType Float where

141instance DBType Double where

140instance DBType Double where

142 typeInformation = TypeInformation

141 typeInformation = TypeInformation

143 { encode = \x -> Opaleye.ConstExpr

142 { encode = \x -> Opaleye.ConstExpr

144− if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'"

143+ if | x == (1 /0) -> Opaleye.OtherLit "'Infinity'"

145− | isNaN x -> Opaleye.OtherLit "'NaN'"

144+ | isNaN x -> Opaleye.OtherLit "'NaN'"

146− | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"

145+ | x == (-1/0) -> Opaleye.OtherLit "'-Infinity'"

147− | otherwise -> Opaleye.NumericLit $ realToFrac x

146+ | otherwise -> Opaleye.NumericLit $ realToFrac x

148 , decode = Hasql.float8

147 , decode = Hasql.float8

149 , typeName = "float8"

148 , typeName = "float8"

150 }

149 }

src/Rel8/Type/Array.hs+26−46

@@ -1,13 +1,12 @@

1{-# language GADTs #-}

2−{-# language LambdaCase #-}

3{-# language NamedFieldPuns #-}

2{-# language NamedFieldPuns #-}

4{-# language OverloadedStrings #-}

3{-# language OverloadedStrings #-}

5−{-# language ViewPatterns #-}

7module Rel8.Type.Array

5module Rel8.Type.Array

8− ( array, encodeArrayElement, extractArrayElement

6+ ( array

9 , listTypeInformation

7 , listTypeInformation

10 , nonEmptyTypeInformation

8 , nonEmptyTypeInformation

9+ , fromPrimArray, toPrimArray, zipPrimArraysWith

11 )

10 )

12where

11where

@@ -29,9 +28,10 @@ import Rel8.Type.Information ( TypeInformation(..), parseTypeInformation )

30array :: Foldable f

29array :: Foldable f

31 => TypeInformation a -> f Opaleye.PrimExpr -> Opaleye.PrimExpr

30 => TypeInformation a -> f Opaleye.PrimExpr -> Opaleye.PrimExpr

32−array info =

31+array TypeInformation {typeName} =

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 #-}

@@ -39,23 +39,19 @@ listTypeInformation :: ()

39 => Nullity a

40 -> TypeInformation (Unnullify a)

41 -> TypeInformation [a]

42−listTypeInformation nullity info@TypeInformation {encode, decode} =

42+listTypeInformation nullity info =

43− TypeInformation

43+ case info of

44+ TypeInformation{ encode, decode } -> TypeInformation

44− { decode = case nullity of

45+ { decode = row $ case nullity of

45− Null ->

46− Hasql.listArray (decodeArrayElement info (Hasql.nullable decode))

46+ Null -> Hasql.listArray (Hasql.nullable decode)

47− NotNull ->

48− Hasql.listArray (decodeArrayElement info (Hasql.nonNullable decode))

47+ NotNull -> Hasql.listArray (Hasql.nonNullable decode)

49− , encode = case nullity of

48+ , encode = case nullity of

50− Null ->

51− Opaleye.ArrayExpr .

52− fmap (encodeArrayElement info . maybe null encode)

49+ Null -> array info . fmap (maybe null encode)

53− NotNull ->

50+ NotNull -> array info . fmap encode

54− Opaleye.ArrayExpr .

55− fmap (encodeArrayElement info . encode)

56− , typeName = arrayType info <> "[]"

51+ , typeName = "record"

57− }

52+ }

58 where

53 where

54+ row = Hasql.composite . Hasql.field . Hasql.nonNullable

59 null = Opaleye.ConstExpr Opaleye.NullLit

55 null = Opaleye.ConstExpr Opaleye.NullLit

@@ -70,31 +66,15 @@ nonEmptyTypeInformation nullity =

70 message = "failed to decode NonEmptyList: got empty list"

66 message = "failed to decode NonEmptyList: got empty list"

73−isArray :: TypeInformation a -> Bool

69+fromPrimArray :: Opaleye.PrimExpr -> Opaleye.PrimExpr

74−isArray = \case

70+fromPrimArray = Opaleye.UnExpr (Opaleye.UnOpOther "ROW")

75− (reverse . typeName -> ']' : '[' : _) -> True

76− _ -> False

79−arrayType :: TypeInformation a -> String

73+toPrimArray :: Opaleye.PrimExpr -> Opaleye.PrimExpr

80−arrayType info

74+toPrimArray a = Opaleye.CompositeExpr a "f1"

81− | isArray info = "record"

82− | otherwise = typeName info

85−decodeArrayElement :: TypeInformation a -> Hasql.NullableOrNot Hasql.Value x -> Hasql.NullableOrNot Hasql.Value x

77+zipPrimArraysWith :: ()

86−decodeArrayElement info

87− | isArray info = Hasql.nonNullable . Hasql.composite . Hasql.field

88− | otherwise = id

89−

90−

91−encodeArrayElement :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr

78+ => (Opaleye.PrimExpr -> 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

79+ -> Opaleye.PrimExpr -> Opaleye.PrimExpr -> Opaleye.PrimExpr

98−extractArrayElement info

80+zipPrimArraysWith f a b = fromPrimArray (f (toPrimArray a) (toPrimArray b))

99− | isArray info = flip Opaleye.CompositeExpr "f1"

100− | otherwise = id

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

@@ -0,0 +1,139 @@

1+{-# language DataKinds #-}

2+{-# language DeriveTraversable #-}

3+{-# language DerivingStrategies #-}

4+{-# language FlexibleContexts #-}

5+{-# language FlexibleInstances #-}

6+{-# language GeneralizedNewtypeDeriving #-}

7+{-# language NamedFieldPuns #-}

8+{-# language StandaloneKindSignatures #-}

9+{-# language TypeFamilies #-}

10+{-# language UndecidableInstances #-}

11+

12+{-# options_ghc -fno-warn-redundant-constraints #-}

13+

14+module Rel8.Type.Array1D

15+ ( Array1D( Array1D )

16+ , NotArray

17+ , getArray1D

18+ )

19+where

20+

21+-- aeson

22+import Data.Aeson

23+ ( ToJSON

24+ , ToJSON1

25+ , ToJSONKey

26+ , FromJSON

27+ , FromJSON1

28+ , FromJSONKey

29+ )

30+

31+-- base

32+import Control.Applicative ( Alternative, (<|>) )

33+import Control.Monad ( MonadPlus )

34+import Data.Functor.Classes ( Eq1, Ord1, Read1, Show1 )

35+import Data.Kind ( Type )

36+import GHC.Exts ( IsList )

37+import Prelude hiding ( null )

38+

39+-- hasql

40+import qualified Hasql.Decoders as Hasql

41+

42+-- opaleye

43+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

44+

45+-- rel8

46+import Rel8.Expr.Opaleye ( zipPrimExprsWith )

47+import Rel8.Expr.Serialize ( litExpr )

48+import Rel8.Schema.Null ( Unnullify, Nullity( Null, NotNull ), Sql, nullable )

49+import Rel8.Type ( DBType, typeInformation )

50+import Rel8.Type.Eq ( DBEq )

51+import Rel8.Type.Information ( TypeInformation(..) )

52+import Rel8.Type.Monoid ( DBMonoid, memptyExpr )

53+import Rel8.Type.Ord ( DBMax, DBMin, DBOrd )

54+import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )

55+

56+-- semigroupoids

57+import Data.Functor.Alt ( Alt, (<!>) )

58+import Data.Functor.Apply ( Apply )

59+import Data.Functor.Bind ( Bind )

60+import Data.Functor.Plus ( Plus )

61+

62+-- semialign

63+import Data.Align ( Align )

64+import Data.Semialign ( Semialign )

65+import Data.Zip ( Repeat, Unzip, Zip )

66+

67+

68+-- | A one dimensional array.

69+newtype Array1D a = Array1D [a]

70+ deriving stock Traversable

71+ deriving newtype

72+ ( Eq, Ord, Read, Show, Semigroup, Monoid, IsList

73+ , Functor, Foldable

74+ , Eq1, Ord1, Read1, Show1

75+ , FromJSON1, ToJSON1, FromJSON, FromJSONKey, ToJSON, ToJSONKey

76+ , Apply, Applicative, Alternative, Plus, Bind, Monad, MonadPlus

77+ , Align, Semialign, Repeat, Unzip, Zip

78+ )

79+

80+

81+instance Alt Array1D where

82+ (<!>) = (<|>)

83+

84+

85+getArray1D :: Array1D a -> [a]

86+getArray1D (Array1D a) = a

87+

88+

89+type IsArray1D :: Type -> Bool

90+type family IsArray1D a where

91+ IsArray1D (Array1D _) = 'True

92+ IsArray1D _ = 'False

93+

94+

95+class IsArray1D a ~ 'False => NotArray a

96+instance IsArray1D a ~ 'False => NotArray a

97+

98+

99+array1DTypeInformation :: Sql NotArray a

100+ => Nullity a

101+ -> TypeInformation (Unnullify a)

102+ -> TypeInformation (Array1D a)

103+array1DTypeInformation nullity info =

104+ case info of

105+ TypeInformation{ encode, decode, typeName } -> TypeInformation

106+ { decode = case nullity of

107+ Null -> Array1D <$> Hasql.listArray (Hasql.nullable decode)

108+ NotNull -> Array1D <$> Hasql.listArray (Hasql.nonNullable decode)

109+ , encode = case nullity of

110+ Null -> Opaleye.ArrayExpr . fmap (maybe null encode) . getArray1D

111+ NotNull -> Opaleye.ArrayExpr . fmap encode . getArray1D

112+ , typeName = typeName <> "[]"

113+ }

114+ where

115+ null = Opaleye.ConstExpr Opaleye.NullLit

116+

117+

118+instance (Sql DBType a, Sql NotArray a) => DBType (Array1D a) where

119+ typeInformation = array1DTypeInformation nullable typeInformation

120+

121+

122+instance (Sql DBEq a, Sql NotArray a) => DBEq (Array1D a)

123+

124+

125+instance (Sql DBOrd a, Sql NotArray a) => DBOrd (Array1D a)

126+

127+

128+instance (Sql DBMax a, Sql NotArray a) => DBMax (Array1D a)

129+

130+

131+instance (Sql DBMin a, Sql NotArray a) => DBMin (Array1D a)

132+

133+

134+instance (Sql DBType a, Sql NotArray a) => DBSemigroup (Array1D a) where

135+ (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))

136+

137+

138+instance (Sql DBType a, Sql NotArray a) => DBMonoid (Array1D a) where

139+ memptyExpr = litExpr mempty

src/Rel8/Type/Composite.hs+39−90

@@ -1,28 +1,27 @@

1−{-# language AllowAmbiguousTypes #-}

2−{-# language BlockArguments #-}

3{-# language DataKinds #-}

1{-# language DataKinds #-}

4{-# language FlexibleContexts #-}

2{-# language FlexibleContexts #-}

5{-# language GADTs #-}

3{-# language GADTs #-}

6−{-# language NamedFieldPuns #-}

7{-# language ScopedTypeVariables #-}

4{-# language ScopedTypeVariables #-}

8{-# language StandaloneKindSignatures #-}

5{-# language StandaloneKindSignatures #-}

9{-# language TypeApplications #-}

6{-# language TypeApplications #-}

7+{-# language TypeOperators #-}

10{-# language UndecidableInstances #-}

8{-# language UndecidableInstances #-}

11−{-# language UndecidableSuperClasses #-}

12−{-# language ViewPatterns #-}

14module Rel8.Type.Composite

10module Rel8.Type.Composite

15 ( Composite( Composite )

11 ( Composite( Composite )

16− , DBComposite( compositeFields, compositeTypeName )

17− , compose, decompose

18 )

12 )

19where

13where

21-- base

15-- base

22−import Data.Functor.Const ( Const( Const ), getConst )

16+import Control.Applicative ( liftA2 )

23−import Data.Functor.Identity ( Identity( Identity ) )

24import Data.Kind ( Constraint, Type )

17import Data.Kind ( Constraint, Type )

25−import Prelude

18+import Data.Proxy ( Proxy( Proxy ) )

19+import GHC.Generics

20+ ( Generic, Rep, from, to

21+ , (:*:)( (:*:) ), K1( K1 ), M1( M1 )

22+ )

23+import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )

24+import Prelude hiding ( null )

27-- hasql

26-- hasql

28import qualified Hasql.Decoders as Hasql

27import qualified Hasql.Decoders as Hasql

@@ -31,105 +30,55 @@ import qualified Hasql.Decoders as Hasql

31import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

30import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

33-- rel8

32-- 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 ) )

33+import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )

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 )

47import Rel8.Type ( DBType, typeInformation )

34import Rel8.Type ( DBType, typeInformation )

48−import Rel8.Type.Eq ( DBEq )

49import Rel8.Type.Information ( TypeInformation(..) )

35import Rel8.Type.Information ( TypeInformation(..) )

50−import Rel8.Type.Ord ( DBOrd, DBMax, DBMin )

51−

52−-- semigroupoids

53−import Data.Functor.Apply ( WrappedApplicative(..) )

56-- | A deriving-via helper type for column types that store a Haskell product

38-- | 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.

39-- type in a single Postgres column using a Postgres composite type.

58--

40--

59-- Note that this must map to a specific extant type in your database's schema

41-- 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

42+-- (created with @CREATE TYPE@). The @name@ parameter of @Composite@ should be

61−-- Postgres type and the names of the individual fields (for projecting with

43+-- the name of this type.

62−-- 'decompose').

63−type Composite :: Type -> Type

44+type Composite :: Symbol -> Type -> Type

64−newtype Composite a = Composite

45+newtype Composite name a = Composite

65 { unComposite :: a

46 { unComposite :: a

66 }

47 }

50+instance (KnownSymbol name, Generic a, GComposite (Rep a)) =>

69−instance DBComposite a => DBType (Composite a) where

51+ DBType (Composite name a)

52+ where

70 typeInformation = TypeInformation

53 typeInformation = TypeInformation

71− { decode = Hasql.composite (Composite . fromResult @_ @(HKD a Expr) <$> decoder)

54+ { decode = Hasql.composite (Composite . to <$> gdecode @(Rep a))

72− , encode = encoder . litHTable . toResult @_ @(HKD a Expr) . unComposite

55+ , encode = Opaleye.FunExpr "ROW" . gencode @(Rep a) . from . unComposite

73− , typeName = compositeTypeName @a

56+ , typeName = symbolVal (Proxy @name)

74 }

57 }

77−instance (DBComposite a, EqTable (HKD a Expr)) => DBEq (Composite a)

60+type GComposite :: (Type -> Type) -> Constraint

78−

61+class GComposite rep where

79−

62+ gdecode :: Hasql.Composite (rep x)

80−instance (DBComposite a, OrdTable (HKD a Expr)) => DBOrd (Composite a)

63+ gencode :: rep x -> [Opaleye.PrimExpr]

81−

82−

83−instance (DBComposite a, OrdTable (HKD a Expr)) => DBMax (Composite a)

86−instance (DBComposite a, OrdTable (HKD a Expr)) => DBMin (Composite a)

66+instance GComposite rep => GComposite (M1 i c rep) where

67+ gdecode = M1 <$> gdecode

68+ gencode (M1 a) = gencode a

89−-- | 'DBComposite' is used to associate composite type metadata with a Haskell

71+instance (GComposite a, GComposite b) => GComposite (a :*: b) where

90−-- type.

72+ gdecode = liftA2 (:*:) gdecode gdecode

91−type DBComposite :: Type -> Constraint

73+ gencode (a :*: b) = gencode a <> gencode b

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

96− -- | The name of the composite type that @a@ maps to.

97− compositeTypeName :: String

99−

76+instance Sql DBType a => GComposite (K1 i a) where

100−-- | Collapse a 'HKD' into a PostgreSQL composite type.

77+ gdecode = fmap K1 $ Hasql.field $ case nullable @a of

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

78+ Null -> Hasql.nullable (decode typeInformation)

128− NotNull -> Hasql.field $ Hasql.nonNullable $ decode info

79+ NotNull -> Hasql.nonNullable (decode typeInformation)

129−

80+ gencode (K1 a) = case nullable @a of

130−

81+ Null -> [maybe null (encode typeInformation) a]

131−encoder :: HTable t => t Expr -> Opaleye.PrimExpr

82+ NotNull -> [encode typeInformation a]

132−encoder a = Opaleye.FunExpr "ROW" exprs

83+ where

133− where

84+ null = Opaleye.ConstExpr Opaleye.NullLit

134− exprs = getConst $ htabulateA \field -> case hfield a field of

135− expr -> Const [toPrimExpr expr]

src/Rel8/Type/Enum.hs+33−86

@@ -1,34 +1,27 @@

1−{-# language AllowAmbiguousTypes #-}

2{-# language DataKinds #-}

1{-# language DataKinds #-}

3{-# language FlexibleContexts #-}

2{-# language FlexibleContexts #-}

4{-# language FlexibleInstances #-}

3{-# language FlexibleInstances #-}

5−{-# language LambdaCase #-}

4+{-# language GADTs #-}

6−{-# language RankNTypes #-}

7{-# language ScopedTypeVariables #-}

5{-# language ScopedTypeVariables #-}

8{-# language StandaloneKindSignatures #-}

6{-# language StandaloneKindSignatures #-}

9{-# language TypeApplications #-}

7{-# language TypeApplications #-}

10−{-# language TypeFamilies #-}

11{-# language TypeOperators #-}

8{-# language TypeOperators #-}

12{-# language UndecidableInstances #-}

9{-# language UndecidableInstances #-}

14module Rel8.Type.Enum

11module Rel8.Type.Enum

15− ( Enum( Enum )

12+ ( Enum(..)

16− , DBEnum( enumValue, enumTypeName )

17− , Enumable

18 )

13 )

19where

14where

21-- base

16-- base

22−import Control.Applicative ( (<|>) )

23−import Control.Arrow ( (&&&) )

24import Data.Kind ( Constraint, Type )

17import Data.Kind ( Constraint, Type )

25import Data.Proxy ( Proxy( Proxy ) )

18import Data.Proxy ( Proxy( Proxy ) )

26import GHC.Generics

19import GHC.Generics

27 ( Generic, Rep, from, to

20 ( Generic, Rep, from, to

28− , (:+:)( L1, R1 ), M1( M1 ), U1( U1 )

21+ , (:+:)( L1, R1 ), M1( M1 ), U1( U1 ), Meta( MetaCons )

29− , D, C, Meta( MetaCons )

22+ , D, C

30 )

23 )

31−import GHC.TypeLits ( KnownSymbol, symbolVal )

24+import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )

32import Prelude hiding ( Enum )

25import Prelude hiding ( Enum )

34-- hasql

27-- hasql

@@ -39,101 +32,55 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

40-- rel8

33-- rel8

41import Rel8.Type ( DBType, typeInformation )

34import Rel8.Type ( DBType, typeInformation )

42−import Rel8.Type.Eq ( DBEq )

43import Rel8.Type.Information ( TypeInformation(..) )

35import Rel8.Type.Information ( TypeInformation(..) )

44−import Rel8.Type.Ord ( DBOrd, DBMax, DBMin )

46-- text

37-- text

47−import Data.Text ( pack )

38+import Data.Text ( unpack )

50-- | A deriving-via helper type for column types that store an \"enum\" type

41-- | 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

42-- (in Haskell terms, a sum type where all constructors are nullary) using a

52-- Postgres @enum@ type.

43-- Postgres @enum@ type.

53--

44--

54−-- Note that this should map to a specific type in your database's schema

45+-- Note that this must map to a specific type in your database's schema

55−-- (explicitly created with @CREATE TYPE ... AS ENUM@). Use 'DBEnum' to

46+-- (explicitly created with @CREATE TYPE ... AS ENUM@). The @name@ parameter

56−-- specify the name of this Postgres type and the names of the individual

47+-- of @Enum@ should be the name of this type. Note also the names of the

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

48+-- Postgres @enum@'s values are assumed to match exactly the names of the

59−-- of the Haskell type (up to and including case sensitivity).

49+-- constructors of the Haskell type (up to and including case sensitivity).

60−type Enum :: Type -> Type

50+type Enum :: Symbol -> Type -> Type

61−newtype Enum a = Enum

51+newtype Enum name a = Enum

62 { unEnum :: a

52 { unEnum :: a

63 }

53 }

66−instance DBEnum a => DBType (Enum a) where

56+instance (KnownSymbol name, Generic a, GEnum (Rep a)) => DBType (Enum name a)

57+ where

67 typeInformation = TypeInformation

58 typeInformation = TypeInformation

68− { decode =

59+ { decode = Hasql.enum ((`lookup` (fmap (Enum . to) <$> gdecode)) . unpack)

69− Hasql.enum $

70− flip lookup $

71− map ((pack . enumValue &&& Enum) . to) $

72− genumerate @(Rep a)

73− , encode =

74− Opaleye.ConstExpr .

60+ , encode = Opaleye.ConstExpr . Opaleye.StringLit . gencode . from . unEnum

75− Opaleye.StringLit .

61+ , typeName = symbolVal (Proxy @name)

76− enumValue @a .

77− unEnum

78− , typeName = enumTypeName @a

79 }

62 }

82−instance DBEnum a => DBEq (Enum a)

65+type GEnum :: (Type -> Type) -> Constraint

83−

66+class GEnum rep where

84−

67+ gdecode :: [(String, rep x)]

85−instance DBEnum a => DBOrd (Enum a)

68+ gencode :: rep x -> String

86−

87−

88−instance DBEnum a => DBMax (Enum a)

89−

90−

91−instance DBEnum a => DBMin (Enum a)

92−

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.

71+instance GEnum rep => GEnum (M1 D c rep) where

104− enumTypeName :: String

72+ gdecode = fmap M1 <$> gdecode

73+ gencode (M1 a) = gencode a

105

106

107−-- | Types that are sum types, where each constructor is unary (that is, has no

76+instance (GEnum a, GEnum b) => GEnum (a :+: b) where

108−-- fields).

77+ gdecode = (fmap L1 <$> gdecode) <> (fmap R1 <$> gdecode)

109−type Enumable :: Type -> Constraint

78+ gencode (L1 a) = gencode a

110−class (Generic a, GEnumable (Rep a)) => Enumable a

79+ gencode (R1 a) = gencode a

111−instance (Generic a, GEnumable (Rep a)) => Enumable a

112

113

114−type GEnumable :: (Type -> Type) -> Constraint

82+instance (KnownSymbol name, a ~ U1) =>

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

83+ GEnum (M1 C ('MetaCons name f r) a)

134− , KnownSymbol name

135− )

136− => GEnumable (M1 C meta U1)

137 where

84 where

138− genumerate = [M1 U1]

85+ gdecode = [(symbolVal (Proxy @name), M1 U1)]

139− gshow (M1 U1) = symbolVal (Proxy @name)

86+ gencode _ = symbolVal (Proxy @name)

src/Rel8/Type/JSONBEncoded.hs−4

@@ -1,5 +1,3 @@

1−{-# language StandaloneKindSignatures #-}

2−

3module Rel8.Type.JSONBEncoded ( JSONBEncoded(..) ) where

1module Rel8.Type.JSONBEncoded ( JSONBEncoded(..) ) where

5-- aeson

3-- aeson

@@ -8,7 +6,6 @@ import Data.Aeson.Types ( parseEither )

9-- base

7-- base

10import Data.Bifunctor ( first )

8import Data.Bifunctor ( first )

11−import Data.Kind ( Type )

12import Prelude

9import Prelude

14-- hasql

11-- hasql

@@ -23,7 +20,6 @@ import Data.Text ( pack )

25-- | Like 'Rel8.JSONEncoded', but works for @jsonb@ columns.

22-- | Like 'Rel8.JSONEncoded', but works for @jsonb@ columns.

26−type JSONBEncoded :: Type -> Type

27newtype JSONBEncoded a = JSONBEncoded { fromJSONBEncoded :: a }

23newtype JSONBEncoded a = JSONBEncoded { fromJSONBEncoded :: a }

src/Rel8/Type/JSONEncoded.hs−4

@@ -1,5 +1,3 @@

1−{-# language StandaloneKindSignatures #-}

2−

3module Rel8.Type.JSONEncoded ( JSONEncoded(..) ) where

1module Rel8.Type.JSONEncoded ( JSONEncoded(..) ) where

5-- aeson

3-- aeson

@@ -7,7 +5,6 @@ import Data.Aeson ( FromJSON, ToJSON, parseJSON, toJSON )

7import Data.Aeson.Types ( parseEither )

5import Data.Aeson.Types ( parseEither )

9-- base

7-- base

10−import Data.Kind ( Type )

11import Prelude

8import Prelude

13-- rel8

10-- rel8

@@ -18,7 +15,6 @@ import Rel8.Type.Information ( parseTypeInformation )

18-- | A deriving-via helper type for column types that store a Haskell value

15-- | A deriving-via helper type for column types that store a Haskell value

19-- using a JSON encoding described by @aeson@'s 'ToJSON' and 'FromJSON' type

16-- using a JSON encoding described by @aeson@'s 'ToJSON' and 'FromJSON' type

20-- classes.

17-- classes.

21−type JSONEncoded :: Type -> Type

22newtype JSONEncoded a = JSONEncoded { fromJSONEncoded :: a }

18newtype JSONEncoded a = JSONEncoded { fromJSONEncoded :: a }

src/Rel8/Type/Monoid.hs+2−2

@@ -27,7 +27,7 @@ import Data.CaseInsensitive ( CI )

27import {-# SOURCE #-} Rel8.Expr ( Expr )

28import Rel8.Expr.Array ( sempty )

29import Rel8.Expr.Serialize ( litExpr )

30−import Rel8.Schema.Null ( Sql )

30+import Rel8.Schema.Null ( Sql, nullable )

31import Rel8.Type ( DBType, typeInformation )

32import Rel8.Type.Semigroup ( DBSemigroup )

@@ -48,7 +48,7 @@ class DBSemigroup a => DBMonoid a where

50instance Sql DBType a => DBMonoid [a] where

51− memptyExpr = sempty typeInformation

51+ memptyExpr = sempty nullable typeInformation

54instance DBMonoid CalendarDiffTime where

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

@@ -7,7 +7,7 @@

7{-# language UndecidableInstances #-}

9module Rel8.Type.Num

10− ( DBNum, DBIntegral, DBFractional, DBFloating

10+ ( DBNum, DBIntegral, DBFractional

11 )

12where

@@ -18,7 +18,6 @@ import Prelude

19-- rel8

20import Rel8.Type ( DBType )

21−import Rel8.Type.Ord ( DBOrd )

23-- scientific

22-- scientific

24import Data.Scientific ( Scientific )

23import Data.Scientific ( Scientific )

@@ -40,22 +39,14 @@ instance DBNum Scientific

40-- expressions. This is a Rel8 concept, and allows us to provide

39-- expressions. This is a Rel8 concept, and allows us to provide

41-- 'fromIntegral'.

40-- 'fromIntegral'.

42type DBIntegral :: Type -> Constraint

41type DBIntegral :: Type -> Constraint

43−class (DBNum a, DBOrd a) => DBIntegral a

42+class DBNum a => DBIntegral a

44instance DBIntegral Int16

43instance DBIntegral Int16

45instance DBIntegral Int32

44instance DBIntegral Int32

46instance DBIntegral Int64

45instance DBIntegral Int64

49-- | The class of database types that support the @/@ operator.

48-- | The class of database types that support the @/@ operator.

50−type DBFractional :: Type -> Constraint

51class DBNum a => DBFractional a

49class DBNum a => DBFractional a

52instance DBFractional Float

50instance DBFractional Float

53instance DBFractional Double

51instance DBFractional Double

54instance DBFractional Scientific

52instance DBFractional Scientific

55−

56−

57−-- | The class of database types that support the @/@ operator.

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

@@ -75,6 +75,7 @@ instance Sql DBOrd a => DBOrd (NonEmpty a)

75-- | The class of database types that support the @max@ aggregation function.

76type DBMax :: Type -> Constraint

77class DBOrd a => DBMax a

78+instance DBMax Bool

78instance DBMax Char

79instance DBMax Char

79instance DBMax Int16

80instance DBMax Int16

80instance DBMax Int32

81instance DBMax Int32

@@ -100,6 +101,7 @@ instance Sql DBMax a => DBMax (NonEmpty a)

100-- | The class of database types that support the @min@ aggregation function.

101-- | The class of database types that support the @min@ aggregation function.

101type DBMin :: Type -> Constraint

102type DBMin :: Type -> Constraint

102class DBOrd a => DBMin a

103class DBOrd a => DBMin a

104+instance DBMin Bool

103instance DBMin Char

105instance DBMin Char

104instance DBMin Int16

106instance DBMin Int16

105instance DBMin Int32

107instance DBMin Int32

src/Rel8/Type/ReadShow.hs−3

@@ -1,12 +1,10 @@

1{-# language ScopedTypeVariables #-}

2−{-# language StandaloneKindSignatures #-}

3{-# language TypeApplications #-}

2{-# language TypeApplications #-}

4{-# language ViewPatterns #-}

3{-# language ViewPatterns #-}

6module Rel8.Type.ReadShow ( ReadShow(..) ) where

5module Rel8.Type.ReadShow ( ReadShow(..) ) where

8-- base

7-- base

9−import Data.Kind ( Type )

10import Data.Proxy ( Proxy( Proxy ) )

8import Data.Proxy ( Proxy( Proxy ) )

11import Data.Typeable ( Typeable, typeRep )

9import Data.Typeable ( Typeable, typeRep )

12import Prelude

10import Prelude

@@ -22,7 +20,6 @@ import qualified Data.Text as Text

23-- | A deriving-via helper type for column types that store a Haskell value

21-- | A deriving-via helper type for column types that store a Haskell value

24-- using a Haskell's 'Read' and 'Show' type classes.

22-- using a Haskell's 'Read' and 'Show' type classes.

25−type ReadShow :: Type -> Type

26newtype ReadShow a = ReadShow { fromReadShow :: a }

23newtype ReadShow a = ReadShow { fromReadShow :: a }

src/Rel8/Type/Semigroup.hs+2−4

@@ -1,4 +1,3 @@

1−{-# language BlockArguments #-}

2{-# language DataKinds #-}

1{-# language DataKinds #-}

3{-# language FlexibleContexts #-}

2{-# language FlexibleContexts #-}

4{-# language FlexibleInstances #-}

3{-# language FlexibleInstances #-}

@@ -29,7 +28,6 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

30-- rel8

29-- rel8

31import {-# SOURCE #-} Rel8.Expr ( Expr )

30import {-# SOURCE #-} Rel8.Expr ( Expr )

32−import Rel8.Expr.Array ( sappend, sappend1 )

33import Rel8.Expr.Opaleye ( zipPrimExprsWith )

31import Rel8.Expr.Opaleye ( zipPrimExprsWith )

34import Rel8.Schema.Null ( Sql )

32import Rel8.Schema.Null ( Sql )

35import Rel8.Type ( DBType )

33import Rel8.Type ( DBType )

@@ -52,11 +50,11 @@ class DBType a => DBSemigroup a where

54instance Sql DBType a => DBSemigroup [a] where

52instance Sql DBType a => DBSemigroup [a] where

55− (<>.) = sappend

53+ (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))

58instance Sql DBType a => DBSemigroup (NonEmpty a) where

56instance Sql DBType a => DBSemigroup (NonEmpty a) where

59− (<>.) = sappend1

57+ (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))

62instance DBSemigroup CalendarDiffTime where

60instance DBSemigroup CalendarDiffTime where

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

@@ -21,7 +21,7 @@ import Prelude

21import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

23-- rel8

24−import Rel8.Expr ( Expr )

24+import {-# SOURCE #-} Rel8.Expr ( Expr )

25import Rel8.Expr.Eq ( (==.) )

26import Rel8.Expr.Opaleye ( zipPrimExprsWith )

27import Rel8.Expr.Serialize ( litExpr )

@@ -90,7 +90,6 @@ instance DBMonoid MaybeTag where

90 memptyExpr = litExpr mempty

93−type Tag :: Type

94newtype Tag = Tag Text

93newtype Tag = Tag Text

95 deriving newtype

94 deriving newtype

96 ( Eq, Ord, Read, Show

95 ( Eq, Ord, Read, Show

src/Rel8/Window.hsdeleted−97

@@ -1,97 +0,0 @@

1−{-# language DerivingVia #-}

2−{-# language FlexibleContexts #-}

3−{-# language GeneralizedNewtypeDeriving #-}

4−{-# language ScopedTypeVariables #-}

5−{-# language StandaloneKindSignatures #-}

6−{-# language TypeApplications #-}

7−

8−module Rel8.Window

9− ( Window(..)

10− , Partition

11− , over

12− , partitionBy

13− , orderPartitionBy

14− )

15−where

16−

17−-- base

18−import Data.Functor.Const ( Const( Const ), getConst )

19−import Data.Functor.Contravariant ( Contravariant, contramap )

20−import Data.Kind ( Type )

21−import Prelude

22−

23−-- opaleye

24−import qualified Opaleye.Internal.Window as Opaleye

25−import qualified Opaleye.Internal.PackMap as Opaleye

26−

27−-- profunctors

28−import Data.Profunctor ( Profunctor )

29−

30−-- product-profunctors

31−import Data.Profunctor.Product ( ProductProfunctor, (****), purePP )

32−

33−-- rel8

34−import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )

35−import Rel8.Order( Order( Order ) )

36−import Rel8.Schema.HTable ( hfield, htabulateA )

37−import Rel8.Table ( Columns, toColumns )

38−import Rel8.Table.Eq ( EqTable )

39−

40−-- semigroupoids

41−import Data.Functor.Apply ( Apply, WrappedApplicative(..) )

42−

43−

44−-- | 'Window' is an applicative functor that represents expressions that

45−-- contain

46−-- [window functions](https://www.postgresql.org/docs/current/tutorial-window.html).

47−-- 'Rel8.Query.Window.window' can be used to

48−-- evaluate these expressions over a particular query.

49−type Window :: Type -> Type -> Type

50−newtype Window a b = Window (Opaleye.Windows a b)

51− deriving newtype (Profunctor)

52− deriving newtype (Functor, Applicative)

53− deriving (Apply) via (WrappedApplicative (Window a))

54−

55−

56−instance ProductProfunctor Window where

57− purePP = pure

58− (****) = (<*>)

59−

60−

61−-- | In PostgreSQL, window functions must specify the \"window\" or

62−-- \"partition\" over which they operate. The syntax for this looks like:

63−-- @SUM(salary) OVER (PARTITION BY department)@. The Rel8 type 'Partition'

64−-- represents everything that comes after @OVER@.

65−--

66−-- 'Partition' is a 'Monoid', so 'Window's created with 'partitionBy' and

67−-- 'orderWindowBy' can be combined using '<>'.

68−type Partition :: Type -> Type

69−newtype Partition a = Partition (Opaleye.Window a)

70− deriving newtype (Contravariant, Semigroup, Monoid)

71−

72−

73−-- | 'over' adds a 'Partition' to a 'Window' expression.

74−--

75−-- @@@

76−-- 'Rel8.Table.Window.cumulative' ('Rel8.Expr.Aggregate.sum' . salary) `over` 'partitionBy' department <> 'orderPartitionBy' (salary >$< 'Rel8.desc')

77−-- @@@

78−over :: Window a b -> Partition a -> Window a b

79−over (Window (Opaleye.Windows (Opaleye.PackMap w))) (Partition p) =

80− Window $ Opaleye.Windows $ Opaleye.PackMap $ \f ->

81− w (\(o, p') -> f (o, p' <> p))

82−infixl 1 `over`

83−

84−

85−-- | Restricts a window function to operate only the group of rows that share

86−-- the same value(s) for the given expression(s).

87−partitionBy :: forall b a. EqTable b => (a -> b) -> Partition a

88−partitionBy f =

89− Partition $ contramap (toColumns . f) $ getConst $

90− htabulateA @(Columns b) $ \field ->

91− Const $ Opaleye.partitionBy (toColumn . toPrimExpr . (`hfield` field))

92−

93−

94−-- | Controls the order in which rows are processed by window functions. This

95−-- does not need to match the ordering of the overall query.

96−orderPartitionBy :: Order a -> Partition a

97−orderPartitionBy (Order ordering) = Partition $ Opaleye.orderPartitionBy ordering

tests/Main.hs+159−323

@@ -1,11 +1,12 @@

1−{-# language BangPatterns #-}

2{-# language BlockArguments #-}

1{-# language BlockArguments #-}

2+{-# language DataKinds #-}

3{-# language DeriveAnyClass #-}

4{-# language DeriveGeneric #-}

5{-# language DerivingStrategies #-}

6+{-# language DisambiguateRecordFields #-}

6{-# language FlexibleContexts #-}

7{-# language FlexibleContexts #-}

7{-# language FlexibleInstances #-}

8{-# language FlexibleInstances #-}

8−{-# language MonoLocalBinds #-}

9+{-# language GADTs #-}

9{-# language NamedFieldPuns #-}

10{-# language NamedFieldPuns #-}

10{-# language OverloadedStrings #-}

11{-# language OverloadedStrings #-}

11{-# language RecordWildCards #-}

12{-# language RecordWildCards #-}

@@ -13,15 +14,17 @@

13{-# language StandaloneDeriving #-}

14{-# language StandaloneDeriving #-}

14{-# language TypeApplications #-}

15{-# language TypeApplications #-}

17+{-# options_ghc -fno-warn-redundant-constraints #-}

18+

16module Main

19module Main

17 ( main

20 ( main

18 )

21 )

19where

22where

21-- base

24-- base

22−import Control.Applicative ( empty, liftA2, liftA3 )

25+import Control.Applicative ( liftA2, liftA3 )

23−import Control.Exception ( bracket, throwIO )

26+import Control.Monad (void)

24−import Control.Monad ( (>=>), void )

27+import Control.Monad.IO.Class ( MonadIO, liftIO )

25import Data.Bifunctor ( bimap )

28import Data.Bifunctor ( bimap )

26import Data.Foldable ( for_ )

29import Data.Foldable ( for_ )

27import Data.Int ( Int32, Int64 )

30import Data.Int ( Int32, Int64 )

@@ -35,27 +38,25 @@ import GHC.Generics ( Generic )

35import qualified Data.ByteString.Lazy

38import qualified Data.ByteString.Lazy

37-- case-insensitive

40-- case-insensitive

38−import Data.CaseInsensitive ( mk )

41+import Data.CaseInsensitive (mk)

40-- containers

43-- containers

41−import Data.Containers.ListUtils ( nubOrdOn )

42import qualified Data.Map.Strict as Map

44import qualified Data.Map.Strict as Map

44-- hasql

46-- hasql

45−import Hasql.Connection ( Connection, acquire, release )

47+import Hasql.Connection ( Connection, acquire, release )

46import Hasql.Session ( sql, run )

48import Hasql.Session ( sql, run )

48−-- hasql-transaction

49−import Hasql.Transaction ( Transaction, condemn, statement )

50−import qualified Hasql.Transaction.Sessions as Hasql

51−

52-- hedgehog

50-- hedgehog

53import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )

51import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )

54import qualified Hedgehog.Gen as Gen

52import qualified Hedgehog.Gen as Gen

55import qualified Hedgehog.Range as Range

53import qualified Hedgehog.Range as Range

57−-- mmorph

55+-- lifted-base

56+import Control.Exception.Lifted ( bracket, throwIO, bracket_ )

57+

58+-- monad-control

58−import Control.Monad.Morph ( hoist )

59+import Control.Monad.Trans.Control ( MonadBaseControl )

60-- rel8

61-- rel8

61import Rel8 ( Result )

62import Rel8 ( Result )

@@ -71,16 +72,12 @@ import Test.Tasty

71import Test.Tasty.Hedgehog ( testProperty )

72import Test.Tasty.Hedgehog ( testProperty )

73-- text

74-- text

74−import Data.Text ( Text, pack, unpack )

75+import Data.Text (Text, pack)

75import qualified Data.Text.Lazy

76import qualified Data.Text.Lazy

76−import Data.Text.Encoding ( decodeUtf8 )

78-- time

79import Data.Time

81−-- transformers

82−import Control.Monad.Trans.Class ( lift )

83−

84-- tmp-postgres

81-- tmp-postgres

85import qualified Database.Postgres.Temp as TmpPostgres

82import qualified Database.Postgres.Temp as TmpPostgres

@@ -116,17 +113,14 @@ tests =

116 , testCatMaybeTable getTestDatabase

113 , testCatMaybeTable getTestDatabase

117 , testCatMaybe getTestDatabase

114 , testCatMaybe getTestDatabase

118 , testMaybeTable getTestDatabase

115 , testMaybeTable getTestDatabase

119− , testAggregateMaybeTable getTestDatabase

120 , testNestedTables getTestDatabase

116 , testNestedTables getTestDatabase

121 , testMaybeTableApplicative getTestDatabase

117 , testMaybeTableApplicative getTestDatabase

122 , testLogicalFixities getTestDatabase

118 , testLogicalFixities getTestDatabase

123 , testUpdate getTestDatabase

119 , testUpdate getTestDatabase

124 , testDelete getTestDatabase

120 , testDelete getTestDatabase

125− , testUpsert getTestDatabase

126 , testSelectNestedPairs getTestDatabase

121 , testSelectNestedPairs getTestDatabase

127 , testSelectArray getTestDatabase

122 , testSelectArray getTestDatabase

128 , testNestedMaybeTable getTestDatabase

123 , testNestedMaybeTable getTestDatabase

129− , testEvaluate getTestDatabase

130 ]

124 ]

131

125

132 where

126 where

@@ -138,29 +132,25 @@ tests =

138 flip run conn do

132 flip run conn do

139 sql "CREATE EXTENSION citext"

133 sql "CREATE EXTENSION citext"

140 sql "CREATE TABLE test_table ( column1 text not null, column2 bool not null )"

134 sql "CREATE TABLE test_table ( column1 text not null, column2 bool not null )"

141− sql "CREATE TABLE unique_table ( \"key\" text not null unique, \"value\" text not null )"

142− sql "CREATE SEQUENCE test_seq"

143

135

144 return db

136 return db

145

137

146 stopTestDatabase = TmpPostgres.stop

138 stopTestDatabase = TmpPostgres.stop

147

139

148

140

149−connect :: TmpPostgres.DB -> IO Connection

150−connect = acquire . TmpPostgres.toConnectionString >=> either (maybe empty (fail . unpack . decodeUtf8)) pure

151−

152−

153databasePropertyTest

141databasePropertyTest

154 :: TestName

142 :: TestName

155− -> ((TestT Transaction () -> PropertyT IO ()) -> PropertyT IO ())

143+ -> (((Connection -> TestT IO ()) -> PropertyT IO ()) -> PropertyT IO ())

156 -> IO TmpPostgres.DB -> TestTree

144 -> IO TmpPostgres.DB -> TestTree

157databasePropertyTest testName f getTestDatabase =

145databasePropertyTest testName f getTestDatabase =

158− withResource (connect =<< getTestDatabase) release $ \c ->

146+ withResource connect release $ \c ->

159 testProperty testName $ property do

147 testProperty testName $ property do

160− connection <- lift c

148+ connection <- liftIO c

161− f $ test . hoist \m -> do

149+ f \g -> test $ rollingBack connection $ g connection

162− e <- run (Hasql.transaction Hasql.Serializable Hasql.Write (m <* condemn)) connection

150+

163− either throwIO pure e

151+ where

152+

153+ connect = either (error . show) return =<< acquire . TmpPostgres.toConnectionString =<< getTestDatabase

164

154

165

155

166data TestTable f = TestTable

156data TestTable f = TestTable

@@ -192,17 +182,18 @@ testSelectTestTable :: IO TmpPostgres.DB -> TestTree

192testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do

182testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do

193 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

183 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

194

184

195− transaction do

185+ transaction \connection -> do

196− selected <- lift do

186+ void do

187+ liftIO $ Rel8.insert connection

197− statement () $ Rel8.insert Rel8.Insert

188+ Rel8.Insert

198− { into = testTableSchema

189+ { into = testTableSchema

199− , rows = Rel8.values $ map Rel8.lit rows

190+ , rows = map (Rel8.toInsert . Rel8.lit) rows

200− , onConflict = Rel8.DoNothing

191+ , onConflict = Rel8.DoNothing

201− , returning = pure ()

192+ , returning = Rel8.NumberOfRowsAffected

202− }

193+ }

203

194

204− statement () $ Rel8.select do

195+ selected <- liftIO $ Rel8.select connection do

205− Rel8.each testTableSchema

196+ Rel8.each testTableSchema

206

197

207 sort selected === sort rows

198 sort selected === sort rows

208

199

@@ -219,12 +210,11 @@ testWhere_ = databasePropertyTest "WHERE (Rel8.where_)" \transaction -> do

219

210

220 let expected = filter (\t -> testTableColumn2 t == magicBool) rows

211 let expected = filter (\t -> testTableColumn2 t == magicBool) rows

221

212

222− transaction do

213+ transaction \connection -> do

223− selected <- lift do

224− statement () $ Rel8.select do

214+ selected <- liftIO $ Rel8.select connection do

225− t <- Rel8.values $ Rel8.lit <$> rows

215+ t <- Rel8.values $ Rel8.lit <$> rows

226− Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool

216+ Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool

227− return t

217+ return t

228

218

229 sort selected === sort expected

219 sort selected === sort expected

230

220

@@ -237,12 +227,11 @@ testFilter :: IO TmpPostgres.DB -> TestTree

237testFilter = databasePropertyTest "filter" \transaction -> do

227testFilter = databasePropertyTest "filter" \transaction -> do

238 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable

228 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable

239

229

240− transaction do

230+ transaction \connection -> do

241 let expected = filter testTableColumn2 rows

231 let expected = filter testTableColumn2 rows

242

232

243− selected <- lift do

233+ selected <- liftIO $ Rel8.select connection

244− statement () $ Rel8.select do

245− Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)

234+ $ Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)

246

235

247 sort selected === sort expected

236 sort selected === sort expected

248

237

@@ -257,10 +246,9 @@ testLimit = databasePropertyTest "LIMIT (Rel8.limit)" \transaction -> do

257

246

258 n <- forAll $ Gen.integral (Range.linear 0 10)

247 n <- forAll $ Gen.integral (Range.linear 0 10)

259

248

260− transaction do

249+ transaction \connection -> do

261− selected <- lift do

250+ selected <- liftIO $ Rel8.select connection do

262− statement () $ Rel8.select do

263− Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)

251+ Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)

264

252

265 diff (length selected) (<=) (fromIntegral n)

253 diff (length selected) (<=) (fromIntegral n)

266

254

@@ -278,10 +266,9 @@ testUnion = databasePropertyTest "UNION (Rel8.union)" \transaction -> evalM do

278 left <- forAll $ Gen.list (Range.linear 0 10) genTestTable

266 left <- forAll $ Gen.list (Range.linear 0 10) genTestTable

279 right <- forAll $ Gen.list (Range.linear 0 10) genTestTable

267 right <- forAll $ Gen.list (Range.linear 0 10) genTestTable

280

268

281− transaction do

269+ transaction \connection -> do

282− selected <- lift do

270+ selected <- liftIO $ Rel8.select connection do

283− statement () $ Rel8.select do

284− Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)

271+ Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)

285

272

286 sort selected === sort (nub (left ++ right))

273 sort selected === sort (nub (left ++ right))

287

274

@@ -290,11 +277,9 @@ testDistinct :: IO TmpPostgres.DB -> TestTree

290testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do

277testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do

291 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

278 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

292

279

293− transaction do

280+ transaction \connection -> do

294− selected <- lift do

295− statement () $ Rel8.select do

296− Rel8.distinct do

281+ selected <- liftIO $ Rel8.select connection $ Rel8.distinct do

297− Rel8.values (Rel8.lit <$> rows)

282+ Rel8.values (Rel8.lit <$> rows)

298

283

299 sort selected === nub (sort rows)

284 sort selected === nub (sort rows)

300

285

@@ -307,10 +292,8 @@ testExists :: IO TmpPostgres.DB -> TestTree

307testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do

292testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do

308 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

293 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

309

294

310− transaction do

295+ transaction \connection -> do

311− exists <- lift do

312− statement () $ Rel8.select do

313− Rel8.exists $ Rel8.values $ Rel8.lit <$> rows

296+ exists <- liftIO $ Rel8.select connection $ Rel8.exists $ Rel8.values $ Rel8.lit <$> rows

314

297

315 case rows of

298 case rows of

316 [] -> exists === [False]

299 [] -> exists === [False]

@@ -321,10 +304,9 @@ testOptional :: IO TmpPostgres.DB -> TestTree

321testOptional = databasePropertyTest "Rel8.optional" \transaction -> do

304testOptional = databasePropertyTest "Rel8.optional" \transaction -> do

322 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

305 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

323

306

324− transaction do

307+ transaction \connection -> do

325− selected <- lift do

308+ selected <- liftIO $ Rel8.select connection do

326− statement () $ Rel8.select do

327− Rel8.optional $ Rel8.values (Rel8.lit <$> rows)

309+ Rel8.optional $ Rel8.values (Rel8.lit <$> rows)

328

310

329 case rows of

311 case rows of

330 [] -> selected === [Nothing]

312 [] -> selected === [Nothing]

@@ -335,10 +317,9 @@ testAnd :: IO TmpPostgres.DB -> TestTree

335testAnd = databasePropertyTest "AND (&&.)" \transaction -> do

317testAnd = databasePropertyTest "AND (&&.)" \transaction -> do

336 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool

318 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool

337

319

338− transaction do

320+ transaction \connection -> do

339− [result] <- lift do

321+ [result] <- liftIO $ Rel8.select connection $ pure $

340− statement () $ Rel8.select do

341− pure $ Rel8.lit x Rel8.&&. Rel8.lit y

322+ Rel8.lit x Rel8.&&. Rel8.lit y

342

323

343 result === (x && y)

324 result === (x && y)

344

325

@@ -347,10 +328,9 @@ testOr :: IO TmpPostgres.DB -> TestTree

347testOr = databasePropertyTest "OR (||.)" \transaction -> do

328testOr = databasePropertyTest "OR (||.)" \transaction -> do

348 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool

329 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool

349

330

350− transaction do

331+ transaction \connection -> do

351− [result] <- lift do

352− statement () $ Rel8.select $ pure $

332+ [result] <- liftIO $ Rel8.select connection $ pure $

353− Rel8.lit x Rel8.||. Rel8.lit y

333+ Rel8.lit x Rel8.||. Rel8.lit y

354

334

355 result === (x || y)

335 result === (x || y)

356

336

@@ -359,10 +339,9 @@ testLogicalFixities :: IO TmpPostgres.DB -> TestTree

359testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do

339testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do

360 (u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool

340 (u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool

361

341

362− transaction do

342+ transaction \connection -> do

363− [result] <- lift do

343+ [result] <- liftIO $ Rel8.select connection $ pure $

364− statement () $ Rel8.select do

344+ Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x

365− pure $ Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x

366

345

367 result === (u || v && w == x)

346 result === (u || v && w == x)

368

347

@@ -371,10 +350,9 @@ testNot :: IO TmpPostgres.DB -> TestTree

371testNot = databasePropertyTest "NOT (not_)" \transaction -> do

350testNot = databasePropertyTest "NOT (not_)" \transaction -> do

372 x <- forAll Gen.bool

351 x <- forAll Gen.bool

373

352

374− transaction do

353+ transaction \connection -> do

375− [result] <- lift do

354+ [result] <- liftIO $ Rel8.select connection $ pure $

376− statement () $ Rel8.select do

355+ Rel8.not_ $ Rel8.lit x

377− pure $ Rel8.not_ $ Rel8.lit x

378

356

379 result === not x

357 result === not x

380

358

@@ -383,10 +361,9 @@ testBool :: IO TmpPostgres.DB -> TestTree

383testBool = databasePropertyTest "ifThenElse_" \transaction -> do

361testBool = databasePropertyTest "ifThenElse_" \transaction -> do

384 (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool

362 (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool

385

363

386− transaction do

364+ transaction \connection -> do

387− [result] <- lift do

365+ [result] <- liftIO $ Rel8.select connection $ pure $

388− statement () $ Rel8.select do

366+ Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)

389− pure $ Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)

390

367

391 result === if x then y else z

368 result === if x then y else z

392

369

@@ -398,10 +375,9 @@ testAp = databasePropertyTest "Cartesian product (<*>)" \transaction -> do

398 (Gen.list (Range.linear 1 10) genTestTable)

375 (Gen.list (Range.linear 1 10) genTestTable)

399 (Gen.list (Range.linear 1 10) genTestTable)

376 (Gen.list (Range.linear 1 10) genTestTable)

400

377

401− transaction do

378+ transaction \connection -> do

402− result <- lift do

379+ result <- liftIO $ Rel8.select connection $ do

403− statement () $ Rel8.select do

380+ liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))

404− liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))

405

381

406 sort result === sort (liftA2 (,) rows1 rows2)

382 sort result === sort (liftA2 (,) rows1 rows2)

407

383

@@ -430,22 +406,21 @@ testDBType getTestDatabase = testGroup "DBType instances"

430 where

406 where

431 dbTypeTest :: (Eq a, Show a, Rel8.DBType a) => TestName -> Gen a -> TestTree

407 dbTypeTest :: (Eq a, Show a, Rel8.DBType a) => TestName -> Gen a -> TestTree

432 dbTypeTest name generator = testGroup name

408 dbTypeTest name generator = testGroup name

433− [ databasePropertyTest name (t generator) getTestDatabase

409+ [ databasePropertyTest name (t (==) generator) getTestDatabase

434− , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase

410+ , databasePropertyTest ("Maybe " <> name) (t (==) (Gen.maybe generator)) getTestDatabase

435 ]

411 ]

436

412

437− t :: forall a b. (Eq a, Show a, Rel8.Sql Rel8.DBType a)

413+ t :: forall a b. (Show a, Rel8.Sql Rel8.DBType a)

438− => Gen a

414+ => (a -> a -> Bool)

439− -> (TestT Transaction () -> PropertyT IO b)

415+ -> Gen a

416+ -> ((Connection -> TestT IO ()) -> PropertyT IO b)

440 -> PropertyT IO b

417 -> PropertyT IO b

441− t generator transaction = do

418+ t eq generator transaction = do

442 x <- forAll generator

419 x <- forAll generator

443

420

444− transaction do

421+ transaction \connection -> do

445− [res] <- lift do

422+ [res] <- liftIO $ Rel8.select connection $ pure (Rel8.litExpr x)

446− statement () $ Rel8.select do

423+ diff res eq x

447− pure (Rel8.litExpr x)

448− diff res (==) x

449

424

450 genDay :: Gen Day

425 genDay :: Gen Day

451 genDay = do

426 genDay = do

@@ -487,38 +462,39 @@ testDBEq getTestDatabase = testGroup "DBEq instances"

487

462

488 t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBEq a)

463 t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBEq a)

489 => Gen a

464 => Gen a

490− -> (TestT Transaction () -> PropertyT IO ())

465+ -> ((Connection -> TestT IO ()) -> PropertyT IO ())

491 -> PropertyT IO ()

466 -> PropertyT IO ()

492 t generator transaction = do

467 t generator transaction = do

493 (x, y) <- forAll (liftA2 (,) generator generator)

468 (x, y) <- forAll (liftA2 (,) generator generator)

494

469

495− transaction do

470+ transaction \connection -> do

496− [res] <- lift do

471+ [res] <- liftIO $ Rel8.select connection $ pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y

497− statement () $ Rel8.select do

498− pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y

499 res === (x == y)

472 res === (x == y)

500

473

474+ cover 1 "Equal" $ x == y

475+ cover 1 "Not Equal" $ x /= y

476+

501

477

502testTableEquality :: IO TmpPostgres.DB -> TestTree

478testTableEquality :: IO TmpPostgres.DB -> TestTree

503testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do

479testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do

504 (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable

480 (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable

505

481

506− transaction do

482+ transaction \connection -> do

507− [eq] <- lift do

483+ [eq] <- liftIO $ Rel8.select connection do

508− statement () $ Rel8.select do

484+ pure $ Rel8.lit x Rel8.==: Rel8.lit y

509− pure $ Rel8.lit x Rel8.==: Rel8.lit y

510

485

511 eq === (x == y)

486 eq === (x == y)

512

487

488+ cover 1 "Equal" $ x == y

489+ cover 1 "Not Equal" $ x /= y

490+

513

491

514testFromString :: IO TmpPostgres.DB -> TestTree

492testFromString :: IO TmpPostgres.DB -> TestTree

515testFromString = databasePropertyTest "FromString" \transaction -> do

493testFromString = databasePropertyTest "FromString" \transaction -> do

516 str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode

494 str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode

517

495

518− transaction do

496+ transaction \connection -> do

519− [result] <- lift do

497+ [result] <- liftIO $ Rel8.select connection $ pure $ fromString str

520− statement () $ Rel8.select do

521− pure $ fromString str

522 result === pack str

498 result === pack str

523

499

524

500

@@ -526,11 +502,10 @@ testCatMaybeTable :: IO TmpPostgres.DB -> TestTree

526testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do

502testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do

527 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

503 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

528

504

529− transaction do

505+ transaction \connection -> do

530− selected <- lift do

506+ selected <- liftIO $ Rel8.select connection do

531− statement () $ Rel8.select do

507+ testTable <- Rel8.values $ Rel8.lit <$> rows

532− testTable <- Rel8.values $ Rel8.lit <$> rows

508+ Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)

533− Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)

534

509

535 sort selected === sort (filter testTableColumn2 rows)

510 sort selected === sort (filter testTableColumn2 rows)

536

511

@@ -539,10 +514,9 @@ testCatMaybe :: IO TmpPostgres.DB -> TestTree

539testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do

514testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do

540 rows <- forAll $ Gen.list (Range.linear 0 10) $ Gen.maybe Gen.bool

515 rows <- forAll $ Gen.list (Range.linear 0 10) $ Gen.maybe Gen.bool

541

516

542− transaction do

517+ transaction \connection -> do

543− selected <- lift do

518+ selected <- evalM $ liftIO $ Rel8.select connection do

544− statement () $ Rel8.select do

519+ Rel8.catNull =<< Rel8.values (map Rel8.lit rows)

545− Rel8.catNull =<< Rel8.values (map Rel8.lit rows)

546

520

547 sort selected === sort (catMaybes rows)

521 sort selected === sort (catMaybes rows)

548

522

@@ -551,44 +525,21 @@ testMaybeTable :: IO TmpPostgres.DB -> TestTree

551testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do

525testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do

552 (rows, def) <- forAll $ liftA2 (,) (Gen.list (Range.linear 0 10) genTestTable) genTestTable

526 (rows, def) <- forAll $ liftA2 (,) (Gen.list (Range.linear 0 10) genTestTable) genTestTable

553

527

554− transaction do

528+ transaction \connection -> do

555− selected <- lift do

529+ selected <- liftIO $ Rel8.select connection $

556− statement () $ Rel8.select do

530+ Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))

557− Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))

558

531

559 case rows of

532 case rows of

560 [] -> selected === [def]

533 [] -> selected === [def]

561 _ -> sort selected === sort rows

534 _ -> sort selected === sort rows

562

535

563

536

564−testAggregateMaybeTable :: IO TmpPostgres.DB -> TestTree

565−testAggregateMaybeTable = databasePropertyTest "aggregateMaybeTable" \transaction -> evalM do

566− rows <- forAll $ Gen.list (Range.linear 0 10) (Gen.maybe (Gen.int64 (Range.linear 0 10)))

567−

568− let

569− aggregate = go 0 False False

570− where

571− go !n nothing _ (Just a : as) = go (n + a) nothing True as

572− go n _ just (Nothing : as) = go n True just as

573− go _ False False [] = []

574− go _ True False [] = [Nothing]

575− go n False True [] = [Just n]

576− go n True True [] = [Nothing, Just n]

577−

578− transaction do

579− selected <- lift do

580− statement () $ Rel8.select do

581− Rel8.aggregate $ Rel8.aggregateMaybeTable Rel8.sum <$> Rel8.values (Rel8.lit <$> rows)

582−

583− sort selected === aggregate rows

584−

585−

586data TwoTestTables f =

537data TwoTestTables f =

587 TwoTestTables

538 TwoTestTables

588 { testTable1 :: TestTable f

539 { testTable1 :: TestTable f

589 , testTable2 :: TestTable f

540 , testTable2 :: TestTable f

590 }

541 }

591− deriving stock Generic

542+ deriving stock Generic

592 deriving anyclass Rel8.Rel8able

543 deriving anyclass Rel8.Rel8able

593

544

594

545

@@ -603,10 +554,9 @@ testNestedTables = databasePropertyTest "Nested TestTables" \transaction -> eval

603 Gen.list (Range.linear 0 10) $

554 Gen.list (Range.linear 0 10) $

604 liftA2 TwoTestTables genTestTable genTestTable

555 liftA2 TwoTestTables genTestTable genTestTable

605

556

606− transaction do

557+ transaction \connection -> do

607− selected <- lift do

558+ selected <- liftIO $ Rel8.select connection do

608− statement () $ Rel8.select do

559+ Rel8.values (Rel8.lit <$> rows)

609− Rel8.values (Rel8.lit <$> rows)

610

560

611 sort selected === sort rows

561 sort selected === sort rows

612

562

@@ -616,12 +566,11 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction

616 rows1 <- genRows

566 rows1 <- genRows

617 rows2 <- genRows

567 rows2 <- genRows

618

568

619− transaction do

569+ transaction \connection -> do

620− selected <- lift do

570+ selected <- liftIO $ Rel8.select connection do

621− statement () $ Rel8.select do

571+ as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))

622− as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))

572+ bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))

623− bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))

573+ pure $ liftA2 (,) as bs

624− pure $ liftA2 (,) as bs

625

574

626 case (rows1, rows2) of

575 case (rows1, rows2) of

627 ([], []) -> selected === [Nothing]

576 ([], []) -> selected === [Nothing]

@@ -633,6 +582,14 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction

633 genRows = forAll do

582 genRows = forAll do

634 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)

583 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)

635

584

585+rollingBack

586+ :: (MonadBaseControl IO m, MonadIO m)

587+ => Connection -> m a -> m a

588+rollingBack connection =

589+ bracket_

590+ (liftIO (run (sql "BEGIN") connection))

591+ (liftIO (run (sql "ROLLBACK") connection))

592+

636

593

637genTestTable :: Gen (TestTable Result)

594genTestTable :: Gen (TestTable Result)

638genTestTable = do

595genTestTable = do

@@ -645,19 +602,19 @@ testUpdate :: IO TmpPostgres.DB -> TestTree

645testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do

602testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do

646 rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable

603 rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable

647

604

648− transaction do

605+ transaction \connection -> do

649− selected <- lift do

606+ void $ liftIO $ Rel8.insert connection

650− statement () $ Rel8.insert Rel8.Insert

607+ Rel8.Insert

651 { into = testTableSchema

608 { into = testTableSchema

652− , rows = Rel8.values $ map Rel8.lit $ Map.keys rows

609+ , rows = map (Rel8.toInsert . Rel8.lit) $ Map.keys rows

653 , onConflict = Rel8.DoNothing

610 , onConflict = Rel8.DoNothing

654− , returning = pure ()

611+ , returning = Rel8.NumberOfRowsAffected

655 }

612 }

656

613

657− statement () $ Rel8.update Rel8.Update

614+ void $ liftIO $ Rel8.update connection

615+ Rel8.Update

658 { target = testTableSchema

616 { target = testTableSchema

659− , from = pure ()

617+ , set = \r ->

660− , set = \_ r ->

661 let updates = map (bimap Rel8.lit Rel8.lit) $ Map.toList rows

618 let updates = map (bimap Rel8.lit Rel8.lit) $ Map.toList rows

662 in

619 in

663 foldl

620 foldl

@@ -671,12 +628,12 @@ testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do

671 )

628 )

672 r

629 r

673 updates

630 updates

674− , updateWhere = \_ _ -> Rel8.lit True

631+ , updateWhere = \_ -> Rel8.lit True

675− , returning = pure ()

632+ , returning = Rel8.NumberOfRowsAffected

676 }

633 }

677

634

678− statement () $ Rel8.select do

635+ selected <- liftIO $ Rel8.select connection do

679− Rel8.each testTableSchema

636+ Rel8.each testTableSchema

680

637

681 sort selected === sort (Map.elems rows)

638 sort selected === sort (Map.elems rows)

682

639

@@ -689,96 +646,29 @@ testDelete :: IO TmpPostgres.DB -> TestTree

689testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do

646testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do

690 rows <- forAll $ Gen.list (Range.linear 0 5) genTestTable

647 rows <- forAll $ Gen.list (Range.linear 0 5) genTestTable

691

648

692− transaction do

649+ transaction \connection -> do

693− (deleted, selected) <- lift do

650+ void $ liftIO $ Rel8.insert connection

694− statement () $ Rel8.insert Rel8.Insert

651+ Rel8.Insert

695 { into = testTableSchema

652 { into = testTableSchema

696− , rows = Rel8.values $ map Rel8.lit rows

653+ , rows = map (Rel8.toInsert . Rel8.lit) rows

697 , onConflict = Rel8.DoNothing

654 , onConflict = Rel8.DoNothing

698− , returning = pure ()

655+ , returning = Rel8.NumberOfRowsAffected

699 }

656 }

700

657

701− deleted <- statement () $ Rel8.delete Rel8.Delete

658+ deleted <-

659+ liftIO $ Rel8.delete connection

660+ Rel8.Delete

702 { from = testTableSchema

661 { from = testTableSchema

703− , using = pure ()

662+ , deleteWhere = testTableColumn2

704− , deleteWhere = const testTableColumn2

705 , returning = Rel8.Projection id

663 , returning = Rel8.Projection id

706 }

664 }

707

665

708− selected <- statement () $ Rel8.select do

666+ selected <- liftIO $ Rel8.select connection do

709− Rel8.each testTableSchema

667+ Rel8.each testTableSchema

710−

711− pure (deleted, selected)

712

668

713 sort (deleted <> selected) === sort rows

669 sort (deleted <> selected) === sort rows

714

670

715

671

716−data UniqueTable f = UniqueTable

717− { uniqueTableKey :: Rel8.Column f Text

718− , uniqueTableValue :: Rel8.Column f Text

719− }

720− deriving stock Generic

721− deriving anyclass Rel8.Rel8able

722−

723−

724−deriving stock instance Eq (UniqueTable Result)

725−deriving stock instance Ord (UniqueTable Result)

726−deriving stock instance Show (UniqueTable Result)

727−

728−

729−uniqueTableSchema :: Rel8.TableSchema (UniqueTable Rel8.Name)

730−uniqueTableSchema =

731− Rel8.TableSchema

732− { name = "unique_table"

733− , schema = Nothing

734− , columns = UniqueTable

735− { uniqueTableKey = "key"

736− , uniqueTableValue = "value"

737− }

738− }

739−

740−

741−genUniqueTable :: Gen (UniqueTable Result)

742−genUniqueTable = do

743− uniqueTableKey <- Gen.text (Range.linear 0 5) Gen.alphaNum

744− uniqueTableValue <- Gen.text (Range.linear 0 5) Gen.alphaNum

745− pure UniqueTable {..}

746−

747−

748−testUpsert :: IO TmpPostgres.DB -> TestTree

749−testUpsert = databasePropertyTest "Can UPSERT UniqueTable" \transaction -> do

750− as <- unique $ forAll $ Gen.list (Range.linear 0 20) genUniqueTable

751− bs <- unique $ forAll $ Gen.list (Range.linear 0 20) genUniqueTable

752−

753− transaction do

754− selected <- lift do

755− statement () $ Rel8.insert Rel8.Insert

756− { into = uniqueTableSchema

757− , rows = Rel8.values $ Rel8.lit <$> as

758− , onConflict = Rel8.DoNothing

759− , returning = pure ()

760− }

761−

762− statement () $ Rel8.insert Rel8.Insert

763− { into = uniqueTableSchema

764− , rows = Rel8.values $ Rel8.lit <$> bs

765− , onConflict = Rel8.DoUpdate Rel8.Upsert

766− { index = uniqueTableKey

767− , set = \UniqueTable {uniqueTableValue} old -> old {uniqueTableValue}

768− , updateWhere = \_ _ -> Rel8.true

769− }

770− , returning = pure ()

771− }

772−

773− statement () $ Rel8.select do

774− Rel8.each uniqueTableSchema

775−

776− fromUniqueTables selected === fromUniqueTables bs <> fromUniqueTables as

777− where

778− unique = fmap (nubOrdOn uniqueTableKey)

779− fromUniqueTables = Map.fromList . map \(UniqueTable key value) -> (key, value)

780−

781−

782newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }

672newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }

783 deriving stock Generic

673 deriving stock Generic

784 deriving anyclass Rel8.Rel8able

674 deriving anyclass Rel8.Rel8able

@@ -792,10 +682,9 @@ testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree

792testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do

682testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do

793 rows <- forAll $ Gen.list (Range.linear 0 10) $ HKNestedPair <$> liftA2 (,) genTestTable genTestTable

683 rows <- forAll $ Gen.list (Range.linear 0 10) $ HKNestedPair <$> liftA2 (,) genTestTable genTestTable

794

684

795− transaction do

685+ transaction \connection -> do

796− selected <- lift do

686+ selected <- liftIO $ Rel8.select connection do

797− statement () $ Rel8.select do

687+ Rel8.values $ map Rel8.lit rows

798− Rel8.values $ map Rel8.lit rows

799

688

800 sort selected === sort rows

689 sort selected === sort rows

801

690

@@ -804,23 +693,12 @@ testSelectArray :: IO TmpPostgres.DB -> TestTree

804testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do

693testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do

805 rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool

694 rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool

806

695

807− transaction do

696+ transaction \connection -> do

808− selected <- lift do

697+ selected <- liftIO $ Rel8.select connection $ Rel8.aggregate do

809− statement () $ Rel8.select do

698+ Rel8.listAgg <$> Rel8.values (map Rel8.lit rows)

810− Rel8.many $ Rel8.values (map Rel8.lit rows)

811

699

812 selected === [foldMap pure rows]

700 selected === [foldMap pure rows]

813

701

814− selected' <- lift do

815− statement () $ Rel8.select do

816− a <- Rel8.catListTable =<< do

817− Rel8.many $ Rel8.values (map Rel8.lit rows)

818− b <- Rel8.catListTable =<< do

819− Rel8.many $ Rel8.values (map Rel8.lit rows)

820− pure (a, b)

821−

822− selected' === liftA2 (,) rows rows

823−

824

702

825data NestedMaybeTable f = NestedMaybeTable

703data NestedMaybeTable f = NestedMaybeTable

826 { nmt1 :: Rel8.Column f Bool

704 { nmt1 :: Rel8.Column f Bool

@@ -839,51 +717,9 @@ testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree

839testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do

717testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do

840 let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) }

718 let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) }

841

719

842− transaction do

720+ transaction \connection -> do

843− selected <- lift do

721+ selected <- liftIO $ Rel8.select connection do

844− statement () $ Rel8.select do

722+ x <- Rel8.values [Rel8.lit example]

845− x <- Rel8.values [Rel8.lit example]

723+ pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)

846− pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)

847

724

848 selected === [True]

725 selected === [True]

849−

850−

851−testEvaluate :: IO TmpPostgres.DB -> TestTree

852−testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect" \transaction -> do

853−

854− transaction do

855− selected <- lift do

856− statement () $ Rel8.select do

857− x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])

858− y <- Rel8.evaluate (Rel8.nextval "test_seq")

859− pure (x, (y, y))

860−

861− normalize selected ===

862− [ ('a', (0, 0))

863− , ('b', (1, 1))

864− , ('c', (2, 2))

865− ]

866−

867− selected' <- lift do

868− statement () $ Rel8.select do

869− x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])

870− y <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])

871− z <- Rel8.evaluate (Rel8.nextval "test_seq")

872− pure ((x, y), (z, z))

873−

874− normalize selected' ===

875− [ (('a', 'd'), (0, 0))

876− , (('a', 'e'), (1, 1))

877− , (('a', 'f'), (2, 2))

878− , (('b', 'd'), (3, 3))

879− , (('b', 'e'), (4, 4))

880− , (('b', 'f'), (5, 5))

881− , (('c', 'd'), (6, 6))

882− , (('c', 'e'), (7, 7))

883− , (('c', 'f'), (8, 8))

884− ]

885−

886− where

887− normalize :: [(x, (Int64, Int64))] -> [(x, (Int64, Int64))]

888− normalize [] = []

889− normalize xs@((_, (i, _)) : _) = map (fmap (\(a, b) -> (a - i, b - i))) xs