60cbc6a..master · rel8

git.iko.soy/rel8

on master 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@v12

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

13 with:

14 nix_path: nixpkgs=channel:nixos-unstable

15 extra_nix_config: |

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

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

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

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

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

20 with:

21 name: rel8

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

Changelog.mdnew file+159

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

1+# 1.4.0.0 (2002-08-17)

3+## Breaking changes

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

7+## New features

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,4 +10,8 @@ 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+

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

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

cabal.project−5

@@ -1,6 +1 @@

1packages: .

2−

3−allow-newer: generic-monoid:base

4−allow-newer: cryptohash-sha1:base

5−allow-newer: cryptohash-md5:base

6−allow-newer: entropy:Cabal

cabal.project.haskell-nix−6

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

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.

5−

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-2009;

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

6 nixpkgsArgs = haskellNix.nixpkgsArgs;

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

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

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+18−17

@@ -11,18 +11,19 @@ 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 newtype

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

22−

22+of id.

23+

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

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

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

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

25−types clearly different by writing::

26+these types clearly different by writing::

27 newtype UserId = UserId { getUserId :: Int64 }

28 newtype UserId = UserId { getUserId :: Int64 }

28 deriving newtype DBType

29 deriving newtype DBType

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

57stored as ``text`` values.

58stored as ``text`` values.

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

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

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

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

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

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

63 instance DBType OrderStatus where

64 instance DBType OrderStatus where

64 typeInformation = parseTypeInformation parser printer typeInformation

65 typeInformation = parseTypeInformation parser printer typeInformation

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

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

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

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

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

102

103

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

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

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

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

105−this type with Rel8 by writing::

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

106

107

107 data Event = UserCreated UserCreatedData | OrderCreated OrderCreatedData

108 data Event = UserCreated UserCreatedData | OrderCreated OrderCreatedData

108 deriving stock Generic

109 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.rstnew file+181

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

1+``INSERT``, ``UPDATE`` and ``DELETE``

2+=====================================

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.

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−``whereExists`` and ``whereNotExists``. For example, if all blog posts have a

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

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

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

143tagged as "Haskell"::

144

145 blogPost <- each blogPostSchema

146− whereExists do

146+ present do

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

148

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

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

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

150+``filter``. For each blog post, ``present`` 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 ``whereExists`` - ``with``.

154+Like ``filter`` there is also a chaining variant of ``present`` - ``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 author) =<<

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

198 each authorSchema

199

200 While this is a little more code over all, in our experience this style

201− dramatically increases the readabality of queries using joins.

201+ dramatically increases the readability of queries using joins.

202

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

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

docs/cookbook.rst+10−8

@@ -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,23 +142,25 @@ 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.

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

1462. For each blog post, all tags.

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

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

148

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

154− tags <- aggregate do

155+ tags <- some $ do

155 tag <- each tagSchema

156 tag <- each tagSchema

156 where_ (tagPostId tag ==. postId post)

157 where_ (tagPostId tag ==. postId post)

157− return (listAgg (tagName tag))

158+ return (tagName tag)

158

159

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

159− latestComments <-

161+ latestComments <-

160− many $

162+ many $

161− limit 3 $

163+ limit 3 $

162 orderBy (commentCreatedAt >$< desc) do

164 orderBy (commentCreatedAt >$< desc) do

163 comment <- each commentSchema

165 comment <- each commentSchema

164 where_ (commentPostId comment ==. postId post)

166 where_ (commentPostId comment ==. postId post)

docs/index.rst+2−1

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

30 concepts/expr

31 concepts/tables

32 concepts/queries

33+ concepts/insert

34.. toctree::

35.. toctree::

35 :caption: Tips and tricks

36 :caption: Tips and tricks

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

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

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

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

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

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

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

docs/tutorial.rst+64−47

@@ -5,24 +5,25 @@ 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 -XBlockArguments #-}

13+ {-# language BlockArguments #-}

14− {-# language -XDeriveAnyClass #-}

14+ {-# language DeriveAnyClass #-}

15− {-# language -XDeriveGeneric #-}

15+ {-# language DeriveGeneric #-}

16− {-# language -XDerivingStrategies #-}

16+ {-# language DerivingStrategies #-}

17− {-# language -XDerivingVia #-}

17+ {-# language DerivingVia #-}

18− {-# language -XDuplicateRecordFields #-}

18+ {-# language DuplicateRecordFields #-}

19− {-# language -XGeneralizedNewtypeDeriving #-}

19+ {-# language GeneralizedNewtypeDeriving #-}

20− {-# language -XOverloadedStrings #-}

20+ {-# language OverloadedStrings #-}

21− {-# language -XStandaloneDeriving #-}

21+ {-# language StandaloneDeriving #-}

22− {-# language -XTypeApplications #-}

22+ {-# language TypeApplications #-}

23− {-# language -XTypeFamilies #-}

23+ {-# language TypeFamilies #-}

25 import Prelude

26+ import Rel8

27The Example Schema

28The Example Schema

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

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

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

70 { authorId :: Column f Int64

71 { authorId :: Column f Int64

71 , name :: Column f Text

72 , name :: Column f Text

72 , url :: Column f (Maybe Text)

73 , url :: Column f (Maybe Text)

73− }

74+ }

74 deriving stock (Generic)

75 deriving stock (Generic)

75 deriving anyclass (Rel8able)

76 deriving anyclass (Rel8able)

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

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

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

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

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

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

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

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

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

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

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

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

90 { authorId :: Column f AuthorId

91 { authorId :: Column f AuthorId

91 , authorName :: Column f Text

92 , authorName :: Column f Text

92 , authorUrl :: Column f (Maybe Text)

93 , authorUrl :: Column f (Maybe Text)

93− }

94+ }

94 deriving stock (Generic)

95 deriving stock (Generic)

95 deriving anyclass (Rel8able)

96 deriving anyclass (Rel8able)

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

99 data Project f = Project

100 data Project f = Project

100 { projectAuthorId :: Column f AuthorId

101 { projectAuthorId :: Column f AuthorId

101 , projectName :: Column f Text

102 , projectName :: Column f Text

102− }

103+ }

103 deriving stock (Generic)

104 deriving stock (Generic)

104− deriving anyclass (Rel8able

105+ deriving anyclass (Rel8able)

105

106

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

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

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

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

108``deriving (Show)``::

109``deriving (Show)``::

109

110

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

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

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

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

112

113

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

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

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

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

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

125

126

126 authorSchema :: TableSchema (Author Name)

127 authorSchema :: TableSchema (Author Name)

127 authorSchema = TableSchema

128 authorSchema = TableSchema

128− { tableName = "author"

129+ { name = "author"

129− , tableSchema = Nothing

130+ , schema = Nothing

130− , tableColumns = Author

131+ , columns = Author

131 { authorId = "author_id"

132 { authorId = "author_id"

132 , authorName = "name"

133 , authorName = "name"

133 , authorUrl = "url"

134 , authorUrl = "url"

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

138

139

139 projectSchema :: TableSchema (Project Name)

140 projectSchema :: TableSchema (Project Name)

140 projectSchema = TableSchema

141 projectSchema = TableSchema

141− { tableName = "project"

142+ { name = "project"

142− , tableSchema = Nothing

143+ , schema = Nothing

143− , tableColumns = Project

144+ , columns = Project

144 { projectAuthorId = "author_id"

145 { projectAuthorId = "author_id"

145 , projectName = "name"

146 , projectName = "name"

146 }

147 }

148 }

148

149

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

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

152+

153+ projectSchema :: TableSchema (Project Name)

154+ projectSchema = TableSchema

155+ { name = "project"

156+ , schema = Nothing

157+ , columns = namesFromLabels @(Project Name)

158+ }

159+

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

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

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

149

163

150.. note::

164.. note::

151

165

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

169

183

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

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

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

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

172−required knowledge.

186+required knowledge.

173

187

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

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

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

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

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

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

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

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

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

192

206

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

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

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

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

194

210

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

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

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

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

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

197

214

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

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

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

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

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

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

201

218

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

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

203− >>> :t projectAuthorId aProjectIdentity

220+ >>> :t projectAuthorId aProjectResult

204− projectAuthorId aProjectIdentity :: AuthorId

221+ projectAuthorId aProjectResult :: AuthorId

205

222

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

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

207wrappping type at all.

224wrappping type at all.

208

225

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

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

210

227

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

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

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

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

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

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

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

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

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

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

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

219``Functor`` instance::

236``Functor`` instance::

220

237

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

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

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

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

223

240

224Joins

241Joins

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

234their results::

251their results::

235

252

236 >>> :{

253 >>> :{

237− mapM_ print =<< select c do

254+ mapM_ print =<< select conn do

238 author <- each authorSchema

255 author <- each authorSchema

239 project <- each projectSchema

256 project <- each projectSchema

240 return (projectName project, authorName author)

257 return (projectName project, authorName author)

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

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

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

254returned rows. We could write::

271returned rows. We could write::

255

272

256− select c $ do

273+ select conn $ do

257 author <- each authorSchema

274 author <- each authorSchema

258 project <- each projectSchema

275 project <- each projectSchema

259 where_ $ projectAuthorId project ==. authorId author

276 where_ $ projectAuthorId project ==. authorId author

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

270Our final query is then::

287Our final query is then::

271

288

272 >>> :{

289 >>> :{

273− mapM_ print =<< select c do

290+ mapM_ print =<< select conn do

274 author <- each authorSchema

291 author <- each authorSchema

275 project <- projectsForAuthor author

292 project <- projectsForAuthor author

276 return (projectName project, authorName author)

293 return (projectName project, authorName author)

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

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

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

290seen yet::

307seen yet::

291

308

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

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

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

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

294

311

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

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

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

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

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

298

315

299 >>> :{

316 >>> :{

300− mapM_ print =<< select c do

317+ mapM_ print =<< select conn do

301 author <- each authorSchema

318 author <- each authorSchema

302 mproject <- optional $ projectsForAuthor author

319 mproject <- optional $ projectsForAuthor author

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

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

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

342 return (author, project)

359 return (author, project)

343 where

360 where

344

361

345− >>> :t select c authorsAndProjects

362+ >>> :t select conn authorsAndProjects

346− select c authorsAndProjects

363+ select conn authorsAndProjects

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

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

348

365

349

366

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

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

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

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

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

353what we'd like is::

370what we'd like is::

354

371

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

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

356

373

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

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

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

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

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

360author to have no projects::

377author to have no projects::

361

378

362 >>> :{

379 >>> :{

363− mapM_ print =<< select c do

380+ mapM_ print =<< select conn do

364 author <- each authorSchema

381 author <- each authorSchema

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

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

366 return (authorName author, projectNames)

383 return (authorName author, projectNames)

nix/sources.json+9−9

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

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

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

7 "repo": "haskell.nix",

8− "rev": "5b5a18e442df6e27ad8549d69b8868b62adb08c3",

8+ "rev": "0837156c56cb5350dd9bd84eb424187e00aa1e8a",

9− "sha256": "055mk7kmjppng66ppnb8kr96v4wwc8pcxfsls5gl77129hsz9aph",

9+ "sha256": "1djmv5a0vfj78csw2cad6nicrs8iqrp928b9b3v4h7lwwhhzliwl",

10 "type": "tarball",

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

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

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

13 },

14 "niv": {

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

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

18 "owner": "nmattia",

19 "repo": "niv",

20− "rev": "af958e8057f345ee1aca714c1247ef3ba1c15f5e",

20+ "rev": "acdb1726783637852c01e0ad639ac9cbec28d8c8",

21− "sha256": "1qjavxabbrsh73yck5dcq8jggvh3r2jkbr6b5nlz5d9yrqm9255n",

21+ "sha256": "1wszl8q70z6wfgkh2dvgmhhry6qp9nar421qq2ifd17hq2jj9ck3",

22 "type": "tarball",

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

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

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

25 },

26 "nixpkgs": {

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

29 "homepage": null,

30 "owner": "nixos",

31 "repo": "nixpkgs",

32− "rev": "a6847cb5460b47241eb35d1a6588652411642066",

32+ "rev": "1c1f5649bb9c1b0d98637c8c365228f57126f361",

33− "sha256": "0wb5hwgffr4in66qng22sfvbascwnq078q81ziwwayvmnkn73rrm",

33+ "sha256": "0f2nvdijyxfgl5kwyb4465pppd5vkhqxddx6v40k2s0z9jfhj0xl",

34 "type": "tarball",

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

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

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

37 }

38}

nix/sources.nix+66−20

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

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

7 #

9− fetch_file = pkgs: spec:

9+ fetch_file = pkgs: name: spec:

10+ let

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

12+ in

10− if spec.builtin or true then

13+ if spec.builtin or true then

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

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

12− else

15+ else

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

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

15 fetch_tarball = pkgs: name: spec:

18 fetch_tarball = pkgs: name: spec:

16 let

19 let

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

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

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

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

20 in

21 in

21 if spec.builtin or true then

22 if spec.builtin or true then

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

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

23 else

24 else

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

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

26− fetch_git = spec:

27+ fetch_git = name: spec:

28+ let

29+ ref =

30+ if spec ? ref then spec.ref else

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

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

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

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

35+ submoduleArg =

36+ let

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

38+ emptyArgWithWarning =

39+ if submodules == true

40+ then

41+ builtins.trace

42+ (

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

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

45+ + "does not support them"

46+ )

47+ {}

48+ else {};

49+ in

50+ if nixSupportsSubmodules

51+ then { inherit submodules; }

52+ else emptyArgWithWarning;

53+ in

54+ builtins.fetchGit

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

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

29 fetch_local = spec: spec.path;

57 fetch_local = spec: spec.path;

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

40 # Various helpers

68 # Various helpers

41 #

69 #

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

72+ sanitizeName = name:

73+ (

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

75+ (

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

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

78+ )

79+ );

80+

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

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

44− mkPkgs = sources:

82+ mkPkgs = sources: system:

45 let

83 let

46 sourcesNixpkgs =

84 sourcesNixpkgs =

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

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

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

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

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

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

50 in

88 in

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

102

65 if ! builtins.hasAttr "type" spec then

103 if ! builtins.hasAttr "type" spec then

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

82 in

120 in

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

121+ if ersatz == "" then drv else

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

123+ # relative paths)

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

125

85 # Ports of functions for older nix versions

126 # Ports of functions for older nix versions

127

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

139

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

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

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

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

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

101 concatStrings = builtins.concatStringsSep "";

143 concatStrings = builtins.concatStringsSep "";

102

144

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

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

147+

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

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

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

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

105 let

150 let

106 inherit (builtins) lessThan nixVersion fetchTarball;

151 inherit (builtins) lessThan nixVersion fetchTarball;

107 in

152 in

108 if lessThan nixVersion "1.12" then

153 if lessThan nixVersion "1.12" then

109− fetchTarball { inherit name url; }

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

110 else

155 else

111 fetchTarball attrs;

156 fetchTarball attrs;

112

157

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

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

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

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

115 let

160 let

116 inherit (builtins) lessThan nixVersion fetchurl;

161 inherit (builtins) lessThan nixVersion fetchurl;

117 in

162 in

118 if lessThan nixVersion "1.12" then

163 if lessThan nixVersion "1.12" then

119− fetchurl { inherit url; }

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

120 else

165 else

121 fetchurl attrs;

166 fetchurl attrs;

122

167

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

135 mkConfig =

180 mkConfig =

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

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

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

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

183+ , system ? builtins.currentSystem

138− , pkgs ? mkPkgs sources

184+ , pkgs ? mkPkgs sources system

139 }: rec {

185 }: rec {

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

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

141 inherit sources;

187 inherit sources;

rel8.cabal+48−19

@@ -1,38 +1,52 @@

1cabal-version: 2.0

2name: rel8

3−version: 0.1.0.0

3+version: 1.4.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

9build-type: Simple

11build-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

11library

20library

12 build-depends:

21 build-depends:

13 aeson

22 aeson

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

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

24+ , bifunctors

15 , bytestring

25 , bytestring

16 , case-insensitive

26 , case-insensitive

27+ , comonad

17 , contravariant

28 , contravariant

18− , hasql ^>= 1.4.5.1

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

19− , opaleye ^>= 0.7.1.0

30+ , opaleye ^>= 0.9.6.1

31+ , pretty

20 , profunctors

32 , profunctors

33+ , product-profunctors

21 , scientific

34 , scientific

22 , semialign

35 , semialign

23 , semigroupoids

36 , semigroupoids

24 , text

37 , text

25 , these

38 , these

26 , time

39 , time

27− , transformers

28 , uuid

40 , uuid

29 default-language:

41 default-language:

30 Haskell2010

42 Haskell2010

31 ghc-options:

43 ghc-options:

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

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

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

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

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

34 -Wno-monomorphism-restriction

47 -Wno-monomorphism-restriction

35− -Wno-missing-local-signatures

48+ -Wno-missing-local-signatures

49+ -Wno-missing-kind-signatures

36 hs-source-dirs:

50 hs-source-dirs:

37 src

51 src

38 exposed-modules:

52 exposed-modules:

@@ -52,12 +66,14 @@ library

52 Rel8.Column.List

66 Rel8.Column.List

53 Rel8.Column.Maybe

67 Rel8.Column.Maybe

54 Rel8.Column.NonEmpty

68 Rel8.Column.NonEmpty

69+ Rel8.Column.Null

55 Rel8.Column.These

70 Rel8.Column.These

57 Rel8.Expr

72 Rel8.Expr

58 Rel8.Expr.Aggregate

73 Rel8.Expr.Aggregate

59 Rel8.Expr.Array

74 Rel8.Expr.Array

60 Rel8.Expr.Bool

75 Rel8.Expr.Bool

76+ Rel8.Expr.Default

61 Rel8.Expr.Eq

77 Rel8.Expr.Eq

62 Rel8.Expr.Function

78 Rel8.Expr.Function

63 Rel8.Expr.Null

79 Rel8.Expr.Null

@@ -66,21 +82,19 @@ library

66 Rel8.Expr.Order

82 Rel8.Expr.Order

67 Rel8.Expr.Sequence

83 Rel8.Expr.Sequence

68 Rel8.Expr.Serialize

84 Rel8.Expr.Serialize

85+ Rel8.Expr.Window

70 Rel8.FCF

87 Rel8.FCF

72 Rel8.Kind.Algebra

89 Rel8.Kind.Algebra

73 Rel8.Kind.Context

90 Rel8.Kind.Context

74− Rel8.Kind.Labels

76 Rel8.Generic.Construction

92 Rel8.Generic.Construction

77 Rel8.Generic.Construction.ADT

93 Rel8.Generic.Construction.ADT

78 Rel8.Generic.Construction.Record

94 Rel8.Generic.Construction.Record

79 Rel8.Generic.Map

95 Rel8.Generic.Map

80 Rel8.Generic.Record

96 Rel8.Generic.Record

81− Rel8.Generic.Reify

82 Rel8.Generic.Rel8able

97 Rel8.Generic.Rel8able

83− Rel8.Generic.Rel8able.Test

84 Rel8.Generic.Table

98 Rel8.Generic.Table

85 Rel8.Generic.Table.ADT

99 Rel8.Generic.Table.ADT

86 Rel8.Generic.Table.Record

100 Rel8.Generic.Table.Record

@@ -95,21 +109,23 @@ library

95 Rel8.Query.Evaluate

109 Rel8.Query.Evaluate

96 Rel8.Query.Exists

110 Rel8.Query.Exists

97 Rel8.Query.Filter

111 Rel8.Query.Filter

112+ Rel8.Query.Indexed

98 Rel8.Query.Limit

113 Rel8.Query.Limit

99 Rel8.Query.List

114 Rel8.Query.List

100 Rel8.Query.Maybe

115 Rel8.Query.Maybe

101 Rel8.Query.Null

116 Rel8.Query.Null

102 Rel8.Query.Opaleye

117 Rel8.Query.Opaleye

103 Rel8.Query.Order

118 Rel8.Query.Order

119+ Rel8.Query.Rebind

104 Rel8.Query.Set

120 Rel8.Query.Set

105 Rel8.Query.SQL

121 Rel8.Query.SQL

106 Rel8.Query.These

122 Rel8.Query.These

107 Rel8.Query.Values

123 Rel8.Query.Values

124+ Rel8.Query.Window

108

125

109− Rel8.Schema.Context

110− Rel8.Schema.Context.Label

111 Rel8.Schema.Context.Nullify

126 Rel8.Schema.Context.Nullify

112 Rel8.Schema.Dict

127 Rel8.Schema.Dict

128+ Rel8.Schema.Field

113 Rel8.Schema.HTable

129 Rel8.Schema.HTable

114 Rel8.Schema.HTable.Either

130 Rel8.Schema.HTable.Either

115 Rel8.Schema.HTable.Identity

131 Rel8.Schema.HTable.Identity

@@ -125,24 +141,28 @@ library

125 Rel8.Schema.Kind

141 Rel8.Schema.Kind

126 Rel8.Schema.Name

142 Rel8.Schema.Name

127 Rel8.Schema.Null

143 Rel8.Schema.Null

128− Rel8.Schema.Reify

129 Rel8.Schema.Result

144 Rel8.Schema.Result

130 Rel8.Schema.Spec

145 Rel8.Schema.Spec

131− Rel8.Schema.Spec.ConstrainDBType

132 Rel8.Schema.Table

146 Rel8.Schema.Table

133

147

134 Rel8.Statement.Delete

148 Rel8.Statement.Delete

135 Rel8.Statement.Insert

149 Rel8.Statement.Insert

150+ Rel8.Statement.OnConflict

136 Rel8.Statement.Returning

151 Rel8.Statement.Returning

137 Rel8.Statement.Select

152 Rel8.Statement.Select

153+ Rel8.Statement.Set

154+ Rel8.Statement.SQL

138 Rel8.Statement.Update

155 Rel8.Statement.Update

156+ Rel8.Statement.Using

139 Rel8.Statement.View

157 Rel8.Statement.View

158+ Rel8.Statement.Where

140

159

141 Rel8.Table

160 Rel8.Table

142 Rel8.Table.ADT

161 Rel8.Table.ADT

143 Rel8.Table.Aggregate

162 Rel8.Table.Aggregate

144 Rel8.Table.Alternative

163 Rel8.Table.Alternative

145 Rel8.Table.Bool

164 Rel8.Table.Bool

165+ Rel8.Table.Cols

146 Rel8.Table.Either

166 Rel8.Table.Either

147 Rel8.Table.Eq

167 Rel8.Table.Eq

148 Rel8.Table.HKD

168 Rel8.Table.HKD

@@ -150,16 +170,18 @@ library

150 Rel8.Table.Maybe

170 Rel8.Table.Maybe

151 Rel8.Table.Name

171 Rel8.Table.Name

152 Rel8.Table.NonEmpty

172 Rel8.Table.NonEmpty

173+ Rel8.Table.Null

174+ Rel8.Table.Nullify

153 Rel8.Table.Opaleye

175 Rel8.Table.Opaleye

154 Rel8.Table.Ord

176 Rel8.Table.Ord

155 Rel8.Table.Order

177 Rel8.Table.Order

156− Rel8.Table.Recontextualize

178+ Rel8.Table.Projection

157 Rel8.Table.Rel8able

179 Rel8.Table.Rel8able

158 Rel8.Table.Serialize

180 Rel8.Table.Serialize

159− Rel8.Table.Tag

160 Rel8.Table.These

181 Rel8.Table.These

182+ Rel8.Table.Transpose

161 Rel8.Table.Undefined

183 Rel8.Table.Undefined

162− Rel8.Table.Unreify

184+ Rel8.Table.Window

163

185

164 Rel8.Type

186 Rel8.Type

165 Rel8.Type.Array

187 Rel8.Type.Array

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

178 Rel8.Type.Sum

200 Rel8.Type.Sum

179 Rel8.Type.Tag

201 Rel8.Type.Tag

180

202

203+ Rel8.Window

204+

205+

181test-suite tests

206test-suite tests

182 type: exitcode-stdio-1.0

207 type: exitcode-stdio-1.0

183 build-depends:

208 build-depends:

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

186 , case-insensitive

211 , case-insensitive

187 , containers

212 , containers

188 , hasql

213 , hasql

214+ , hasql-transaction

189− , hedgehog ^>=1.0.2

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

190− , lifted-base ^>=0.2.3.12

216+ , mmorph

191− , monad-control ^>=1.0.2.3

192 , rel8

217 , rel8

193 , scientific

218 , scientific

194 , tasty

219 , tasty

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

196 , text

221 , text

197 , time

222 , time

198 , tmp-postgres ^>=1.34.1.0

223 , tmp-postgres ^>=1.34.1.0

224+ , transformers

199 , uuid

225 , uuid

200

226

227+ other-modules:

228+ Rel8.Generic.Rel8able.Test

229+

201 main-is: Main.hs

230 main-is: Main.hs

202 hs-source-dirs: tests

231 hs-source-dirs: tests

203 default-language: Haskell2010

232 default-language: Haskell2010

shell.nix+1−1

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

1let

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

3− pkgs = import sources.nixpkgs {};

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

4 hsPkgs = import ./default.nix;

5in

6 hsPkgs.shellFor {

src/Rel8.hs+321−35

@@ -38,26 +38,31 @@ module Rel8

38 , HMaybe

39 , HList

40 , HNonEmpty

41+ , HNull

41 , HThese

42 , HThese

42 , Lift

43 , Lift

44 , Table(..)

45 , Table(..)

46+ , HTable

47+ , Transposes

45 , AltTable((<|>:))

48 , AltTable((<|>:))

46 , AlternativeTable( emptyTable )

49 , AlternativeTable( emptyTable )

47− , EqTable, (==:), (/=:)

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

48− , OrdTable, ascTable, descTable

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

49 , lit

52 , lit

50 , bool

53 , bool

51 , case_

54 , case_

55+ , castTable

53 -- ** @MaybeTable@

57 -- ** @MaybeTable@

54 , MaybeTable

58 , MaybeTable

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

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

56 , isNothingTable, isJustTable

60 , isNothingTable, isJustTable

61+ , fromMaybeTable

57 , optional

62 , optional

58 , catMaybeTable

63 , catMaybeTable

59− , bindMaybeTable

60 , traverseMaybeTable

64 , traverseMaybeTable

65+ , aggregateMaybeTable

61 , nameMaybeTable

66 , nameMaybeTable

63 -- ** @EitherTable@

68 -- ** @EitherTable@

@@ -66,8 +71,8 @@ module Rel8

66 , isLeftTable, isRightTable

71 , isLeftTable, isRightTable

67 , keepLeftTable

72 , keepLeftTable

68 , keepRightTable

73 , keepRightTable

69− , bindEitherTable

70 , bitraverseEitherTable

74 , bitraverseEitherTable

75+ , aggregateEitherTable

71 , nameEitherTable

76 , nameEitherTable

73 -- ** @TheseTable@

78 -- ** @TheseTable@

@@ -76,19 +81,20 @@ module Rel8

76 , isThisTable, isThatTable, isThoseTable

81 , isThisTable, isThatTable, isThoseTable

77 , hasHereTable, hasThereTable

82 , hasHereTable, hasThereTable

78 , justHereTable, justThereTable

83 , justHereTable, justThereTable

84+ , alignMaybeTable

79 , alignBy

85 , alignBy

80 , keepHereTable, loseHereTable

86 , keepHereTable, loseHereTable

81 , keepThereTable, loseThereTable

87 , keepThereTable, loseThereTable

82 , keepThisTable, loseThisTable

88 , keepThisTable, loseThisTable

83 , keepThatTable, loseThatTable

89 , keepThatTable, loseThatTable

84 , keepThoseTable, loseThoseTable

90 , keepThoseTable, loseThoseTable

85− , bindTheseTable

86 , bitraverseTheseTable

91 , bitraverseTheseTable

92+ , aggregateTheseTable

87 , nameTheseTable

93 , nameTheseTable

89 -- ** @ListTable@

95 -- ** @ListTable@

90 , ListTable

96 , ListTable

91− , listTable

97+ , listTable, ($*)

92 , nameListTable

98 , nameListTable

93 , many

99 , many

94 , manyExpr

100 , manyExpr

@@ -97,23 +103,46 @@ module Rel8

103

98 -- ** @NonEmptyTable@

104 -- ** @NonEmptyTable@

99 , NonEmptyTable

105 , NonEmptyTable

100− , nonEmptyTable

106+ , nonEmptyTable, ($+)

101 , nameNonEmptyTable

107 , nameNonEmptyTable

102 , some

108 , some

103 , someExpr

109 , someExpr

104 , catNonEmptyTable

110 , catNonEmptyTable

105 , catNonEmpty

111 , catNonEmpty

106

112

107− -- ** @ADT@

113+ -- ** @NullTable@

114+ , NullTable

115+ , nullableTable, nullTable, nullifyTable

116+ , isNullTable, isNonNullTable

117+ , catNullTable

118+ , nameNullTable

119+ , toNullTable, toMaybeTable

120+

121+ -- ** Algebraic data types / sum types

122+ -- $adts

123+

124+ -- *** Naming of ADTs

125+ -- $naming

126+ , NameADT, nameADT

108− , ADT, ADTable, fromADT, toADT

127+ , ADT, ADTable

128+

129+ -- *** Deconstruction of ADTs

130+ -- $deconstruction

131+ , DeconstructADT, deconstructADT

132+

133+ -- *** Construction of ADTs

134+ -- $construction

109 , BuildADT, buildADT

135 , BuildADT, buildADT

110 , ConstructADT, constructADT

136 , ConstructADT, constructADT

111− , DeconstructADT, deconstructADT

137+

112− , NameADT, nameADT

138+ -- *** Other ADT operations

113 , AggregateADT, aggregateADT

139 , AggregateADT, aggregateADT

114

140

141+ -- *** Miscellaneous notes

142+ -- $misc-notes

143+

115 -- ** @HKD@

144 -- ** @HKD@

116− , HKD, HKDable, fromHKD, toHKD

145+ , HKD, HKDable

117 , BuildHKD, buildHKD

146 , BuildHKD, buildHKD

118 , ConstructHKD, constructHKD

147 , ConstructHKD, constructHKD

119 , DeconstructHKD, deconstructHKD

148 , DeconstructHKD, deconstructHKD

@@ -134,6 +163,9 @@ module Rel8

134 , unsafeLiteral

163 , unsafeLiteral

135

164

136 -- ** @null@

165 -- ** @null@

166+ , NotNull

167+ , Nullable

168+ , Homonullable

137 , null

169 , null

138 , nullify

170 , nullify

139 , nullable

171 , nullable

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

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

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

153 , in_

185 , in_

154 , boolExpr, caseExpr

186 , boolExpr, caseExpr

187+ , like, ilike

155

188

156 -- ** Ordering

189 -- ** Ordering

157 , DBOrd

190 , DBOrd

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

169 , Query

202 , Query

170 , showQuery

203 , showQuery

171

204

205+ -- ** Projection

206+ , Projection

207+ , Projectable( project )

208+ , Biprojectable( biproject )

209+ , Projecting

210+ , Field

211+

172 -- ** Selecting rows

212 -- ** Selecting rows

173 , Selects

213 , Selects

174 , each

214 , each

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

177 -- ** Filtering

217 -- ** Filtering

178 , filter

218 , filter

179 , where_

219 , where_

180− , whereExists

220+ , present

181− , whereNotExists

221+ , absent

182 , distinct

222 , distinct

183 , distinctOn

223 , distinctOn

184 , distinctOnBy

224 , distinctOnBy

@@ -213,10 +253,11 @@ module Rel8

213 , countRows

253 , countRows

214 , groupBy

254 , groupBy

215 , listAgg, listAggExpr

255 , listAgg, listAggExpr

256+ , mode

216 , nonEmptyAgg, nonEmptyAggExpr

257 , nonEmptyAgg, nonEmptyAggExpr

217 , DBMax, max

258 , DBMax, max

218 , DBMin, min

259 , DBMin, min

219− , DBSum, sum, sumWhere

260+ , DBSum, sum, sumWhere, avg

220 , DBString, stringAgg

261 , DBString, stringAgg

221 , count

262 , count

222 , countStar

263 , countStar

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

233 , nullsFirst

274 , nullsFirst

234 , nullsLast

275 , nullsLast

235

276

277+ -- ** Window functions

278+ , Window

279+ , window

280+ , Partition

281+ , over

282+ , partitionBy

283+ , orderPartitionBy

284+ , cumulative

285+ , cumulative_

286+ , currentRow

287+ , rowNumber

288+ , rank

289+ , denseRank

290+ , percentRank

291+ , cumeDist

292+ , ntile

293+ , lag

294+ , lead

295+ , firstValue

296+ , lastValue

297+ , nthValue

298+ , indexed

299+

300+ -- ** Bindings

301+ , rebind

302+

236 -- * IO

303 -- * IO

237 , Serializable

304 , Serializable

305+ , ToExprs

306+ , Result

238

307

239 -- * Running statements

308 -- * Running statements

309+ -- $running

310+

240 -- ** @SELECT@

311 -- ** @SELECT@

241 , select

312 , select

242

313

243 -- ** @INSERT@

314 -- ** @INSERT@

244 , Insert(..)

315 , Insert(..)

245 , OnConflict(..)

316 , OnConflict(..)

317+ , Upsert(..)

246 , insert

318 , insert

319+ , unsafeDefault

320+ , showInsert

247

321

248 -- ** @DELETE@

322 -- ** @DELETE@

249 , Delete(..)

323 , Delete(..)

250 , delete

324 , delete

325+ , showDelete

251

326

252 -- ** @UPDATE@

327 -- ** @UPDATE@

253− , update

254 , Update(..)

328 , Update(..)

329+ , update

330+ , showUpdate

255

331

256 -- ** @.. RETURNING@

332 -- ** @.. RETURNING@

257 , Returning(..)

333 , Returning(..)

258

334

259 -- ** @CREATE VIEW@

335 -- ** @CREATE VIEW@

260 , createView

336 , createView

337+ , createOrReplaceView

261

338

262 -- ** Sequences

339 -- ** Sequences

263 , nextval

340 , nextval

264−

265− , Evaluate

266− , eval

267 , evaluate

341 , evaluate

268−

269− -- * TODO

270− -- TODO

271− -- These need organizing, but are reachable from Rel8's documentation so we

272− -- do need to export and document them.

273− , Recontextualize

274− , Nullable

275− , NotNull

276− , HTable

277− , Labelable

278− , ToExprs(..)

279− , FromExprs

280− , Result

281− , HKDT(..)

282 ) where

342 ) where

283

343

284-- base

344-- base

@@ -293,10 +353,12 @@ import Rel8.Column.Lift

293import Rel8.Column.List

353import Rel8.Column.List

294import Rel8.Column.Maybe

354import Rel8.Column.Maybe

295import Rel8.Column.NonEmpty

355import Rel8.Column.NonEmpty

356+import Rel8.Column.Null

296import Rel8.Column.These

357import Rel8.Column.These

297import Rel8.Expr

358import Rel8.Expr

298import Rel8.Expr.Aggregate

359import Rel8.Expr.Aggregate

299import Rel8.Expr.Bool

360import Rel8.Expr.Bool

361+import Rel8.Expr.Default

300import Rel8.Expr.Eq

362import Rel8.Expr.Eq

301import Rel8.Expr.Function

363import Rel8.Expr.Function

302import Rel8.Expr.Null

364import Rel8.Expr.Null

@@ -305,6 +367,8 @@ import Rel8.Expr.Ord

305import Rel8.Expr.Order

367import Rel8.Expr.Order

306import Rel8.Expr.Serialize

368import Rel8.Expr.Serialize

307import Rel8.Expr.Sequence

369import Rel8.Expr.Sequence

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

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

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

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

309import Rel8.Order

373import Rel8.Order

310import Rel8.Query

374import Rel8.Query

@@ -315,16 +379,19 @@ import Rel8.Query.Either

315import Rel8.Query.Evaluate

379import Rel8.Query.Evaluate

316import Rel8.Query.Exists

380import Rel8.Query.Exists

317import Rel8.Query.Filter

381import Rel8.Query.Filter

382+import Rel8.Query.Indexed

318import Rel8.Query.Limit

383import Rel8.Query.Limit

319import Rel8.Query.List

384import Rel8.Query.List

320import Rel8.Query.Maybe

385import Rel8.Query.Maybe

321import Rel8.Query.Null

386import Rel8.Query.Null

322import Rel8.Query.Order

387import Rel8.Query.Order

388+import Rel8.Query.Rebind

323import Rel8.Query.SQL (showQuery)

389import Rel8.Query.SQL (showQuery)

324import Rel8.Query.Set

390import Rel8.Query.Set

325import Rel8.Query.These

391import Rel8.Query.These

326import Rel8.Query.Values

392import Rel8.Query.Values

327−import Rel8.Schema.Context.Label

393+import Rel8.Query.Window

394+import Rel8.Schema.Field

328import Rel8.Schema.HTable

395import Rel8.Schema.HTable

329import Rel8.Schema.Name

396import Rel8.Schema.Name

330import Rel8.Schema.Null hiding ( nullable )

397import Rel8.Schema.Null hiding ( nullable )

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

332import Rel8.Schema.Table

399import Rel8.Schema.Table

333import Rel8.Statement.Delete

400import Rel8.Statement.Delete

334import Rel8.Statement.Insert

401import Rel8.Statement.Insert

402+import Rel8.Statement.OnConflict

335import Rel8.Statement.Returning

403import Rel8.Statement.Returning

336import Rel8.Statement.Select

404import Rel8.Statement.Select

405+import Rel8.Statement.SQL

337import Rel8.Statement.Update

406import Rel8.Statement.Update

338import Rel8.Statement.View

407import Rel8.Statement.View

339import Rel8.Table

408import Rel8.Table

@@ -348,12 +417,16 @@ import Rel8.Table.List

348import Rel8.Table.Maybe

417import Rel8.Table.Maybe

349import Rel8.Table.Name

418import Rel8.Table.Name

350import Rel8.Table.NonEmpty

419import Rel8.Table.NonEmpty

420+import Rel8.Table.Null

421+import Rel8.Table.Opaleye ( castTable )

351import Rel8.Table.Ord

422import Rel8.Table.Ord

352import Rel8.Table.Order

423import Rel8.Table.Order

353−import Rel8.Table.Recontextualize

424+import Rel8.Table.Projection

354import Rel8.Table.Rel8able ()

425import Rel8.Table.Rel8able ()

355import Rel8.Table.Serialize

426import Rel8.Table.Serialize

356import Rel8.Table.These

427import Rel8.Table.These

428+import Rel8.Table.Transpose

429+import Rel8.Table.Window

357import Rel8.Type

430import Rel8.Type

358import Rel8.Type.Composite

431import Rel8.Type.Composite

359import Rel8.Type.Eq

432import Rel8.Type.Eq

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

368import Rel8.Type.Semigroup

441import Rel8.Type.Semigroup

369import Rel8.Type.String

442import Rel8.Type.String

370import Rel8.Type.Sum

443import 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+37−109

@@ -1,155 +1,83 @@

1{-# language DataKinds #-}

2−{-# language DerivingVia #-}

3{-# language FlexibleContexts #-}

2{-# language FlexibleContexts #-}

4{-# language FlexibleInstances #-}

3{-# language FlexibleInstances #-}

5−{-# language GADTs #-}

6{-# language MultiParamTypeClasses #-}

4{-# language MultiParamTypeClasses #-}

7−{-# language NamedFieldPuns #-}

5+{-# language RankNTypes #-}

8−{-# language PolyKinds #-}

9{-# language StandaloneKindSignatures #-}

6{-# language StandaloneKindSignatures #-}

10{-# language TypeFamilies #-}

7{-# language TypeFamilies #-}

11{-# language UndecidableInstances #-}

8{-# language UndecidableInstances #-}

12−{-# language UndecidableSuperClasses #-}

14module Rel8.Aggregate

10module Rel8.Aggregate

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

11+ ( Aggregate(..), zipOutputs

16− , Aggregator(..), unsafeMakeAggregate

12+ , unsafeMakeAggregate

17 , Aggregates

13 , Aggregates

18− , Col( A, unA )

19 )

14 )

20where

15where

22-- base

17-- base

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

18+import Control.Applicative ( liftA2 )

24−import Data.Functor.Identity ( Identity )

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

25import Data.Kind ( Constraint, Type )

20import Data.Kind ( Constraint, Type )

26import Prelude

21import Prelude

23+-- profunctors

24+import Data.Profunctor ( dimap )

25+

28-- opaleye

26-- opaleye

29−import qualified Opaleye.Internal.Aggregate as Opaleye

27+import qualified Opaleye.Aggregate as Opaleye

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

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

31−import qualified Opaleye.Internal.PackMap as Opaleye

29+import qualified Opaleye.Internal.Column as Opaleye

33-- rel8

31-- rel8

34import Rel8.Expr ( Expr )

32import Rel8.Expr ( Expr )

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

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

37−import Rel8.Schema.HTable.Identity ( HIdentity(..), HType )

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

38−import Rel8.Schema.Name ( Name )

34+import qualified Rel8.Schema.Kind as K

39import Rel8.Schema.Null ( Sql )

35import Rel8.Schema.Null ( Sql )

40−import Rel8.Schema.Reify ( notReify )

41−import Rel8.Schema.Result ( Result )

42−import Rel8.Schema.Spec ( Spec( Spec ) )

43import Rel8.Table

36import Rel8.Table

44 ( Table, Columns, Context, fromColumns, toColumns

37 ( Table, Columns, Context, fromColumns, toColumns

45− , reify, unreify

38+ , FromExprs, fromResult, toResult

39+ , Transpose

46 )

40 )

47−import Rel8.Table.Recontextualize ( Recontextualize )

41+import Rel8.Table.Transpose ( Transposes )

48import Rel8.Type ( DBType )

42import Rel8.Type ( DBType )

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

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

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

53−-- @Aggregate@ is almost an 'Applicative' functor - but there is no 'pure'

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

55−-- combine @Aggregate@s using the @<.>@ combinator.

56−type Aggregate :: k -> Type

46+type Aggregate :: K.Context

57−data Aggregate a where

58− Aggregate :: !(Opaleye.Aggregator () (Expr a)) -> Aggregate a

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

59−

60−

61−instance Interpretation Aggregate where

62− data Col Aggregate _spec where

63− A :: ()

64− => { unA :: !(Aggregate a) }

65− -> Col Aggregate ('Spec labels a)

68instance Sql DBType a => Table Aggregate (Aggregate a) where

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

69− type Columns (Aggregate a) = HType a

51+ type Columns (Aggregate a) = HIdentity a

70 type Context (Aggregate a) = Aggregate

52 type Context (Aggregate a) = Aggregate

53+ type FromExprs (Aggregate a) = a

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

72− toColumns = HIdentity . A

56+ toColumns = HIdentity

73− fromColumns (HIdentity (A a)) = a

57+ fromColumns (HIdentity a) = a

74−

58+ toResult = HIdentity . Identity

75− reify = notReify

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

76− unreify = notReify

77−

78−

79−instance Sql DBType a =>

80− Recontextualize Aggregate Aggregate (Aggregate a) (Aggregate a)

81−

82−

83−instance Sql DBType a =>

84− Recontextualize Aggregate Expr (Aggregate a) (Expr a)

85−

86−

87−instance Sql DBType a =>

88− Recontextualize Aggregate Result (Aggregate a) (Identity a)

89−

90−

91−instance Sql DBType a =>

92− Recontextualize Aggregate Name (Aggregate a) (Name a)

95−instance Sql DBType a =>

96− Recontextualize Expr Aggregate (Expr a) (Aggregate a)

97−

98−

99−instance Sql DBType a =>

100− Recontextualize Result Aggregate (Identity a) (Aggregate a)

101−

102−

103−instance Sql DBType a =>

104− Recontextualize Name Aggregate (Name a) (Aggregate a)

105−

106−

107−instance Labelable Aggregate where

108− labeler (A aggregate) = A aggregate

109− unlabeler (A aggregate) = A aggregate

110−

111−

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

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

113−-- for the columns in @b@.

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

114type Aggregates :: Type -> Type -> Constraint

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

115−class Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs

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

116−instance Recontextualize Aggregate Expr aggregates exprs => Aggregates aggregates exprs

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

117−

118−

119−foldInputs :: Monoid b

120− => (Maybe Aggregator -> Opaleye.PrimExpr -> b) -> Aggregate a -> b

121−foldInputs f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =

122− getConst $ flip agg () $ \(aggregator, a) ->

123− Const $ f (detuplize <$> aggregator) a

124− where

125− detuplize (operation, ordering, distinction) =

126− Aggregator {operation, ordering, distinction}

127−

128−

129−mapInputs :: ()

130− => (Opaleye.PrimExpr -> Opaleye.PrimExpr) -> Aggregate a -> Aggregate a

131−mapInputs transform (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =

132− Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ agg . \f input ->

133− f (fmap transform input)

134

135

136−type Aggregator :: Type

69+zipOutputs :: ()

137−data Aggregator = Aggregator

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

138− { operation :: Opaleye.AggrOp

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

139− , ordering :: [Opaleye.OrderExpr]

140− , distinction :: Opaleye.AggrDistinct

141− }

142

143

144−unsafeMakeAggregate :: ()

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

145 => (Expr input -> Opaleye.PrimExpr)

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

146 -> (Opaleye.PrimExpr -> Expr output)

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

147− -> Maybe Aggregator

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

148 -> Expr input

78 -> Expr input

149 -> Aggregate output

79 -> Aggregate output

150unsafeMakeAggregate input output aggregator expr =

80unsafeMakeAggregate input output aggregator expr =

151− Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ \f _ ->

81+ Aggregate $ dimap in_ out aggregator

152− output <$> f (tuplize <$> aggregator, input expr)

82+ where out = output . Opaleye.unColumn

153− where

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

154− tuplize Aggregator {operation, ordering, distinction} =

155− (operation, ordering, distinction)

src/Rel8/Column.hs+8−77

@@ -1,99 +1,30 @@

1{-# language DataKinds #-}

2−{-# language FlexibleContexts #-}

3−{-# language LambdaCase #-}

4−{-# language MultiParamTypeClasses #-}

5{-# language StandaloneKindSignatures #-}

2{-# language StandaloneKindSignatures #-}

6{-# language TypeFamilies #-}

3{-# language TypeFamilies #-}

8module Rel8.Column

5module Rel8.Column

9− ( Column, AColumn(..)

6+ ( Column

10 , TColumn

7 , TColumn

11 )

8 )

12where

9where

14-- base

11-- base

15import Data.Kind ( Type )

12import Data.Kind ( Type )

16−import Prelude

13+import Prelude ()

18-- rel8

15-- rel8

19−import Rel8.Aggregate ( Aggregate, Col( A ) )

20−import Rel8.Expr ( Expr, Col( E ) )

21import Rel8.FCF ( Eval, Exp )

16import Rel8.FCF ( Eval, Exp )

22−import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )

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

24import qualified Rel8.Schema.Kind as K

17import qualified Rel8.Schema.Kind as K

25−import Rel8.Schema.Name ( Name(..), Col( N ) )

18+import Rel8.Schema.Result ( Result )

26−import Rel8.Schema.Null ( Sql )

27−import Rel8.Schema.Reify ( Reify, Col(..) )

28−import Rel8.Schema.Result ( Col( R ), Result )

29−import Rel8.Schema.Spec ( Spec( Spec ) )

30−import Rel8.Table

31− ( Table, Columns, Context, fromColumns, toColumns

32− , Unreify, reify, unreify

33− )

34−import Rel8.Table.Recontextualize ( Recontextualize )

35−import Rel8.Type ( DBType )

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

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

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

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

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

39type family Column context a where

25type family Column context a where

40− Column (Reify context) a = AColumn context a

41− Column Aggregate a = Aggregate a

42− Column Expr a = Expr a

43− Column Name a = Name a

44− Column Result a = a

26+ Column Result a = a

45−

46−

47−type AColumn :: K.Context -> Type -> Type

48−newtype AColumn context a = AColumn (Column context a)

49−

50−

51−instance (Reifiable context, Sql DBType a) =>

52− Table (Reify context) (AColumn context a)

53− where

54− type Context (AColumn context a) = Reify context

55− type Columns (AColumn context a) = HIdentity ('Spec '[] a)

56− type Unreify (AColumn context a) = Column context a

27+ Column context a = context a

57−

58− fromColumns (HIdentity (Reify a)) = sfromColumn contextSing a

59− toColumns = HIdentity . Reify . stoColumn contextSing

60− reify _ = AColumn

61− unreify _ (AColumn a) = a

62−

63−

64−instance

65− ( Reifiable context, Reifiable context'

66− , Sql DBType a

67− ) =>

68− Recontextualize

69− (Reify context)

70− (Reify context')

71− (AColumn context a)

72− (AColumn context' a)

73−

74−

75−sfromColumn :: ()

76− => SContext context

77− -> Col context ('Spec labels a)

78− -> AColumn context a

79−sfromColumn = \case

80− SAggregate -> \(A a) -> AColumn a

81− SExpr -> \(E a) -> AColumn a

82− SName -> \(N a) -> AColumn a

83− SResult -> \(R a) -> AColumn a

84− SReify context -> \(Reify a) -> AColumn (sfromColumn context a)

85−

86−

87−stoColumn :: ()

88− => SContext context

89− -> AColumn context a

90− -> Col context ('Spec labels a)

91−stoColumn = \case

92− SAggregate -> \(AColumn a) -> A a

93− SExpr -> \(AColumn a) -> E a

94− SName -> \(AColumn a) -> N a

95− SResult -> \(AColumn a) -> R a

96− SReify context -> \(AColumn a) -> Reify (stoColumn context a)

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

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

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

@@ -1,88 +1,23 @@

1{-# language DataKinds #-}

2−{-# language LambdaCase #-}

3−{-# language MultiParamTypeClasses #-}

4{-# language StandaloneKindSignatures #-}

2{-# language StandaloneKindSignatures #-}

5{-# language TypeFamilies #-}

3{-# language TypeFamilies #-}

6−{-# language UndecidableInstances #-}

8module Rel8.Column.ADT

5module Rel8.Column.ADT

9− ( HADT, AHADT(..)

6+ ( HADT

10 )

7 )

11where

8where

13-- base

10-- base

14import Data.Kind ( Type )

11import Data.Kind ( Type )

15−import Prelude

12+import Prelude ()

17-- rel8

14-- rel8

18−import Rel8.Generic.Rel8able ( GColumns )

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

20−import Rel8.Schema.Context ( Col )

21import qualified Rel8.Schema.Kind as K

15import qualified Rel8.Schema.Kind as K

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

23import Rel8.Schema.Result ( Result )

16import Rel8.Schema.Result ( Result )

24−import Rel8.Table

17+import Rel8.Table.ADT ( ADT )

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 )

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

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

33type family HADT context t where

21type family HADT context t where

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

35 HADT Result t = t Result

22 HADT Result t = t Result

36 HADT context t = ADT t context

23 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− SName -> AHADT . ADT . hunreify

75− SResult -> AHADT . fromADT . ADT . hunreify

76− SReify context -> AHADT . sfromColumnsADT context . hunreify

77−

78−

79−stoColumnsADT :: ADTable t

80− => SContext context

81− -> AHADT context t

82− -> GColumns (ADT t) (Col (Reify context))

83−stoColumnsADT = \case

84− SAggregate -> hreify . (\(AHADT (ADT a)) -> a)

85− SExpr -> hreify . (\(AHADT (ADT a)) -> a)

86− SName -> hreify . (\(AHADT (ADT a)) -> a)

87− SResult -> hreify . (\(ADT a) -> a) . toADT . (\(AHADT a) -> a)

88− SReify context -> hreify . stoColumnsADT context . (\(AHADT a) -> a)

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

@@ -1,159 +1,26 @@

1{-# language DataKinds #-}

2−{-# language FlexibleContexts #-}

3−{-# language LambdaCase #-}

4−{-# language MultiParamTypeClasses #-}

5{-# language StandaloneKindSignatures #-}

2{-# language StandaloneKindSignatures #-}

6−{-# language TypeFamilies #-}

3+{-# language TypeFamilyDependencies #-}

7−{-# language UndecidableInstances #-}

9module Rel8.Column.Either

5module Rel8.Column.Either

10− ( HEither, AHEither(..)

6+ ( HEither

11 )

7 )

12where

8where

14-- base

10-- base

15−import Control.Applicative ( liftA2 )

16−import Data.Bifunctor ( Bifunctor, bimap )

17import Data.Kind ( Type )

11import Data.Kind ( Type )

18import Prelude

12import Prelude

20-- rel8

14-- 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 )

26import qualified Rel8.Schema.Kind as K

15import qualified Rel8.Schema.Kind as K

27−import Rel8.Schema.Name ( Name(..) )

28−import Rel8.Schema.Reify ( Reify, hreify, hunreify )

29import Rel8.Schema.Result ( Result )

16import Rel8.Schema.Result ( Result )

30−import Rel8.Table

31− ( Table, Columns, Context, fromColumns, toColumns

32− , Unreify, reify, unreify

33− )

34import Rel8.Table.Either ( EitherTable )

17import Rel8.Table.Either ( EitherTable )

35−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.

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

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

39−type family HEither context where

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

40− HEither (Reify context) = AHEither context

41− HEither Aggregate = EitherTable

42− HEither Expr = EitherTable

43− HEither Name = EitherTable

44 HEither Result = Either

25 HEither Result = Either

45−

26+ HEither context = EitherTable context

46−

47−type AHEither :: K.Context -> Type -> Type -> Type

48−newtype AHEither context a b = AHEither (HEither context a b)

49−

50−

51−instance Reifiable context => Bifunctor (AHEither context) where

52− bimap = sbimapEither contextSing

53−

54−

55−instance Reifiable context => Functor (AHEither context a) where

56− fmap = bimap id

57−

58−

59−instance (Reifiable context, Table (Reify context) a, Table (Reify context) b)

60− => Table (Reify context) (AHEither context a b)

61− where

62− type Context (AHEither context a b) = Reify context

63− type Columns (AHEither context a b) = HEitherTable (Columns a) (Columns b)

64− type Unreify (AHEither context a b) = HEither context (Unreify a) (Unreify b)

65−

66− fromColumns = sfromColumnsEither contextSing

67− toColumns = stoColumnsEither contextSing

68− reify proof = liftA2 bimap reify reify proof . AHEither

69− unreify proof = (\(AHEither a) -> a) . liftA2 bimap unreify unreify proof

70−

71−

72−instance

73− ( Reifiable context, Reifiable context'

74− , Recontextualize (Reify context) (Reify context') a a'

75− , Recontextualize (Reify context) (Reify context') b b'

76− ) =>

77− Recontextualize

78− (Reify context)

79− (Reify context')

80− (AHEither context a b)

81− (AHEither context' a' b')

82−

83−

84−sbimapEither :: ()

85− => SContext context

86− -> (a -> c)

87− -> (b -> d)

88− -> AHEither context a b

89− -> AHEither context c d

90−sbimapEither = \case

91− SAggregate -> \f g (AHEither a) -> AHEither (bimap f g a)

92− SExpr -> \f g (AHEither a) -> AHEither (bimap f g a)

93− SResult -> \f g (AHEither a) -> AHEither (bimap f g a)

94− SName -> \f g (AHEither a) -> AHEither (bimap f g a)

95− SReify context -> \f g (AHEither a) -> AHEither (sbimapEither context f g a)

96−

97−

98−sfromColumnsEither :: (Table (Reify context) a, Table (Reify context) b)

99− => SContext context

100− -> HEitherTable (Columns a) (Columns b) (Col (Reify context))

101− -> AHEither context a b

102−sfromColumnsEither = \case

103− SAggregate ->

104− AHEither .

105− bimap (fromColumns . hreify) (fromColumns . hreify) .

106− fromColumns .

107− hunreify

108− SExpr ->

109− AHEither .

110− bimap (fromColumns . hreify) (fromColumns . hreify) .

111− fromColumns .

112− hunreify

113− SResult ->

114− AHEither .

115− bimap (fromColumns . hreify) (fromColumns . hreify) .

116− fromColumns .

117− hunreify

118− SName ->

119− AHEither .

120− bimap (fromColumns . hreify) (fromColumns . hreify) .

121− fromColumns .

122− hunreify

123− SReify context ->

124− AHEither .

125− sbimapEither context (fromColumns . hreify) (fromColumns . hreify) .

126− sfromColumnsEither context .

127− hunreify

128−

129−

130−stoColumnsEither :: (Table (Reify context) a, Table (Reify context) b)

131− => SContext context

132− -> AHEither context a b

133− -> HEitherTable (Columns a) (Columns b) (Col (Reify context))

134−stoColumnsEither = \case

135− SAggregate ->

136− hreify .

137− toColumns .

138− bimap (hunreify . toColumns) (hunreify . toColumns) .

139− (\(AHEither a) -> a)

140− SExpr ->

141− hreify .

142− toColumns .

143− bimap (hunreify . toColumns) (hunreify . toColumns) .

144− (\(AHEither a) -> a)

145− SResult ->

146− hreify .

147− toColumns .

148− bimap (hunreify . toColumns) (hunreify . toColumns) .

149− (\(AHEither a) -> a)

150− SName ->

151− hreify .

152− toColumns .

153− bimap (hunreify . toColumns) (hunreify . toColumns) .

154− (\(AHEither a) -> a)

155− SReify context ->

156− hreify .

157− stoColumnsEither context .

158− sbimapEither context (hunreify . toColumns) (hunreify . toColumns) .

159− (\(AHEither a) -> a)

src/Rel8/Column/Lift.hs+3−67

@@ -1,87 +1,23 @@

1{-# language DataKinds #-}

2−{-# language LambdaCase #-}

3−{-# language MultiParamTypeClasses #-}

4{-# language StandaloneKindSignatures #-}

2{-# language StandaloneKindSignatures #-}

5{-# language TypeFamilies #-}

3{-# language TypeFamilies #-}

7module Rel8.Column.Lift

5module Rel8.Column.Lift

8− ( Lift, ALift(..)

6+ ( Lift

9 )

7 )

10where

8where

12-- base

10-- base

13import Data.Kind ( Type )

11import Data.Kind ( Type )

14−import Prelude

12+import Prelude ()

16-- rel8

14-- rel8

17−import Rel8.Generic.Rel8able ( GColumns )

18−import Rel8.Kind.Context ( Reifiable(..), SContext(..) )

19−import Rel8.Schema.Context ( Col )

20import qualified Rel8.Schema.Kind as K

15import qualified Rel8.Schema.Kind as K

21−import Rel8.Schema.Reify ( Reify, hreify, hunreify )

22import Rel8.Schema.Result ( Result )

16import Rel8.Schema.Result ( Result )

23−import Rel8.Table

17+import Rel8.Table.HKD ( HKD )

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 )

32type Lift :: K.Context -> Type -> Type

20type Lift :: K.Context -> Type -> Type

33type family Lift context a where

21type family Lift context a where

34− Lift (Reify context) a = ALift context a

35 Lift Result a = a

22 Lift Result a = a

36 Lift context a = HKD a context

23 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− SName -> ALift . fromColumns . hunreify

74− SResult -> ALift . fromHKD . HKD . hunreify

75− SReify context -> ALift . sfromColumnsLift context . hunreify

76−

77−

78−stoColumnsLift :: HKDable a

79− => SContext context

80− -> ALift context a

81− -> GColumns (HKD a) (Col (Reify context))

82−stoColumnsLift = \case

83− SAggregate -> hreify . toColumns . unALift

84− SExpr -> hreify . toColumns . unALift

85− SName -> hreify . toColumns . unALift

86− SResult -> hreify . (\(HKD a) -> a) . toHKD . unALift

87− SReify context -> hreify . stoColumnsLift context . unALift

src/Rel8/Column/List.hs+8−126

@@ -1,143 +1,25 @@

1{-# language DataKinds #-}

2−{-# language FlexibleContexts #-}

3−{-# language LambdaCase #-}

4−{-# language MultiParamTypeClasses #-}

5{-# language StandaloneKindSignatures #-}

2{-# language StandaloneKindSignatures #-}

6−{-# language TypeFamilies #-}

3+{-# language TypeFamilyDependencies #-}

7−{-# language UndecidableInstances #-}

9module Rel8.Column.List

5module Rel8.Column.List

10− ( HList, AHList(..)

6+ ( HList

11 )

7 )

12where

8where

14-- base

10-- base

15import Data.Kind ( Type )

11import Data.Kind ( Type )

16−import Data.Type.Equality ( (:~:)( Refl ) )

17−import Prelude

12+import Prelude ()

19-- rel8

14-- 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 )

25import qualified Rel8.Schema.Kind as K

15import qualified Rel8.Schema.Kind as K

26−import Rel8.Schema.Name ( Name )

27−import Rel8.Schema.Reify ( Reify, hreify, hunreify )

28import Rel8.Schema.Result ( Result )

16import Rel8.Schema.Result ( Result )

29−import Rel8.Table

17+import Rel8.Table.List ( ListTable )

30− ( Table, Columns, Congruent, Context, fromColumns, toColumns

31− , Unreify, reify, unreify

32− )

33−import Rel8.Table.List ( ListTable( ListTable ) )

34−import Rel8.Table.Recontextualize ( Recontextualize )

35−import Rel8.Table.Unreify ( Unreifiability(..), Unreifiable, unreifiability )

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.

38type HList :: K.Context -> Type -> Type

22type HList :: K.Context -> Type -> Type

39−type family HList context where

23+type family HList context = list | list -> context where

40− HList (Reify context) = AHList context

41− HList Aggregate = ListTable

42− HList Expr = ListTable

43− HList Name = ListTable

44 HList Result = []

24 HList Result = []

45−

25+ HList context = ListTable context

46−

47−type AHList :: K.Context -> Type -> Type

48−newtype AHList context a = AHList (HList context a)

49−

50−

51−instance (Reifiable context, Unreifiable a, Table (Reify context) a) =>

52− Table (Reify context) (AHList context a)

53− where

54− type Context (AHList context a) = Reify context

55− type Columns (AHList context a) = HListTable (Columns a)

56− type Unreify (AHList context a) = HList context (Unreify a)

57−

58− fromColumns = sfromColumnsList contextSing

59− toColumns = stoColumnsList contextSing

60−

61− reify _ = sreifyList (unreifiability contextSing)

62− unreify _ = sunreifyList (unreifiability contextSing)

63−

64−

65−instance

66− ( Reifiable context, Reifiable context'

67− , Unreifiable a, Unreifiable a'

68− , Recontextualize (Reify context) (Reify context') a a'

69− )

70− => Recontextualize

71− (Reify context)

72− (Reify context')

73− (AHList context a)

74− (AHList context' a')

75−

76−

77−smapList :: Congruent a b

78− => SContext context

79− -> (a -> b)

80− -> (HListTable (Columns a) (Col (Context a)) -> HListTable (Columns b) (Col (Context b)))

81− -> AHList context a

82− -> AHList context b

83−smapList = \case

84− SAggregate -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))

85− SExpr -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))

86− SResult -> \f _ (AHList as) -> AHList (fmap f as)

87− SName -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))

88− SReify context -> \f g (AHList as) -> AHList (smapList context f g as)

89−

90−

91−sfromColumnsList :: Table (Reify context) a

92− => SContext context

93− -> HListTable (Columns a) (Col (Reify context))

94− -> AHList context a

95−sfromColumnsList = \case

96− SAggregate -> AHList . ListTable

97− SExpr -> AHList . ListTable

98− SResult -> AHList . fmap (fromColumns . hreify) . fromColumns . hunreify

99− SName -> AHList . ListTable

100− SReify context ->

101− AHList .

102− smapList context (fromColumns . hreify) hreify .

103− sfromColumnsList context .

104− hunreify

105−

106−

107−stoColumnsList :: Table (Reify context) a

108− => SContext context

109− -> AHList context a

110− -> HListTable (Columns a) (Col (Reify context))

111−stoColumnsList = \case

112− SAggregate -> \(AHList (ListTable a)) -> a

113− SExpr -> \(AHList (ListTable a)) -> a

114− SResult ->

115− hreify . toColumns . fmap (hunreify . toColumns) . (\(AHList a) -> a)

116− SName -> \(AHList (ListTable a)) -> a

117− SReify context ->

118− hreify .

119− stoColumnsList context .

120− smapList context (hunreify . toColumns) hunreify .

121− (\(AHList a) -> a)

122−

123−

124−sreifyList :: Table (Reify context) a

125− => Unreifiability context a

126− -> HList context (Unreify a)

127− -> AHList context a

128−sreifyList = \case

129− UResult -> AHList . fmap (reify Refl)

130− Unreifiability context ->

131− smapList context (reify Refl) hreify .

132− AHList

133−

134−

135−sunreifyList :: Table (Reify context) a

136− => Unreifiability context a

137− -> AHList context a

138− -> HList context (Unreify a)

139−sunreifyList = \case

140− UResult -> fmap (unreify Refl) . (\(AHList a) -> a)

141− Unreifiability context ->

142− (\(AHList a) -> a) .

143− smapList context (unreify Refl) hunreify

src/Rel8/Column/Maybe.hs+7−105

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

1{-# language DataKinds #-}

2−{-# language FlexibleContexts #-}

3−{-# language GADTs #-}

4−{-# language LambdaCase #-}

5−{-# language MultiParamTypeClasses #-}

6{-# language StandaloneKindSignatures #-}

2{-# language StandaloneKindSignatures #-}

7−{-# language TypeFamilies #-}

3+{-# language TypeFamilyDependencies #-}

8−{-# language UndecidableInstances #-}

10module Rel8.Column.Maybe

5module Rel8.Column.Maybe

11− ( HMaybe, AHMaybe(..)

6+ ( HMaybe

12 )

7 )

13where

8where

@@ -17,108 +12,15 @@ import Data.Kind ( Type )

17import Prelude

12import Prelude

19-- rel8

14-- 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 )

25import qualified Rel8.Schema.Kind as K

15import qualified Rel8.Schema.Kind as K

26−import Rel8.Schema.Name ( Name )

27−import Rel8.Schema.Reify ( Reify, hreify, hunreify )

28import Rel8.Schema.Result ( Result )

16import Rel8.Schema.Result ( Result )

29−import Rel8.Table

30− ( Table, Columns, Context, fromColumns, toColumns

31− , Unreify, reify, unreify

32− )

33import Rel8.Table.Maybe ( MaybeTable )

17import Rel8.Table.Maybe ( MaybeTable )

34−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.

37type HMaybe :: K.Context -> Type -> Type

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

38−type family HMaybe context where

24+type family HMaybe context = maybe | maybe -> context where

39− HMaybe (Reify context) = AHMaybe context

40− HMaybe Aggregate = MaybeTable

41− HMaybe Expr = MaybeTable

42− HMaybe Name = MaybeTable

43 HMaybe Result = Maybe

25 HMaybe Result = Maybe

44−

26+ HMaybe context = MaybeTable context

45−

46−type AHMaybe :: K.Context -> Type -> Type

47−newtype AHMaybe context a = AHMaybe (HMaybe context a)

48−

49−

50−instance Reifiable context => Functor (AHMaybe context) where

51− fmap = smapMaybe contextSing

52−

53−

54−instance (Reifiable context, Table (Reify context) a) =>

55− Table (Reify context) (AHMaybe context a)

56− where

57− type Context (AHMaybe context a) = Reify context

58− type Columns (AHMaybe context a) = HMaybeTable (Columns a)

59− type Unreify (AHMaybe context a) = HMaybe context (Unreify a)

60−

61− fromColumns = sfromColumnsMaybe contextSing

62− toColumns = stoColumnsMaybe contextSing

63− reify proof = fmap fmap reify proof . AHMaybe

64− unreify proof = (\(AHMaybe a) -> a) . fmap fmap unreify proof

65−

66−

67−instance

68− ( Reifiable context, Reifiable context'

69− , Recontextualize (Reify context) (Reify context') a a'

70− ) =>

71− Recontextualize

72− (Reify context)

73− (Reify context')

74− (AHMaybe context a)

75− (AHMaybe context' a')

76−

77−

78−smapMaybe :: ()

79− => SContext context

80− -> (a -> b)

81− -> AHMaybe context a

82− -> AHMaybe context b

83−smapMaybe = \case

84− SAggregate -> \f (AHMaybe a) -> AHMaybe (fmap f a)

85− SExpr -> \f (AHMaybe a) -> AHMaybe (fmap f a)

86− SResult -> \f (AHMaybe a) -> AHMaybe (fmap f a)

87− SName -> \f (AHMaybe a) -> AHMaybe (fmap f a)

88− SReify context -> \f (AHMaybe a) -> AHMaybe (smapMaybe context f a)

89−

90−

91−sfromColumnsMaybe :: Table (Reify context) a

92− => SContext context

93− -> HMaybeTable (Columns a) (Col (Reify context))

94− -> AHMaybe context a

95−sfromColumnsMaybe = \case

96− SAggregate -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify

97− SExpr -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify

98− SResult -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify

99− SName -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify

100− SReify context ->

101− AHMaybe .

102− smapMaybe context (fromColumns . hreify) .

103− sfromColumnsMaybe context .

104− hunreify

105−

106−

107−stoColumnsMaybe :: Table (Reify context) a

108− => SContext context

109− -> AHMaybe context a

110− -> HMaybeTable (Columns a) (Col (Reify context))

111−stoColumnsMaybe = \case

112− SAggregate ->

113− hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)

114− SExpr ->

115− hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)

116− SResult ->

117− hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)

118− SName ->

119− hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)

120− SReify context ->

121− hreify .

122− stoColumnsMaybe context .

123− smapMaybe context (hunreify . toColumns) .

124− (\(AHMaybe a) -> a)

src/Rel8/Column/NonEmpty.hs+9−127

@@ -1,145 +1,27 @@

1{-# language DataKinds #-}

2−{-# language FlexibleContexts #-}

3−{-# language LambdaCase #-}

4−{-# language MultiParamTypeClasses #-}

5{-# language StandaloneKindSignatures #-}

2{-# language StandaloneKindSignatures #-}

6−{-# language TypeFamilies #-}

3+{-# language TypeFamilyDependencies #-}

7−{-# language UndecidableInstances #-}

9module Rel8.Column.NonEmpty

5module Rel8.Column.NonEmpty

10− ( HNonEmpty, AHNonEmpty(..)

6+ ( HNonEmpty

11 )

7 )

12where

8where

14-- base

10-- base

15import Data.Kind ( Type )

11import Data.Kind ( Type )

16import Data.List.NonEmpty ( NonEmpty )

12import Data.List.NonEmpty ( NonEmpty )

17−import Data.Type.Equality ( (:~:)( Refl ) )

18−import Prelude

13+import Prelude ()

20-- rel8

15-- 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 )

26import qualified Rel8.Schema.Kind as K

16import qualified Rel8.Schema.Kind as K

27−import Rel8.Schema.Name ( Name )

28−import Rel8.Schema.Reify ( Reify, hreify, hunreify )

29import Rel8.Schema.Result ( Result )

17import Rel8.Schema.Result ( Result )

30−import Rel8.Table

18+import Rel8.Table.NonEmpty ( NonEmptyTable )

31− ( Table, Columns, Congruent, Context, fromColumns, toColumns

32− , Unreify, reify, unreify

33− )

34−import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )

35−import Rel8.Table.Recontextualize ( Recontextualize )

36−import Rel8.Table.Unreify ( Unreifiability(..), Unreifiable, unreifiability )

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.

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

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

40−type family HNonEmpty context where

25+type family HNonEmpty context = nonEmpty | nonEmpty -> context where

41− HNonEmpty (Reify context) = AHNonEmpty context

42− HNonEmpty Aggregate = NonEmptyTable

43− HNonEmpty Expr = NonEmptyTable

44− HNonEmpty Name = NonEmptyTable

45 HNonEmpty Result = NonEmpty

26 HNonEmpty Result = NonEmpty

46−

27+ HNonEmpty context = NonEmptyTable context

47−

48−type AHNonEmpty :: K.Context -> Type -> Type

49−newtype AHNonEmpty context a = AHNonEmpty (HNonEmpty context a)

50−

51−

52−instance (Reifiable context, Unreifiable a, Table (Reify context) a) =>

53− Table (Reify context) (AHNonEmpty context a)

54− where

55− type Context (AHNonEmpty context a) = Reify context

56− type Columns (AHNonEmpty context a) = HNonEmptyTable (Columns a)

57− type Unreify (AHNonEmpty context a) = HNonEmpty context (Unreify a)

58−

59− fromColumns = sfromColumnsNonEmpty contextSing

60− toColumns = stoColumnsNonEmpty contextSing

61−

62− reify _ = sreifyNonEmpty (unreifiability contextSing)

63− unreify _ = sunreifyNonEmpty (unreifiability contextSing)

64−

65−

66−instance

67− ( Reifiable context, Reifiable context'

68− , Unreifiable a, Unreifiable a'

69− , Recontextualize (Reify context) (Reify context') a a'

70− )

71− => Recontextualize

72− (Reify context)

73− (Reify context')

74− (AHNonEmpty context a)

75− (AHNonEmpty context' a')

76−

77−

78−smapNonEmpty :: Congruent a b

79− => SContext context

80− -> (a -> b)

81− -> (HNonEmptyTable (Columns a) (Col (Context a)) -> HNonEmptyTable (Columns b) (Col (Context b)))

82− -> AHNonEmpty context a

83− -> AHNonEmpty context b

84−smapNonEmpty = \case

85− SAggregate -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))

86− SExpr -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))

87− SResult -> \f _ (AHNonEmpty as) -> AHNonEmpty (fmap f as)

88− SName -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))

89− SReify context -> \f g (AHNonEmpty as) -> AHNonEmpty (smapNonEmpty context f g as)

90−

91−

92−sfromColumnsNonEmpty :: Table (Reify context) a

93− => SContext context

94− -> HNonEmptyTable (Columns a) (Col (Reify context))

95− -> AHNonEmpty context a

96−sfromColumnsNonEmpty = \case

97− SAggregate -> AHNonEmpty . NonEmptyTable

98− SExpr -> AHNonEmpty . NonEmptyTable

99− SResult ->

100− AHNonEmpty . fmap (fromColumns . hreify) . fromColumns . hunreify

101− SName -> AHNonEmpty . NonEmptyTable

102− SReify context ->

103− AHNonEmpty .

104− smapNonEmpty context (fromColumns . hreify) hreify .

105− sfromColumnsNonEmpty context .

106− hunreify

107−

108−

109−stoColumnsNonEmpty :: Table (Reify context) a

110− => SContext context

111− -> AHNonEmpty context a

112− -> HNonEmptyTable (Columns a) (Col (Reify context))

113−stoColumnsNonEmpty = \case

114− SAggregate -> \(AHNonEmpty (NonEmptyTable a)) -> a

115− SExpr -> \(AHNonEmpty (NonEmptyTable a)) -> a

116− SResult ->

117− hreify . toColumns . fmap (hunreify . toColumns) . (\(AHNonEmpty a) -> a)

118− SName -> \(AHNonEmpty (NonEmptyTable a)) -> a

119− SReify context ->

120− hreify .

121− stoColumnsNonEmpty context .

122− smapNonEmpty context (hunreify . toColumns) hunreify .

123− (\(AHNonEmpty a) -> a)

124−

125−

126−sreifyNonEmpty :: Table (Reify context) a

127− => Unreifiability context a

128− -> HNonEmpty context (Unreify a)

129− -> AHNonEmpty context a

130−sreifyNonEmpty = \case

131− UResult -> AHNonEmpty . fmap (reify Refl)

132− Unreifiability context ->

133− smapNonEmpty context (reify Refl) hreify .

134− AHNonEmpty

135−

136−

137−sunreifyNonEmpty :: Table (Reify context) a

138− => Unreifiability context a

139− -> AHNonEmpty context a

140− -> HNonEmpty context (Unreify a)

141−sunreifyNonEmpty = \case

142− UResult -> fmap (unreify Refl) . (\(AHNonEmpty a) -> a)

143− Unreifiability context ->

144− (\(AHNonEmpty a) -> a) .

145− smapNonEmpty context (unreify Refl) hunreify

src/Rel8/Column/Null.hsnew file+26

@@ -0,0 +1,26 @@

1+{-# language DataKinds #-}

2+{-# language StandaloneKindSignatures #-}

3+{-# language TypeFamilyDependencies #-}

5+module Rel8.Column.Null

6+ ( HNull

7+ )

8+where

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

@@ -1,163 +1,29 @@

1{-# language DataKinds #-}

2−{-# language FlexibleContexts #-}

3−{-# language GADTs #-}

4−{-# language LambdaCase #-}

5−{-# language MultiParamTypeClasses #-}

6{-# language StandaloneKindSignatures #-}

2{-# language StandaloneKindSignatures #-}

7−{-# language TypeFamilies #-}

3+{-# language TypeFamilyDependencies #-}

8−{-# language UndecidableInstances #-}

10module Rel8.Column.These

5module Rel8.Column.These

11− ( HThese, AHThese(..)

6+ ( HThese

12 )

7 )

13where

8where

15-- base

10-- base

16−import Control.Applicative ( liftA2 )

17−import Data.Bifunctor ( Bifunctor, bimap )

18import Data.Kind ( Type )

11import Data.Kind ( Type )

19−import Prelude

12+import Prelude ()

21-- rel8

14-- 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 )

27import qualified Rel8.Schema.Kind as K

15import qualified Rel8.Schema.Kind as K

28−import Rel8.Schema.Name ( Name )

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

30import Rel8.Schema.Result ( Result )

16import Rel8.Schema.Result ( Result )

31−import Rel8.Table

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

33− , Unreify, reify, unreify

34− )

35−import Rel8.Table.Recontextualize ( Recontextualize )

36import Rel8.Table.These ( TheseTable )

17import Rel8.Table.These ( TheseTable )

38-- these

19-- these

39import Data.These ( These )

20import 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.

42type HThese :: K.Context -> Type -> Type -> Type

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

43−type family HThese context where

27+type family HThese context = these | these -> context where

44− HThese (Reify context) = AHThese context

45− HThese Aggregate = TheseTable

46− HThese Expr = TheseTable

47− HThese Name = TheseTable

48 HThese Result = These

28 HThese Result = These

49−

29+ HThese context = TheseTable context

50−

51−type AHThese :: K.Context -> Type -> Type -> Type

52−newtype AHThese context a b = AHThese (HThese context a b)

53−

54−

55−instance Reifiable context => Bifunctor (AHThese context) where

56− bimap = sbimapThese contextSing

57−

58−

59−instance Reifiable context => Functor (AHThese context a) where

60− fmap = bimap id

61−

62−

63−instance (Reifiable context, Table (Reify context) a, Table (Reify context) b)

64− => Table (Reify context) (AHThese context a b)

65− where

66− type Context (AHThese context a b) = Reify context

67− type Columns (AHThese context a b) = HTheseTable (Columns a) (Columns b)

68− type Unreify (AHThese context a b) = HThese context (Unreify a) (Unreify b)

69−

70− fromColumns = sfromColumnsThese contextSing

71− toColumns = stoColumnsThese contextSing

72− reify proof = liftA2 bimap reify reify proof . AHThese

73− unreify proof = (\(AHThese a) -> a) . liftA2 bimap unreify unreify proof

74−

75−

76−instance

77− ( Reifiable context, Reifiable context'

78− , Recontextualize (Reify context) (Reify context') a a'

79− , Recontextualize (Reify context) (Reify context') b b'

80− ) =>

81− Recontextualize

82− (Reify context)

83− (Reify context')

84− (AHThese context a b)

85− (AHThese context' a' b')

86−

87−

88−sbimapThese :: ()

89− => SContext context

90− -> (a -> c)

91− -> (b -> d)

92− -> AHThese context a b

93− -> AHThese context c d

94−sbimapThese = \case

95− SAggregate -> \f g (AHThese a) -> AHThese (bimap f g a)

96− SExpr -> \f g (AHThese a) -> AHThese (bimap f g a)

97− SResult -> \f g (AHThese a) -> AHThese (bimap f g a)

98− SName -> \f g (AHThese a) -> AHThese (bimap f g a)

99− SReify context -> \f g (AHThese a) -> AHThese (sbimapThese context f g a)

100−

101−

102−sfromColumnsThese :: (Table (Reify context) a, Table (Reify context) b)

103− => SContext context

104− -> HTheseTable (Columns a) (Columns b) (Col (Reify context))

105− -> AHThese context a b

106−sfromColumnsThese = \case

107− SAggregate ->

108− AHThese .

109− bimap (fromColumns . hreify) (fromColumns . hreify) .

110− fromColumns .

111− hunreify

112− SExpr ->

113− AHThese .

114− bimap (fromColumns . hreify) (fromColumns . hreify) .

115− fromColumns .

116− hunreify

117− SResult ->

118− AHThese .

119− bimap (fromColumns . hreify) (fromColumns . hreify) .

120− fromColumns .

121− hunreify

122− SName ->

123− AHThese .

124− bimap (fromColumns . hreify) (fromColumns . hreify) .

125− fromColumns .

126− hunreify

127− SReify context ->

128− AHThese .

129− sbimapThese context (fromColumns . hreify) (fromColumns . hreify) .

130− sfromColumnsThese context .

131− hunreify

132−

133−

134−stoColumnsThese :: (Table (Reify context) a, Table (Reify context) b)

135− => SContext context

136− -> AHThese context a b

137− -> HTheseTable (Columns a) (Columns b) (Col (Reify context))

138−stoColumnsThese = \case

139− SAggregate ->

140− hreify .

141− toColumns .

142− bimap (hunreify . toColumns) (hunreify . toColumns) .

143− (\(AHThese a) -> a)

144− SExpr ->

145− hreify .

146− toColumns .

147− bimap (hunreify . toColumns) (hunreify . toColumns) .

148− (\(AHThese a) -> a)

149− SResult ->

150− hreify .

151− toColumns .

152− bimap (hunreify . toColumns) (hunreify . toColumns) .

153− (\(AHThese a) -> a)

154− SName ->

155− hreify .

156− toColumns .

157− bimap (hunreify . toColumns) (hunreify . toColumns) .

158− (\(AHThese a) -> a)

159− SReify context ->

160− hreify .

161− stoColumnsThese context .

162− sbimapThese context (hunreify . toColumns) (hunreify . toColumns) .

163− (\(AHThese a) -> a)

src/Rel8/Expr.hs+17−47

@@ -1,27 +1,21 @@

1{-# language DataKinds #-}

2{-# language DerivingStrategies #-}

3+{-# language FlexibleContexts #-}

3{-# language FlexibleInstances #-}

4{-# language FlexibleInstances #-}

4−{-# language GADTs #-}

5{-# language MultiParamTypeClasses #-}

6−{-# language PolyKinds #-}

7−{-# language RoleAnnotations #-}

8{-# language ScopedTypeVariables #-}

6{-# language ScopedTypeVariables #-}

9−{-# language StandaloneDeriving #-}

10{-# language StandaloneKindSignatures #-}

7{-# language StandaloneKindSignatures #-}

11{-# language TypeApplications #-}

8{-# language TypeApplications #-}

12{-# language TypeFamilies #-}

9{-# language TypeFamilies #-}

13{-# language UndecidableInstances #-}

10{-# language UndecidableInstances #-}

14−{-# language UndecidableSuperClasses #-}

16module Rel8.Expr

12module Rel8.Expr

17 ( Expr(..)

13 ( Expr(..)

18− , Col( E, unE )

19 )

14 )

20where

15where

22-- base

17-- base

23−import Data.Functor.Identity ( Identity )

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

24−import Data.Kind ( Type )

25import Data.String ( IsString, fromString )

19import Data.String ( IsString, fromString )

26import Prelude hiding ( null )

20import Prelude hiding ( null )

@@ -38,17 +32,14 @@ import Rel8.Expr.Opaleye

38 , zipPrimExprsWith

32 , zipPrimExprsWith

39 )

33 )

40import Rel8.Expr.Serialize ( litExpr )

34import Rel8.Expr.Serialize ( litExpr )

41−import Rel8.Schema.Context ( Interpretation, Col )

42−import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )

43−import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )

35+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

36+import qualified Rel8.Schema.Kind as K

44import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )

37import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )

45−import Rel8.Schema.Reify ( notReify )

46−import Rel8.Schema.Result ( Result )

47−import Rel8.Schema.Spec ( Spec( Spec ) )

48import Rel8.Table

38import Rel8.Table

49− ( Table, Columns, Context, fromColumns, toColumns, reify, unreify

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

40+ , FromExprs, fromResult, toResult

41+ , Transpose

50 )

42 )

51−import Rel8.Table.Recontextualize ( Recontextualize )

52import Rel8.Type ( DBType )

43import Rel8.Type ( DBType )

53import Rel8.Type.Monoid ( DBMonoid, memptyExpr )

44import Rel8.Type.Monoid ( DBMonoid, memptyExpr )

54import Rel8.Type.Num ( DBFloating, DBFractional, DBNum )

45import Rel8.Type.Num ( DBFloating, DBFractional, DBNum )

@@ -56,13 +47,9 @@ import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )

58-- | Typed SQL expressions.

49-- | Typed SQL expressions.

59−type role Expr representational

50+type Expr :: K.Context

60−type Expr :: k -> Type

61−data Expr a where

62− Expr :: k ~ Type => !Opaleye.PrimExpr -> Expr (a :: k)

51+newtype Expr a = Expr Opaleye.PrimExpr

63−

64−

65−deriving stock instance Show (Expr a)

52+ deriving stock Show

68instance Sql DBSemigroup a => Semigroup (Expr a) where

55instance Sql DBSemigroup a => Semigroup (Expr a) where

@@ -126,30 +113,13 @@ instance Sql DBFloating a => Floating (Expr a) where

126 atanh = function "atanh"

113 atanh = function "atanh"

127

114

128

115

129−instance Interpretation Expr where

130− data Col Expr _spec where

131− E :: {unE :: !(Expr a)} -> Col Expr ('Spec labels a)

132−

133−

134instance Sql DBType a => Table Expr (Expr a) where

116instance Sql DBType a => Table Expr (Expr a) where

135− type Columns (Expr a) = HType a

117+ type Columns (Expr a) = HIdentity a

136 type Context (Expr a) = Expr

118 type Context (Expr a) = Expr

119+ type FromExprs (Expr a) = a

120+ type Transpose to (Expr a) = to a

137

121

138− toColumns a = HType (E a)

122+ toColumns a = HIdentity a

139− fromColumns (HType (E a)) = a

123+ fromColumns (HIdentity a) = a

140− reify = notReify

124+ toResult a = HIdentity (Identity a)

141− unreify = notReify

125+ fromResult (HIdentity (Identity a)) = a

142−

143−

144−instance Sql DBType a => Recontextualize Expr Expr (Expr a) (Expr a)

145−

146−

147−instance Sql DBType a => Recontextualize Expr Result (Expr a) (Identity a)

148−

149−

150−instance Sql DBType a => Recontextualize Result Expr (Identity a) (Expr a)

151−

152−

153−instance Labelable Expr where

154− labeler (E a) = E a

155− unlabeler (E a) = E a

src/Rel8/Expr.hs-boot+6−8

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

1−{-# language GADTs #-}

1+{-# language DataKinds #-}

2−{-# language PolyKinds #-}

3−{-# language RoleAnnotations #-}

4{-# language StandaloneKindSignatures #-}

2{-# language StandaloneKindSignatures #-}

6module Rel8.Expr

4module Rel8.Expr

@@ -9,14 +7,14 @@ module Rel8.Expr

9where

7where

11-- base

9-- base

12−import Data.Kind ( Type )

13import Prelude ()

10import Prelude ()

15-- opaleye

12-- opaleye

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

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

15+-- rel8

16+import Rel8.Schema.Kind ( Context )

19−type role Expr representational

18+

20−type Expr :: k -> Type

19+type Expr :: Context

21−data Expr a where

22− Expr :: k ~ Type => !Opaleye.PrimExpr -> Expr (a :: k)

20+newtype Expr a = Expr Opaleye.PrimExpr

src/Rel8/Expr/Aggregate.hs+25−64

@@ -10,6 +10,7 @@ module Rel8.Expr.Aggregate

10 , and, or

11 , min, max

12 , sum, sumWhere

13+ , avg

13 , stringAgg

14 , stringAgg

14 , groupByExpr

15 , groupByExpr

15 , listAggExpr, nonEmptyAggExpr

16 , listAggExpr, nonEmptyAggExpr

@@ -23,10 +24,12 @@ import Data.List.NonEmpty ( NonEmpty )

23import Prelude hiding ( and, max, min, null, or, sum )

24import Prelude hiding ( and, max, min, null, or, sum )

25-- opaleye

26-- opaleye

26−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

27+import qualified Opaleye.Internal.Aggregate as Opaleye

28+import Opaleye.Internal.Column ( Field_( Column ) )

29+import qualified Opaleye.Aggregate as Opaleye

28-- rel8

31-- rel8

29−import Rel8.Aggregate ( Aggregate, Aggregator(..), unsafeMakeAggregate )

32+import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )

30import Rel8.Expr ( Expr )

33import Rel8.Expr ( Expr )

31import Rel8.Expr.Bool ( caseExpr )

34import Rel8.Expr.Bool ( caseExpr )

32import Rel8.Expr.Opaleye

35import Rel8.Expr.Opaleye

@@ -50,23 +53,13 @@ import Rel8.Type.Sum ( DBSum )

51-- | Count the occurances of a single column. Corresponds to @COUNT(a)@

54-- | Count the occurances of a single column. Corresponds to @COUNT(a)@

52count :: Expr a -> Aggregate Int64

55count :: Expr a -> Aggregate Int64

53−count = unsafeMakeAggregate toPrimExpr fromPrimExpr $

56+count = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.count

54− Just Aggregator

55− { operation = Opaleye.AggrCount

56− , ordering = []

57− , distinction = Opaleye.AggrAll

58− }

59−

61-- | Count the number of distinct occurances of a single column. Corresponds to

58-- | Count the number of distinct occurances of a single column. Corresponds to

62-- @COUNT(DISTINCT a)@

59-- @COUNT(DISTINCT a)@

63countDistinct :: Sql DBEq a => Expr a -> Aggregate Int64

60countDistinct :: Sql DBEq a => Expr a -> Aggregate Int64

64countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $

61countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $

65− Just Aggregator

62+ Opaleye.distinctAggregator Opaleye.count

66− { operation = Opaleye.AggrCount

67− , ordering = []

68− , distinction = Opaleye.AggrDistinct

69− }

72-- | Corresponds to @COUNT(*)@.

65-- | Corresponds to @COUNT(*)@.

@@ -81,56 +74,39 @@ countWhere condition = count (caseExpr [(condition, litExpr (Just True))] null)

82-- | Corresponds to @bool_and@.

75-- | Corresponds to @bool_and@.

83and :: Expr Bool -> Aggregate Bool

76and :: Expr Bool -> Aggregate Bool

84−and = unsafeMakeAggregate toPrimExpr fromPrimExpr $

77+and = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolAnd

85− Just Aggregator

86− { operation = Opaleye.AggrBoolAnd

87− , ordering = []

88− , distinction = Opaleye.AggrAll

89− }

92-- | Corresponds to @bool_or@.

80-- | Corresponds to @bool_or@.

93or :: Expr Bool -> Aggregate Bool

81or :: Expr Bool -> Aggregate Bool

94−or = unsafeMakeAggregate toPrimExpr fromPrimExpr $

82+or = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolOr

95− Just Aggregator

96− { operation = Opaleye.AggrBoolOr

97− , ordering = []

98− , distinction = Opaleye.AggrAll

99− }

100

101

102-- | Produce an aggregation for @Expr a@ using the @max@ function.

85-- | Produce an aggregation for @Expr a@ using the @max@ function.

103max :: Sql DBMax a => Expr a -> Aggregate a

86max :: Sql DBMax a => Expr a -> Aggregate a

104−max = unsafeMakeAggregate toPrimExpr fromPrimExpr $

87+max = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMax

105− Just Aggregator

106− { operation = Opaleye.AggrMax

107− , ordering = []

108− , distinction = Opaleye.AggrAll

109− }

110

111

112-- | Produce an aggregation for @Expr a@ using the @max@ function.

90-- | Produce an aggregation for @Expr a@ using the @max@ function.

113min :: Sql DBMin a => Expr a -> Aggregate a

91min :: Sql DBMin a => Expr a -> Aggregate a

114−min = unsafeMakeAggregate toPrimExpr fromPrimExpr $

92+min = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMin

115− Just Aggregator

116− { operation = Opaleye.AggrMin

117− , ordering = []

118− , distinction = Opaleye.AggrAll

119− }

120

121-- | Corresponds to @sum@. Note that in SQL, @sum@ is type changing - for

94-- | Corresponds to @sum@. Note that in SQL, @sum@ is type changing - for

122-- example the @sum@ of @integer@ returns a @bigint@. Rel8 doesn't support

95-- example the @sum@ of @integer@ returns a @bigint@. Rel8 doesn't support

123−-- this, and will add explicit cast back to the original input type. This can

96+-- this, and will add explicit casts back to the original input type. This can

124-- lead to overflows, and if you anticipate very large sums, you should upcast

97-- lead to overflows, and if you anticipate very large sums, you should upcast

125-- your input.

98-- your input.

126sum :: Sql DBSum a => Expr a -> Aggregate a

99sum :: Sql DBSum a => Expr a -> Aggregate a

127−sum = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $

100+sum = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) Opaleye.unsafeSum

128− Just Aggregator

101+

129− { operation = Opaleye.AggrSum

130− , ordering = []

131− , distinction = Opaleye.AggrAll

132− }

133

102

103+-- | Corresponds to @avg@. Note that in SQL, @avg@ is type changing - for

104+-- example, the @avg@ of @integer@ returns a @numeric@. Rel8 doesn't support

105+-- this, and will add explicit casts back to the original input type. If you

106+-- need a fractional result on an integral column, you should cast your input

107+-- to 'Double' or 'Data.Scientific.Scientific' before calling 'avg'.

108+avg :: Sql DBSum a => Expr a -> Aggregate a

109+avg = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) Opaleye.unsafeAvg

134

110

135-- | Take the sum of all expressions that satisfy a predicate.

111-- | Take the sum of all expressions that satisfy a predicate.

136sumWhere :: (Sql DBNum a, Sql DBSum a)

112sumWhere :: (Sql DBNum a, Sql DBSum a)

@@ -142,17 +118,12 @@ sumWhere condition a = sum (caseExpr [(condition, a)] 0)

142stringAgg :: Sql DBString a

118stringAgg :: Sql DBString a

143 => Expr db -> Expr a -> Aggregate a

119 => Expr db -> Expr a -> Aggregate a

144stringAgg delimiter =

120stringAgg delimiter =

145− unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $

121+ unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) (Opaleye.stringAgg (Column (toPrimExpr delimiter)))

146− Just Aggregator

147− { operation = Opaleye.AggrStringAggr (toPrimExpr delimiter)

148− , ordering = []

149− , distinction = Opaleye.AggrAll

150− }

151

122

152

123

153-- | Aggregate a value by grouping by it.

124-- | Aggregate a value by grouping by it.

154groupByExpr :: Sql DBEq a => Expr a -> Aggregate a

125groupByExpr :: Sql DBEq a => Expr a -> Aggregate a

155−groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Nothing

126+groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.groupBy

156

127

157

128

158-- | Collect expressions values as a list.

129-- | Collect expressions values as a list.

@@ -167,23 +138,13 @@ nonEmptyAggExpr = snonEmptyAggExpr typeInformation

167

138

168slistAggExpr :: ()

139slistAggExpr :: ()

169 => TypeInformation (Unnullify a) -> Expr a -> Aggregate [a]

140 => TypeInformation (Unnullify a) -> Expr a -> Aggregate [a]

170−slistAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just

141+slistAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg

171− Aggregator

172− { operation = Opaleye.AggrArr

173− , ordering = []

174− , distinction = Opaleye.AggrAll

175− }

176 where

142 where

177 to = encodeArrayElement info . toPrimExpr

143 to = encodeArrayElement info . toPrimExpr

178

144

179

145

180snonEmptyAggExpr :: ()

146snonEmptyAggExpr :: ()

181 => TypeInformation (Unnullify a) -> Expr a -> Aggregate (NonEmpty a)

147 => TypeInformation (Unnullify a) -> Expr a -> Aggregate (NonEmpty a)

182−snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just

148+snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg

183− Aggregator

184− { operation = Opaleye.AggrArr

185− , ordering = []

186− , distinction = Opaleye.AggrAll

187− }

188 where

149 where

189 to = encodeArrayElement info . toPrimExpr

150 to = encodeArrayElement info . toPrimExpr

src/Rel8/Expr/Default.hsnew file+35

@@ -0,0 +1,35 @@

1+module Rel8.Expr.Default

2+ ( unsafeDefault

3+ )

4+where

6+-- base

7+import Prelude ()

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 {-# SOURCE #-} Rel8.Expr ( Expr )

25+import 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/Num.hs+39−6

@@ -4,18 +4,24 @@

4{-# options_ghc -fno-warn-redundant-constraints #-}

6module Rel8.Expr.Num

7+ ( fromIntegral

8+ , realToFrac

9+ , div, mod, divMod

10+ , quot, rem, quotRem

7− ( fromIntegral, realToFrac, div, mod, ceiling, floor, round, truncate

11+ , ceiling, floor, round, truncate

8 )

12 )

9where

13where

11-- base

15-- base

12−import Prelude ()

16+import Prelude ( (+), (-), fst, negate, signum, snd )

14-- rel

18-- rel

15import Rel8.Expr ( Expr( Expr ) )

19import Rel8.Expr ( Expr( Expr ) )

20+import Rel8.Expr.Eq ( (==.) )

16import Rel8.Expr.Function ( function )

21import Rel8.Expr.Function ( function )

17import Rel8.Expr.Opaleye ( castExpr )

22import Rel8.Expr.Opaleye ( castExpr )

18import Rel8.Schema.Null ( Homonullable, Sql )

23import Rel8.Schema.Null ( Homonullable, Sql )

24+import Rel8.Table.Bool ( bool )

19import Rel8.Type.Num ( DBFractional, DBIntegral, DBNum )

25import Rel8.Type.Num ( DBFractional, DBIntegral, DBNum )

@@ -42,14 +48,41 @@ ceiling :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)

42ceiling = function "ceiling"

48ceiling = function "ceiling"

45−-- | Perform integral division. Corresponds to the @div()@ function.

51+-- | Emulates the behaviour of the Haskell function 'Prelude.div' in

52+-- PostgreSQL.

46div :: Sql DBIntegral a => Expr a -> Expr a -> Expr a

53div :: Sql DBIntegral a => Expr a -> Expr a -> Expr a

47−div = function "div"

54+div n d = fst (divMod n d)

50−-- | Corresponds to the @mod()@ function.

57+-- | Emulates the behaviour of the Haskell function 'Prelude.mod' in

58+-- PostgreSQL.

51mod :: Sql DBIntegral a => Expr a -> Expr a -> Expr a

59mod :: Sql DBIntegral a => Expr a -> Expr a -> Expr a

52−mod = function "mod"

60+mod n d = snd (divMod n d)

61+

62+

63+-- | Simultaneous 'div' and 'mod'.

64+divMod :: Sql DBIntegral a => Expr a -> Expr a -> (Expr a, Expr a)

65+divMod n d = bool qr (q - 1, r + d) (signum r ==. negate (signum d))

66+ where

67+ qr@(q, r) = quotRem n d

68+

69+

70+-- | Perform integral division. Corresponds to the @div()@ function in

71+-- PostgreSQL, which behaves like Haskell's 'Prelude.quot' rather than

72+-- 'Prelude.div'.

73+quot :: Sql DBIntegral a => Expr a -> Expr a -> Expr a

74+quot = function "div"

75+

76+

77+-- | Corresponds to the @mod()@ function in PostgreSQL, which behaves like

78+-- Haskell's 'Prelude.rem' rather than 'Prelude.mod'.

79+rem :: Sql DBIntegral a => Expr a -> Expr a -> Expr a

80+rem = function "mod"

81+

82+

83+-- | Simultaneous 'quot' and 'rem'.

84+quotRem :: Sql DBIntegral a => Expr a -> Expr a -> (Expr a, Expr a)

85+quotRem n d = (quot n d, rem n d)

55-- | Round a 'DFractional' to a 'DBIntegral' by rounding to the nearest smaller

88-- | Round a 'DFractional' to a 'DBIntegral' by rounding to the nearest smaller

src/Rel8/Expr/Opaleye.hs+17−3

@@ -10,7 +10,7 @@ module Rel8.Expr.Opaleye

10 , scastExpr, sunsafeCastExpr

11 , unsafeLiteral

12 , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith, traversePrimExpr

13− , toColumn, fromColumn

13+ , toColumn, fromColumn, traverseFieldP

14 )

15where

@@ -27,6 +27,9 @@ 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+

31castExpr :: Sql DBType a => Expr a -> Expr a

34castExpr :: Sql DBType a => Expr a -> Expr a

32castExpr = scastExpr typeInformation

35castExpr = scastExpr typeInformation

@@ -48,6 +51,11 @@ sunsafeCastExpr TypeInformation {typeName} =

48 fromPrimExpr . Opaleye.CastExpr typeName . toPrimExpr

51 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!

51unsafeLiteral :: String -> Expr a

59unsafeLiteral :: String -> Expr a

52unsafeLiteral = Expr . Opaleye.ConstExpr . Opaleye.OtherLit

60unsafeLiteral = Expr . Opaleye.ConstExpr . Opaleye.OtherLit

@@ -75,9 +83,15 @@ traversePrimExpr :: Functor f

75traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr

83traversePrimExpr 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+

78−toColumn :: Opaleye.PrimExpr -> Opaleye.Column b

92+toColumn :: Opaleye.PrimExpr -> Opaleye.Field_ n b

79toColumn = Opaleye.Column

93toColumn = Opaleye.Column

82−fromColumn :: Opaleye.Column b -> Opaleye.PrimExpr

96+fromColumn :: Opaleye.Field_ n b -> Opaleye.PrimExpr

83fromColumn (Opaleye.Column a) = a

97fromColumn (Opaleye.Column a) = a

src/Rel8/Expr/Sequence.hs+2−1

@@ -11,6 +11,7 @@ import Prelude

11import Rel8.Expr ( Expr )

12import Rel8.Expr.Function ( function )

13import Rel8.Expr.Serialize ( litExpr )

14+import Rel8.Expr.Text ( quoteIdent )

15-- text

16-- text

16import Data.Text ( pack )

17import Data.Text ( pack )

@@ -18,4 +19,4 @@ import Data.Text ( pack )

19-- | See https://www.postgresql.org/docs/current/functions-sequence.html

20-- | See https://www.postgresql.org/docs/current/functions-sequence.html

20nextval :: String -> Expr Int64

21nextval :: String -> Expr Int64

21−nextval = function "nextval" . litExpr . pack

22+nextval = function "nextval" . quoteIdent . litExpr . pack

src/Rel8/Expr/Text.hs+23−2

@@ -17,6 +17,9 @@ module Rel8.Expr.Text

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

20 )

23 )

21where

24where

@@ -24,7 +27,7 @@ where

24import Data.Bool ( Bool )

27import Data.Bool ( Bool )

25import Data.Int ( Int32 )

28import Data.Int ( Int32 )

26import Data.Maybe ( Maybe( Nothing, Just ) )

29import Data.Maybe ( Maybe( Nothing, Just ) )

27−import Prelude ()

30+import Prelude ( flip )

29-- bytestring

32-- bytestring

30import Data.ByteString ( ByteString )

33import Data.ByteString ( ByteString )

@@ -49,7 +52,7 @@ infixr 6 ++.

51-- | Matches regular expression, case sensitive

54-- | Matches regular expression, case sensitive

52−--

55+--

53-- Corresponds to the @~.@ operator.

56-- Corresponds to the @~.@ operator.

54(~.) :: Expr Text -> Expr Text -> Expr Bool

57(~.) :: Expr Text -> Expr Text -> Expr Bool

55(~.) = binaryOperator "~."

58(~.) = binaryOperator "~."

@@ -273,3 +276,21 @@ substr a b Nothing = function "substr" a b

273-- | Corresponds to the @translate@ function.

276-- | Corresponds to the @translate@ function.

274translate :: Expr Text -> Expr Text -> Expr Text -> Expr Text

277translate :: Expr Text -> Expr Text -> Expr Text -> Expr Text

275translate = function "translate"

278translate = function "translate"

279+

280+

281+-- | @like x y@ corresponds to the expression @y LIKE x@.

282+--

283+-- Note that the arguments to @like@ are swapped. This is to aid currying, so

284+-- you can write expressions like

285+-- @filter (like "Rel%" . packageName) =<< each haskellPackages@

286+like :: Expr Text -> Expr Text -> Expr Bool

287+like = flip (binaryOperator "LIKE")

288+

289+

290+-- | @ilike x y@ corresponds to the expression @y ILIKE x@.

291+--

292+-- Note that the arguments to @ilike@ are swapped. This is to aid currying, so

293+-- you can write expressions like

294+-- @filter (ilike "Rel%" . packageName) =<< each haskellPackages@

295+ilike :: Expr Text -> Expr Text -> Expr Bool

296+ilike = flip (binaryOperator "ILIKE")

src/Rel8/Expr/Window.hsnew file+121

@@ -0,0 +1,121 @@

1+module Rel8.Expr.Window

2+ ( cumulative

3+ , rowNumber

4+ , rank

5+ , denseRank

6+ , percentRank

7+ , cumeDist

8+ , ntile

9+ , lag

10+ , lead

11+ , firstValue

12+ , lastValue

13+ , nthValue

14+ )

15+where

16+

17+-- base

18+import Data.Int ( Int32, Int64 )

19+import Prelude

20+

21+-- opaleye

22+import qualified Opaleye.Internal.Aggregate as Opaleye

23+import qualified Opaleye.Internal.PackMap as Opaleye

24+import qualified Opaleye.Internal.Window as Opaleye

25+import qualified Opaleye.Window as Opaleye

26+

27+-- profunctors

28+import Data.Profunctor (dimap)

29+

30+-- rel8

31+import Rel8.Aggregate ( Aggregate( Aggregate ) )

32+import Rel8.Expr ( Expr )

33+import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr, toColumn, toPrimExpr )

34+import Rel8.Schema.Null ( Nullify )

35+import Rel8.Window ( Window( Window ) )

36+

37+

38+cumulative :: (a -> Aggregate b) -> Window a (Expr b)

39+cumulative f =

40+ fromWindowFunction $ Opaleye.aggregatorWindowFunction (fromAggregate f) id

41+

42+

43+-- | [@row_number()@](https://www.postgresql.org/docs/current/functions-window.html)

44+rowNumber :: Window a (Expr Int64)

45+rowNumber = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.rowNumber

46+

47+

48+-- | [@rank()@](https://www.postgresql.org/docs/current/functions-window.html)

49+rank :: Window a (Expr Int64)

50+rank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.rank

51+

52+

53+-- | [@dense_rank()@](https://www.postgresql.org/docs/current/functions-window.html)

54+denseRank :: Window a (Expr Int64)

55+denseRank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.denseRank

56+

57+

58+-- | [@percent_rank()@](https://www.postgresql.org/docs/current/functions-window.html)

59+percentRank :: Window a (Expr Double)

60+percentRank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.percentRank

61+

62+

63+-- | [@cume_dist()@](https://www.postgresql.org/docs/current/functions-window.html)

64+cumeDist :: Window a (Expr Double)

65+cumeDist = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.cumeDist

66+

67+

68+-- | [@ntile(num_buckets)@](https://www.postgresql.org/docs/current/functions-window.html)

69+ntile :: Expr Int32 -> Window a (Expr Int32)

70+ntile buckets = fromWindowFunction $ fromPrimExpr . fromColumn <$>

71+ Opaleye.ntile (toColumn (toPrimExpr buckets))

72+

73+

74+-- | [@lag(value, offset, default)@](https://www.postgresql.org/docs/current/functions-window.html)

75+lag :: Expr Int32 -> Expr a -> Window (Expr a) (Expr a)

76+lag offset def =

77+ fromWindowFunction $

78+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $

79+ Opaleye.lag (toColumn (toPrimExpr offset)) (toColumn (toPrimExpr def))

80+

81+

82+-- | [@lead(value, offset, default)@](https://www.postgresql.org/docs/current/functions-window.html)

83+lead :: Expr Int32 -> Expr a -> Window (Expr a) (Expr a)

84+lead offset def =

85+ fromWindowFunction $

86+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $

87+ Opaleye.lead (toColumn (toPrimExpr offset)) (toColumn (toPrimExpr def))

88+

89+

90+-- | [@first_value(value)@](https://www.postgresql.org/docs/current/functions-window.html)

91+firstValue :: Window (Expr a) (Expr a)

92+firstValue =

93+ fromWindowFunction $

94+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn)

95+ Opaleye.firstValue

96+

97+

98+-- | [@last_value(value)@](https://www.postgresql.org/docs/current/functions-window.html)

99+lastValue :: Window (Expr a) (Expr a)

100+lastValue =

101+ fromWindowFunction $

102+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn)

103+ Opaleye.lastValue

104+

105+

106+-- | [@nth_value(value, n)@](https://www.postgresql.org/docs/current/functions-window.html)

107+nthValue :: Expr Int32 -> Window (Expr a) (Expr (Nullify a))

108+nthValue n =

109+ fromWindowFunction $

110+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $

111+ Opaleye.nthValue (toColumn (toPrimExpr n))

112+

113+

114+fromAggregate :: (a -> Aggregate b) -> Opaleye.Aggregator a (Expr b)

115+fromAggregate f = Opaleye.Aggregator $ Opaleye.PackMap $ \w a -> case f a of

116+ Aggregate (Opaleye.Aggregator (Opaleye.PackMap x)) -> x w ()

117+

118+

119+fromWindowFunction :: Opaleye.WindowFunction a b -> Window a b

120+fromWindowFunction (Opaleye.WindowFunction (Opaleye.PackMap w)) =

121+ Window $ Opaleye.Windows $ Opaleye.PackMap $ \f -> w $ \o -> f (o, mempty)

src/Rel8/FCF.hs+3−3

@@ -5,7 +5,7 @@

6module Rel8.FCF

7 ( Exp, Eval

8− , Compose

8+ , Id

9 )

10where

@@ -22,5 +22,5 @@ type Eval :: Exp e -> e

22type family Eval a

25−data Compose :: (Type -> Type) -> (Type -> Exp Type) -> Type -> Exp Type

25+data Id :: a -> Exp a

26−type instance Eval (Compose f g a) = f (Eval (g a))

26+type instance Eval (Id a) = a

src/Rel8/Generic/Construction.hs+146−165

@@ -2,9 +2,6 @@

2{-# language ConstraintKinds #-}

3{-# language DataKinds #-}

4{-# language FlexibleContexts #-}

5−{-# language FlexibleInstances #-}

6−{-# language LambdaCase #-}

7−{-# language MultiParamTypeClasses #-}

8{-# language NamedFieldPuns #-}

5{-# language NamedFieldPuns #-}

9{-# language ScopedTypeVariables #-}

6{-# language ScopedTypeVariables #-}

10{-# language StandaloneKindSignatures #-}

7{-# language StandaloneKindSignatures #-}

@@ -28,18 +25,17 @@ where

28import Data.Bifunctor ( first )

25import Data.Bifunctor ( first )

29import Data.Kind ( Constraint, Type )

26import Data.Kind ( Constraint, Type )

30import Data.List.NonEmpty ( NonEmpty( (:|) ) )

27import Data.List.NonEmpty ( NonEmpty( (:|) ) )

31−import Data.Type.Equality ( (:~:)( Refl ) )

32import GHC.TypeLits ( Symbol )

28import GHC.TypeLits ( Symbol )

33import Prelude

29import Prelude

35-- rel8

31-- rel8

36−import Rel8.Aggregate ( Col( A ), Aggregate( Aggregate ) )

32+import Rel8.Aggregate ( Aggregate( Aggregate ) )

37−import Rel8.Expr ( Col( E ), Expr )

33+import Rel8.Expr ( Expr )

38import Rel8.Expr.Aggregate ( groupByExpr )

34import Rel8.Expr.Aggregate ( groupByExpr )

39import Rel8.Expr.Eq ( (==.) )

35import Rel8.Expr.Eq ( (==.) )

40import Rel8.Expr.Null ( nullify, snull, unsafeUnnullify )

36import Rel8.Expr.Null ( nullify, snull, unsafeUnnullify )

41import Rel8.Expr.Serialize ( litExpr )

37import Rel8.Expr.Serialize ( litExpr )

42−import Rel8.FCF ( Eval, Exp )

38+import Rel8.FCF ( Eval, Exp, Id )

43import Rel8.Generic.Construction.ADT

39import Rel8.Generic.Construction.ADT

44 ( GConstructorADT, GMakeableADT, gmakeADT

40 ( GConstructorADT, GMakeableADT, gmakeADT

45 , GConstructableADT

41 , GConstructableADT

@@ -59,18 +55,16 @@ import Rel8.Kind.Algebra

59 , KnownAlgebra, algebraSing

55 , KnownAlgebra, algebraSing

60 )

56 )

61import qualified Rel8.Kind.Algebra as K

57import qualified Rel8.Kind.Algebra as K

62−import Rel8.Schema.Context.Nullify ( runTag )

58+import Rel8.Schema.Context.Nullify ( sguard, snullify )

63import Rel8.Schema.HTable ( HTable )

59import Rel8.Schema.HTable ( HTable )

64−import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )

60+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

65import qualified Rel8.Schema.Kind as K

61import qualified Rel8.Schema.Kind as K

66−import Rel8.Schema.Name ( Col( N ), Name( Name ) )

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

67import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

63import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

68−import Rel8.Schema.Spec ( SSpec( SSpec, nullity, info ) )

64+import Rel8.Schema.Spec ( Spec( Spec, nullity, info ) )

69−import Rel8.Schema.Reify ( Col( Reify ), Reify, hreify, hunreify )

70−import Rel8.Schema.Result ( Result )

71import Rel8.Table

65import Rel8.Table

72− ( TTable, TColumns, TUnreify

66+ ( TTable, TColumns

73− , Table, fromColumns, toColumns, reify, unreify

67+ , Table, fromColumns, toColumns

74 )

68 )

75import Rel8.Table.Bool ( case_ )

69import Rel8.Table.Bool ( case_ )

76import Rel8.Type.Tag ( Tag )

70import Rel8.Type.Tag ( Tag )

@@ -79,10 +73,10 @@ import Rel8.Type.Tag ( Tag )

79type GGBuildable :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Constraint

73type GGBuildable :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Constraint

80type GGBuildable algebra name rep =

74type GGBuildable algebra name rep =

81 ( KnownAlgebra algebra

75 ( KnownAlgebra algebra

82− , Eval (GGColumns algebra TColumns (Eval (rep (Reify Aggregate)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))

76+ , Eval (GGColumns algebra TColumns (Eval (rep Aggregate))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))

83− , Eval (GGColumns algebra TColumns (Eval (rep (Reify Expr)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))

77+ , Eval (GGColumns algebra TColumns (Eval (rep Expr))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))

84− , Eval (GGColumns algebra TColumns (Eval (rep (Reify Name)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))

78+ , Eval (GGColumns algebra TColumns (Eval (rep Name))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))

85− , HTable (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))))

79+ , HTable (Eval (GGColumns algebra TColumns (Eval (rep Expr))))

86 , GGBuildable' algebra name rep

80 , GGBuildable' algebra name rep

87 )

81 )

@@ -90,65 +84,63 @@ type GGBuildable algebra name rep =

90type GGBuildable' :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Constraint

84type GGBuildable' :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Constraint

91type family GGBuildable' algebra name rep where

85type family GGBuildable' algebra name rep where

92 GGBuildable' 'K.Product name rep =

86 GGBuildable' 'K.Product name rep =

93− ( name ~ GConstructor (Eval (rep (Reify Expr)))

87+ ( name ~ GConstructor (Eval (rep Expr))

94− , Representable TUnreify (Eval (rep (Reify Expr)))

88+ , Representable Id (Eval (rep Expr))

95− , GConstructable (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) (Eval (rep (Reify Expr)))

89+ , GConstructable (TTable Expr) TColumns Id Expr (Eval (rep Expr))

96 )

90 )

97 GGBuildable' 'K.Sum name rep =

91 GGBuildable' 'K.Sum name rep =

98− ( Representable TUnreify (GConstructorADT name (Eval (rep (Reify Expr))))

92+ ( Representable Id (GConstructorADT name (Eval (rep Expr)))

99− , GMakeableADT (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) name (Eval (rep (Reify Expr)))

93+ , GMakeableADT (TTable Expr) TColumns Id Expr name (Eval (rep Expr))

100 )

94 )

101

102

103type GGBuild :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Type -> Type

97type GGBuild :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Type -> Type

104type family GGBuild algebra name rep r where

98type family GGBuild algebra name rep r where

105 GGBuild 'K.Product _name rep r =

99 GGBuild 'K.Product _name rep r =

106− GConstruct TUnreify (Eval (rep (Reify Expr))) r

100+ GConstruct Id (Eval (rep Expr)) r

107 GGBuild 'K.Sum name rep r =

101 GGBuild 'K.Sum name rep r =

108− GConstruct TUnreify (GConstructorADT name (Eval (rep (Reify Expr)))) r

102+ GConstruct Id (GConstructorADT name (Eval (rep Expr))) r

109

103

110

104

111ggbuild :: forall algebra name rep a. GGBuildable algebra name rep

105ggbuild :: forall algebra name rep a. GGBuildable algebra name rep

112− => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr) -> a)

106+ => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a)

113 -> GGBuild algebra name rep a

107 -> GGBuild algebra name rep a

114ggbuild gfromColumns = case algebraSing @algebra of

108ggbuild gfromColumns = case algebraSing @algebra of

115 SProduct ->

109 SProduct ->

116− gtabulate @TUnreify @(Eval (rep (Reify Expr))) @a $

110+ gtabulate @Id @(Eval (rep Expr)) @a $

117 gfromColumns .

111 gfromColumns .

118− hunreify .

119 gconstruct

112 gconstruct

120− @(TTable (Reify Expr))

113+ @(TTable Expr)

121 @TColumns

114 @TColumns

122− @TUnreify

115+ @Id

123− @(Col (Reify Expr))

116+ @Expr

124− @(Eval (rep (Reify Expr)))

117+ @(Eval (rep Expr))

125− (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)

118+ (const toColumns)

126 SSum ->

119 SSum ->

127− gtabulate @TUnreify @(GConstructorADT name (Eval (rep (Reify Expr)))) @a $

120+ gtabulate @Id @(GConstructorADT name (Eval (rep Expr))) @a $

128 gfromColumns .

121 gfromColumns .

129− hunreify .

130 gmakeADT

122 gmakeADT

131− @(TTable (Reify Expr))

123+ @(TTable Expr)

132 @TColumns

124 @TColumns

133− @TUnreify

125+ @Id

134− @(Col (Reify Expr))

126+ @Expr

135 @name

127 @name

136− @(Eval (rep (Reify Expr)))

128+ @(Eval (rep Expr))

137− (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)

129+ (const toColumns)

138− (\SSpec {info} -> Reify (E (snull info)))

130+ (\Spec {info} -> snull info)

139− (\SSpec {nullity} -> case nullity of

131+ (\Spec {nullity} -> case nullity of

140 Null -> id

132 Null -> id

141− NotNull -> \(Reify (E a)) -> Reify (E (nullify a)))

133+ NotNull -> nullify)

142− (HType . Reify . E . litExpr)

134+ (HIdentity . litExpr)

143

135

144

136

145type GGConstructable :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint

137type GGConstructable :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint

146type GGConstructable algebra rep =

138type GGConstructable algebra rep =

147 ( KnownAlgebra algebra

139 ( KnownAlgebra algebra

148− , Eval (GGColumns algebra TColumns (Eval (rep (Reify Aggregate)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))

140+ , Eval (GGColumns algebra TColumns (Eval (rep Aggregate))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))

149− , Eval (GGColumns algebra TColumns (Eval (rep (Reify Expr)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))

141+ , Eval (GGColumns algebra TColumns (Eval (rep Expr))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))

150− , Eval (GGColumns algebra TColumns (Eval (rep (Reify Name)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))

142+ , Eval (GGColumns algebra TColumns (Eval (rep Name))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))

151− , HTable (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))))

143+ , HTable (Eval (GGColumns algebra TColumns (Eval (rep Expr))))

152 , GGConstructable' algebra rep

144 , GGConstructable' algebra rep

153 )

145 )

154

146

@@ -156,105 +148,100 @@ type GGConstructable algebra rep =

156type GGConstructable' :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint

148type GGConstructable' :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint

157type family GGConstructable' algebra rep where

149type family GGConstructable' algebra rep where

158 GGConstructable' 'K.Product rep =

150 GGConstructable' 'K.Product rep =

159− ( Representable TUnreify (Eval (rep (Reify Aggregate)))

151+ ( Representable Id (Eval (rep Aggregate))

160− , Representable TUnreify (Eval (rep (Reify Expr)))

152+ , Representable Id (Eval (rep Expr))

161− , Representable TUnreify (Eval (rep (Reify Name)))

153+ , Representable Id (Eval (rep Name))

162− , GConstructable (TTable (Reify Aggregate)) TColumns TUnreify (Col (Reify Aggregate)) (Eval (rep (Reify Aggregate)))

154+ , GConstructable (TTable Aggregate) TColumns Id Aggregate (Eval (rep Aggregate))

163− , GConstructable (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) (Eval (rep (Reify Expr)))

155+ , GConstructable (TTable Expr) TColumns Id Expr (Eval (rep Expr))

164− , GConstructable (TTable (Reify Name)) TColumns TUnreify (Col (Reify Name)) (Eval (rep (Reify Name)))

156+ , GConstructable (TTable Name) TColumns Id Name (Eval (rep Name))

165 )

157 )

166 GGConstructable' 'K.Sum rep =

158 GGConstructable' 'K.Sum rep =

167− ( RepresentableConstructors TUnreify (Eval (rep (Reify Expr)))

159+ ( RepresentableConstructors Id (Eval (rep Expr))

168− , RepresentableFields TUnreify (Eval (rep (Reify Aggregate)))

160+ , RepresentableFields Id (Eval (rep Aggregate))

169− , RepresentableFields TUnreify (Eval (rep (Reify Expr)))

161+ , RepresentableFields Id (Eval (rep Expr))

170− , RepresentableFields TUnreify (Eval (rep (Reify Name)))

162+ , RepresentableFields Id (Eval (rep Name))

171− , Functor (GConstructors TUnreify (Eval (rep (Reify Expr))))

163+ , Functor (GConstructors Id (Eval (rep Expr)))

172− , GConstructableADT (TTable (Reify Aggregate)) TColumns TUnreify (Col (Reify Aggregate)) (Eval (rep (Reify Aggregate)))

164+ , GConstructableADT (TTable Aggregate) TColumns Id Aggregate (Eval (rep Aggregate))

173− , GConstructableADT (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) (Eval (rep (Reify Expr)))

165+ , GConstructableADT (TTable Expr) TColumns Id Expr (Eval (rep Expr))

174− , GConstructableADT (TTable (Reify Name)) TColumns TUnreify (Col (Reify Name)) (Eval (rep (Reify Name)))

166+ , GConstructableADT (TTable Name) TColumns Id Name (Eval (rep Name))

175 )

167 )

176

168

177

169

178type GGConstruct :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type

170type GGConstruct :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type

179type family GGConstruct algebra rep r where

171type family GGConstruct algebra rep r where

180− GGConstruct 'K.Product rep r =

172+ GGConstruct 'K.Product rep r = GConstruct Id (Eval (rep Expr)) r -> r

181− GConstruct TUnreify (Eval (rep (Reify Expr))) r -> r

182− GGConstruct 'K.Sum rep r =

183− GConstructADT TUnreify (Eval (rep (Reify Expr))) r r

173+ GGConstruct 'K.Sum rep r = GConstructADT Id (Eval (rep Expr)) r r

184

174

185

175

186ggconstruct :: forall algebra rep a. GGConstructable algebra rep

176ggconstruct :: forall algebra rep a. GGConstructable algebra rep

187− => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr) -> a)

177+ => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a)

188 -> GGConstruct algebra rep a -> a

178 -> GGConstruct algebra rep a -> a

189ggconstruct gfromColumns f = case algebraSing @algebra of

179ggconstruct gfromColumns f = case algebraSing @algebra of

190 SProduct ->

180 SProduct ->

191 f $

181 f $

192− gtabulate @TUnreify @(Eval (rep (Reify Expr))) @a $

182+ gtabulate @Id @(Eval (rep Expr)) @a $

193 gfromColumns .

183 gfromColumns .

194− hunreify .

195 gconstruct

184 gconstruct

196− @(TTable (Reify Expr))

185+ @(TTable Expr)

197 @TColumns

186 @TColumns

198− @TUnreify

187+ @Id

199− @(Col (Reify Expr))

188+ @Expr

200− @(Eval (rep (Reify Expr)))

189+ @(Eval (rep Expr))

201− (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)

190+ (const toColumns)

202 SSum ->

191 SSum ->

203− gcindex @TUnreify @(Eval (rep (Reify Expr))) @a f $

192+ gcindex @Id @(Eval (rep Expr)) @a f $

204− fmap (gfromColumns . hunreify) $

193+ fmap gfromColumns $

205 gconstructADT

194 gconstructADT

206− @(TTable (Reify Expr))

195+ @(TTable Expr)

207 @TColumns

196 @TColumns

208− @TUnreify

197+ @Id

209− @(Col (Reify Expr))

198+ @Expr

210− @(Eval (rep (Reify Expr)))

199+ @(Eval (rep Expr))

211− (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)

200+ (const toColumns)

212− (\SSpec {info} -> Reify (E (snull info)))

201+ (\Spec {info} -> snull info)

213− (\SSpec {nullity} -> case nullity of

202+ (\Spec {nullity} -> case nullity of

214 Null -> id

203 Null -> id

215− NotNull -> \(Reify (E a)) -> Reify (E (nullify a)))

204+ NotNull -> nullify)

216− (HType . Reify . E . litExpr)

205+ (HIdentity . litExpr)

217

206

218

207

219type GGDeconstruct :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type -> Type

208type GGDeconstruct :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type -> Type

220type family GGDeconstruct algebra rep a r where

209type family GGDeconstruct algebra rep a r where

221 GGDeconstruct 'K.Product rep a r =

210 GGDeconstruct 'K.Product rep a r =

222− GConstruct TUnreify (Eval (rep (Reify Expr))) r -> a -> r

211+ GConstruct Id (Eval (rep Expr)) r -> a -> r

223 GGDeconstruct 'K.Sum rep a r =

212 GGDeconstruct 'K.Sum rep a r =

224− GConstructADT TUnreify (Eval (rep (Reify Expr))) r (a -> r)

213+ GConstructADT Id (Eval (rep Expr)) r (a -> r)

225

214

226

215

227ggdeconstruct :: forall algebra rep a r. (GGConstructable algebra rep, Table Expr r)

216ggdeconstruct :: forall algebra rep a r. (GGConstructable algebra rep, Table Expr r)

228− => (a -> Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr))

217+ => (a -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)

229 -> GGDeconstruct algebra rep a r

218 -> GGDeconstruct algebra rep a r

230ggdeconstruct gtoColumns = case algebraSing @algebra of

219ggdeconstruct gtoColumns = case algebraSing @algebra of

231 SProduct -> \build ->

220 SProduct -> \build ->

232− gindex @TUnreify @(Eval (rep (Reify Expr))) @r build .

221+ gindex @Id @(Eval (rep Expr)) @r build .

233 gdeconstruct

222 gdeconstruct

234− @(TTable (Reify Expr))

223+ @(TTable Expr)

235 @TColumns

224 @TColumns

236− @TUnreify

225+ @Id

237− @(Col (Reify Expr))

226+ @Expr

238− @(Eval (rep (Reify Expr)))

227+ @(Eval (rep Expr))

239− (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns) .

228+ (const fromColumns) .

240− hreify .

241 gtoColumns

229 gtoColumns

242 SSum ->

230 SSum ->

243− gctabulate @TUnreify @(Eval (rep (Reify Expr))) @r @(a -> r) $ \constructors as ->

231+ gctabulate @Id @(Eval (rep Expr)) @r @(a -> r) $ \constructors as ->

244 let

232 let

245− (HType (Reify (E tag)), cases) =

233+ (HIdentity tag, cases) =

246 gdeconstructADT

234 gdeconstructADT

247− @(TTable (Reify Expr))

235+ @(TTable Expr)

248 @TColumns

236 @TColumns

249− @TUnreify

237+ @Id

250− @(Col (Reify Expr))

238+ @Expr

251− @(Eval (rep (Reify Expr)))

239+ @(Eval (rep Expr))

252− (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns)

240+ (const fromColumns)

253− (\SSpec {nullity} -> case nullity of

241+ (\Spec {nullity} -> case nullity of

254 Null -> id

242 Null -> id

255− NotNull -> \(Reify (E a)) -> Reify (E (unsafeUnnullify a)))

243+ NotNull -> unsafeUnnullify)

256 constructors $

244 constructors $

257− hreify $

258 gtoColumns as

245 gtoColumns as

259 in

246 in

260 case cases of

247 case cases of

@@ -264,108 +251,102 @@ ggdeconstruct gtoColumns = case algebraSing @algebra of

264

251

265type GGName :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type

252type GGName :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type

266type family GGName algebra rep a where

253type family GGName algebra rep a where

267− GGName 'K.Product rep a = GConstruct TUnreify (Eval (rep (Reify Name))) a

254+ GGName 'K.Product rep a = GConstruct Id (Eval (rep Name)) a

268− GGName 'K.Sum rep a = Name Tag -> GBuildADT TUnreify (Eval (rep (Reify Name))) a

255+ GGName 'K.Sum rep a = Name Tag -> GBuildADT Id (Eval (rep Name)) a

269

256

270

257

271ggname :: forall algebra rep a. GGConstructable algebra rep

258ggname :: forall algebra rep a. GGConstructable algebra rep

272− => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Name) -> a)

259+ => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Name -> a)

273 -> GGName algebra rep a

260 -> GGName algebra rep a

274ggname gfromColumns = case algebraSing @algebra of

261ggname gfromColumns = case algebraSing @algebra of

275 SProduct ->

262 SProduct ->

276− gtabulate @TUnreify @(Eval (rep (Reify Name))) @a $

263+ gtabulate @Id @(Eval (rep Name)) @a $

277 gfromColumns .

264 gfromColumns .

278− hunreify .

279 gconstruct

265 gconstruct

280− @(TTable (Reify Name))

266+ @(TTable Name)

281 @TColumns

267 @TColumns

282− @TUnreify

268+ @Id

283− @(Col (Reify Name))

269+ @Name

284− @(Eval (rep (Reify Name)))

270+ @(Eval (rep Name))

285− (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)

271+ (const toColumns)

286 SSum -> \tag ->

272 SSum -> \tag ->

287− gftabulate @TUnreify @(Eval (rep (Reify Name))) @a $

273+ gftabulate @Id @(Eval (rep Name)) @a $

288 gfromColumns .

274 gfromColumns .

289− hunreify .

290 gbuildADT

275 gbuildADT

291− @(TTable (Reify Name))

276+ @(TTable Name)

292 @TColumns

277 @TColumns

293− @TUnreify

278+ @Id

294− @(Col (Reify Name))

279+ @Name

295− @(Eval (rep (Reify Name)))

280+ @(Eval (rep Name))

296− (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)

281+ (const toColumns)

297− (\_ _ (Reify (N (Name a))) -> Reify (N (Name a)))

282+ (\_ _ (Name a) -> Name a)

298− (HType (Reify (N tag)))

283+ (HIdentity tag)

299

284

300

285

301type GGAggregate :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type

286type GGAggregate :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type

302type family GGAggregate algebra rep r where

287type family GGAggregate algebra rep r where

303 GGAggregate 'K.Product rep r =

288 GGAggregate 'K.Product rep r =

304− GConstruct TUnreify (Eval (rep (Reify Aggregate))) r ->

289+ GConstruct Id (Eval (rep Aggregate)) r ->

305− GConstruct TUnreify (Eval (rep (Reify Expr))) r

290+ GConstruct Id (Eval (rep Expr)) r

306 GGAggregate 'K.Sum rep r =

291 GGAggregate 'K.Sum rep r =

307− GBuildADT TUnreify (Eval (rep (Reify Aggregate))) r ->

292+ GBuildADT Id (Eval (rep Aggregate)) r ->

308− GBuildADT TUnreify (Eval (rep (Reify Expr))) r

293+ GBuildADT Id (Eval (rep Expr)) r

309

294

310

295

311ggaggregate :: forall algebra rep exprs agg. GGConstructable algebra rep

296ggaggregate :: forall algebra rep exprs agg. GGConstructable algebra rep

312− => (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Aggregate) -> agg)

297+ => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Aggregate -> agg)

313− -> (exprs -> Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Expr))

298+ -> (exprs -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)

314 -> GGAggregate algebra rep agg -> exprs -> agg

299 -> GGAggregate algebra rep agg -> exprs -> agg

315ggaggregate gfromColumns gtoColumns agg es = case algebraSing @algebra of

300ggaggregate gfromColumns gtoColumns agg es = case algebraSing @algebra of

316 SProduct -> flip f exprs $

301 SProduct -> flip f exprs $

317 gfromColumns .

302 gfromColumns .

318− hunreify .

319 gconstruct

303 gconstruct

320− @(TTable (Reify Aggregate))

304+ @(TTable Aggregate)

321 @TColumns

305 @TColumns

322− @TUnreify

306+ @Id

323− @(Col (Reify Aggregate))

307+ @Aggregate

324− @(Eval (rep (Reify Aggregate)))

308+ @(Eval (rep Aggregate))

325− (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)

309+ (const toColumns)

326 where

310 where

327 f =

311 f =

328− gindex @TUnreify @(Eval (rep (Reify Expr))) @agg .

312+ gindex @Id @(Eval (rep Expr)) @agg .

329 agg .

313 agg .

330− gtabulate @TUnreify @(Eval (rep (Reify Aggregate))) @agg

314+ gtabulate @Id @(Eval (rep Aggregate)) @agg

331 exprs =

315 exprs =

332 gdeconstruct

316 gdeconstruct

333− @(TTable (Reify Expr))

317+ @(TTable Expr)

334 @TColumns

318 @TColumns

335− @TUnreify

319+ @Id

336− @(Col (Reify Expr))

320+ @Expr

337− @(Eval (rep (Reify Expr)))

321+ @(Eval (rep Expr))

338− (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns) $

322+ (const fromColumns) $

339− hreify $

340 gtoColumns es

323 gtoColumns es

341 SSum -> flip f exprs $

324 SSum -> flip f exprs $

342 gfromColumns .

325 gfromColumns .

343− hunreify .

344 gbuildADT

326 gbuildADT

345− @(TTable (Reify Aggregate))

327+ @(TTable Aggregate)

346 @TColumns

328 @TColumns

347− @TUnreify

329+ @Id

348− @(Col (Reify Aggregate))

330+ @Aggregate

349− @(Eval (rep (Reify Aggregate)))

331+ @(Eval (rep Aggregate))

350− (\(_ :: proxy x) -> toColumns . reify @_ @x Refl)

332+ (const toColumns)

351− (\tag' SSpec {nullity} (Reify (A (Aggregate a))) ->

333+ (\tag' Spec {nullity} (Aggregate a) ->

352− Reify $ A $ Aggregate $ runTag nullity (tag ==. litExpr tag') <$> a)

334+ Aggregate $ sguard (tag ==. litExpr tag') . snullify nullity <$> a)

353− (HType (Reify (A (groupByExpr tag))))

335+ (HIdentity (groupByExpr tag))

354 where

336 where

355 f =

337 f =

356− gfindex @TUnreify @(Eval (rep (Reify Expr))) @agg .

338+ gfindex @Id @(Eval (rep Expr)) @agg .

357 agg .

339 agg .

358− gftabulate @TUnreify @(Eval (rep (Reify Aggregate))) @agg

340+ gftabulate @Id @(Eval (rep Aggregate)) @agg

359− (HType (Reify (E tag)), exprs) =

341+ (HIdentity tag, exprs) =

360 gunbuildADT

342 gunbuildADT

361− @(TTable (Reify Expr))

343+ @(TTable Expr)

362 @TColumns

344 @TColumns

363− @TUnreify

345+ @Id

364− @(Col (Reify Expr))

346+ @Expr

365− @(Eval (rep (Reify Expr)))

347+ @(Eval (rep Expr))

366− (\(_ :: proxy x) -> unreify @_ @x Refl . fromColumns)

348+ (const fromColumns)

367− (\SSpec {nullity} -> case nullity of

349+ (\Spec {nullity} -> case nullity of

368 Null -> id

350 Null -> id

369− NotNull -> \(Reify (E a)) -> Reify (E (unsafeUnnullify a))) $

351+ NotNull -> unsafeUnnullify) $

370− hreify $

371 gtoColumns es

352 gtoColumns es

src/Rel8/Generic/Construction/ADT.hs+32−47

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

1{-# language AllowAmbiguousTypes #-}

2{-# language BlockArguments #-}

3{-# language DataKinds #-}

4+{-# language FlexibleContexts #-}

4{-# language FlexibleInstances #-}

5{-# language FlexibleInstances #-}

5{-# language MultiParamTypeClasses #-}

6{-# language MultiParamTypeClasses #-}

6{-# language RankNTypes #-}

7{-# language RankNTypes #-}

@@ -48,14 +49,13 @@ import Rel8.Generic.Construction.Record

48 )

49 )

49import Rel8.Generic.Table.ADT ( GColumnsADT, GColumnsADT' )

50import Rel8.Generic.Table.ADT ( GColumnsADT, GColumnsADT' )

50import Rel8.Generic.Table.Record ( GColumns )

51import Rel8.Generic.Table.Record ( GColumns )

51−import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )

52import Rel8.Schema.HTable ( HTable )

53−import Rel8.Schema.HTable.Identity ( HType )

53+import Rel8.Schema.HTable.Identity ( HIdentity )

54import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )

55import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify )

56import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )

57import Rel8.Schema.Null ( Nullify )

58−import Rel8.Schema.Spec ( Spec( Spec ), SSpec )

58+import Rel8.Schema.Spec ( Spec )

59import qualified Rel8.Schema.Kind as K

60import Rel8.Type.Tag ( Tag( Tag ) )

@@ -63,24 +63,16 @@ import Rel8.Type.Tag ( Tag( Tag ) )

63import Data.Text ( pack )

66−type Null :: K.HContext -> Type

66+type Null :: K.Context -> Type

67−type Null context = forall labels a. ()

67+type Null context = forall a. Spec a -> context (Nullify a)

68− => SSpec ('Spec labels a)

69− -> context ('Spec labels (Nullify a))

72−type Nullifier :: K.HContext -> Type

70+type Nullifier :: K.Context -> Type

73−type Nullifier context = forall labels a. ()

71+type Nullifier context = forall a. Spec a -> context a -> context (Nullify a)

74− => SSpec ('Spec labels a)

75− -> context ('Spec labels a)

76− -> context ('Spec labels (Nullify a))

79−type Unnullifier :: K.HContext -> Type

74+type Unnullifier :: K.Context -> Type

80−type Unnullifier context = forall labels a. ()

75+type Unnullifier context = forall a. Spec a -> context (Nullify a) -> context a

81− => SSpec ('Spec labels a)

82− -> context ('Spec labels (Nullify a))

83− -> context ('Spec labels a)

86type NoConstructor :: Symbol -> Symbol -> ErrorMessage

78type NoConstructor :: Symbol -> Symbol -> ErrorMessage

@@ -189,12 +181,12 @@ type GConstructableADT

189 :: (Type -> Exp Constraint)

181 :: (Type -> Exp Constraint)

190 -> (Type -> Exp K.HTable)

182 -> (Type -> Exp K.HTable)

191 -> (Type -> Exp Type)

183 -> (Type -> Exp Type)

192− -> K.HContext -> (Type -> Type) -> Constraint

184+ -> K.Context -> (Type -> Type) -> Constraint

193class GConstructableADT _Table _Columns f context rep where

185class GConstructableADT _Table _Columns f context rep where

194 gbuildADT :: ()

186 gbuildADT :: ()

195 => ToColumns _Table _Columns f context

187 => ToColumns _Table _Columns f context

196 -> (Tag -> Nullifier context)

188 -> (Tag -> Nullifier context)

197− -> HType Tag context

189+ -> HIdentity Tag context

198 -> GFieldsADT f rep

190 -> GFieldsADT f rep

199 -> GColumnsADT _Columns rep context

191 -> GColumnsADT _Columns rep context

200

192

@@ -202,13 +194,13 @@ class GConstructableADT _Table _Columns f context rep where

202 => FromColumns _Table _Columns f context

194 => FromColumns _Table _Columns f context

203 -> Unnullifier context

195 -> Unnullifier context

204 -> GColumnsADT _Columns rep context

196 -> GColumnsADT _Columns rep context

205− -> (HType Tag context, GFieldsADT f rep)

197+ -> (HIdentity Tag context, GFieldsADT f rep)

206

198

207 gconstructADT :: ()

199 gconstructADT :: ()

208 => ToColumns _Table _Columns f context

200 => ToColumns _Table _Columns f context

209 -> Null context

201 -> Null context

210 -> Nullifier context

202 -> Nullifier context

211− -> (Tag -> HType Tag context)

203+ -> (Tag -> HIdentity Tag context)

212 -> GConstructors f rep (GColumnsADT _Columns rep context)

204 -> GConstructors f rep (GColumnsADT _Columns rep context)

213

205

214 gdeconstructADT :: ()

206 gdeconstructADT :: ()

@@ -216,30 +208,29 @@ class GConstructableADT _Table _Columns f context rep where

216 -> Unnullifier context

208 -> Unnullifier context

217 -> GConstructors f rep r

209 -> GConstructors f rep r

218 -> GColumnsADT _Columns rep context

210 -> GColumnsADT _Columns rep context

219− -> (HType Tag context, NonEmpty (Tag, r))

211+ -> (HIdentity Tag context, NonEmpty (Tag, r))

220

212

221

213

222instance

214instance

223− ( htable ~ HLabel "tag" (HType Tag)

215+ ( htable ~ HLabel "tag" (HIdentity Tag)

224 , GConstructableADT' _Table _Columns f context htable rep

216 , GConstructableADT' _Table _Columns f context htable rep

225− , HLabelable context

226 )

217 )

227 => GConstructableADT _Table _Columns f context (M1 D meta rep)

218 => GConstructableADT _Table _Columns f context (M1 D meta rep)

228 where

219 where

229 gbuildADT toColumns nullifier =

220 gbuildADT toColumns nullifier =

230 gbuildADT' @_Table @_Columns @f @context @htable @rep toColumns nullifier .

221 gbuildADT' @_Table @_Columns @f @context @htable @rep toColumns nullifier .

231− hlabel hlabeler

222+ hlabel

232

223

233 gunbuildADT fromColumns unnullifier =

224 gunbuildADT fromColumns unnullifier =

234− first (hunlabel hunlabeler) .

225+ first hunlabel .

235 gunbuildADT' @_Table @_Columns @f @context @htable @rep fromColumns unnullifier

226 gunbuildADT' @_Table @_Columns @f @context @htable @rep fromColumns unnullifier

236

227

237 gconstructADT toColumns null nullifier mk =

228 gconstructADT toColumns null nullifier mk =

238 gconstructADT' @_Table @_Columns @f @context @htable @rep toColumns null nullifier

229 gconstructADT' @_Table @_Columns @f @context @htable @rep toColumns null nullifier

239− (hlabel hlabeler . mk)

230+ (hlabel . mk)

240

231

241 gdeconstructADT fromColumns unnullifier cases =

232 gdeconstructADT fromColumns unnullifier cases =

242− first (hunlabel hunlabeler) .

233+ first hunlabel .

243 gdeconstructADT' @_Table @_Columns @f @context @htable @rep fromColumns unnullifier cases

234 gdeconstructADT' @_Table @_Columns @f @context @htable @rep fromColumns unnullifier cases

244

235

245

236

@@ -247,7 +238,7 @@ type GConstructableADT'

247 :: (Type -> Exp Constraint)

238 :: (Type -> Exp Constraint)

248 -> (Type -> Exp K.HTable)

239 -> (Type -> Exp K.HTable)

249 -> (Type -> Exp Type)

240 -> (Type -> Exp Type)

250− -> K.HContext -> K.HTable -> (Type -> Type) -> Constraint

241+ -> K.Context -> K.HTable -> (Type -> Type) -> Constraint

251class GConstructableADT' _Table _Columns f context htable rep where

242class GConstructableADT' _Table _Columns f context htable rep where

252 gbuildADT' :: ()

243 gbuildADT' :: ()

253 => ToColumns _Table _Columns f context

244 => ToColumns _Table _Columns f context

@@ -334,7 +325,6 @@ instance {-# OVERLAPPABLE #-}

334 ( HTable (GColumns _Columns rep)

325 ( HTable (GColumns _Columns rep)

335 , KnownSymbol label

326 , KnownSymbol label

336 , meta ~ 'MetaCons label _fixity _isRecord

327 , meta ~ 'MetaCons label _fixity _isRecord

337− , HLabelable context

338 , GConstructable _Table _Columns f context rep

328 , GConstructable _Table _Columns f context rep

339 , GColumnsADT' _Columns htable (M1 C meta rep) ~

329 , GColumnsADT' _Columns htable (M1 C meta rep) ~

340 HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))

330 HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))

@@ -343,7 +333,7 @@ instance {-# OVERLAPPABLE #-}

343 where

333 where

344 gbuildADT' toColumns nullifier htable =

334 gbuildADT' toColumns nullifier htable =

345 HProduct htable .

335 HProduct htable .

346− hlabel hlabeler .

336+ hlabel .

347 hnullify (nullifier tag) .

337 hnullify (nullifier tag) .

348 gconstruct @_Table @_Columns @f @context @rep toColumns

338 gconstruct @_Table @_Columns @f @context @rep toColumns

349 where

339 where

@@ -354,13 +344,13 @@ instance {-# OVERLAPPABLE #-}

354 , gdeconstruct @_Table @_Columns @f @context @rep fromColumns $

344 , gdeconstruct @_Table @_Columns @f @context @rep fromColumns $

355 runIdentity $

345 runIdentity $

356 hunnullify (\spec -> pure . unnullifier spec) $

346 hunnullify (\spec -> pure . unnullifier spec) $

357− hunlabel hunlabeler

347+ hunlabel

358 a

348 a

359 )

349 )

360

350

361 gconstructADT' toColumns _ nullifier mk =

351 gconstructADT' toColumns _ nullifier mk =

362 HProduct htable .

352 HProduct htable .

363− hlabel hlabeler .

353+ hlabel .

364 hnullify nullifier .

354 hnullify nullifier .

365 gconstruct @_Table @_Columns @f @context @rep toColumns

355 gconstruct @_Table @_Columns @f @context @rep toColumns

366 where

356 where

@@ -375,35 +365,34 @@ instance {-# OVERLAPPABLE #-}

375 a = gdeconstruct @_Table @_Columns @f @context @rep fromColumns $

365 a = gdeconstruct @_Table @_Columns @f @context @rep fromColumns $

376 runIdentity $

366 runIdentity $

377 hunnullify (\spec -> pure . unnullifier spec) $

367 hunnullify (\spec -> pure . unnullifier spec) $

378− hunlabel hunlabeler

368+ hunlabel

379 columns

369 columns

380 tag = Tag $ pack $ symbolVal (Proxy @label)

370 tag = Tag $ pack $ symbolVal (Proxy @label)

381

371

382− gfill null htable = HProduct htable (hlabel hlabeler (hnulls null))

372+ gfill null htable = HProduct htable (hlabel (hnulls null))

383

373

384

374

385type GMakeableADT

375type GMakeableADT

386 :: (Type -> Exp Constraint)

376 :: (Type -> Exp Constraint)

387 -> (Type -> Exp K.HTable)

377 -> (Type -> Exp K.HTable)

388 -> (Type -> Exp Type)

378 -> (Type -> Exp Type)

389− -> K.HContext -> Symbol -> (Type -> Type) -> Constraint

379+ -> K.Context -> Symbol -> (Type -> Type) -> Constraint

390class GMakeableADT _Table _Columns f context name rep where

380class GMakeableADT _Table _Columns f context name rep where

391 gmakeADT :: ()

381 gmakeADT :: ()

392 => ToColumns _Table _Columns f context

382 => ToColumns _Table _Columns f context

393 -> Null context

383 -> Null context

394 -> Nullifier context

384 -> Nullifier context

395− -> (Tag -> HType Tag context)

385+ -> (Tag -> HIdentity Tag context)

396 -> GFields f (GConstructorADT name rep)

386 -> GFields f (GConstructorADT name rep)

397 -> GColumnsADT _Columns rep context

387 -> GColumnsADT _Columns rep context

398

388

399

389

400instance

390instance

401− ( htable ~ HLabel "tag" (HType Tag)

391+ ( htable ~ HLabel "tag" (HIdentity Tag)

402 , meta ~ 'MetaData datatype _module _package _newtype

392 , meta ~ 'MetaData datatype _module _package _newtype

403 , fallback ~ TypeError (NoConstructor datatype name)

393 , fallback ~ TypeError (NoConstructor datatype name)

404 , fields ~ GFields f (GConstructorADT' name rep fallback)

394 , fields ~ GFields f (GConstructorADT' name rep fallback)

405 , GMakeableADT' _Table _Columns f context htable name rep fields

395 , GMakeableADT' _Table _Columns f context htable name rep fields

406− , HLabelable context

407 , KnownSymbol name

396 , KnownSymbol name

408 )

397 )

409 => GMakeableADT _Table _Columns f context name (M1 D meta rep)

398 => GMakeableADT _Table _Columns f context name (M1 D meta rep)

@@ -414,14 +403,14 @@ instance

414 toColumns null nullifier htable

403 toColumns null nullifier htable

415 where

404 where

416 tag = Tag $ pack $ symbolVal (Proxy @name)

405 tag = Tag $ pack $ symbolVal (Proxy @name)

417− htable = hlabel hlabeler (wrap tag)

406+ htable = hlabel (wrap tag)

418

407

419

408

420type GMakeableADT'

409type GMakeableADT'

421 :: (Type -> Exp Constraint)

410 :: (Type -> Exp Constraint)

422 -> (Type -> Exp K.HTable)

411 -> (Type -> Exp K.HTable)

423 -> (Type -> Exp Type)

412 -> (Type -> Exp Type)

424− -> K.HContext -> K.HTable -> Symbol -> (Type -> Type) -> Type -> Constraint

413+ -> K.Context -> K.HTable -> Symbol -> (Type -> Type) -> Type -> Constraint

425class GMakeableADT' _Table _Columns f context htable name rep fields where

414class GMakeableADT' _Table _Columns f context htable name rep fields where

426 gmakeADT' :: ()

415 gmakeADT' :: ()

427 => ToColumns _Table _Columns f context

416 => ToColumns _Table _Columns f context

@@ -462,8 +451,6 @@ instance {-# OVERLAPS #-}

462

451

463instance {-# OVERLAPS #-}

452instance {-# OVERLAPS #-}

464 ( HTable (GColumns _Columns rep)

453 ( HTable (GColumns _Columns rep)

465− , KnownSymbol name

466− , HLabelable context

467 , GConstructable _Table _Columns f context rep

454 , GConstructable _Table _Columns f context rep

468 , fields ~ GFields f rep

455 , fields ~ GFields f rep

469 , GColumnsADT' _Columns htable (M1 C ('MetaCons name _fixity _isRecord) rep) ~

456 , GColumnsADT' _Columns htable (M1 C ('MetaCons name _fixity _isRecord) rep) ~

@@ -473,15 +460,13 @@ instance {-# OVERLAPS #-}

473 where

460 where

474 gmakeADT' toColumns _ nullifier htable =

461 gmakeADT' toColumns _ nullifier htable =

475 HProduct htable .

462 HProduct htable .

476− hlabel hlabeler .

463+ hlabel .

477 hnullify nullifier .

464 hnullify nullifier .

478 gconstruct @_Table @_Columns @f @context @rep toColumns

465 gconstruct @_Table @_Columns @f @context @rep toColumns

479

466

480

467

481instance {-# OVERLAPPABLE #-}

468instance {-# OVERLAPPABLE #-}

482 ( HTable (GColumns _Columns rep)

469 ( HTable (GColumns _Columns rep)

483− , KnownSymbol label

484− , HLabelable context

485 , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) rep) ~

470 , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) rep) ~

486 HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))

471 HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))

487 )

472 )

@@ -489,5 +474,5 @@ instance {-# OVERLAPPABLE #-}

489 where

474 where

490 gmakeADT' _ null _ htable _ =

475 gmakeADT' _ null _ htable _ =

491 HProduct htable $

476 HProduct htable $

492− hlabel hlabeler $

477+ hlabel $

493 hnulls null

478 hnulls null

src/Rel8/Generic/Construction/Record.hs+6−11

@@ -27,15 +27,13 @@ import GHC.Generics

27 )

28import GHC.TypeLits

29 ( ErrorMessage( (:<>:), Text ), TypeError

30− , Symbol, KnownSymbol

30+ , Symbol

31 )

32import Prelude

34-- rel8

35import Rel8.FCF ( Eval, Exp )

36import Rel8.Generic.Table.Record ( GColumns )

37−import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )

38−import Rel8.Schema.HTable ( HTable )

39import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

37import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

40import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )

38import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )

41import qualified Rel8.Schema.Kind as K

39import qualified Rel8.Schema.Kind as K

@@ -45,7 +43,7 @@ type FromColumns

45 :: (Type -> Exp Constraint)

43 :: (Type -> Exp Constraint)

46 -> (Type -> Exp K.HTable)

44 -> (Type -> Exp K.HTable)

47 -> (Type -> Exp Type)

45 -> (Type -> Exp Type)

48− -> K.HContext

46+ -> K.Context

49 -> Type

47 -> Type

50type FromColumns _Table _Columns f context = forall proxy x.

48type FromColumns _Table _Columns f context = forall proxy x.

51 Eval (_Table x) => proxy x -> Eval (_Columns x) context -> Eval (f x)

49 Eval (_Table x) => proxy x -> Eval (_Columns x) context -> Eval (f x)

@@ -55,7 +53,7 @@ type ToColumns

55 :: (Type -> Exp Constraint)

53 :: (Type -> Exp Constraint)

56 -> (Type -> Exp K.HTable)

54 -> (Type -> Exp K.HTable)

57 -> (Type -> Exp Type)

55 -> (Type -> Exp Type)

58− -> K.HContext

56+ -> K.Context

59 -> Type

57 -> Type

60type ToColumns _Table _Columns f context = forall proxy x.

58type ToColumns _Table _Columns f context = forall proxy x.

61 Eval (_Table x) => proxy x -> Eval (f x) -> Eval (_Columns x) context

59 Eval (_Table x) => proxy x -> Eval (f x) -> Eval (_Columns x) context

@@ -119,7 +117,7 @@ type GConstructable

119 :: (Type -> Exp Constraint)

117 :: (Type -> Exp Constraint)

120 -> (Type -> Exp K.HTable)

118 -> (Type -> Exp K.HTable)

121 -> (Type -> Exp Type)

119 -> (Type -> Exp Type)

122− -> K.HContext -> (Type -> Type) -> Constraint

120+ -> K.Context -> (Type -> Type) -> Constraint

123class GConstructable _Table _Columns f context rep where

121class GConstructable _Table _Columns f context rep where

124 gconstruct :: ()

122 gconstruct :: ()

125 => ToColumns _Table _Columns f context

123 => ToColumns _Table _Columns f context

@@ -162,12 +160,9 @@ instance

162

160

163instance

161instance

164 ( Eval (_Table a)

162 ( Eval (_Table a)

165− , HTable (Eval (_Columns a))

166− , HLabelable context

167− , KnownSymbol label

168 , meta ~ 'MetaSel ('Just label) _su _ss _ds

163 , meta ~ 'MetaSel ('Just label) _su _ss _ds

169 )

164 )

170 => GConstructable _Table _Columns f context (M1 S meta (K1 i a))

165 => GConstructable _Table _Columns f context (M1 S meta (K1 i a))

171 where

166 where

172− gconstruct toColumns = hlabel hlabeler . toColumns (Proxy @a)

167+ gconstruct toColumns = hlabel . toColumns (Proxy @a)

173− gdeconstruct fromColumns = fromColumns (Proxy @a) . hunlabel hunlabeler

168+ gdeconstruct fromColumns = fromColumns (Proxy @a) . hunlabel

src/Rel8/Generic/Map.hs+20−64

@@ -1,26 +1,19 @@

1−{-# language AllowAmbiguousTypes #-}

2{-# language DataKinds #-}

1{-# language DataKinds #-}

3−{-# language EmptyCase #-}

4−{-# language FlexibleInstances #-}

5−{-# language LambdaCase #-}

6−{-# language MultiParamTypeClasses #-}

7−{-# language RankNTypes #-}

8−{-# language ScopedTypeVariables #-}

9{-# language StandaloneKindSignatures #-}

2{-# language StandaloneKindSignatures #-}

10−{-# language TypeApplications #-}

11{-# language TypeFamilies #-}

3{-# language TypeFamilies #-}

12{-# language TypeOperators #-}

4{-# language TypeOperators #-}

13{-# language UndecidableInstances #-}

5{-# language UndecidableInstances #-}

15module Rel8.Generic.Map

7module Rel8.Generic.Map

16− ( GMap, GMappable (gmap, gunmap)

8+ ( GMap

9+ , Map

17 )

10 )

18where

11where

20-- base

13-- base

21−import Data.Kind ( Constraint, Type )

14+import Data.Kind ( Type )

22import GHC.Generics

15import GHC.Generics

23− ( (:+:)( L1, R1 ), (:*:)( (:*:) ), K1( K1 ), M1( M1 ), U1( U1 ), V1

16+ ( (:+:), (:*:), K1, M1, U1, V1

24 )

17 )

25import Prelude ()

18import Prelude ()

@@ -38,56 +31,19 @@ type family GMap f rep where

38 GMap f (K1 i a) = K1 i (Eval (f a))

31 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.

41−type GMappable :: (Type -> Exp Constraint) -> (Type -> Type) -> Constraint

36+type Map :: (Type -> Exp Type) -> Type -> Type

42−class GMappable constraint rep where

37+type family Map f a where

43− gmap :: ()

38+ Map p (t a b c d e f g) =

44− => proxy f

39+ t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e))

45− -> (forall a. Eval (constraint a) => a -> Eval (f a))

40+ (Eval (p f)) (Eval (p g))

46− -> rep x

41+ Map p (t a b c d e f) =

47− -> GMap f rep x

42+ t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e))

48−

43+ (Eval (p f))

49− gunmap :: ()

44+ Map p (t a b c d e) =

50− => proxy f

45+ t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e))

51− -> (forall a. Eval (constraint a) => Eval (f a) -> a)

46+ Map p (t a b c d) = t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d))

52− -> GMap f rep x

47+ Map p (t a b c) = t (Eval (p a)) (Eval (p b)) (Eval (p c))

53− -> rep x

48+ Map p (t a b) = t (Eval (p a)) (Eval (p b))

54−

49+ Map p (t a) = t (Eval (p a))

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,5 +1,6 @@

1{-# language AllowAmbiguousTypes #-}

2{-# language DataKinds #-}

3+{-# language FlexibleContexts #-}

3{-# language FlexibleInstances #-}

4{-# language FlexibleInstances #-}

4{-# language MultiParamTypeClasses #-}

5{-# language MultiParamTypeClasses #-}

5{-# language PolyKinds #-}

6{-# language PolyKinds #-}

@@ -141,6 +142,7 @@ instance {-# OVERLAPPABLE #-} Snd (Count n rep) ~ rep => Countable n rep where

141 uncount = id

142 uncount = id

142

143

144

145+type Record :: Type -> Type

144newtype Record a = Record

146newtype Record a = Record

145 { unrecord :: a

147 { unrecord :: a

146 }

148 }

src/Rel8/Generic/Reify.hsdeleted−24

@@ -1,24 +0,0 @@

1−{-# language StandaloneKindSignatures #-}

2−{-# language TypeFamilies #-}

3−

4−module Rel8.Generic.Reify

5− ( ARep

6− )

7−where

8−

9−-- base

10−import Data.Functor.Contravariant ( Contravariant, contramap )

11−import Data.Kind ( Type )

12−import Data.Void ( Void, absurd )

13−import GHC.Generics ( Generic, Rep, from, to )

14−import Prelude

15−

16−

17−type ARep :: (Type -> Type) -> Type

18−newtype ARep rep = ARep (rep Void)

19−

20−

21−instance (Contravariant rep, Functor rep) => Generic (ARep rep) where

22− type Rep (ARep rep) = rep

23− from (ARep a) = fmap absurd a

24− to = ARep . contramap absurd

src/Rel8/Generic/Rel8able.hs+188−81

@@ -1,13 +1,18 @@

1{-# language AllowAmbiguousTypes #-}

2+{-# language ConstraintKinds #-}

2{-# language DataKinds #-}

3{-# language DataKinds #-}

3{-# language DefaultSignatures #-}

4{-# language DefaultSignatures #-}

4{-# language FlexibleContexts #-}

5{-# language FlexibleContexts #-}

5{-# language FlexibleInstances #-}

6{-# language FlexibleInstances #-}

7+{-# language LambdaCase #-}

6{-# language MultiParamTypeClasses #-}

8{-# language MultiParamTypeClasses #-}

9+{-# language PolyKinds #-}

10+{-# language QuantifiedConstraints #-}

7{-# language ScopedTypeVariables #-}

11{-# language ScopedTypeVariables #-}

8{-# language StandaloneKindSignatures #-}

12{-# language StandaloneKindSignatures #-}

9{-# language TypeApplications #-}

13{-# language TypeApplications #-}

10−{-# language TypeFamilies #-}

14+{-# language TypeFamilyDependencies #-}

15+{-# language TypeOperators #-}

11{-# language UndecidableInstances #-}

16{-# language UndecidableInstances #-}

13module Rel8.Generic.Rel8able

18module Rel8.Generic.Rel8able

@@ -15,42 +20,99 @@ module Rel8.Generic.Rel8able

15 , Algebra

20 , Algebra

16 , GRep

21 , GRep

17 , GColumns, gfromColumns, gtoColumns

22 , GColumns, gfromColumns, gtoColumns

18− , greify, gunreify

23+ , GFromExprs, gfromResult, gtoResult

19− , TUnreifyContext

24+ , TSerialize, serialize, deserialize

20 )

25 )

21where

26where

23-- base

28-- base

29+import Data.Functor.Identity ( Identity )

24import Data.Kind ( Constraint, Type )

30import Data.Kind ( Constraint, Type )

25−import Data.Proxy ( Proxy( Proxy ) )

31+import Data.Type.Bool ( type (&&) )

26−import Data.Type.Equality ( (:~:)( Refl ) )

27import GHC.Generics ( Generic, Rep, from, to )

32import GHC.Generics ( Generic, Rep, from, to )

28import Prelude

33import Prelude

30-- rel8

35-- rel8

31−import Rel8.Kind.Context ( Reifiable )

36+import Rel8.Aggregate ( Aggregate )

37+import Rel8.Expr ( Expr )

32−import Rel8.FCF ( Eval, Exp )

38+import Rel8.FCF ( Exp, Eval )

33−import Rel8.Generic.Map ( GMap, GMappable, gmap, gunmap )

34import Rel8.Generic.Record ( Record(..) )

39import Rel8.Generic.Record ( Record(..) )

35import Rel8.Generic.Table ( GAlgebra )

40import Rel8.Generic.Table ( GAlgebra )

36import qualified Rel8.Generic.Table.Record as G

41import qualified Rel8.Generic.Table.Record as G

37import qualified Rel8.Kind.Algebra as K ( Algebra(..) )

42import qualified Rel8.Kind.Algebra as K ( Algebra(..) )

38−import Rel8.Schema.Context ( Col )

43+import Rel8.Kind.Context ( SContext(..) )

39−import Rel8.Schema.Context.Label ( Labelable )

44+import Rel8.Schema.Field ( Field )

40import Rel8.Schema.HTable ( HTable )

45import Rel8.Schema.HTable ( HTable )

41import qualified Rel8.Schema.Kind as K

46import qualified Rel8.Schema.Kind as K

42−import Rel8.Schema.Reify ( Reify, UnwrapReify )

47+import Rel8.Schema.Name ( Name )

43import Rel8.Schema.Result ( Result )

48import Rel8.Schema.Result ( Result )

44import Rel8.Table

49import Rel8.Table

45− ( fromColumns, toColumns, reify, unreify

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

51+ , FromExprs, fromResult, toResult

52+ , Transpose

46− , TTable, TColumns, TContext, TUnreify

53+ , TTable, TColumns

47 )

54 )

55+import Rel8.Table.Transpose ( Transposes )

58+-- | The kind of 'Rel8able' types

50type KRel8able :: Type

59type KRel8able :: Type

51type KRel8able = K.Rel8able

60type 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+

54-- | This type class allows you to define custom 'Table's using higher-kinded

116-- | This type class allows you to define custom 'Table's using higher-kinded

55-- data types. Higher-kinded data types are data types of the pattern:

117-- data types. Higher-kinded data types are data types of the pattern:

56--

118--

@@ -62,113 +124,158 @@ type KRel8able = K.Rel8able

62-- , fieldN :: Column f Tn OR HKn f

124-- , fieldN :: Column f Tn OR HKn f

63-- }

125-- }

64-- @

126-- @

65−--

127+--

66-- where @Tn@ is any Haskell type, and @HKn@ is any higher-kinded type.

128-- where @Tn@ is any Haskell type, and @HKn@ is any higher-kinded type.

67−--

129+--

68-- That is, higher-kinded data are records where all fields in the record are

130-- That is, higher-kinded data are records where all fields in the record are

69-- all either of the type @Column f T@ (for any @T@), or are themselves

131-- all either of the type @Column f T@ (for any @T@), or are themselves

70-- higher-kinded data:

132-- higher-kinded data:

71−--

133+--

72-- [Nested]

134-- [Nested]

73−--

135+--

74-- @

136-- @

75-- data Nested f =

137-- data Nested f =

76-- Nested { nested1 :: MyType f

138-- Nested { nested1 :: MyType f

77-- , nested2 :: MyType f

139-- , nested2 :: MyType f

78-- }

140-- }

79-- @

141-- @

80−--

142+--

81-- The @Rel8able@ type class is used to give us a special mapping operation

143-- The @Rel8able@ type class is used to give us a special mapping operation

82-- that lets us change the type parameter @f@.

144-- that lets us change the type parameter @f@.

83−--

145+--

84-- [Supplying @Rel8able@ instances]

146-- [Supplying @Rel8able@ instances]

85−--

147+--

86-- This type class should be derived generically for all table types in your

148-- This type class should be derived generically for all table types in your

87−-- project. To do this, enable the @DeriveAnyType@ and @DeriveGeneric@ language

149+-- project. To do this, enable the @DeriveAnyClass@ and @DeriveGeneric@ language

88-- extensions:

150-- extensions:

89−--

151+--

90-- @

152-- @

91-- \{\-\# LANGUAGE DeriveAnyClass, DeriveGeneric #-\}

153-- \{\-\# LANGUAGE DeriveAnyClass, DeriveGeneric #-\}

92−--

154+--

93-- data MyType f = MyType { fieldA :: Column f T }

155-- data MyType f = MyType { fieldA :: Column f T }

94-- deriving ( GHC.Generics.Generic, Rel8able )

156-- deriving ( GHC.Generics.Generic, Rel8able )

95-- @

157-- @

96type Rel8able :: K.Rel8able -> Constraint

158type Rel8able :: K.Rel8able -> Constraint

97class HTable (GColumns t) => Rel8able t where

159class HTable (GColumns t) => Rel8able t where

98 type GColumns t :: K.HTable

160 type GColumns t :: K.HTable

161+ type GFromExprs t :: Type

162

100− gfromColumns :: (Labelable context, Reifiable context)

101− => GColumns t (Col (Reify context)) -> t (Reify context)

163+ gfromColumns :: SContext context -> GColumns t context -> t context

102−

164+ gtoColumns :: SContext context -> t context -> GColumns t context

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)

108

165

109− gunreify :: (Labelable context, Reifiable context)

166+ gfromResult :: GColumns t Result -> GFromExprs t

110− => t (Reify context) -> t context

167+ gtoResult :: GFromExprs t -> GColumns t Result

111

168

112− type GColumns t = G.GColumns TColumns (GRep t (Reify Result))

169+ type GColumns t = G.GColumns TColumns (GRep t Expr)

170+ type GFromExprs t = t Result

113

171

114 default gfromColumns :: forall context.

172 default gfromColumns :: forall context.

115− ( Generic (Record (t (Reify context)))

173+ ( SRel8able t Aggregate

116− , G.GTable (TTable (Reify context)) TColumns (Col (Reify context)) (GRep t (Reify context))

174+ , SRel8able t Expr

117− , G.GColumns TColumns (GRep t (Reify context)) ~ GColumns t

175+ , forall table. SRel8able t (Field table)

176+ , SRel8able t Name

177+ , SSerialize t

118 )

178 )

119− => GColumns t (Col (Reify context)) -> t (Reify context)

179+ => SContext context -> GColumns t context -> t context

120− gfromColumns =

180+ gfromColumns = \case

121− unrecord .

181+ SAggregate -> sfromColumns

122− to .

182+ SExpr -> sfromColumns

123− G.gfromColumns @(TTable (Reify context)) @TColumns fromColumns

183+ SField -> sfromColumns

184+ SName -> sfromColumns

185+ SResult -> sfromResult

124

186

125 default gtoColumns :: forall context.

187 default gtoColumns :: forall context.

126− ( Generic (Record (t (Reify context)))

188+ ( SRel8able t Aggregate

127− , G.GTable (TTable (Reify context)) TColumns (Col (Reify context)) (GRep t (Reify context))

189+ , SRel8able t Expr

128− , G.GColumns TColumns (GRep t (Reify context)) ~ GColumns t

190+ , forall table. SRel8able t (Field table)

129− )

191+ , SRel8able t Name

130− => t (Reify context) -> GColumns t (Col (Reify context))

192+ , SSerialize t

131− gtoColumns =

132− G.gtoColumns @(TTable (Reify context)) @TColumns toColumns .

133− from .

134− Record

135−

136− default greify :: forall context.

137− ( Generic (Record (t context))

138− , Generic (Record (t (Reify context)))

139− , GMappable (TTable (Reify context)) (GRep t (Reify context))

140− , GRep t context ~ GMap TUnreify (GRep t (Reify context))

141− )

142− => t context -> t (Reify context)

143− greify =

144− unrecord .

145− to .

146− gunmap @(TTable (Reify context)) (Proxy @TUnreify) (reify Refl) .

147− from .

148− Record

149−

150− default gunreify :: forall context.

151− ( Generic (Record (t context))

152− , Generic (Record (t (Reify context)))

153− , GMappable (TTable (Reify context)) (GRep t (Reify context))

154− , GRep t context ~ GMap TUnreify (GRep t (Reify context))

155 )

193 )

156− => t (Reify context) -> t context

194+ => SContext context -> t context -> GColumns t context

157− gunreify =

195+ gtoColumns = \case

158− unrecord .

196+ SAggregate -> stoColumns

159− to .

197+ SExpr -> stoColumns

160− gmap @(TTable (Reify context)) (Proxy @TUnreify) (unreify Refl) .

198+ SField -> stoColumns

161− from .

199+ SName -> stoColumns

162− Record

200+ SResult -> stoResult

201+

202+ default gfromResult :: (SSerialize t, GFromExprs t ~ t Result)

203+ => GColumns t Result -> GFromExprs t

204+ gfromResult = sfromResult

205+

206+ default gtoResult :: (SSerialize t, GFromExprs t ~ t Result)

207+ => GFromExprs t -> GColumns t Result

208+ gtoResult = stoResult

163

209

164

210

165type Algebra :: K.Rel8able -> K.Algebra

211type Algebra :: K.Rel8able -> K.Algebra

166−type Algebra t = GAlgebra (GRep t (Reify Result))

212+type Algebra t = GAlgebra (GRep t Expr)

167

213

168

214

169type GRep :: K.Rel8able -> K.Context -> Type -> Type

215type GRep :: K.Rel8able -> K.Context -> Type -> Type

170type GRep t context = Rep (Record (t context))

216type GRep t context = Rep (Record (t context))

171

217

172

218

173−data TUnreifyContext :: Type -> Exp K.Context

219+type SRel8able :: K.Rel8able -> K.Context -> Constraint

174−type instance Eval (TUnreifyContext a) = UnwrapReify (Eval (TContext a))

220+class

221+ ( Generic (Record (t context))

222+ , G.GTable (TTable context) TColumns (GRep t context)

223+ , G.GColumns TColumns (GRep t context) ~ GColumns t

224+ )

225+ => SRel8able t context

226+instance

227+ ( Generic (Record (t context))

228+ , G.GTable (TTable context) TColumns (GRep t context)

229+ , G.GColumns TColumns (GRep t context) ~ GColumns t

230+ )

231+ => SRel8able t context

232+

233+

234+type SSerialize :: K.Rel8able -> Constraint

235+type SSerialize t =

236+ ( Generic (Record (t Result))

237+ , G.GSerialize TSerialize TColumns (GRep t Expr) (GRep t Result)

238+ , G.GColumns TColumns (GRep t Expr) ~ GColumns t

239+ )

240+

241+

242+sfromColumns :: forall t context. SRel8able t context

243+ => GColumns t context -> t context

244+sfromColumns =

245+ unrecord .

246+ to .

247+ G.gfromColumns @(TTable context) @TColumns fromColumns

248+

249+

250+stoColumns :: forall t context. SRel8able t context

251+ => t context -> GColumns t context

252+stoColumns =

253+ G.gtoColumns @(TTable context) @TColumns toColumns .

254+ from .

255+ Record

256+

257+

258+sfromResult :: forall t. SSerialize t

259+ => GColumns t Result -> t Result

260+sfromResult =

261+ unrecord .

262+ to .

263+ G.gfromResult

264+ @TSerialize

265+ @TColumns

266+ @(GRep t Expr)

267+ @(GRep t Result)

268+ (\(_ :: proxy x) -> deserialize @_ @x)

269+

270+

271+stoResult :: forall t. SSerialize t

272+ => t Result -> GColumns t Result

273+stoResult =

274+ G.gtoResult

275+ @TSerialize

276+ @TColumns

277+ @(GRep t Expr)

278+ @(GRep t Result)

279+ (\(_ :: proxy x) -> serialize @_ @x) .

280+ from .

281+ Record

src/Rel8/Generic/Table.hs+24−109

@@ -12,8 +12,7 @@

12{-# language UndecidableInstances #-}

14module Rel8.Generic.Table

15− ( GGTable, GGColumns, GGContext, ggfromColumns, ggtoColumns, ggtable

16− , GGToExprs, ggfromResult, ggtoResult

15+ ( GGSerialize, GGColumns, ggfromResult, ggtoResult

17 , GAlgebra

16 , GAlgebra

18 )

17 )

19where

18where

@@ -26,43 +25,19 @@ import Prelude ()

26-- rel8

25-- rel8

27import Rel8.FCF ( Eval, Exp )

26import Rel8.FCF ( Eval, Exp )

28import Rel8.Generic.Table.ADT

27import Rel8.Generic.Table.ADT

29− ( GTableADT, GColumnsADT, gfromColumnsADT, gtoColumnsADT, gtableADT

30− , GToExprsADT, gtoResultADT, gfromResultADT

28+ ( GSerializeADT, GColumnsADT, gtoResultADT, gfromResultADT

31− )

32−import Rel8.Generic.Table.Record

33− ( GTable, GColumns, GContext, gfromColumns, gtoColumns, gtable

34− , GToExprs, gtoResult, gfromResult

35 )

29 )

30+import Rel8.Generic.Table.Record ( GSerialize, GColumns, gtoResult, gfromResult )

36import Rel8.Kind.Algebra

31import Rel8.Kind.Algebra

37 ( Algebra( Product, Sum )

32 ( Algebra( Product, Sum )

38 , SAlgebra( SProduct, SSum )

33 , SAlgebra( SProduct, SSum )

39 , KnownAlgebra, algebraSing

34 , KnownAlgebra, algebraSing

40 )

35 )

41−import Rel8.Schema.Context ( Col )

42import qualified Rel8.Schema.Kind as K

36import qualified Rel8.Schema.Kind as K

43−import Rel8.Schema.Null ( Nullify )

44−import Rel8.Schema.Spec ( Spec( Spec ), SSpec )

45import Rel8.Schema.Result ( Result )

37import Rel8.Schema.Result ( Result )

48−data GGTable

40+data GGSerialize

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

66 :: Algebra

41 :: Algebra

67 -> (Type -> Type -> Exp Constraint)

42 -> (Type -> Type -> Exp Constraint)

68 -> (Type -> Exp K.HTable)

43 -> (Type -> Exp K.HTable)

@@ -71,12 +46,12 @@ data GGToExprs

71 -> Exp Constraint

46 -> Exp Constraint

74−type instance Eval (GGToExprs 'Product _ToExprs _Columns exprs rep) =

49+type instance Eval (GGSerialize 'Product _Serialize _Columns exprs rep) =

75− GToExprs _ToExprs _Columns exprs rep

50+ GSerialize _Serialize _Columns exprs rep

78−type instance Eval (GGToExprs 'Sum _ToExprs _Columns exprs rep) =

53+type instance Eval (GGSerialize 'Sum _Serialize _Columns exprs rep) =

79− GToExprsADT _ToExprs _Columns exprs rep

54+ GSerializeADT _Serialize _Columns exprs rep

82data GGColumns

57data GGColumns

@@ -92,19 +67,6 @@ type instance Eval (GGColumns 'Product _Columns rep) = GColumns _Columns rep

92type instance Eval (GGColumns 'Sum _Columns rep) = GColumnsADT _Columns rep

67type 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−

108type GAlgebra :: (Type -> Type) -> Algebra

70type GAlgebra :: (Type -> Type) -> Algebra

109type family GAlgebra rep where

71type family GAlgebra rep where

110 GAlgebra (M1 _ _ rep) = GAlgebra rep

72 GAlgebra (M1 _ _ rep) = GAlgebra rep

@@ -115,74 +77,27 @@ type family GAlgebra rep where

115 GAlgebra (K1 _ _) = 'Product

77 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. ()

152− => SSpec ('Spec labels a)

153− -> context ('Spec labels a)

154− -> context ('Spec labels (Nullify a)))

155− -> Eval (GGColumns algebra _Columns rep) context

156−ggtable = case algebraSing @algebra of

157− SProduct -> \table _ -> gtable @_Table @_Columns @_ @rep table

158− SSum -> gtableADT @_Table @_Columns @_ @rep

159−

160−

161−ggfromResult :: forall algebra _ToExprs _Columns exprs rep x.

80+ggfromResult :: forall algebra _Serialize _Columns exprs rep x.

162 ( KnownAlgebra algebra

81 ( KnownAlgebra algebra

163− , Eval (GGToExprs algebra _ToExprs _Columns exprs rep)

82+ , Eval (GGSerialize algebra _Serialize _Columns exprs rep)

164 )

83 )

165− => (forall expr a proxy. Eval (_ToExprs expr a)

84+ => (forall expr a proxy. Eval (_Serialize expr a)

166− => proxy expr

167− -> Eval (_Columns expr) (Col Result)

85+ => proxy expr -> Eval (_Columns expr) Result -> a)

168− -> a)

169− -> Eval (GGColumns algebra _Columns exprs) (Col Result)

86+ -> Eval (GGColumns algebra _Columns exprs) Result

170 -> rep x

87 -> rep x

171−ggfromResult = case algebraSing @algebra of

88+ggfromResult f x = case algebraSing @algebra of

172− SProduct -> gfromResult @_ToExprs @_Columns @exprs

89+ SProduct -> gfromResult @_Serialize @_Columns @exprs @rep f x

173− SSum -> gfromResultADT @_ToExprs @_Columns @exprs

90+ SSum -> gfromResultADT @_Serialize @_Columns @exprs @rep f x

174

175

176−ggtoResult :: forall algebra _ToExprs _Columns exprs rep x.

93+ggtoResult :: forall algebra _Serialize _Columns exprs rep x.

177 ( KnownAlgebra algebra

94 ( KnownAlgebra algebra

178− , Eval (GGToExprs algebra _ToExprs _Columns exprs rep)

95+ , Eval (GGSerialize algebra _Serialize _Columns exprs rep)

179 )

96 )

180− => (forall expr a proxy. Eval (_ToExprs expr a)

97+ => (forall expr a proxy. Eval (_Serialize expr a)

181− => proxy expr

182− -> a

183− -> Eval (_Columns expr) (Col Result))

98+ => proxy expr -> a -> Eval (_Columns expr) Result)

184 -> rep x

99 -> rep x

185− -> Eval (GGColumns algebra _Columns exprs) (Col Result)

100+ -> Eval (GGColumns algebra _Columns exprs) Result

186−ggtoResult = case algebraSing @algebra of

101+ggtoResult f x = case algebraSing @algebra of

187− SProduct -> gtoResult @_ToExprs @_Columns @exprs

102+ SProduct -> gtoResult @_Serialize @_Columns @exprs @rep f x

188− SSum -> gtoResultADT @_ToExprs @_Columns @exprs

103+ SSum -> gtoResultADT @_Serialize @_Columns @exprs @rep f x

src/Rel8/Generic/Table/ADT.hs+61−203

@@ -4,7 +4,6 @@

4{-# language FlexibleInstances #-}

5{-# language LambdaCase #-}

6{-# language MultiParamTypeClasses #-}

7−{-# language PolyKinds #-}

8{-# language RankNTypes #-}

7{-# language RankNTypes #-}

9{-# language ScopedTypeVariables #-}

8{-# language ScopedTypeVariables #-}

10{-# language StandaloneKindSignatures #-}

9{-# language StandaloneKindSignatures #-}

@@ -14,13 +13,13 @@

14{-# language UndecidableInstances #-}

13{-# language UndecidableInstances #-}

16module Rel8.Generic.Table.ADT

15module Rel8.Generic.Table.ADT

17− ( GTableADT, GColumnsADT, gfromColumnsADT, gtoColumnsADT, gtableADT

18− , GTableADT', GColumnsADT'

19− , GToExprsADT, gfromResultADT, gtoResultADT

16+ ( GSerializeADT, GColumnsADT, gfromResultADT, gtoResultADT

17+ , GSerializeADT', GColumnsADT'

20 )

18 )

21where

19where

23-- base

21-- base

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

24import Data.Kind ( Constraint, Type )

23import Data.Kind ( Constraint, Type )

25import Data.Proxy ( Proxy( Proxy ) )

24import Data.Proxy ( Proxy( Proxy ) )

26import GHC.Generics

25import GHC.Generics

@@ -33,23 +32,14 @@ import Prelude hiding ( null )

34-- rel8

33-- rel8

35import Rel8.FCF ( Eval, Exp )

34import Rel8.FCF ( Eval, Exp )

36−import Rel8.Generic.Table.Record

35+import Rel8.Generic.Table.Record ( GSerialize, GColumns, gfromResult, gtoResult )

37− ( GTable, GColumns, gtable

38− , GToExprs, gfromResult, gtoResult

39− )

40−import Rel8.Schema.Context.Label ( HLabelable, hlabeler, labeler, unlabeler )

41−import Rel8.Schema.HTable ( HTable, hmap )

36+import Rel8.Schema.HTable ( HTable )

42−import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )

37+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

43import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )

38import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )

44import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify )

39import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify )

45import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )

40import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )

46import qualified Rel8.Schema.Kind as K

41import 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( R ), Result

51− , null, nullifier, unnullifier

42+import Rel8.Schema.Result ( Result, null, nullifier, unnullifier )

52− )

53import Rel8.Type.Tag ( Tag( Tag ) )

43import Rel8.Type.Tag ( Tag( Tag ) )

55-- text

45-- text

@@ -61,7 +51,7 @@ type GColumnsADT

61 -> (Type -> Type) -> K.HTable

51 -> (Type -> Type) -> K.HTable

62type family GColumnsADT _Columns rep where

52type family GColumnsADT _Columns rep where

63 GColumnsADT _Columns (M1 D _ rep) =

53 GColumnsADT _Columns (M1 D _ rep) =

64− GColumnsADT' _Columns (HLabel "tag" (HType Tag)) rep

54+ GColumnsADT' _Columns (HLabel "tag" (HIdentity Tag)) rep

67type GColumnsADT'

57type GColumnsADT'

@@ -75,246 +65,118 @@ type family GColumnsADT' _Columns htable rep where

75 HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))

65 HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))

78−type GTableADT

68+type GSerializeADT

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. ()

100− => SSpec ('Spec labels a)

101− -> context ('Spec labels a)

102− -> context ('Spec labels (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. ()

140− => SSpec ('Spec labels a)

141− -> context ('Spec labels a)

142− -> context ('Spec labels (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

184 :: (Type -> Type -> Exp Constraint)

69 :: (Type -> Type -> Exp Constraint)

185 -> (Type -> Exp K.HTable)

70 -> (Type -> Exp K.HTable)

186 -> (Type -> Type) -> (Type -> Type) -> Constraint

71 -> (Type -> Type) -> (Type -> Type) -> Constraint

187−class GToExprsADT _ToExprs _Columns exprs rep where

72+class GSerializeADT _Serialize _Columns exprs rep where

188 gfromResultADT :: ()

73 gfromResultADT :: ()

189− => (forall expr a proxy.

74+ => (forall expr a proxy. Eval (_Serialize expr a)

190− ( Eval (_ToExprs expr a)

191− , HTable (Eval (_Columns expr))

192− )

193− => proxy expr

194− -> Eval (_Columns expr) (Col Result)

75+ => proxy expr -> Eval (_Columns expr) Result -> a)

195− -> a)

196− -> GColumnsADT _Columns exprs (Col Result)

76+ -> GColumnsADT _Columns exprs Result

197 -> rep x

77 -> rep x

198

199 gtoResultADT :: ()

79 gtoResultADT :: ()

200− => (forall expr a proxy.

80+ => (forall expr a proxy. Eval (_Serialize expr a)

201− ( Eval (_ToExprs expr a)

202− , HTable (Eval (_Columns expr))

203− )

204− => proxy expr

205− -> a

206− -> Eval (_Columns expr) (Col Result))

81+ => proxy expr -> a -> Eval (_Columns expr) Result)

207 -> rep x

82 -> rep x

208− -> GColumnsADT _Columns exprs (Col Result)

83+ -> GColumnsADT _Columns exprs Result

209

210

211instance

86instance

212− ( htable ~ HLabel "tag" (HType Tag)

87+ ( htable ~ HLabel "tag" (HIdentity Tag)

213− , GToExprsADT' _ToExprs _Columns htable exprs rep

88+ , GSerializeADT' _Serialize _Columns htable exprs rep

214 )

89 )

215− => GToExprsADT _ToExprs _Columns (M1 D meta exprs) (M1 D meta rep)

90+ => GSerializeADT _Serialize _Columns (M1 D meta exprs) (M1 D meta rep)

216 where

91 where

217 gfromResultADT fromResult columns =

92 gfromResultADT fromResult columns =

218− case gfromResultADT' @_ToExprs @_Columns @_ @exprs fromResult tag columns of

93+ case gfromResultADT' @_Serialize @_Columns @htable @exprs @rep fromResult tag columns of

219 Just rep -> M1 rep

94 Just rep -> M1 rep

220 _ -> error "ADT.fromColumns: mismatch between tag and data"

95 _ -> error "ADT.fromColumns: mismatch between tag and data"

221 where

96 where

222− tag = (\(HType (R a)) -> a) . hunlabel @_ @"tag" unlabeler

97+ tag = (\(HIdentity (Identity a)) -> a) . hunlabel @"tag"

223

224 gtoResultADT toResult (M1 rep) =

99 gtoResultADT toResult (M1 rep) =

225− gtoResultADT' @_ToExprs @_Columns @_ @exprs toResult tag (Just rep)

100+ gtoResultADT' @_Serialize @_Columns @htable @exprs @rep toResult tag (Just rep)

226 where

101 where

227− tag = hlabel @_ @"tag" labeler . HType . R

102+ tag = hlabel @"tag" . HIdentity . Identity

228

103

229

104

230−type GToExprsADT'

105+type GSerializeADT'

231 :: (Type -> Type -> Exp Constraint)

106 :: (Type -> Type -> Exp Constraint)

232 -> (Type -> Exp K.HTable)

107 -> (Type -> Exp K.HTable)

233 -> K.HTable -> (Type -> Type) -> (Type -> Type) -> Constraint

108 -> K.HTable -> (Type -> Type) -> (Type -> Type) -> Constraint

234−class GToExprsADT' _ToExprs _Columns htable exprs rep where

109+class GSerializeADT' _Serialize _Columns htable exprs rep where

235− gfromResultADT' :: ()

110+ gfromResultADT' :: context ~ Result

236− => (forall expr a proxy.

111+ => (forall expr a proxy. Eval (_Serialize expr a)

237− ( Eval (_ToExprs expr a)

238− , HTable (Eval (_Columns expr))

239− )

240− => proxy expr

241− -> Eval (_Columns expr) (Col Result)

112+ => proxy expr -> Eval (_Columns expr) context -> a)

242− -> a)

243− -> (htable (Col Result) -> Tag)

113+ -> (htable Result -> Tag)

244− -> GColumnsADT' _Columns htable exprs (Col Result)

114+ -> GColumnsADT' _Columns htable exprs context

245 -> Maybe (rep x)

115 -> Maybe (rep x)

246

116

247− gtoResultADT' :: ()

117+ gtoResultADT' :: context ~ Result

248− => (forall expr a proxy.

118+ => (forall expr a proxy. Eval (_Serialize expr a)

249− ( Eval (_ToExprs expr a)

250− , HTable (Eval (_Columns expr))

251− )

252− => proxy expr

253− -> a

254− -> Eval (_Columns expr) (Col Result))

119+ => proxy expr -> a -> Eval (_Columns expr) context)

255− -> (Tag -> htable (Col Result))

120+ -> (Tag -> htable Result)

256 -> Maybe (rep x)

121 -> Maybe (rep x)

257− -> GColumnsADT' _Columns htable exprs (Col Result)

122+ -> GColumnsADT' _Columns htable exprs context

258

123

259 extract :: GColumnsADT' _Columns htable exprs context -> htable context

124 extract :: GColumnsADT' _Columns htable exprs context -> htable context

260

125

261

126

262instance

127instance

263− ( htable' ~ GColumnsADT' _Columns htable a

128+ ( htable' ~ GColumnsADT' _Columns htable exprs1

264− , GToExprsADT' _ToExprs _Columns htable a rep1

129+ , GSerializeADT' _Serialize _Columns htable exprs1 a

265− , GToExprsADT' _ToExprs _Columns htable' b rep2

130+ , GSerializeADT' _Serialize _Columns htable' exprs2 b

266 )

131 )

267− => GToExprsADT' _ToExprs _Columns htable (a :+: b) (rep1 :+: rep2)

132+ => GSerializeADT' _Serialize _Columns htable (exprs1 :+: exprs2) (a :+: b)

268 where

133 where

269 gfromResultADT' fromResult f columns =

134 gfromResultADT' fromResult f columns =

270 case ma of

135 case ma of

271 Just a -> Just (L1 a)

136 Just a -> Just (L1 a)

272 Nothing -> R1 <$>

137 Nothing -> R1 <$>

273− gfromResultADT' @_ToExprs @_Columns @_ @b @rep2

138+ gfromResultADT' @_Serialize @_Columns @_ @exprs2 @b

274 fromResult

139 fromResult

275− (f . extract @_ToExprs @_Columns @_ @a @rep1)

140+ (f . extract @_Serialize @_Columns @_ @exprs1 @a)

276 columns

141 columns

277 where

142 where

278 ma =

143 ma =

279− gfromResultADT' @_ToExprs @_Columns @_ @a @rep1

144+ gfromResultADT' @_Serialize @_Columns @_ @exprs1 @a

280 fromResult

145 fromResult

281 f

146 f

282− (extract @_ToExprs @_Columns @_ @b @rep2 columns)

147+ (extract @_Serialize @_Columns @_ @exprs2 @b columns)

283

148

284 gtoResultADT' toResult tag = \case

149 gtoResultADT' toResult tag = \case

285 Just (L1 a) ->

150 Just (L1 a) ->

286− gtoResultADT' @_ToExprs @_Columns @_ @b @rep2

151+ gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b

287 toResult

152 toResult

288− (\_ -> gtoResultADT' @_ToExprs @_Columns @_ @a @rep1

153+ (\_ -> gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a

289 toResult

154 toResult

290 tag

155 tag

291 (Just a))

156 (Just a))

292 Nothing

157 Nothing

293 Just (R1 b) ->

158 Just (R1 b) ->

294− gtoResultADT' @_ToExprs @_Columns @_ @b @rep2

159+ gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b

295 toResult

160 toResult

296 (\tag' ->

161 (\tag' ->

297− gtoResultADT' @_ToExprs @_Columns @_ @a @rep1

162+ gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a

298 toResult

163 toResult

299 (\_ -> tag tag')

164 (\_ -> tag tag')

300 Nothing)

165 Nothing)

301 (Just b)

166 (Just b)

302 Nothing ->

167 Nothing ->

303− gtoResultADT' @_ToExprs @_Columns @_ @b @rep2

168+ gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b

304 toResult

169 toResult

305− (\_ -> gtoResultADT' @_ToExprs @_Columns @_ @a @rep1 toResult tag Nothing)

170+ (\_ -> gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a toResult tag Nothing)

306 Nothing

171 Nothing

307

172

308 extract =

173 extract =

309− extract @_ToExprs @_Columns @_ @a @rep1 .

174+ extract @_Serialize @_Columns @_ @exprs1 @a .

310− extract @_ToExprs @_Columns @_ @b @rep2

175+ extract @_Serialize @_Columns @_ @exprs2 @b

311

176

312

177

313−instance

314− ( meta ~ 'MetaCons label _fixity _isRecord

178+instance (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) =>

315− , KnownSymbol label

316− )

317− => GToExprsADT' _ToExprs _Columns htable (M1 C meta U1) (M1 C meta U1)

179+ GSerializeADT' _Serialize _Columns _htable (M1 C meta U1) (M1 C meta U1)

318 where

180 where

319 gfromResultADT' _ tag columns

181 gfromResultADT' _ tag columns

320 | tag columns == tag' = Just (M1 U1)

182 | tag columns == tag' = Just (M1 U1)

@@ -331,33 +193,29 @@ instance

331

193

332instance {-# OVERLAPPABLE #-}

194instance {-# OVERLAPPABLE #-}

333 ( HTable (GColumns _Columns exprs)

195 ( HTable (GColumns _Columns exprs)

334− , GToExprs _ToExprs _Columns exprs rep

196+ , GSerialize _Serialize _Columns exprs rep

335 , meta ~ 'MetaCons label _fixity _isRecord

197 , meta ~ 'MetaCons label _fixity _isRecord

336 , KnownSymbol label

198 , KnownSymbol label

337− , GColumnsADT' _Columns htable (M1 C meta exprs) ~

199+ , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) exprs) ~

338 HProduct htable (HLabel label (HNullify (GColumns _Columns exprs)))

200 HProduct htable (HLabel label (HNullify (GColumns _Columns exprs)))

339 )

201 )

340− => GToExprsADT' _ToExprs _Columns htable (M1 C meta exprs) (M1 C meta rep)

202+ => GSerializeADT' _Serialize _Columns htable (M1 C meta exprs) (M1 C meta rep)

341 where

203 where

342 gfromResultADT' fromResult tag (HProduct a b)

204 gfromResultADT' fromResult tag (HProduct a b)

343 | tag a == tag' =

205 | tag a == tag' =

344− M1 . gfromResult @_ToExprs @_Columns @exprs fromResult <$>

206+ M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult <$>

345− hunnullify unnullifier (hunlabel unlabeler b)

207+ hunnullify unnullifier (hunlabel b)

346 | otherwise = Nothing

208 | otherwise = Nothing

347 where

209 where

348 tag' = Tag $ pack $ symbolVal (Proxy @label)

210 tag' = Tag $ pack $ symbolVal (Proxy @label)

349

211

350 gtoResultADT' toResult tag = \case

212 gtoResultADT' toResult tag = \case

351− Nothing -> HProduct (tag tag') (hlabel labeler (hnulls (const null)))

213+ Nothing -> HProduct (tag tag') (hlabel (hnulls (const null)))

352 Just (M1 rep) -> HProduct (tag tag') $

214 Just (M1 rep) -> HProduct (tag tag') $

353− hlabel labeler $

215+ hlabel $

354 hnullify nullifier $

216 hnullify nullifier $

355− gtoResult @_ToExprs @_Columns @exprs toResult rep

217+ gtoResult @_Serialize @_Columns @exprs @rep toResult rep

356 where

218 where

357 tag' = Tag $ pack $ symbolVal (Proxy @label)

219 tag' = Tag $ pack $ symbolVal (Proxy @label)

358

220

359 extract (HProduct a _) = a

221 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+74−99

@@ -14,7 +14,7 @@

15module Rel8.Generic.Table.Record

16 ( GTable, GColumns, GContext, gfromColumns, gtoColumns, gtable

17− , GToExprs, gfromResult, gtoResult

17+ , GSerialize, gfromResult, gtoResult

18 )

19where

@@ -26,18 +26,13 @@ import GHC.Generics

26 , C, D, S

27 , Meta( MetaSel )

28 )

29−import GHC.TypeLits ( KnownSymbol )

30import Prelude hiding ( null )

29import Prelude hiding ( null )

32-- rel8

31-- rel8

33import Rel8.FCF ( Eval, Exp )

32import 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 )

37import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )

33import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )

38import Rel8.Schema.HTable.Product ( HProduct(..) )

34import Rel8.Schema.HTable.Product ( HProduct(..) )

39import qualified Rel8.Schema.Kind as K

35import qualified Rel8.Schema.Kind as K

40−import Rel8.Schema.Result ( Result )

43type GColumns :: (Type -> Exp K.HTable) -> (Type -> Type) -> K.HTable

38type GColumns :: (Type -> Exp K.HTable) -> (Type -> Type) -> K.HTable

@@ -60,8 +55,8 @@ type family GContext _Context rep where

60type GTable

55type GTable

61 :: (Type -> Exp Constraint)

56 :: (Type -> Exp Constraint)

62 -> (Type -> Exp K.HTable)

57 -> (Type -> Exp K.HTable)

63− -> K.HContext -> (Type -> Type) -> Constraint

58+ -> (Type -> Type) -> Constraint

64−class GTable _Table _Columns context rep

59+class GTable _Table _Columns rep

65 where

60 where

66 gfromColumns :: ()

61 gfromColumns :: ()

67 => (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)

62 => (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)

@@ -78,129 +73,109 @@ class GTable _Table _Columns context rep

78 -> GColumns _Columns rep context

73 -> GColumns _Columns rep context

81−instance GTable _Table _Columns context rep =>

76+type GSerialize

82− GTable _Table _Columns context (M1 D c rep)

77+ :: (Type -> Type -> Exp Constraint)

78+ -> (Type -> Exp K.HTable)

79+ -> (Type -> Type) -> (Type -> Type) -> Constraint

80+class GSerialize _Serialize _Columns exprs rep

83 where

81 where

84− gfromColumns fromColumns =

82+ gfromResult :: ()

85− M1 . gfromColumns @_Table @_Columns @context @rep fromColumns

83+ => (forall expr a proxy. Eval (_Serialize expr a)

86− gtoColumns toColumns (M1 a) =

84+ => proxy expr -> Eval (_Columns expr) context -> a)

87− gtoColumns @_Table @_Columns @context @rep toColumns a

85+ -> GColumns _Columns exprs context

86+ -> rep x

87+

88+ gtoResult :: ()

89+ => (forall expr a proxy. Eval (_Serialize expr a)

88− gtable = gtable @_Table @_Columns @context @rep

90+ => proxy expr -> a -> Eval (_Columns expr) context)

91+ -> rep x

92+ -> GColumns _Columns exprs context

91−instance GTable _Table _Columns context rep =>

95+instance GTable _Table _Columns rep => GTable _Table _Columns (M1 D c rep)

92− GTable _Table _Columns context (M1 C c rep)

93 where

96 where

94 gfromColumns fromColumns =

97 gfromColumns fromColumns =

95− M1 . gfromColumns @_Table @_Columns @context @rep fromColumns

98+ M1 . gfromColumns @_Table @_Columns @rep fromColumns

96 gtoColumns toColumns (M1 a) =

99 gtoColumns toColumns (M1 a) =

97− gtoColumns @_Table @_Columns @context @rep toColumns a

100+ gtoColumns @_Table @_Columns @rep toColumns a

98− gtable = gtable @_Table @_Columns @context @rep

101+ gtable = gtable @_Table @_Columns @rep

102

100

103

101−instance

104+instance GSerialize _Serialize _Columns exprs rep =>

102− ( GTable _Table _Columns context rep1

105+ GSerialize _Serialize _Columns (M1 D c exprs) (M1 D c rep)

103− , GTable _Table _Columns context rep2

104− )

105− => GTable _Table _Columns context (rep1 :*: rep2)

106 where

107− gfromColumns fromColumns (HProduct a b) =

107+ gfromResult fromResult =

108− gfromColumns @_Table @_Columns @context @rep1 fromColumns a :*:

108+ M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult

109− gfromColumns @_Table @_Columns @context @rep2 fromColumns b

109+ gtoResult toResult (M1 a) =

110− gtoColumns toColumns (a :*: b) = HProduct

110+ gtoResult @_Serialize @_Columns @exprs @rep toResult a

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)

116

111

117

112

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

126− => GTable _Table _Columns context (M1 S meta k1)

113+instance GTable _Table _Columns rep => GTable _Table _Columns (M1 C c rep)

127 where

114 where

128− gfromColumns fromColumns = M1 . K1 . fromColumns . hunlabel hunlabeler

115+ gfromColumns fromColumns =

116+ M1 . gfromColumns @_Table @_Columns @rep fromColumns

129− gtoColumns toColumns (M1 (K1 a)) = hlabel hlabeler (toColumns a)

117+ gtoColumns toColumns (M1 a) =

130− gtable table = hlabel hlabeler (table (Proxy @a))

118+ gtoColumns @_Table @_Columns @rep toColumns a

131−

119+ gtable = gtable @_Table @_Columns @rep

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

120

159

121

160−instance GToExprs _ToExprs _Columns exprs rep =>

122+instance GSerialize _Serialize _Columns exprs rep =>

161− GToExprs _ToExprs _Columns (M1 D c exprs) (M1 D c rep)

123+ GSerialize _Serialize _Columns (M1 C c exprs) (M1 C c rep)

162 where

124 where

163 gfromResult fromResult =

125 gfromResult fromResult =

164− M1 . gfromResult @_ToExprs @_Columns @exprs fromResult

126+ M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult

165 gtoResult toResult (M1 a) =

127 gtoResult toResult (M1 a) =

166− gtoResult @_ToExprs @_Columns @exprs toResult a

128+ gtoResult @_Serialize @_Columns @exprs @rep toResult a

167

129

168

130

169−instance GToExprs _ToExprs _Columns exprs rep =>

131+instance (GTable _Table _Columns rep1, GTable _Table _Columns rep2) =>

170− GToExprs _ToExprs _Columns (M1 C c exprs) (M1 C c rep)

132+ GTable _Table _Columns (rep1 :*: rep2)

171 where

133 where

172− gfromResult fromResult =

134+ gfromColumns fromColumns (HProduct a b) =

173− M1 . gfromResult @_ToExprs @_Columns @exprs fromResult

135+ gfromColumns @_Table @_Columns @rep1 fromColumns a :*:

174− gtoResult toResult (M1 a) =

136+ gfromColumns @_Table @_Columns @rep2 fromColumns b

175− gtoResult @_ToExprs @_Columns @exprs toResult a

137+ gtoColumns toColumns (a :*: b) = HProduct

138+ (gtoColumns @_Table @_Columns @rep1 toColumns a)

139+ (gtoColumns @_Table @_Columns @rep2 toColumns b)

140+ gtable table = HProduct

141+ (gtable @_Table @_Columns @rep1 table)

142+ (gtable @_Table @_Columns @rep2 table)

176

143

177

144

178instance

145instance

179− ( GToExprs _ToExprs _Columns exprs1 rep1

146+ ( GSerialize _Serialize _Columns expr1 rep1

180− , GToExprs _ToExprs _Columns exprs2 rep2

147+ , GSerialize _Serialize _Columns expr2 rep2

181 )

148 )

182− => GToExprs _ToExprs _Columns (exprs1 :*: exprs2) (rep1 :*: rep2)

149+ => GSerialize _Serialize _Columns (expr1 :*: expr2) (rep1 :*: rep2)

183 where

150 where

184 gfromResult fromResult (HProduct a b) =

151 gfromResult fromResult (HProduct a b) =

185− gfromResult @_ToExprs @_Columns @exprs1 fromResult a :*:

152+ gfromResult @_Serialize @_Columns @expr1 @rep1 fromResult a :*:

186− gfromResult @_ToExprs @_Columns @exprs2 fromResult b

153+ gfromResult @_Serialize @_Columns @expr2 @rep2 fromResult b

187 gtoResult toResult (a :*: b) =

154 gtoResult toResult (a :*: b) =

188 HProduct

155 HProduct

189− (gtoResult @_ToExprs @_Columns @exprs1 toResult a)

156+ (gtoResult @_Serialize @_Columns @expr1 @rep1 toResult a)

190− (gtoResult @_ToExprs @_Columns @exprs2 toResult b)

157+ (gtoResult @_Serialize @_Columns @expr2 @rep2 toResult b)

191

158

192

159

193instance

160instance

194− ( Eval (_ToExprs exprs a)

161+ ( Eval (_Table a)

195− , HTable (Eval (_Columns exprs))

196− , KnownSymbol label

197 , meta ~ 'MetaSel ('Just label) _su _ss _ds

162 , meta ~ 'MetaSel ('Just label) _su _ss _ds

198− , k1 ~ K1 i exprs

163+ , k1 ~ K1 i a

164+ )

165+ => GTable _Table _Columns (M1 S meta k1)

166+ where

167+ gfromColumns fromColumns = M1 . K1 . fromColumns . hunlabel

168+ gtoColumns toColumns (M1 (K1 a)) = hlabel (toColumns a)

169+ gtable table = hlabel (table (Proxy @a))

170+

171+

172+instance

173+ ( Eval (_Serialize expr a)

174+ , meta ~ 'MetaSel ('Just label) _su _ss _ds

175+ , k1 ~ K1 i expr

199 , k1' ~ K1 i a

176 , k1' ~ K1 i a

200 )

177 )

201− => GToExprs _ToExprs _Columns (M1 S meta k1) (M1 S meta k1')

178+ => GSerialize _Serialize _Columns (M1 S meta k1) (M1 S meta k1')

202 where

179 where

203− gfromResult fromResult =

180+ gfromResult fromResult = M1 . K1 . fromResult (Proxy @expr) . hunlabel

204− M1 . K1 . fromResult (Proxy @exprs) . hunlabel hunlabeler

205− gtoResult toResult (M1 (K1 a)) =

181+ gtoResult toResult (M1 (K1 a)) = hlabel (toResult (Proxy @expr) a)

206− hlabel hlabeler (toResult (Proxy @exprs) a)

src/Rel8/Kind/Context.hs+8−33

@@ -1,13 +1,11 @@

1{-# language DataKinds #-}

2{-# language GADTs #-}

3−{-# language LambdaCase #-}

4{-# language StandaloneKindSignatures #-}

3{-# language StandaloneKindSignatures #-}

4+{-# language TypeSynonymInstances #-}

6module Rel8.Kind.Context

7 ( Reifiable( contextSing )

8 , SContext(..)

9− , sReifiable

10− , sLabelable

11 )

9 )

12where

10where

@@ -18,12 +16,9 @@ import Prelude ()

18-- rel8

16-- rel8

19import Rel8.Aggregate ( Aggregate )

17import Rel8.Aggregate ( Aggregate )

20import Rel8.Expr ( Expr )

18import Rel8.Expr ( Expr )

21−import Rel8.Schema.Dict ( Dict( Dict ) )

19+import Rel8.Schema.Field ( Field )

22−import Rel8.Schema.Context ( Interpretation )

23−import Rel8.Schema.Context.Label ( Labelable )

24import Rel8.Schema.Kind ( Context )

20import Rel8.Schema.Kind ( Context )

25import Rel8.Schema.Name ( Name )

21import Rel8.Schema.Name ( Name )

26−import Rel8.Schema.Reify ( Reify )

27import Rel8.Schema.Result ( Result )

22import Rel8.Schema.Result ( Result )

@@ -31,13 +26,13 @@ type SContext :: Context -> Type

31data SContext context where

26data SContext context where

32 SAggregate :: SContext Aggregate

27 SAggregate :: SContext Aggregate

33 SExpr :: SContext Expr

28 SExpr :: SContext Expr

29+ SField :: SContext (Field table)

34 SName :: SContext Name

30 SName :: SContext Name

35 SResult :: SContext Result

31 SResult :: SContext Result

36− SReify :: SContext context -> SContext (Reify context)

39type Reifiable :: Context -> Constraint

34type Reifiable :: Context -> Constraint

40−class Interpretation context => Reifiable context where

35+class Reifiable context where

41 contextSing :: SContext context

36 contextSing :: SContext context

@@ -49,33 +44,13 @@ instance Reifiable Expr where

49 contextSing = SExpr

44 contextSing = SExpr

47+instance Reifiable (Field table) where

48+ contextSing = SField

49+

50+

52instance Reifiable Result where

51instance Reifiable Result where

53 contextSing = SResult

52 contextSing = SResult

56instance Reifiable Name where

55instance Reifiable Name where

57 contextSing = SName

56 contextSing = SName

58−

59−

60−instance Reifiable context => Reifiable (Reify context) where

61− contextSing = SReify contextSing

62−

63−

64−sReifiable :: SContext context -> Dict Reifiable context

65−sReifiable = \case

66− SAggregate -> Dict

67− SExpr -> Dict

68− SName -> Dict

69− SResult -> Dict

70− SReify context -> case sReifiable context of

71− Dict -> Dict

72−

73−

74−sLabelable :: SContext context -> Dict Labelable context

75−sLabelable = \case

76− SAggregate -> Dict

77− SExpr -> Dict

78− SName -> Dict

79− SResult -> Dict

80− SReify context -> case sLabelable context of

81− Dict -> Dict

src/Rel8/Kind/Labels.hsdeleted−57

@@ -1,57 +0,0 @@

1−{-# language DataKinds #-}

2−{-# language FlexibleContexts #-}

3−{-# language FlexibleInstances #-}

4−{-# language GADTs #-}

5−{-# language LambdaCase #-}

6−{-# language StandaloneKindSignatures #-}

7−{-# language TypeOperators #-}

8−

9−module Rel8.Kind.Labels

10− ( Labels

11− , SLabels( 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/Order.hs+2−9

@@ -4,7 +4,6 @@

5module Rel8.Order

6 ( Order(..)

7− , toOrderExprs

8 )

7 )

9where

8where

@@ -17,8 +16,7 @@ import Prelude

17import Data.Functor.Contravariant.Divisible ( Decidable, Divisible )

16import Data.Functor.Contravariant.Divisible ( Decidable, Divisible )

19-- opaleye

18-- opaleye

20−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

19+import qualified Opaleye.Order as Opaleye

21−import qualified Opaleye.Internal.Order as Opaleye

24-- | An ordering expression for @a@. Primitive orderings are defined with

22-- | An ordering expression for @a@. Primitive orderings are defined with

@@ -26,12 +24,7 @@ import qualified Opaleye.Internal.Order as Opaleye

26-- instances.

24-- instances.

27--

25--

28-- A common pattern is to use '<>' to combine multiple orderings in sequence,

26-- A common pattern is to use '<>' to combine multiple orderings in sequence,

29−-- and '>$<' (from 'Contravariant') to select individual columns.

27+-- and 'Data.Functor.Contravariant.>$<' to select individual columns.

30type Order :: Type -> Type

28type Order :: Type -> Type

31newtype Order a = Order (Opaleye.Order a)

29newtype Order a = Order (Opaleye.Order a)

32 deriving newtype (Contravariant, Divisible, Decidable, Semigroup, Monoid)

30 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+181−7

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

1−{-# language DerivingVia #-}

1+{-# language FlexibleContexts #-}

2−{-# language GeneralizedNewtypeDeriving #-}

3{-# language StandaloneKindSignatures #-}

2{-# language StandaloneKindSignatures #-}

3+{-# language UndecidableInstances #-}

5module Rel8.Query

6 ( Query( Query )

@@ -8,37 +8,201 @@ module Rel8.Query

8where

10-- base

11+import Control.Applicative ( liftA2 )

12+import Control.Monad ( liftM2 )

11import Data.Kind ( Type )

13import Data.Kind ( Type )

14+import Data.Monoid ( Any( Any ) )

12import Prelude

15import Prelude

14-- opaleye

17-- opaleye

15−import qualified Opaleye.Select as Opaleye

18+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

19+import qualified Opaleye.Internal.PackMap as Opaleye

20+import qualified Opaleye.Internal.PrimQuery as Opaleye hiding (lateral)

21+import qualified Opaleye.Internal.QueryArr as Opaleye

22+import qualified Opaleye.Internal.Tag as Opaleye

17-- rel8

24-- rel8

25+import Rel8.Expr ( Expr )

18import Rel8.Query.Set ( unionAll )

26import Rel8.Query.Set ( unionAll )

27+import Rel8.Query.Opaleye ( fromOpaleye )

19import Rel8.Query.Values ( values )

28import Rel8.Query.Values ( values )

29+import Rel8.Table ( Table, fromColumns, toColumns )

20import Rel8.Table.Alternative

30import Rel8.Table.Alternative

21 ( AltTable, (<|>:)

31 ( AltTable, (<|>:)

22 , AlternativeTable, emptyTable

32 , AlternativeTable, emptyTable

23 )

33 )

34+import Rel8.Table.Projection ( Projectable, apply, project )

25-- semigroupoids

36-- semigroupoids

26−import Data.Functor.Apply ( Apply, WrappedApplicative(..) )

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

27import Data.Functor.Bind ( Bind, (>>-) )

38import Data.Functor.Bind ( Bind, (>>-) )

30-- | The @Query@ monad allows you to compose a @SELECT@ query. This monad has

41-- | The @Query@ monad allows you to compose a @SELECT@ query. This monad has

31-- semantics similar to the list (@[]@) monad.

42-- semantics similar to the list (@[]@) monad.

32type Query :: Type -> Type

43type Query :: Type -> Type

33−newtype Query a = Query (Opaleye.Select a)

44+newtype Query a =

34− deriving newtype (Functor, Applicative, Monad)

45+ Query (

35− deriving Apply via (WrappedApplicative Opaleye.Select)

46+ -- This is based on Opaleye's Select monad, but with two addtions. We

47+ -- maintain a stack of PrimExprs from parent previous subselects. In

48+ -- practice, these are always the results of dummy calls to random().

49+ --

50+ -- We also return a Bool that indicates to the parent subselect whether

51+ -- or not that stack of PrimExprs were used at any point. If they weren't,

52+ -- then the call to random() is never added to the query.

53+ --

54+ -- This is all needed to implement evaluate. Consider the following code:

55+ --

56+ -- do

57+ -- x <- values [lit 'a', lit 'b', lit 'c']

58+ -- y <- evaluate $ nextval "user_id_seq"

59+ -- pure (x, y)

60+ --

61+ -- If we just used Opaleye's Select monad directly, the SQL would come out

62+ -- like this:

63+ --

64+ -- SELECT

65+ -- a, b

66+ -- FROM

67+ -- (VALUES ('a'), ('b'), ('c')) Q1(a),

68+ -- LATERAL (SELECT nextval('user_id_seq')) Q2(b);

69+ --

70+ -- From the Haskell code, you would intuitively expect to get back the

71+ -- results of three different calls to nextval(), but from Postgres' point

72+ -- of view, because the Q2 subquery doesn't reference anything from the Q1

73+ -- query, it thinks it only needs to call nextval() once. This is actually

74+ -- exactly the same problem you get with the deprecated ListT IO monad from

75+ -- the transformers package — *> behaves differently to >>=, so

76+ -- using ApplicativeDo can change the results of a program. ApplicativeDo

77+ -- is exactly the optimisation Postgres does on a "LATERAL" query that

78+ -- doesn't make any references to previous subselects.

79+ --

80+ -- Rel8's solution is generate the following SQL instead:

81+ --

82+ -- SELECT

83+ -- a, b

84+ -- FROM

85+ -- (SELECT

86+ -- random() AS dummy,

87+ -- *

88+ -- FROM

89+ -- (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1,

90+ -- LATERAL (SELECT

91+ -- CASE

92+ -- WHEN dummy IS NOT NULL

93+ -- THEN nextval('user_id_seq')

94+ -- END) Q2(b);

95+ --

96+ -- We use random() here as the dummy value (and not some constant) because

97+ -- Postgres will again optimize if it sees that a value is constant

98+ -- (and thus only call nextval() once), but because random() is marked as

99+ -- VOLATILE, this inhibits Postgres from doing that optimisation.

100+ --

101+ -- Why not just reference the a column from the previous query directly

102+ -- instead of adding a dummy value? Basically, even if we extract out all

103+ -- the bindings introduced in a PrimQuery, we can't always be sure which

104+ -- ones refer to constant values, so if we end up laterally referencing a

105+ -- constant value, then all of this would be for nothing.

106+ --

107+ -- Why not just add the call to the previous subselect directly, like so:

108+ --

109+ -- SELECT

110+ -- a, b

111+ -- FROM

112+ -- (SELECT

113+ -- nextval('user_id_seq') AS eval,

114+ -- *

115+ -- FROM

116+ -- (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1,

117+ -- LATERAL (SELECT eval) Q2(b);

118+ --

119+ -- That would work in this case. But consider the following Rel8 code:

120+ --

121+ -- do

122+ -- x <- values [lit 'a', lit 'b', lit 'c']

123+ -- y <- values [lit 'd', lit 'e', lit 'f']

124+ -- z <- evaluate $ nextval "user_id_seq"

125+ -- pure (x, y, z)

126+ --

127+ -- How many calls to nextval should there be? Our Haskell intuition says

128+ -- nine. But that's not what you would get if you used the above

129+ -- technique. The problem is, which VALUES query should the nextval be

130+ -- added to? You can choose one or the other to get three calls to

131+ -- nextval, but you still need to make a superfluous LATERAL references to

132+ -- the other if you want nine calls. So for the above Rel8 code we generate

133+ -- the following SQL:

134+ --

135+ -- SELECT

136+ -- a, b, c

137+ -- FROM

138+ -- (SELECT

139+ -- random() AS dummy,

140+ -- *

141+ -- FROM

142+ -- (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1,

143+ -- (SELECT

144+ -- random() AS dummy,

145+ -- *

146+ -- FROM

147+ -- (VALUES ('d'), ('e'), ('f')) Q2(b)) Q2,

148+ -- LATERAL (SELECT

149+ -- CASE

150+ -- WHEN Q1.dummy IS NOT NULL AND Q2.dummy IS NOT NULL

151+ -- THEN nextval('user_id_seq')

152+ -- END) Q3(c);

153+ --

154+ -- This gives nine calls to nextval() as we would expect.

155+ [Opaleye.PrimExpr] -> Opaleye.Select (Any, a)

156+ )

157+

158+

159+instance Projectable Query where

160+ project f = fmap (fromColumns . apply f . toColumns)

161+

162+

163+instance Functor Query where

164+ fmap f (Query a) = Query (fmap (fmap (fmap f)) a)

165+

166+

167+instance Apply Query where

168+ (<.>) = (<*>)

169+

170+

171+instance Applicative Query where

172+ pure = fromOpaleye . pure

173+ liftA2 = liftM2

174

175

38instance Bind Query where

176instance Bind Query where

39 (>>-) = (>>=)

177 (>>-) = (>>=)

178

179

180+instance Monad Query where

181+ Query q >>= f = Query $ \dummies -> Opaleye.stateQueryArr $ \_ tag ->

182+ let

183+ qa = q dummies

184+ ((m, a), query, tag') = Opaleye.runStateQueryArr qa () tag

185+ Query q' = f a

186+ (dummies', query', tag'') =

187+ ( dummy : dummies

188+ , query <> Opaleye.aRebind bindings

189+ , Opaleye.next tag'

190+ )

191+ where

192+ (dummy, bindings) = Opaleye.run $ name random

193+ where

194+ random = Opaleye.FunExpr "random" []

195+ name = Opaleye.extractAttr "dummy" tag'

196+ qa' = Opaleye.lateral $ \_ -> q' dummies'

197+ ((m'@(Any needsDummies), b), query'', tag''') = Opaleye.runStateQueryArr qa' () tag''

198+ query'''

199+ | needsDummies = query' <> query''

200+ | otherwise = query <> query''

201+ m'' = m <> m'

202+ in

203+ ((m'', b), query''', tag''')

204+

205+

42-- | '<|>:' = 'unionAll'.

206-- | '<|>:' = 'unionAll'.

43instance AltTable Query where

207instance AltTable Query where

44 (<|>:) = unionAll

208 (<|>:) = unionAll

@@ -47,3 +211,13 @@ instance AltTable Query where

47-- | 'emptyTable' = 'values' @[]@.

211-- | 'emptyTable' = 'values' @[]@.

48instance AlternativeTable Query where

212instance AlternativeTable Query where

49 emptyTable = values []

213 emptyTable = values []

214+

215+

216+-- | '<>' = 'unionAll'.

217+instance Table Expr a => Semigroup (Query a) where

218+ (<>) = (<|>:)

219+

220+

221+-- | 'mempty' = @'values' []@.

222+instance Table Expr a => Monoid (Query a) where

223+ mempty = emptyTable

src/Rel8/Query.hs-boot+3−1

@@ -7,11 +7,13 @@ where

8-- base

9import Data.Kind ( Type )

10+import Data.Monoid ( Any )

10import Prelude ()

11import Prelude ()

12-- opaleye

13-- opaleye

14+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

13import qualified Opaleye.Select as Opaleye

15import qualified Opaleye.Select as Opaleye

16type Query :: Type -> Type

18type Query :: Type -> Type

17−newtype Query a = Query (Opaleye.Select a)

19+newtype Query a = Query ([Opaleye.PrimExpr] -> Opaleye.Select (Any, a))

src/Rel8/Query/Aggregate.hs+19

@@ -1,13 +1,17 @@

1{-# language FlexibleContexts #-}

2{-# language MonoLocalBinds #-}

3+{-# language ScopedTypeVariables #-}

4+{-# language TypeApplications #-}

4module Rel8.Query.Aggregate

6module Rel8.Query.Aggregate

5 ( aggregate

7 ( aggregate

6 , countRows

8 , countRows

9+ , mode

7 )

10 )

8where

11where

10-- base

13-- base

14+import Data.Functor.Contravariant ( (>$<) )

11import Data.Int ( Int64 )

15import Data.Int ( Int64 )

12import Prelude

16import Prelude

@@ -18,9 +22,16 @@ import qualified Opaleye.Aggregate as Opaleye

18import Rel8.Aggregate ( Aggregates )

22import Rel8.Aggregate ( Aggregates )

19import Rel8.Expr ( Expr )

23import Rel8.Expr ( Expr )

20import Rel8.Expr.Aggregate ( countStar )

24import Rel8.Expr.Aggregate ( countStar )

25+import Rel8.Expr.Order ( desc )

21import Rel8.Query ( Query )

26import Rel8.Query ( Query )

27+import Rel8.Query.Limit ( limit )

22import Rel8.Query.Maybe ( optional )

28import Rel8.Query.Maybe ( optional )

23import Rel8.Query.Opaleye ( mapOpaleye )

29import Rel8.Query.Opaleye ( mapOpaleye )

30+import Rel8.Query.Order ( orderBy )

31+import Rel8.Table ( toColumns )

32+import Rel8.Table.Aggregate ( hgroupBy )

33+import Rel8.Table.Cols ( Cols( Cols ), fromCols )

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

24import Rel8.Table.Opaleye ( aggregator )

35import Rel8.Table.Opaleye ( aggregator )

25import Rel8.Table.Maybe ( maybeTable )

36import Rel8.Table.Maybe ( maybeTable )

@@ -35,3 +46,11 @@ aggregate = mapOpaleye (Opaleye.aggregate aggregator)

35-- will return @0@.

46-- will return @0@.

36countRows :: Query a -> Query (Expr Int64)

47countRows :: Query a -> Query (Expr Int64)

37countRows = fmap (maybeTable 0 id) . optional . aggregate . fmap (const countStar)

48countRows = fmap (maybeTable 0 id) . optional . aggregate . fmap (const countStar)

49+

50+

51+-- | Return the most common row in a query.

52+mode :: forall a. EqTable a => Query a -> Query a

53+mode rows = limit 1 $ fmap (fromCols . snd) $ orderBy (fst >$< desc) $ do

54+ aggregate $ do

55+ row <- toColumns <$> rows

56+ pure (countStar, Cols $ hgroupBy (eqTable @a) row)

src/Rel8/Query/Distinct.hs+4−9

@@ -1,5 +1,3 @@

1−{-# options_ghc -fno-warn-redundant-constraints #-}

2−

3module Rel8.Query.Distinct

1module Rel8.Query.Distinct

4 ( distinct

2 ( distinct

5 , distinctOn

3 , distinctOn

@@ -8,12 +6,11 @@ module Rel8.Query.Distinct

8where

6where

10-- base

8-- base

11−import Prelude

9+import Prelude ()

13-- opaleye

11-- opaleye

14import qualified Opaleye.Distinct as Opaleye

12import qualified Opaleye.Distinct as Opaleye

15−import qualified Opaleye.Internal.Order as Opaleye

13+import qualified Opaleye.Order as Opaleye

16−import qualified Opaleye.Internal.QueryArr as Opaleye

18-- rel8

15-- rel8

19import Rel8.Order ( Order( Order ) )

16import Rel8.Order ( Order( Order ) )

@@ -33,13 +30,11 @@ distinct = mapOpaleye (Opaleye.distinctExplicit distinctspec)

33-- to a projection. If multiple rows have the same projection, it is

30-- to a projection. If multiple rows have the same projection, it is

34-- unspecified which row will be returned. If this matters, use 'distinctOnBy'.

31-- unspecified which row will be returned. If this matters, use 'distinctOnBy'.

35distinctOn :: EqTable b => (a -> b) -> Query a -> Query a

32distinctOn :: EqTable b => (a -> b) -> Query a -> Query a

36−distinctOn proj =

37− mapOpaleye (\q -> Opaleye.productQueryArr (Opaleye.distinctOn unpackspec proj . Opaleye.runSimpleQueryArr q))

33+distinctOn proj = mapOpaleye (Opaleye.distinctOnExplicit unpackspec proj)

40-- | Select all distinct rows from a query, where rows are equivalent according

36-- | Select all distinct rows from a query, where rows are equivalent according

41-- to a projection. If there are multiple rows with the same projection, the

37-- to a projection. If there are multiple rows with the same projection, the

42-- first row according to the specified 'Order' will be returned.

38-- first row according to the specified 'Order' will be returned.

43distinctOnBy :: EqTable b => (a -> b) -> Order a -> Query a -> Query a

39distinctOnBy :: EqTable b => (a -> b) -> Order a -> Query a -> Query a

44−distinctOnBy proj (Order order) =

40+distinctOnBy proj (Order order) = mapOpaleye (Opaleye.distinctOnByExplicit unpackspec proj 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 ( fromColumns, toColumns )

20+import Rel8.Table.Cols ( fromCols, toCols )

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 fromColumns .

28+ fmap fromCols .

29 fromOpaleye .

30 Opaleye.selectTableExplicit unpackspec .

31 table .

32− fmap toColumns

32+ fmap toCols

src/Rel8/Query/Either.hs+27−17

@@ -3,23 +3,22 @@

3module Rel8.Query.Either

4 ( keepLeftTable

5 , keepRightTable

6− , bindEitherTable

7 , bitraverseEitherTable

6 , bitraverseEitherTable

8 )

7 )

9where

8where

11-- base

10-- base

12−import Data.Functor ( (<&>) )

13import Prelude

11import Prelude

13+-- comonad

14+import Control.Comonad ( extract )

15+

15-- rel8

16-- rel8

16import Rel8.Expr ( Expr )

17import Rel8.Expr ( Expr )

17import Rel8.Expr.Eq ( (==.) )

18import Rel8.Expr.Eq ( (==.) )

18import Rel8.Query ( Query )

19import Rel8.Query ( Query )

19import Rel8.Query.Filter ( where_ )

20import Rel8.Query.Filter ( where_ )

20import Rel8.Query.Maybe ( optional )

21import Rel8.Query.Maybe ( optional )

21−import Rel8.Table ( Table )

22−import Rel8.Table.Bool ( bool )

23import Rel8.Table.Either

22import Rel8.Table.Either

24 ( EitherTable( EitherTable )

23 ( EitherTable( EitherTable )

25 , isLeftTable, isRightTable

24 , isLeftTable, isRightTable

@@ -27,30 +26,41 @@ import Rel8.Table.Either

27import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )

26import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )

29+-- | Filter 'EitherTable's, keeping only 'leftTable's.

30−keepLeftTable :: EitherTable a b -> Query a

30+keepLeftTable :: EitherTable Expr a b -> Query a

31keepLeftTable e@(EitherTable _ a _) = do

32 where_ $ isLeftTable e

33− pure a

33+ pure (extract a)

36+-- | Filter 'EitherTable's, keeping only 'rightTable's.

36−keepRightTable :: EitherTable a b -> Query b

37+keepRightTable :: EitherTable Expr a b -> Query b

37keepRightTable e@(EitherTable _ _ b) = do

38keepRightTable e@(EitherTable _ _ b) = do

38 where_ $ isRightTable e

39 where_ $ isRightTable e

39− pure b

40+ pure (extract b)

40−

41−

42−bindEitherTable :: (Table Expr a, Functor m)

43− => (i -> m (EitherTable a b)) -> EitherTable a i -> m (EitherTable a b)

44−bindEitherTable query e@(EitherTable input a i) = do

45− query i <&> \(EitherTable output a' b) ->

46− EitherTable (input <> output) (bool a a' (isRightTable e)) b

43+-- | @bitraverseEitherTable f g x@ will pass all @leftTable@s through @f@ and

44+-- all @rightTable@s through @g@. The results are then lifted back into

45+-- @leftTable@ and @rightTable@, respectively. This is similar to 'bitraverse'

46+-- for 'Either'.

47+--

48+-- For example,

49+--

50+-- >>> :{

51+-- select do

52+-- x <- values (map lit [ Left True, Right (42 :: Int32) ])

53+-- bitraverseEitherTable (\y -> values [y, not_ y]) (\y -> pure (y * 100)) x

54+-- :}

55+-- [ Left True

56+-- , Left False

57+-- , Right 4200

58+-- ]

49bitraverseEitherTable :: ()

59bitraverseEitherTable :: ()

50 => (a -> Query c)

60 => (a -> Query c)

51 -> (b -> Query d)

61 -> (b -> Query d)

52− -> EitherTable a b

62+ -> EitherTable Expr a b

53− -> Query (EitherTable c d)

63+ -> Query (EitherTable Expr c d)

54bitraverseEitherTable f g e@(EitherTable tag _ _) = do

64bitraverseEitherTable f g e@(EitherTable tag _ _) = do

55 mc@(MaybeTable _ c) <- optional (f =<< keepLeftTable e)

65 mc@(MaybeTable _ c) <- optional (f =<< keepLeftTable e)

56 md@(MaybeTable _ d) <- optional (g =<< keepRightTable e)

66 md@(MaybeTable _ d) <- optional (g =<< keepRightTable e)

src/Rel8/Query/Evaluate.hs+28−62

@@ -1,83 +1,49 @@

1−{-# language DerivingStrategies #-}

2{-# language FlexibleContexts #-}

1{-# language FlexibleContexts #-}

3−{-# language GeneralizedNewtypeDeriving #-}

2+{-# language TupleSections #-}

4−{-# language NamedFieldPuns #-}

5−{-# language StandaloneKindSignatures #-}

7module Rel8.Query.Evaluate

4module Rel8.Query.Evaluate

8− ( Evaluate

9− , eval

10− , evaluate

5+ ( evaluate

11 )

6 )

12where

7where

14-- base

9-- base

15−import Data.Kind ( Type )

10+import Control.Monad ( (>=>) )

11+import Data.Foldable ( foldl' )

12+import Data.List.NonEmpty ( NonEmpty( (:|) ), nonEmpty )

16−import Data.Monoid ( Endo ( Endo ), appEndo )

13+import Data.Monoid ( Any( Any ) )

17−import Debug.Trace

18−import Prelude

14+import Prelude hiding ( undefined )

20-- opaleye

16-- opaleye

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

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

22−import qualified Opaleye.Internal.PackMap as Opaleye

23−import qualified Opaleye.Internal.PrimQuery as Opaleye

24−import qualified Opaleye.Internal.QueryArr as Opaleye

25−import qualified Opaleye.Internal.Tag as Opaleye

26−import qualified Opaleye.Internal.Unpackspec as Opaleye

28-- rel8

19-- rel8

29import Rel8.Expr ( Expr )

20import Rel8.Expr ( Expr )

21+import Rel8.Expr.Bool ( (&&.) )

22+import Rel8.Expr.Opaleye ( fromPrimExpr )

30import Rel8.Query ( Query( Query ) )

23import Rel8.Query ( Query( Query ) )

24+import Rel8.Query.Rebind ( rebind )

31import Rel8.Table ( Table )

25import Rel8.Table ( Table )

32−import Rel8.Table.Opaleye ( unpackspec )

26+import Rel8.Table.Bool ( case_ )

27+import Rel8.Table.Undefined ( undefined )

34−-- semigroupoids

35−import Data.Functor.Apply ( Apply )

36−import Data.Functor.Bind ( Bind, (>>-) )

38−-- transformers

30+-- | 'evaluate' takes expressions that could potentially have side effects and

39−import Control.Monad.Trans.State.Strict ( State, get, put, runState )

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"

42−type Evaluations :: Type

37+laterally :: Table Expr a => a -> Query a

43−data Evaluations = Evaluations

38+laterally a = Query $ \bindings -> pure $ (Any True,) $

44− { tag :: !Opaleye.Tag

39+ case nonEmpty bindings of

45− , bindings :: !(Endo (Opaleye.Bindings Opaleye.PrimExpr))

40+ Nothing -> a

46− }

41+ Just bindings' -> case_ [(condition, a)] undefined

42+ where

43+ condition = foldl1' (&&.) (fmap go bindings')

44+ where

45+ go = fromPrimExpr . Opaleye.UnExpr Opaleye.OpIsNotNull

49−-- | Some PostgreSQL functions, such as 'Rel8.nextval', have side effects,

48+foldl1' :: (a -> a -> a) -> NonEmpty a -> a

50−-- breaking the referential transparency we would otherwise enjoy.

49+foldl1' f (a :| as) = foldl' f a as

51−--

52−-- To try to recover our ability to reason about such expressions, 'Rel8'

53−-- provides the 'Evaluate' monad, which allows us to control the evaluation

54−-- order of side-effects by sequencing them monadically.

55−type Evaluate :: Type -> Type

56−newtype Evaluate a = Evaluate (State Evaluations a)

57− deriving newtype (Functor, Apply, Applicative, Monad)

58−

59−

60−instance Bind Evaluate where

61− (>>-) = (>>=)

62−

63−

64−-- | 'eval' takes expressions that could potentially have side effects and

65−-- lifts them into the 'Evaluate' monad. The resulting expressions has no side

66−-- effetcs and can safely be reused.

67−eval :: Table Expr a => a -> Evaluate a

68−eval a = Evaluate $ do

69− Evaluations {tag, bindings} <- get

70− let

71− tag' = Opaleye.next tag

72− (a', bindings') = Opaleye.run $

73− Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr "eval" tag') a

74− put Evaluations {tag = tag', bindings = bindings <> Endo (bindings' ++)}

75− pure a'

76−

77−

78−-- | 'evaluate' runs an 'Evaluate' inside the 'Query' monad.

79−evaluate :: Evaluate a -> Query a

80−evaluate (Evaluate m) = Query $ Opaleye.QueryArr $ \(_, query, tag) ->

81− case runState m (Evaluations tag mempty) of

82− (a, Evaluations {tag = tag', bindings}) ->

83− (a, Opaleye.Rebind True (traceShowId (appEndo bindings mempty)) query, tag')

src/Rel8/Query/Exists.hs+14−16

@@ -2,8 +2,8 @@

3module Rel8.Query.Exists

4 ( exists, inQuery

5− , whereExists, with, withBy

5+ , present, with, withBy

6− , whereNotExists, without, withoutBy

6+ , absent, without, withoutBy

7 )

8where

@@ -11,46 +11,44 @@ where

11import Prelude hiding ( filter )

13-- opaleye

14+import qualified Opaleye.Exists as Opaleye

14import qualified Opaleye.Operators as Opaleye

15import qualified Opaleye.Operators as Opaleye

16-- rel8

17-- rel8

17import Rel8.Expr ( Expr )

18import Rel8.Expr ( Expr )

19+import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )

18import Rel8.Query ( Query )

20import Rel8.Query ( Query )

19import Rel8.Query.Filter ( filter )

21import Rel8.Query.Filter ( filter )

20−import Rel8.Query.Maybe ( optional )

21import Rel8.Query.Opaleye ( mapOpaleye )

22import Rel8.Query.Opaleye ( mapOpaleye )

22import Rel8.Table.Eq ( EqTable, (==:) )

23import Rel8.Table.Eq ( EqTable, (==:) )

23−import Rel8.Table.Maybe ( isJustTable )

26-- | Checks if a query returns at least one row.

27exists :: Query a -> Query (Expr Bool)

28−exists = fmap isJustTable . optional . whereExists

28+exists = fmap (fromPrimExpr . fromColumn) . mapOpaleye Opaleye.exists

29−-- FIXME: change this when b7aacc07c6392654cae439fc3b997620c3aa7a87 makes it

30−-- into a release of Opaleye

33inQuery :: EqTable a => a -> Query a -> Query (Expr Bool)

31inQuery :: EqTable a => a -> Query a -> Query (Expr Bool)

34inQuery a = exists . (>>= filter (a ==:))

32inQuery a = exists . (>>= filter (a ==:))

37−-- | Produce the empty query if the given query returns no rows. @whereExists@

35+-- | Produce the empty query if the given query returns no rows. @present@

38-- is equivalent to @WHERE EXISTS@ in SQL.

36-- is equivalent to @WHERE EXISTS@ in SQL.

39−whereExists :: Query a -> Query ()

37+present :: Query a -> Query ()

40−whereExists = mapOpaleye Opaleye.restrictExists

38+present = mapOpaleye Opaleye.restrictExists

43−-- | Produce the empty query if the given query returns rows. @whereNotExists@

41+-- | Produce the empty query if the given query returns rows. @absent@

44-- is equivalent to @WHERE NOT EXISTS@ in SQL.

42-- is equivalent to @WHERE NOT EXISTS@ in SQL.

45−whereNotExists :: Query a -> Query ()

43+absent :: Query a -> Query ()

46−whereNotExists = mapOpaleye Opaleye.restrictNotExists

44+absent = mapOpaleye Opaleye.restrictNotExists

49-- | @with@ is similar to 'filter', but allows the predicate to be a full query.

47-- | @with@ is similar to 'filter', but allows the predicate to be a full query.

50--

48--

51−-- @with f a = a <$ whereExists (f a)@, but this form matches 'filter'.

49+-- @with f a = a <$ present (f a)@, but this form matches 'filter'.

52with :: (a -> Query b) -> a -> Query a

50with :: (a -> Query b) -> a -> Query a

53−with f a = a <$ whereExists (f a)

51+with f a = a <$ present (f a)

56-- | Like @with@, but with a custom membership test.

54-- | Like @with@, but with a custom membership test.

@@ -60,7 +58,7 @@ withBy predicate bs = with $ \a -> bs >>= filter (predicate a)

61-- | Filter rows where @a -> Query b@ yields no rows.

59-- | Filter rows where @a -> Query b@ yields no rows.

62without :: (a -> Query b) -> a -> Query a

60without :: (a -> Query b) -> a -> Query a

63−without f a = a <$ whereNotExists (f a)

61+without f a = a <$ absent (f a)

66-- | Like @without@, but with a custom membership test.

64-- | Like @without@, but with a custom membership test.

src/Rel8/Query/Indexed.hsnew file+21

@@ -0,0 +1,21 @@

1+module Rel8.Query.Indexed

2+ ( indexed

3+ )

4+where

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+36−16

@@ -19,16 +19,18 @@ import Prelude

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

21-- rel8

22−import Rel8.Expr ( Col( E, unE ), Expr )

22+import Rel8.Expr ( Expr )

23import Rel8.Expr.Aggregate ( listAggExpr, nonEmptyAggExpr )

24import Rel8.Expr.Opaleye ( mapPrimExpr )

25import Rel8.Query ( Query )

26import Rel8.Query.Aggregate ( aggregate )

27import Rel8.Query.Maybe ( optional )

28+import Rel8.Query.Rebind ( rebind )

28import Rel8.Schema.HTable.Vectorize ( hunvectorize )

29import Rel8.Schema.HTable.Vectorize ( hunvectorize )

29import Rel8.Schema.Null ( Sql, Unnullify )

30import Rel8.Schema.Null ( Sql, Unnullify )

30−import Rel8.Schema.Spec ( SSpec( SSpec, info ) )

31+import Rel8.Schema.Spec ( Spec( Spec, info ) )

31−import Rel8.Table ( Table, fromColumns, toColumns )

32+import Rel8.Table ( Table, fromColumns )

33+import Rel8.Table.Cols ( toCols )

32import Rel8.Table.Aggregate ( listAgg, nonEmptyAgg )

34import Rel8.Table.Aggregate ( listAgg, nonEmptyAgg )

33import Rel8.Table.List ( ListTable( ListTable ) )

35import Rel8.Table.List ( ListTable( ListTable ) )

34import Rel8.Table.Maybe ( maybeTable )

36import Rel8.Table.Maybe ( maybeTable )

@@ -42,15 +44,15 @@ import Rel8.Type.Information ( TypeInformation )

42-- rows, this function will produce a 'Query' that returns one row containing

44-- rows, this function will produce a 'Query' that returns one row containing

43-- the empty @ListTable@. If the supplied @Query@ does return rows, @many@ will

45-- the empty @ListTable@. If the supplied @Query@ does return rows, @many@ will

44-- return exactly one row, with a @ListTable@ collecting all returned rows.

46-- return exactly one row, with a @ListTable@ collecting all returned rows.

45−--

47+--

46-- @many@ is analogous to 'Control.Applicative.many' from

48-- @many@ is analogous to 'Control.Applicative.many' from

47-- @Control.Applicative@.

49-- @Control.Applicative@.

48−many :: Table Expr a => Query a -> Query (ListTable a)

50+many :: Table Expr a => Query a -> Query (ListTable Expr a)

49many =

51many =

50 fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .

52 fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .

51 optional .

53 optional .

52 aggregate .

54 aggregate .

53− fmap (listAgg . toColumns)

55+ fmap (listAgg . toCols)

56-- | Aggregate a 'Query' into a 'NonEmptyTable'. If the supplied query returns

58-- | Aggregate a 'Query' into a 'NonEmptyTable'. If the supplied query returns

@@ -61,11 +63,11 @@ many =

61--

63--

62-- @some@ is analogous to 'Control.Applicative.some' from

64-- @some@ is analogous to 'Control.Applicative.some' from

63-- @Control.Applicative@.

65-- @Control.Applicative@.

64−some :: Table Expr a => Query a -> Query (NonEmptyTable a)

66+some :: Table Expr a => Query a -> Query (NonEmptyTable Expr a)

65some =

67some =

66 fmap (\(NonEmptyTable a) -> NonEmptyTable a) .

68 fmap (\(NonEmptyTable a) -> NonEmptyTable a) .

67 aggregate .

69 aggregate .

68− fmap (nonEmptyAgg . toColumns)

70+ fmap (nonEmptyAgg . toCols)

71-- | A version of 'many' specialised to single expressions.

73-- | A version of 'many' specialised to single expressions.

@@ -78,22 +80,40 @@ someExpr :: Sql DBType a => Query (Expr a) -> Query (Expr (NonEmpty a))

78someExpr = aggregate . fmap nonEmptyAggExpr

80someExpr = aggregate . fmap nonEmptyAggExpr

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'.

81−catListTable :: Table Expr a => ListTable a -> Query a

87+catListTable :: Table Expr a => ListTable Expr a -> Query a

82−catListTable (ListTable as) = pure $ fromColumns $ runIdentity $

88+catListTable (ListTable as) =

89+ rebind "unnest" $ fromColumns $ runIdentity $

83− hunvectorize (\SSpec {info} -> pure . E . sunnest info . unE) as

90+ hunvectorize (\Spec {info} -> pure . sunnest info) as

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'.

86−catNonEmptyTable :: Table Expr a => NonEmptyTable a -> Query a

97+catNonEmptyTable :: Table Expr a => NonEmptyTable Expr a -> Query a

87−catNonEmptyTable (NonEmptyTable as) = pure $ fromColumns $ runIdentity $

98+catNonEmptyTable (NonEmptyTable as) =

99+ rebind "unnest" $ fromColumns $ runIdentity $

88− hunvectorize (\SSpec {info} -> pure . E . sunnest info . unE) as

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'.

91catList :: Sql DBType a => Expr [a] -> Query (Expr a)

107catList :: Sql DBType a => Expr [a] -> Query (Expr a)

92−catList = pure . sunnest typeInformation

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'.

95catNonEmpty :: Sql DBType a => Expr (NonEmpty a) -> Query (Expr a)

115catNonEmpty :: Sql DBType a => Expr (NonEmpty a) -> Query (Expr a)

96−catNonEmpty = pure . sunnest typeInformation

116+catNonEmpty = rebind "unnest" . sunnest typeInformation

117

118

99sunnest :: TypeInformation (Unnullify a) -> Expr (list a) -> Expr a

119sunnest :: TypeInformation (Unnullify a) -> Expr (list a) -> Expr a

src/Rel8/Query/Maybe.hs+26−45

@@ -1,7 +1,10 @@

1+{-# language GADTs #-}

2+{-# language LambdaCase #-}

3+{-# language NamedFieldPuns #-}

1module Rel8.Query.Maybe

5module Rel8.Query.Maybe

2 ( optional

6 ( optional

3 , catMaybeTable

7 , catMaybeTable

4− , bindMaybeTable

5 , traverseMaybeTable

8 , traverseMaybeTable

6 )

9 )

7where

10where

@@ -9,23 +12,20 @@ where

9-- base

12-- base

10import Prelude

13import Prelude

15+-- comonad

16+import Control.Comonad ( extract )

17+

12-- opaleye

18-- opaleye

13−import qualified Opaleye.Internal.PackMap as Opaleye

19+import qualified Opaleye.Internal.MaybeFields as Opaleye

14−import qualified Opaleye.Internal.PrimQuery as Opaleye

15−import qualified Opaleye.Internal.QueryArr as Opaleye

16−import qualified Opaleye.Internal.Tag as Opaleye

17−import qualified Opaleye.Internal.Unpackspec as Opaleye

19-- rel8

21-- rel8

20−import Rel8.Expr.Bool ( true )

22+import Rel8.Expr ( Expr )

21import Rel8.Expr.Eq ( (==.) )

23import Rel8.Expr.Eq ( (==.) )

22−import Rel8.Expr.Opaleye ( toPrimExpr )

24+import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )

23import Rel8.Query ( Query )

25import Rel8.Query ( Query )

24import Rel8.Query.Filter ( where_ )

26import Rel8.Query.Filter ( where_ )

25import Rel8.Query.Opaleye ( mapOpaleye )

27import Rel8.Query.Opaleye ( mapOpaleye )

26−import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )

28+import Rel8.Table.Maybe ( MaybeTable(..), isJustTable )

27−import Rel8.Table.Opaleye ( unpackspec )

28−import Rel8.Table.Tag ( Tag(..), fromExpr )

31-- | Convert a query that might return zero rows to a query that always returns

@@ -33,18 +33,11 @@ import Rel8.Table.Tag ( Tag(..), fromExpr )

33--

34-- To speak in more concrete terms, 'optional' is most useful to write @LEFT

35-- JOIN@s.

36−optional :: Query a -> Query (MaybeTable a)

36+optional :: Query a -> Query (MaybeTable Expr a)

37−optional = mapOpaleye $ Opaleye.QueryArr . go

37+optional = mapOpaleye $ Opaleye.optionalInternal $ \tag a -> MaybeTable

38− where

38+ { tag = fromPrimExpr $ fromColumn tag

39− go query (i, left, tag) =

39+ , just = pure a

40− (MaybeTable (fromExpr t') a, join, Opaleye.next tag')

40+ }

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

50-- | Filter out 'MaybeTable's, returning only the tables that are not-null.

43-- | Filter out 'MaybeTable's, returning only the tables that are not-null.

@@ -52,36 +45,24 @@ optional = mapOpaleye $ Opaleye.QueryArr . go

52-- This operation can be used to "undo" the effect of 'optional', which

45-- This operation can be used to "undo" the effect of 'optional', which

53-- operationally is like turning a @LEFT JOIN@ back into a full @JOIN@. You

46-- operationally is like turning a @LEFT JOIN@ back into a full @JOIN@. You

54-- can think of this as analogous to 'Data.Maybe.catMaybes'.

47-- can think of this as analogous to 'Data.Maybe.catMaybes'.

55−catMaybeTable :: MaybeTable a -> Query a

48+catMaybeTable :: MaybeTable Expr a -> Query a

56catMaybeTable ma@(MaybeTable _ a) = do

49catMaybeTable ma@(MaybeTable _ a) = do

57 where_ $ isJustTable ma

50 where_ $ isJustTable ma

58− pure a

51+ pure (extract 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

75-- | Extend an optional query with another query. This is useful if you want

54-- | Extend an optional query with another query. This is useful if you want

76-- to step through multiple @LEFT JOINs@.

55-- to step through multiple @LEFT JOINs@.

77--

56--

78-- Note that @traverseMaybeTable@ takes a @a -> Query b@ function, which means

57-- Note that @traverseMaybeTable@ takes a @a -> Query b@ function, which means

79−-- you also have the ability to "expand" one row into multiple rows. If the

58+-- you also have the ability to "expand" one row into multiple rows. If the

80-- @a -> Query b@ function returns no rows, then the resulting query will also

59-- @a -> Query b@ function returns no rows, then the resulting query will also

81-- have no rows. However, regardless of the given @a -> Query b@ function, if

60-- have no rows. However, regardless of the given @a -> Query b@ function, if

82−-- the input is @noTable@, you will always get exactly one @noTable@ back.

61+-- the input is @nothingTable@, you will always get exactly one @nothingTable@

62+-- back.

83−traverseMaybeTable :: (a -> Query b) -> MaybeTable a -> Query (MaybeTable b)

63+traverseMaybeTable :: (a -> Query b) -> MaybeTable Expr a -> Query (MaybeTable Expr b)

84traverseMaybeTable query ma@(MaybeTable input _) = do

64traverseMaybeTable query ma@(MaybeTable input _) = do

85− MaybeTable output b <- optional (query =<< catMaybeTable ma)

65+ optional (query =<< catMaybeTable ma) >>= \case

66+ MaybeTable output b -> do

86− where_ $ expr output ==. expr input

67+ where_ $ output ==. input

87− pure $ MaybeTable input b

68+ pure $ MaybeTable input b

src/Rel8/Query/Null.hs+15

@@ -1,5 +1,8 @@

1+{-# language FlexibleContexts #-}

1module Rel8.Query.Null

3module Rel8.Query.Null

2 ( catNull

4 ( catNull

5+ , catNullTable

3 )

6 )

4where

7where

@@ -9,6 +12,8 @@ import Prelude

9-- rel8

12-- rel8

10import Rel8.Expr ( Expr )

13import Rel8.Expr ( Expr )

11import Rel8.Expr.Null ( isNonNull, unsafeUnnullify )

14import Rel8.Expr.Null ( isNonNull, unsafeUnnullify )

15+import Rel8.Table ( Table )

16+import Rel8.Table.Null ( NullTable, isNonNullTable, unsafeUnnullifyTable )

12import Rel8.Query ( Query )

17import Rel8.Query ( Query )

13import Rel8.Query.Filter ( where_ )

18import Rel8.Query.Filter ( where_ )

@@ -21,3 +26,13 @@ catNull :: Expr (Maybe a) -> Query (Expr a)

21catNull a = do

26catNull a = do

22 where_ $ isNonNull a

27 where_ $ isNonNull a

23 pure $ unsafeUnnullify a

28 pure $ unsafeUnnullify a

29+

30+

31+-- | Filter a 'Query' that might return @nullTable@ to a 'Query' without any

32+-- @nullTable@s.

33+--

34+-- Corresponds to 'Data.Maybe.catMaybes'.

35+catNullTable :: Table Expr a => NullTable Expr a -> Query a

36+catNullTable a = do

37+ where_ $ isNonNullTable a

38+ pure $ unsafeUnnullifyTable a

src/Rel8/Query/Opaleye.hs+41−5

@@ -1,34 +1,70 @@

1+{-# language TupleSections #-}

1module Rel8.Query.Opaleye

3module Rel8.Query.Opaleye

2 ( fromOpaleye

4 ( fromOpaleye

3 , toOpaleye

5 , toOpaleye

4 , mapOpaleye

6 , mapOpaleye

5 , zipOpaleyeWith

7 , zipOpaleyeWith

8+ , unsafePeekQuery

6 )

9 )

7where

10where

9-- base

12-- base

13+import Control.Applicative ( liftA2 )

10import Prelude

14import Prelude

12-- opaleye

16-- opaleye

13−import qualified Opaleye.Select as Opaleye

17+import qualified Opaleye.Internal.QueryArr as Opaleye

18+import qualified Opaleye.Internal.Tag as Opaleye

15-- rel8

20-- rel8

16import {-# SOURCE #-} Rel8.Query ( Query( Query ) )

21import {-# SOURCE #-} Rel8.Query ( Query( Query ) )

19fromOpaleye :: Opaleye.Select a -> Query a

24fromOpaleye :: Opaleye.Select a -> Query a

20−fromOpaleye = Query

25+fromOpaleye = Query . pure . fmap pure

23toOpaleye :: Query a -> Opaleye.Select a

28toOpaleye :: Query a -> Opaleye.Select a

24−toOpaleye (Query a) = a

29+toOpaleye (Query a) = snd <$> a mempty

27mapOpaleye :: (Opaleye.Select a -> Opaleye.Select b) -> Query a -> Query b

32mapOpaleye :: (Opaleye.Select a -> Opaleye.Select b) -> Query a -> Query b

28−mapOpaleye f = fromOpaleye . f . toOpaleye

33+mapOpaleye f (Query a) = Query (fmap (mapping f) a)

31zipOpaleyeWith :: ()

36zipOpaleyeWith :: ()

32 => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)

37 => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)

33 -> Query a -> Query b -> Query c

38 -> Query a -> Query b -> Query c

34−zipOpaleyeWith f a b = fromOpaleye $ f (toOpaleye a) (toOpaleye b)

39+zipOpaleyeWith f (Query a) (Query b) = Query $ liftA2 (zipping f) a b

40+

41+

42+unsafePeekQuery :: Query a -> a

43+unsafePeekQuery (Query q) = case q mempty of

44+ f -> case Opaleye.runStateQueryArr f () Opaleye.start of

45+ ((_, a), _, _) -> a

46+

47+

48+mapping :: ()

49+ => (Opaleye.Select a -> Opaleye.Select b)

50+ -> Opaleye.Select (m, a) -> Opaleye.Select (m, b)

51+mapping f q = Opaleye.stateQueryArr $ \_ tag ->

52+ let

53+ ((m, _), _, _) = Opaleye.runStateQueryArr q () tag

54+ q' = (m,) <$> f (snd <$> q)

55+ in

56+ Opaleye.runStateQueryArr q' () tag

57+

58+

59+zipping :: Semigroup m

60+ => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)

61+ -> Opaleye.Select (m, a) -> Opaleye.Select (m, b) -> Opaleye.Select (m, c)

62+zipping f q q' =

63+ Opaleye.stateQueryArr $ \_ tag ->

64+ let

65+ ((m, _), _, _) = Opaleye.runStateQueryArr q () tag

66+ ((m', _), _, _) = Opaleye.runStateQueryArr q' () tag

67+ m'' = m <> m'

68+ q'' = (m'',) <$> f (snd <$> q) (snd <$> q')

69+ in

70+ Opaleye.runStateQueryArr q'' () tag

src/Rel8/Query/Rebind.hsnew file+27

@@ -0,0 +1,27 @@

1+{-# language FlexibleContexts #-}

3+module Rel8.Query.Rebind

4+ ( rebind

5+ )

6+where

8+-- base

9+import Prelude

10+import Control.Arrow ((<<<))

11+

12+-- opaleye

13+import qualified Opaleye.Internal.Rebind as Opaleye

14+

15+-- rel8

16+import Rel8.Expr ( Expr )

17+import Rel8.Query ( Query )

18+import Rel8.Table ( Table )

19+import Rel8.Table.Opaleye ( unpackspec )

20+import Rel8.Query.Opaleye (fromOpaleye)

21+

22+

23+-- | 'rebind' takes a variable name, some expressions, and binds each of them

24+-- to a new variable in the SQL. The @a@ returned consists only of these

25+-- variables. It's essentially a @let@ binding for Postgres expressions.

26+rebind :: Table Expr a => String -> a -> Query a

27+rebind prefix a = fromOpaleye (Opaleye.rebindExplicitPrefix prefix unpackspec <<< pure a)

src/Rel8/Query/SQL.hs+6−59

@@ -1,74 +1,21 @@

1{-# language FlexibleContexts #-}

2−{-# language TypeFamilies #-}

2+{-# language MonoLocalBinds #-}

3−{-# language ViewPatterns #-}

5module Rel8.Query.SQL

4module Rel8.Query.SQL

6 ( showQuery

5 ( showQuery

7− , sqlForQuery, sqlForQueryWithNames

8 )

6 )

9where

7where

11-- base

9-- base

12−import Data.Foldable ( fold )

13−import Data.Functor.Const ( Const( Const ), getConst )

14−import Data.Void ( Void )

15import Prelude

10import Prelude

17−-- opaleye

18−import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye

19−import qualified Opaleye.Internal.PrimQuery as Opaleye

20−import qualified Opaleye.Internal.Print as Opaleye

21−import qualified Opaleye.Internal.Optimize as Opaleye

22−import qualified Opaleye.Internal.QueryArr as Opaleye hiding ( Select )

23−import qualified Opaleye.Internal.Sql as Opaleye

24−

25-- rel8

12-- rel8

26−import Rel8.Expr ( Expr, Col( E ) )

13+import Rel8.Expr ( Expr )

27−import Rel8.Expr.Opaleye ( toPrimExpr )

28import Rel8.Query ( Query )

14import Rel8.Query ( Query )

29−import Rel8.Query.Opaleye ( toOpaleye )

15+import Rel8.Statement.Select ( ppSelect )

30−import Rel8.Schema.Name ( Name( Name ), Selects, Col( N ) )

31−import Rel8.Schema.HTable ( htabulateA, hfield )

32−import Rel8.Table ( Table, toColumns )

33−import Rel8.Table.Name ( namesFromLabels )

16+import Rel8.Table ( Table )

34−import Rel8.Table.Opaleye ( castTable )

37−-- | Convert a query to a 'String' containing the query as a @SELECT@

19+-- | Convert a 'Query' to a 'String' containing a @SELECT@ statement.

38−-- statement.

39showQuery :: Table Expr a => Query a -> String

20showQuery :: Table Expr a => Query a -> String

40−showQuery = fold . sqlForQuery

21+showQuery = show . ppSelect

41−

42−

43−sqlForQuery :: Table Expr a

44− => Query a -> Maybe String

45−sqlForQuery = sqlForQueryWithNames namesFromLabels . fmap toColumns

46−

47−

48−sqlForQueryWithNames :: Selects names exprs

49− => names -> Query exprs -> Maybe String

50−sqlForQueryWithNames names query =

51− show . Opaleye.ppSql . selectFrom names exprs <$> optimize primQuery

52− where

53− (exprs, primQuery, _) =

54− Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

55−

56−

57−optimize :: Opaleye.PrimQuery' a -> Maybe (Opaleye.PrimQuery' Void)

58−optimize = Opaleye.removeEmpty . Opaleye.optimize

59−

60−

61−selectFrom :: Selects names exprs

62− => names -> exprs -> Opaleye.PrimQuery' Void -> Opaleye.Select

63−selectFrom (toColumns -> names) (toColumns . castTable -> exprs) query =

64− Opaleye.SelectFrom $ Opaleye.newSelect

65− { Opaleye.attrs = Opaleye.SelectAttrs attributes

66− , Opaleye.tables = Opaleye.oneTable select

67− }

68− where

69− select = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator query

70− attributes = getConst $ htabulateA $ \field -> case hfield names field of

71− N (Name name) -> case hfield exprs field of

72− E (toPrimExpr -> expr) -> Const (pure (makeAttr name expr))

73− makeAttr label expr =

74− (Opaleye.sqlExpr expr, Just (Opaleye.SqlColumn label))

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 @x UNION b@.

26+-- duplicates. @union a b@ is the same as the SQL statement @a 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 @x UNION ALL b@.

32+-- @unionAll a b@ is the same as the SQL statement @a 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 @x INTERSECT b@.

38+-- b@ is the same as the SQL statement @a 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 @x INTERSECT ALL b@.

44+-- a b@ is the same as the SQL statement @a 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 @x INTERSECT b@.

50+-- the same as the SQL statement @a EXCEPT 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 @x EXCEPT ALL b@.

56+-- is the same as the SQL statement @a EXCEPT ALL b@.

57exceptAll :: EqTable a => Query a -> Query a -> Query a

58exceptAll = zipOpaleyeWith (Opaleye.exceptAllExplicit binaryspec)

src/Rel8/Query/These.hs+52−45

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

1{-# language FlexibleContexts #-}

2+{-# language GADTs #-}

3module Rel8.Query.These

4module Rel8.Query.These

4 ( alignBy

5 ( alignBy

@@ -7,7 +8,6 @@ module Rel8.Query.These

7 , keepThisTable, loseThisTable

8 , keepThisTable, loseThisTable

8 , keepThatTable, loseThatTable

9 , keepThatTable, loseThatTable

9 , keepThoseTable, loseThoseTable

10 , keepThoseTable, loseThoseTable

10− , bindTheseTable

11 , bitraverseTheseTable

12 )

13where

@@ -15,27 +15,29 @@ where

15-- base

16import Prelude

18+-- comonad

19+import Control.Comonad ( extract )

20+

18-- opaleye

21-- opaleye

19−import qualified Opaleye.Internal.Join as Opaleye

22+import qualified Opaleye.Internal.PackMap as Opaleye

20import qualified Opaleye.Internal.PrimQuery as Opaleye

23import qualified Opaleye.Internal.PrimQuery as Opaleye

24+import qualified Opaleye.Internal.QueryArr as Opaleye

25+import qualified Opaleye.Internal.Tag as Opaleye

22-- rel8

27-- rel8

23import Rel8.Expr ( Expr )

28import Rel8.Expr ( Expr )

24import Rel8.Expr.Bool ( boolExpr, not_ )

29import Rel8.Expr.Bool ( boolExpr, not_ )

25import Rel8.Expr.Eq ( (==.) )

30import Rel8.Expr.Eq ( (==.) )

26−import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )

31+import Rel8.Expr.Opaleye ( toPrimExpr, traversePrimExpr )

27import Rel8.Expr.Serialize ( litExpr )

32import Rel8.Expr.Serialize ( litExpr )

28import Rel8.Query ( Query )

33import Rel8.Query ( Query )

29import Rel8.Query.Filter ( where_ )

34import Rel8.Query.Filter ( where_ )

30import Rel8.Query.Maybe ( optional )

35import Rel8.Query.Maybe ( optional )

31import Rel8.Query.Opaleye ( zipOpaleyeWith )

36import Rel8.Query.Opaleye ( zipOpaleyeWith )

32−import Rel8.Table ( Table )

33import Rel8.Table.Either ( EitherTable( EitherTable ) )

37import Rel8.Table.Either ( EitherTable( EitherTable ) )

34import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )

38import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )

35−import Rel8.Table.Opaleye ( unpackspec )

36−import Rel8.Table.Tag ( Tag(..) )

37import Rel8.Table.These

39import Rel8.Table.These

38− ( TheseTable( TheseTable )

40+ ( TheseTable( TheseTable, here, there )

39 , hasHereTable, hasThereTable

41 , hasHereTable, hasThereTable

40 , isThisTable, isThatTable, isThoseTable

42 , isThisTable, isThatTable, isThoseTable

41 )

43 )

@@ -43,86 +45,91 @@ import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) )

45-- | Corresponds to a @FULL OUTER JOIN@ between two queries.

47-- | Corresponds to a @FULL OUTER JOIN@ between two queries.

46−alignBy :: (Table Expr a, Table Expr b)

48+alignBy :: ()

47 => (a -> b -> Expr Bool)

49 => (a -> b -> Expr Bool)

48− -> Query a -> Query b -> Query (TheseTable a b)

50+ -> Query a -> Query b -> Query (TheseTable Expr a b)

49−alignBy condition as bs =

51+alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.stateQueryArr $ \_ t -> case t of

50− uncurry TheseTable <$> zipOpaleyeWith fullOuterJoin as bs

52+ tag -> (tab, join', tag''')

51− where

53+ where

52− fullOuterJoin a b =

54+ (ma, left', tag') = Opaleye.runStateQueryArr (pure <$> left) () tag

53− Opaleye.joinExplicit unpackspec unpackspec pure pure full a b on

55+ (mb, right', tag'') = Opaleye.runStateQueryArr (pure <$> right) () tag'

54− where

56+ MaybeTable hasHere a = ma

57+ MaybeTable hasThere b = mb

58+ (hasHere', lbindings) = Opaleye.run $ do

59+ traversePrimExpr (Opaleye.extractAttr "hasHere" tag'') hasHere

60+ (hasThere', rbindings) = Opaleye.run $ do

61+ traversePrimExpr (Opaleye.extractAttr "hasThere" tag'') hasThere

62+ tag''' = Opaleye.next tag''

55− full = Opaleye.FullJoin

63+ join = Opaleye.Join Opaleye.FullJoin on left'' right''

56− on = toColumn . toPrimExpr . uncurry condition

64+ where

57−

65+ on = toPrimExpr $ condition (extract a) (extract b)

58−

66+ left'' = (Opaleye.NonLateral, Opaleye.toPrimQuery (left' <> Opaleye.aRebind lbindings))

67+ right'' = (Opaleye.NonLateral, Opaleye.toPrimQuery (right' <> Opaleye.aRebind rbindings))

68+ ma' = MaybeTable hasHere' a

69+ mb' = MaybeTable hasThere' b

70+ tab = TheseTable {here = ma', there = mb'}

71+ join' = Opaleye.aProduct join

72+

73+

59−keepHereTable :: TheseTable a b -> Query (a, MaybeTable b)

74+keepHereTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)

60keepHereTable = loseThatTable

75keepHereTable = loseThatTable

63−loseHereTable :: TheseTable a b -> Query b

78+loseHereTable :: TheseTable Expr a b -> Query b

64loseHereTable = keepThatTable

79loseHereTable = keepThatTable

67−keepThereTable :: TheseTable a b -> Query (MaybeTable a, b)

82+keepThereTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)

68keepThereTable = loseThisTable

83keepThereTable = loseThisTable

71−loseThereTable :: TheseTable a b -> Query a

86+loseThereTable :: TheseTable Expr a b -> Query a

72loseThereTable = keepThisTable

87loseThereTable = keepThisTable

75−keepThisTable :: TheseTable a b -> Query a

90+keepThisTable :: TheseTable Expr a b -> Query a

76keepThisTable t@(TheseTable (MaybeTable _ a) _) = do

91keepThisTable t@(TheseTable (MaybeTable _ a) _) = do

77 where_ $ isThisTable t

92 where_ $ isThisTable t

78− pure a

93+ pure (extract a)

81−loseThisTable :: TheseTable a b -> Query (MaybeTable a, b)

96+loseThisTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)

82loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do

97loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do

83 where_ $ not_ $ isThisTable t

98 where_ $ not_ $ isThisTable t

84− pure (ma, b)

99+ pure (ma, extract b)

100

101

87−keepThatTable :: TheseTable a b -> Query b

102+keepThatTable :: TheseTable Expr a b -> Query b

88keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do

103keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do

89 where_ $ isThatTable t

104 where_ $ isThatTable t

90− pure b

105+ pure (extract b)

106

107

93−loseThatTable :: TheseTable a b -> Query (a, MaybeTable b)

108+loseThatTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)

94loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do

109loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do

95 where_ $ not_ $ isThatTable t

110 where_ $ not_ $ isThatTable t

96− pure (a, mb)

111+ pure (extract a, mb)

112

113

99−keepThoseTable :: TheseTable a b -> Query (a, b)

114+keepThoseTable :: TheseTable Expr a b -> Query (a, b)

100keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do

115keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do

101 where_ $ isThoseTable t

116 where_ $ isThoseTable t

102− pure (a, b)

117+ pure (extract a, extract b)

103

118

104

119

105−loseThoseTable :: TheseTable a b -> Query (EitherTable a b)

120+loseThoseTable :: TheseTable Expr a b -> Query (EitherTable Expr a b)

106loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do

121loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do

107 where_ $ not_ $ isThoseTable t

122 where_ $ not_ $ isThoseTable t

108− pure $ EitherTable result a b

123+ pure $ EitherTable tag a b

109 where

124 where

110 tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)

125 tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)

111− result = (mempty `asTypeOf` result) {expr = tag}

112−

113−

114−bindTheseTable :: (Table Expr a, Semigroup a, Monad m)

115− => (i -> m (TheseTable a b)) -> TheseTable a i -> m (TheseTable a b)

116−bindTheseTable query (TheseTable here (MaybeTable input i)) = do

117− TheseTable here' (MaybeTable output b) <- query i

118− pure $ TheseTable (here <> here') (MaybeTable (input <> output) b)

119

126

120

127

121bitraverseTheseTable :: ()

128bitraverseTheseTable :: ()

122 => (a -> Query c)

129 => (a -> Query c)

123 -> (b -> Query d)

130 -> (b -> Query d)

124− -> TheseTable a b

131+ -> TheseTable Expr a b

125− -> Query (TheseTable c d)

132+ -> Query (TheseTable Expr c d)

126bitraverseTheseTable f g t = do

133bitraverseTheseTable f g t = do

127 mc <- optional (f . fst =<< keepHereTable t)

134 mc <- optional (f . fst =<< keepHereTable t)

128 md <- optional (g . snd =<< keepThereTable t)

135 md <- optional (g . snd =<< keepThereTable t)

src/Rel8/Query/Window.hsnew file+26

@@ -0,0 +1,26 @@

1+module Rel8.Query.Window

2+ ( window

3+ )

4+where

6+-- base

7+import Prelude ()

9+-- opaleye

10+import qualified Opaleye.Window as Opaleye

11+

12+-- rel8

13+import Rel8.Query ( Query )

14+import Rel8.Query.Opaleye ( mapOpaleye )

15+import Rel8.Window ( Window( Window ) )

16+

17+

18+-- | 'window' runs a query composed of expressions containing

19+-- [window functions](https://www.postgresql.org/docs/current/tutorial-window.html).

20+-- 'window' is similar to 'Rel8.aggregate', with the main difference being

21+-- that in a window query, each input row corresponds to one output row,

22+-- whereas aggregation queries fold the entire input query down into a single

23+-- row. To put this into a Haskell context, 'Rel8.aggregate' is to 'foldl' as

24+-- 'window' is to 'scanl'.

25+window :: Window a b -> Query a -> Query b

26+window (Window a) = mapOpaleye (Opaleye.runWindows a)

src/Rel8/Schema/Context.hsdeleted−20

@@ -1,20 +0,0 @@

1−{-# language DataKinds #-}

2−{-# language StandaloneKindSignatures #-}

3−{-# language TypeFamilies #-}

4−

5−module Rel8.Schema.Context

6− ( Interpretation( Col )

7− )

8−where

9−

10−-- base

11−import Data.Kind ( Constraint )

12−import Prelude ()

13−

14−-- rel8

15−import Rel8.Schema.Kind ( Context, HContext )

16−

17−

18−type Interpretation :: Context -> Constraint

19−class Interpretation context where

20− data Col context :: HContext

src/Rel8/Schema/Context/Label.hsdeleted−60

@@ -1,60 +0,0 @@

1−{-# language DataKinds #-}

2−{-# language FlexibleInstances #-}

3−{-# language StandaloneKindSignatures #-}

4−{-# language TypeFamilies #-}

5−{-# language TypeOperators #-}

6−

7−module Rel8.Schema.Context.Label

8− ( Labelable( labeler, unlabeler )

9− , HLabelable( hlabeler, hunlabeler )

10− )

11−where

12−

13−-- base

14−import Data.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( R ), 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 a)

30− -> Col context ('Spec (label ': labels) a)

31−

32− unlabeler :: ()

33− => Col context ('Spec (label ': labels) a)

34− -> Col context ('Spec labels a)

35−

36−

37−instance Labelable Result where

38− labeler (R a) = R a

39− unlabeler (R a) = R a

40−

41−

42−type HLabelable :: HContext -> Constraint

43−class HLabelable context where

44− hlabeler :: ()

45− => context ('Spec labels a)

46− -> context ('Spec (label ': labels) a)

47−

48− hunlabeler :: ()

49− => context ('Spec (label ': labels) a)

50− -> context ('Spec labels a)

51−

52−

53−instance Labelable context => HLabelable (Col context) where

54− hlabeler = labeler

55− hunlabeler = unlabeler

56−

57−

58−instance HLabelable (Dict (ConstrainDBType constraint)) where

59− hlabeler Dict = Dict

60− hunlabeler Dict = Dict

src/Rel8/Schema/Context/Nullify.hs+105−149

@@ -1,188 +1,144 @@

1{-# language DataKinds #-}

2+{-# language EmptyCase #-}

2{-# language FlexibleContexts #-}

3{-# language FlexibleContexts #-}

3−{-# language FlexibleInstances #-}

4+{-# language GADTs #-}

4−{-# language InstanceSigs #-}

5+{-# language LambdaCase #-}

5−{-# language MultiParamTypeClasses #-}

6{-# language NamedFieldPuns #-}

7−{-# language ScopedTypeVariables #-}

8{-# language StandaloneKindSignatures #-}

7{-# language StandaloneKindSignatures #-}

9−{-# language TypeFamilies #-}

11module Rel8.Schema.Context.Nullify

9module Rel8.Schema.Context.Nullify

10+ ( Nullifiability(..), NonNullifiability(..), nullifiableOrNot, absurd

11+ , Nullifiable, nullifiability

12− ( Nullifiable( ConstrainTag, encodeTag, decodeTag, nullifier, unnullifier )

12+ , guarder, nullifier, unnullifier

13− , HNullifiable( HConstrainTag, hencodeTag, hdecodeTag, hnullifier, hunnullifier )

13+ , sguard, snullify

14− , runTag, unnull

15 )

14 )

16where

15where

18-- base

17-- base

18+import Data.Bool ( bool )

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

19import Data.Kind ( Constraint, Type )

20import 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

27+import Rel8.Aggregate ( Aggregate(..), zipOutputs )

28− ( Aggregate( Aggregate ), Col( A )

29− , mapInputs

30− , unsafeMakeAggregate

31− )

32−import Rel8.Expr ( Expr, Col( E ) )

28+import Rel8.Expr ( Expr )

33import Rel8.Expr.Bool ( boolExpr )

29import Rel8.Expr.Bool ( boolExpr )

34import Rel8.Expr.Null ( nullify, unsafeUnnullify )

30import Rel8.Expr.Null ( nullify, unsafeUnnullify )

35−import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )

31+import Rel8.Expr.Opaleye ( fromPrimExpr )

32+import Rel8.Kind.Context ( SContext(..) )

36−import Rel8.Schema.Context ( Interpretation )

33+import Rel8.Schema.Field ( Field )

37import qualified Rel8.Schema.Kind as K

34import qualified Rel8.Schema.Kind as K

38−import Rel8.Schema.Name ( Name( Name ), Col( N ) )

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

39−import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql )

36+import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )

40−import Rel8.Schema.Dict ( Dict( Dict ) )

37+import Rel8.Schema.Result ( Result )

41−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

38+import Rel8.Schema.Spec ( Spec(..) )

42−import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )

43−import qualified Rel8.Schema.Spec.ConstrainDBType as ConstrainDBType

44−import Rel8.Table.Tag ( Tag(..), Taggable, fromAggregate, fromExpr, fromName )

45−

47−type Nullifiable :: K.Context -> Constraint

48−class Interpretation context => Nullifiable context where

49− type ConstrainTag context :: Type -> Constraint

50− type ConstrainTag _context = DefaultConstrainTag

51−

52− encodeTag ::

53− ( Sql (ConstrainTag context) a

54− , KnownSymbol label

55− , Taggable a

56− )

57− => Tag label a

58− -> Col context ('Spec labels a)

59−

60− decodeTag ::

61− ( Sql (ConstrainTag context) a

62− , KnownSymbol label

63− , Taggable a

64− )

65− => Col context ('Spec labels a)

66− -> Tag label a

67−

68− nullifier :: ()

69− => Tag label a

70− -> (Expr a -> Expr Bool)

71− -> SSpec ('Spec labels x)

72− -> Col context ('Spec labels x)

73− -> Col context ('Spec labels (Nullify x))

74−

75− unnullifier :: ()

76− => SSpec ('Spec labels x)

77− -> Col context ('Spec labels (Nullify x))

78− -> Col context ('Spec labels x)

41+type Nullifiability :: K.Context -> Type

42+data Nullifiability context where

43+ NAggregate :: Nullifiability Aggregate

44+ NExpr :: Nullifiability Expr

45+ NName :: Nullifiability Name

81−instance Nullifiable Aggregate where

82− encodeTag Tag {aggregator, expr} =

83− A $ unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr

85− decodeTag (A aggregate) = fromAggregate aggregate

48+type Nullifiable :: K.Context -> Constraint

86−

49+class Nullifiable context where

87− nullifier Tag {expr} test SSpec {nullity} (A (Aggregate a)) =

50+ nullifiability :: Nullifiability context

88− A $

89− mapInputs (toPrimExpr . runTag nullity condition . fromPrimExpr) $

90− Aggregate $

91− runTag nullity condition <$> a

92− where

93− condition = test expr

95− unnullifier SSpec {nullity} (A (Aggregate a)) =

96− A (Aggregate (unnull nullity <$> a))

98− {-# INLINABLE encodeTag #-}

53+instance Nullifiable Aggregate where

99− {-# INLINABLE decodeTag #-}

54+ nullifiability = NAggregate

100− {-# INLINABLE nullifier #-}

101− {-# INLINABLE unnullifier #-}

102

103

104instance Nullifiable Expr where

57instance Nullifiable Expr where

105− encodeTag Tag {expr} = E expr

58+ nullifiability = NExpr

106− decodeTag (E a) = fromExpr a

107− nullifier Tag {expr} test SSpec {nullity} (E a) =

108− E $ runTag nullity (test expr) a

109− unnullifier SSpec {nullity} (E a) = E $ unnull nullity a

110−

111− {-# INLINABLE encodeTag #-}

112− {-# INLINABLE decodeTag #-}

113− {-# INLINABLE nullifier #-}

114− {-# INLINABLE unnullifier #-}

115

116

117instance Nullifiable Name where

61instance Nullifiable Name where

118− encodeTag Tag {name} = N name

62+ nullifiability = NName

119− decodeTag (N name) = fromName name

63+

120− nullifier _ _ _ (N (Name name)) = N (Name name)

64+

121− unnullifier _ (N (Name name)) = N (Name name)

65+type NonNullifiability :: K.Context -> Type

122−

66+data NonNullifiability context where

123− {-# INLINABLE encodeTag #-}

67+ NField :: NonNullifiability (Field table)

124− {-# INLINABLE decodeTag #-}

68+ NResult :: NonNullifiability Result

125− {-# INLINABLE nullifier #-}

69+

126− {-# INLINABLE unnullifier #-}

70+

127−

71+nullifiableOrNot :: ()

128−

72+ => SContext context

129−runTag :: Nullity a -> Expr Bool -> Expr a -> Expr (Nullify a)

73+ -> Either (NonNullifiability context) (Nullifiability context)

130−runTag nullity tag a = case nullity of

74+nullifiableOrNot = \case

131− Null -> boolExpr null a tag

75+ SAggregate -> Right NAggregate

132− NotNull -> boolExpr null (nullify a) tag

76+ SExpr -> Right NExpr

77+ SField -> Left NField

78+ SName -> Right NName

79+ SResult -> Left NResult

80+

81+

82+absurd :: Nullifiability context -> NonNullifiability context -> a

83+absurd = \case

84+ NAggregate -> \case

85+ NExpr -> \case

86+ NName -> \case

87+

88+

89+guarder :: ()

90+ => SContext context

91+ -> context tag

92+ -> (tag -> Bool)

93+ -> (Expr tag -> Expr Bool)

94+ -> context (Maybe a)

95+ -> context (Maybe a)

96+guarder = \case

97+ SAggregate -> \tag _ isNonNull -> zipOutputs (sguard . isNonNull) tag

98+ SExpr -> \tag _ isNonNull -> sguard (isNonNull tag)

99+ SField -> \_ _ _ -> id

100+ SName -> \_ _ _ -> id

101+ SResult -> \(Identity tag) isNonNull _ (Identity a) ->

102+ Identity (bool Nothing a (isNonNull tag))

103+

104+

105+nullifier :: ()

106+ => Nullifiability context

107+ -> Spec a

108+ -> context a

109+ -> context (Nullify a)

110+nullifier = \case

111+ NAggregate -> \Spec {nullity} (Aggregate a) ->

112+ Aggregate $ snullify nullity <$> a

113+ NExpr -> \Spec {nullity} a -> snullify nullity a

114+ NName -> \_ (Name a) -> Name a

115+

116+

117+unnullifier :: ()

118+ => Nullifiability context

119+ -> Spec a

120+ -> context (Nullify a)

121+ -> context a

122+unnullifier = \case

123+ NAggregate -> \Spec {nullity} (Aggregate a) ->

124+ Aggregate $ sunnullify nullity <$> a

125+ NExpr -> \Spec {nullity} a -> sunnullify nullity a

126+ NName -> \_ (Name a) -> Name a

127+

128+

129+sguard :: Expr Bool -> Expr (Maybe a) -> Expr (Maybe a)

130+sguard condition a = boolExpr null a condition

133 where

131 where

134 null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit

132 null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit

135

133

136

134

137−unnull :: Nullity a -> Expr (Nullify a) -> Expr a

135+snullify :: Nullity a -> Expr a -> Expr (Nullify a)

138−unnull nullity a = case nullity of

136+snullify nullity a = case nullity of

139 Null -> a

137 Null -> a

140− NotNull -> unsafeUnnullify a

138+ NotNull -> nullify a

141−

142

139

143−type HNullifiable :: K.HContext -> Constraint

144−class HNullifiable context where

145− type HConstrainTag context :: Type -> Constraint

146− type HConstrainTag _context = DefaultConstrainTag

147

140

148− hencodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)

141+sunnullify :: Nullity a -> Expr (Nullify a) -> Expr a

149− => Tag label a

142+sunnullify nullity a = case nullity of

150− -> context ('Spec labels a)

143+ Null -> a

151−

144+ NotNull -> unsafeUnnullify a

152− hdecodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)

153− => context ('Spec labels a)

154− -> Tag label a

155−

156− hnullifier :: ()

157− => Tag label a

158− -> (Expr a -> Expr Bool)

159− -> SSpec ('Spec labels x)

160− -> context ('Spec labels x)

161− -> context ('Spec labels (Nullify x))

162−

163− hunnullifier :: ()

164− => SSpec ('Spec labels x)

165− -> context ('Spec labels (Nullify x))

166− -> context ('Spec labels 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.hsnew file+50

@@ -0,0 +1,50 @@

1+{-# language DataKinds #-}

2+{-# language FlexibleContexts #-}

3+{-# language MultiParamTypeClasses #-}

4+{-# language StandaloneKindSignatures #-}

5+{-# language TypeFamilies #-}

7+module Rel8.Schema.Field

8+ ( Field(..)

9+ , fields

10+ )

11+where

12+

13+-- base

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

15+import Data.Kind ( Type )

16+import Prelude

17+

18+-- rel8

19+import Rel8.Schema.HTable ( HField, htabulate )

20+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

21+import Rel8.Schema.Kind as K

22+import Rel8.Schema.Null ( Sql )

23+import Rel8.Table

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

25+ , FromExprs, fromResult, toResult

26+ , Transpose

27+ )

28+import Rel8.Table.Transpose ( Transposes )

29+import Rel8.Type ( DBType )

30+

31+

32+-- | A special context used in the construction of 'Rel8.Projection's.

33+type Field :: Type -> K.Context

34+newtype Field table a = Field (HField (Columns table) a)

35+

36+

37+instance Sql DBType a => Table (Field table) (Field table a) where

38+ type Columns (Field table a) = HIdentity a

39+ type Context (Field table a) = Field table

40+ type FromExprs (Field table a) = a

41+ type Transpose to (Field table a) = to a

42+

43+ toColumns = HIdentity

44+ fromColumns (HIdentity a) = a

45+ toResult a = HIdentity (Identity a)

46+ fromResult (HIdentity (Identity a)) = a

47+

48+

49+fields :: Transposes context (Field table) table fields => fields

50+fields = fromColumns $ htabulate Field

src/Rel8/Schema/HTable.hs+51−24

@@ -16,11 +16,12 @@

16module Rel8.Schema.HTable

17 ( HTable (HField, HConstrainTable)

18 , hfield, htabulate, htraverse, hdicts, hspecs

19− , hmap, htabulateA

19+ , hfoldMap, hmap, htabulateA, htraverseP, htraversePWithField

20 )

21where

23-- base

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

24import Data.Kind ( Constraint, Type )

25import Data.Kind ( Constraint, Type )

25import Data.Functor.Compose ( Compose( Compose ), getCompose )

26import Data.Functor.Compose ( Compose( Compose ), getCompose )

26import Data.Proxy ( Proxy )

27import Data.Proxy ( Proxy )

@@ -32,16 +33,21 @@ import GHC.Generics

32 )

33 )

33import Prelude

34import Prelude

36+-- profunctors

37+import Data.Profunctor ( rmap, Profunctor (lmap) )

38+

39+-- product-profunctors

40+import Data.Profunctor.Product ( ProductProfunctor ((****)) )

41+

35-- rel8

42-- rel8

36import Rel8.Schema.Dict ( Dict )

43import Rel8.Schema.Dict ( Dict )

37−import Rel8.Schema.Spec ( Spec, SSpec )

44+import Rel8.Schema.Spec ( Spec )

38import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )

45import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )

39import qualified Rel8.Schema.Kind as K

46import qualified Rel8.Schema.Kind as K

41-- semigroupoids

48-- semigroupoids

42import Data.Functor.Apply ( Apply, (<.>) )

49import Data.Functor.Apply ( Apply, (<.>) )

44−

45-- | A @HTable@ is a functor-indexed/higher-kinded data type that is

51-- | A @HTable@ is a functor-indexed/higher-kinded data type that is

46-- representable ('htabulate'/'hfield'), constrainable ('hdicts'), and

52-- representable ('htabulate'/'hfield'), constrainable ('hdicts'), and

47-- specified ('hspecs').

53-- specified ('hspecs').

@@ -50,14 +56,14 @@ import Data.Functor.Apply ( Apply, (<.>) )

50-- instances yourself or specify this constraint.

56-- instances yourself or specify this constraint.

51type HTable :: K.HTable -> Constraint

57type HTable :: K.HTable -> Constraint

52class HTable t where

58class HTable t where

53− type HField t = (field :: Spec -> Type) | field -> t

59+ type HField t = (field :: Type -> Type) | field -> t

54− type HConstrainTable t (c :: Spec -> Constraint) :: Constraint

60+ type HConstrainTable t (c :: Type -> Constraint) :: Constraint

56− hfield :: t context -> HField t spec -> context spec

62+ hfield :: t context -> HField t a -> context a

57− htabulate :: (forall spec. HField t spec -> context spec) -> t context

63+ htabulate :: (forall a. HField t a -> context a) -> t context

58− htraverse :: Apply m => (forall spec. f spec -> m (g spec)) -> t f -> m (t g)

64+ htraverse :: Apply m => (forall a. f a -> m (g a)) -> t f -> m (t g)

59 hdicts :: HConstrainTable t c => t (Dict c)

65 hdicts :: HConstrainTable t c => t (Dict c)

60− hspecs :: t SSpec

66+ hspecs :: t Spec

62 type HField t = GHField t

68 type HField t = GHField t

63 type HConstrainTable t c = HConstrainTable (GHColumns (Rep (t Proxy))) c

69 type HConstrainTable t c = HConstrainTable (GHColumns (Rep (t Proxy))) c

@@ -68,7 +74,7 @@ class HTable t where

68 , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))

74 , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))

69 , GHTable context (Rep (t context))

75 , GHTable context (Rep (t context))

70 )

76 )

71− => t context -> HField t spec -> context spec

77+ => t context -> HField t a -> context a

72 hfield table (GHField field) = hfield (toGHColumns (from table)) field

78 hfield table (GHField field) = hfield (toGHColumns (from table)) field

74 default htabulate ::

80 default htabulate ::

@@ -77,7 +83,7 @@ class HTable t where

77 , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))

83 , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))

78 , GHTable context (Rep (t context))

84 , GHTable context (Rep (t context))

79 )

85 )

80− => (forall spec. HField t spec -> context spec) -> t context

86+ => (forall a. HField t a -> context a) -> t context

81 htabulate f = to $ fromGHColumns $ htabulate (f . GHField)

87 htabulate f = to $ fromGHColumns $ htabulate (f . GHField)

83 default htraverse

89 default htraverse

@@ -87,7 +93,7 @@ class HTable t where

87 , Generic (t g), GHTable g (Rep (t g))

93 , Generic (t g), GHTable g (Rep (t g))

88 , GHColumns (Rep (t f)) ~ GHColumns (Rep (t g))

94 , GHColumns (Rep (t f)) ~ GHColumns (Rep (t g))

89 )

95 )

90− => (forall spec. f spec -> m (g spec)) -> t f -> m (t g)

96+ => (forall a. f a -> m (g a)) -> t f -> m (t g)

91 htraverse f = fmap (to . fromGHColumns) . htraverse f . toGHColumns . from

97 htraverse f = fmap (to . fromGHColumns) . htraverse f . toGHColumns . from

93 default hdicts

99 default hdicts

@@ -101,10 +107,10 @@ class HTable t where

101 hdicts = to $ fromGHColumns (hdicts @(GHColumns (Rep (t Proxy))) @c)

107 hdicts = to $ fromGHColumns (hdicts @(GHColumns (Rep (t Proxy))) @c)

102

108

103 default hspecs ::

109 default hspecs ::

104− ( Generic (t SSpec)

110+ ( Generic (t Spec)

105− , GHTable SSpec (Rep (t SSpec))

111+ , GHTable Spec (Rep (t Spec))

106 )

112 )

107− => t SSpec

113+ => t Spec

108 hspecs = to $ fromGHColumns hspecs

114 hspecs = to $ fromGHColumns hspecs

109

115

110 {-# INLINABLE hfield #-}

116 {-# INLINABLE hfield #-}

@@ -114,22 +120,43 @@ class HTable t where

114 {-# INLINABLE hspecs #-}

120 {-# INLINABLE hspecs #-}

115

121

116

122

123+hfoldMap :: (HTable t, Semigroup s)

124+ => (forall a. context a -> s) -> t context -> s

125+hfoldMap f a = getConst $ htraverse (Const . f) a

126+

127+

117hmap :: HTable t

128hmap :: HTable t

118− => (forall spec. context spec -> context' spec) -> t context -> t context'

129+ => (forall a. context a -> context' a) -> t context -> t context'

119hmap f a = htabulate $ \field -> f (hfield a field)

130hmap f a = htabulate $ \field -> f (hfield a field)

120

131

121

132

122htabulateA :: (HTable t, Apply m)

133htabulateA :: (HTable t, Apply m)

123− => (forall spec. HField t spec -> m (context spec)) -> m (t context)

134+ => (forall a. HField t a -> m (context a)) -> m (t context)

124htabulateA f = htraverse getCompose $ htabulate $ Compose . f

135htabulateA f = htraverse getCompose $ htabulate $ Compose . f

125{-# INLINABLE htabulateA #-}

136{-# INLINABLE htabulateA #-}

126

137

138+newtype ApplyP p a b = ApplyP { unApplyP :: p a b }

139+

140+instance Profunctor p => Functor (ApplyP p a) where

141+ fmap f = ApplyP . rmap f . unApplyP

142+

143+instance ProductProfunctor p => Apply (ApplyP p a) where

144+ ApplyP f <.> ApplyP x = ApplyP (rmap id f **** x)

145+

146+htraverseP :: (HTable t, ProductProfunctor p)

147+ => (forall a. p (f a) (g a)) -> p (t f) (t g)

148+htraverseP f = htraversePWithField (const f)

149+

150+htraversePWithField :: (HTable t, ProductProfunctor p)

151+ => (forall a. HField t a -> p (f a) (g a)) -> p (t f) (t g)

152+htraversePWithField f = unApplyP $ htabulateA $ \field -> ApplyP $

153+ lmap (flip hfield field) (f field)

127

154

128−type GHField :: K.HTable -> Spec -> Type

155+type GHField :: K.HTable -> Type -> Type

129−newtype GHField t spec = GHField (HField (GHColumns (Rep (t Proxy))) spec)

156+newtype GHField t a = GHField (HField (GHColumns (Rep (t Proxy))) a)

130

157

131

158

132−type GHTable :: K.HContext -> (Type -> Type) -> Constraint

159+type GHTable :: K.Context -> (Type -> Type) -> Constraint

133class HTable (GHColumns rep) => GHTable context rep | rep -> context where

160class HTable (GHColumns rep) => GHTable context rep | rep -> context where

134 type GHColumns rep :: K.HTable

161 type GHColumns rep :: K.HTable

135 toGHColumns :: rep x -> GHColumns rep context

162 toGHColumns :: rep x -> GHColumns rep context

@@ -155,10 +182,10 @@ instance (GHTable context a, GHTable context b) => GHTable context (a :*: b) whe

155

182

156

183

157-- | A HField type for indexing into HProduct.

184-- | A HField type for indexing into HProduct.

158−type HProductField :: K.HTable -> K.HTable -> Spec -> Type

185+type HProductField :: K.HTable -> K.HTable -> Type -> Type

159−data HProductField x y spec

186+data HProductField x y a

160− = HFst (HField x spec)

187+ = HFst (HField x a)

161− | HSnd (HField y spec)

188+ | HSnd (HField y a)

162

189

163

190

164instance (HTable x, HTable y) => HTable (HProduct x y) where

191instance (HTable x, HTable y) => HTable (HProduct x y) where

src/Rel8/Schema/HTable/Either.hs+2−3

@@ -15,17 +15,16 @@ import Prelude ()

16-- rel8

17import Rel8.Schema.HTable ( HTable )

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

18+import Rel8.Schema.HTable.Identity ( HIdentity )

19import Rel8.Schema.HTable.Label ( HLabel )

20import Rel8.Schema.HTable.Nullify ( HNullify )

21import qualified Rel8.Schema.Kind as K

22−import Rel8.Schema.Spec ( Spec( Spec ) )

23import Rel8.Type.Tag ( EitherTag )

22import Rel8.Type.Tag ( EitherTag )

26type HEitherTable :: K.HTable -> K.HTable -> K.HTable

25type HEitherTable :: K.HTable -> K.HTable -> K.HTable

27data HEitherTable left right context = HEitherTable

26data HEitherTable left right context = HEitherTable

28− { htag :: HIdentity ('Spec '["isRight"] EitherTag) context

27+ { htag :: HLabel "isRight" (HIdentity EitherTag) context

29 , hleft :: HLabel "Left" (HNullify left) context

28 , hleft :: HLabel "Left" (HNullify left) context

30 , hright :: HLabel "Right" (HNullify right) context

29 , hright :: HLabel "Right" (HNullify right) context

31 }

30 }

src/Rel8/Schema/HTable/Identity.hs+16−28

@@ -1,17 +1,17 @@

1{-# language DataKinds #-}

2−{-# language GADTs #-}

2+{-# language FlexibleContexts #-}

3−{-# language PatternSynonyms #-}

4{-# language StandaloneKindSignatures #-}

3{-# language StandaloneKindSignatures #-}

5{-# language TypeFamilies #-}

4{-# language TypeFamilies #-}

5+{-# language UndecidableInstances #-}

7module Rel8.Schema.HTable.Identity

8− ( HIdentity( HIdentity, HType, unHIdentity )

8+ ( HIdentity( HIdentity, unHIdentity )

9− , HType

10 )

9 )

11where

10where

13-- base

12-- base

14import Data.Kind ( Type )

13import Data.Kind ( Type )

14+import Data.Type.Equality ( (:~:)( Refl ) )

15import Prelude

17-- rel8

@@ -21,35 +21,23 @@ import Rel8.Schema.HTable

21 , hfield, htabulate, htraverse, hdicts, hspecs

22 )

23import qualified Rel8.Schema.Kind as K

24−import Rel8.Schema.Spec ( Spec( Spec ), KnownSpec, specSing )

24+import Rel8.Schema.Null ( Sql )

25+import Rel8.Schema.Spec ( specification )

26+import Rel8.Type ( DBType )

27−type HType :: Type -> K.HTable

29+type HIdentity :: Type -> K.HTable

28−type HType a = HIdentity ('Spec '[] a)

29−

30−

31−pattern HType :: context ('Spec '[] a) -> HType a context

32−pattern HType a = HIdentity a

33−{-# COMPLETE HType #-}

34−

35−

36−type HIdentity :: Spec -> K.HTable

37−newtype HIdentity spec context = HIdentity

30+newtype HIdentity a context = HIdentity

38− { unHIdentity :: context spec

31+ { unHIdentity :: context a

39 }

32 }

42−type HIdentityField :: Spec -> Spec -> Type

43−data HIdentityField _spec spec where

44− HIdentityField :: HIdentityField spec spec

45−

46−

47−instance KnownSpec spec => HTable (HIdentity spec) where

35+instance Sql DBType a => HTable (HIdentity a) where

48− type HConstrainTable (HIdentity spec) c = c spec

36+ type HConstrainTable (HIdentity a) constraint = constraint a

49− type HField (HIdentity spec) = HIdentityField spec

37+ type HField (HIdentity a) = (:~:) a

51− hfield (HIdentity a) HIdentityField = a

39+ hfield (HIdentity a) Refl = a

52− htabulate f = HIdentity $ f HIdentityField

40+ htabulate f = HIdentity $ f Refl

53 htraverse f (HIdentity a) = HIdentity <$> f a

41 htraverse f (HIdentity a) = HIdentity <$> f a

54 hdicts = HIdentity Dict

42 hdicts = HIdentity Dict

55− hspecs = HIdentity specSing

43+ hspecs = HIdentity specification

src/Rel8/Schema/HTable/Label.hs+37−50

@@ -1,83 +1,70 @@

1−{-# LANGUAGE DeriveAnyClass #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE DerivingStrategies #-}

4−{-# LANGUAGE LambdaCase #-}

5−{-# language ConstraintKinds #-}

6{-# language DataKinds #-}

1{-# language DataKinds #-}

7−{-# language FlexibleInstances #-}

8−{-# language GADTs #-}

9−{-# language MultiParamTypeClasses #-}

10−{-# language QuantifiedConstraints #-}

11{-# language RankNTypes #-}

2{-# language RankNTypes #-}

12{-# language RecordWildCards #-}

3{-# language RecordWildCards #-}

13{-# language ScopedTypeVariables #-}

4{-# language ScopedTypeVariables #-}

14{-# language StandaloneKindSignatures #-}

5{-# language StandaloneKindSignatures #-}

6+{-# language TypeApplications #-}

15{-# language TypeFamilies #-}

7{-# language TypeFamilies #-}

16−{-# language TypeOperators #-}

17−{-# language UndecidableInstances #-}

19module Rel8.Schema.HTable.Label

9module Rel8.Schema.HTable.Label

20− ( HLabel, Label

21− , hlabel, hunlabel

10+ ( HLabel, hlabel, hrelabel, hunlabel

11+ , hproject

22 )

12 )

23where

13where

25-- base

15-- base

16+import Data.Kind ( Type )

26import Data.Proxy ( Proxy( Proxy ) )

17import Data.Proxy ( Proxy( Proxy ) )

27−import GHC.TypeLits ( KnownSymbol, Symbol )

18+import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )

28import Prelude

19import Prelude

30-- rel8

21-- rel8

31−import Rel8.Kind.Labels ( SLabels( SCons ) )

32import Rel8.Schema.HTable

22import Rel8.Schema.HTable

33− ( HTable

23+ ( HTable, HConstrainTable, HField

34− , hfield, htabulate, hspecs

24+ , htabulate, hfield, htraverse, hdicts, hspecs

35 )

25 )

36import qualified Rel8.Schema.Kind as K

26import qualified Rel8.Schema.Kind as K

37−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

27+import Rel8.Schema.Spec ( Spec(..) )

38−import Rel8.FCF

39−import Rel8.Schema.HTable.MapTable

40−import GHC.Generics (Generic)

43type HLabel :: Symbol -> K.HTable -> K.HTable

30type HLabel :: Symbol -> K.HTable -> K.HTable

44−newtype HLabel label table context = HLabel (HMapTable (Label label) table context)

31+newtype HLabel label table context = HLabel (table context)

45− deriving stock Generic

46− deriving anyclass HTable

49−data Label :: Symbol -> Spec -> Exp Spec

34+type HLabelField :: Symbol -> K.HTable -> Type -> Type

35+newtype HLabelField label table a = HLabelField (HField table a)

52−type instance Eval (Label label ('Spec labels a)) = 'Spec (label : labels) a

38+instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where

39+ type HField (HLabel label table) = HLabelField label table

40+ type HConstrainTable (HLabel label table) constraint =

41+ HConstrainTable table constraint

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 #-}

55−instance KnownSymbol l => MapSpec (Label l) where

56− mapInfo = \case

57− SSpec {..} -> SSpec {labels = SCons Proxy labels, ..}

59−

60−hlabel :: (HTable t, KnownSymbol label)

61− => (forall labels a. ()

62− => context ('Spec labels a)

63− -> context ('Spec (label ': labels) a))

64− -> t context

65− -> HLabel label t context

52+hlabel :: forall label t context. t context -> HLabel label t context

66−hlabel labeler a = HLabel $ htabulate $ \(HMapTableField field) ->

53+hlabel = HLabel

67− case hfield hspecs field of

68− SSpec {} -> labeler (hfield a field)

69{-# INLINABLE hlabel #-}

54{-# INLINABLE hlabel #-}

72−hunlabel :: (HTable t, KnownSymbol label)

57+hrelabel :: forall label' label t context. HLabel label t context -> HLabel label' t context

73− => (forall labels a. ()

58+hrelabel = hlabel . hunlabel

74− => context ('Spec (label ': labels) a)

59+{-# INLINABLE hrelabel #-}

75− -> context ('Spec labels a))

60+

76− -> HLabel label t context

61+

77− -> t context

62+hunlabel :: forall label t context. HLabel label t context -> t context

78−hunlabel unlabler (HLabel as) =

63+hunlabel (HLabel a) = a

79− htabulate $ \field ->

80− case hfield hspecs field of

81− SSpec {} -> case hfield as (HMapTableField field) of

82− a -> unlabler a

83{-# INLINABLE hunlabel #-}

64{-# INLINABLE hunlabel #-}

65+

66+

67+hproject :: ()

68+ => (forall ctx. t ctx -> t' ctx)

69+ -> HLabel label t context -> HLabel label t' context

70+hproject f (HLabel a) = HLabel (f a)

src/Rel8/Schema/HTable/MapTable.hs+22−12

@@ -6,7 +6,7 @@

6{-# language GADTs #-}

7{-# language InstanceSigs #-}

8{-# language MultiParamTypeClasses #-}

9−{-# language PolyKinds #-}

9+{-# language RankNTypes #-}

10{-# language ScopedTypeVariables #-}

11{-# language StandaloneKindSignatures #-}

12{-# language TypeApplications #-}

@@ -19,34 +19,38 @@ module Rel8.Schema.HTable.MapTable

19 , MapSpec(..)

20 , Precompose(..)

21 , HMapTableField(..)

22+ , hproject

22 )

23 )

23where

24where

25-- base

26-- base

26import Data.Kind ( Constraint, Type )

27import Data.Kind ( Constraint, Type )

27−import Prelude ( ($), (.), (<$>), fmap )

28+import Prelude

29-- rel8

30-- rel8

30−import Rel8.FCF

31+import Rel8.FCF ( Exp, Eval )

31import Rel8.Schema.HTable

32import Rel8.Schema.HTable

33+ ( HTable, HConstrainTable, HField

34+ , hfield, htabulate, htraverse, hdicts, hspecs

35+ )

32−import Rel8.Schema.Spec ( Spec, SSpec )

36+import Rel8.Schema.Spec ( Spec )

33import qualified Rel8.Schema.Kind as K

37import qualified Rel8.Schema.Kind as K

34import Rel8.Schema.Dict ( Dict( Dict ) )

38import Rel8.Schema.Dict ( Dict( Dict ) )

37−type HMapTable :: (a -> Exp b) -> ((a -> Type) -> Type) -> (b -> Type) -> Type

41+type HMapTable :: (Type -> Exp Type) -> K.HTable -> K.HTable

38−newtype HMapTable f t g = HMapTable

42+newtype HMapTable f t context = HMapTable

39− { unHMapTable :: t (Precompose f g)

43+ { unHMapTable :: t (Precompose f context)

40 }

44 }

43−type Precompose :: (a -> Exp b) -> (b -> Type) -> a -> Type

47+type Precompose :: (Type -> Exp Type) -> K.Context -> K.Context

44newtype Precompose f g x = Precompose

48newtype Precompose f g x = Precompose

45 { precomposed :: g (Eval (f x))

49 { precomposed :: g (Eval (f x))

46 }

50 }

49−type HMapTableField :: (Spec -> Exp a) -> K.HTable -> a -> Type

53+type HMapTableField :: (Type -> Exp Type) -> K.HTable -> K.Context

50data HMapTableField f t x where

54data HMapTableField f t x where

51 HMapTableField :: HField t a -> HMapTableField f t (Eval (f a))

55 HMapTableField :: HField t a -> HMapTableField f t (Eval (f a))

@@ -79,11 +83,17 @@ instance (HTable t, MapSpec f) => HTable (HMapTable f t) where

79 {-# INLINABLE hspecs #-}

83 {-# INLINABLE hspecs #-}

82−type MapSpec :: (Spec -> Exp Spec) -> Constraint

86+type MapSpec :: (Type -> Exp Type) -> Constraint

83class MapSpec f where

87class MapSpec f where

84− mapInfo :: SSpec x -> SSpec (Eval (f x))

88+ mapInfo :: Spec x -> Spec (Eval (f x))

87−type ComposeConstraint :: (a -> Exp b) -> (b -> Constraint) -> a -> Constraint

91+type ComposeConstraint :: (Type -> Exp Type) -> (Type -> Constraint) -> Type -> Constraint

88class c (Eval (f a)) => ComposeConstraint f c a

92class c (Eval (f a)) => ComposeConstraint f c a

89instance c (Eval (f a)) => ComposeConstraint f c a

93instance c (Eval (f a)) => ComposeConstraint f c a

94+

95+

96+hproject :: ()

97+ => (forall ctx. t ctx -> t' ctx)

98+ -> HMapTable f t context -> HMapTable f t' context

99+hproject f (HMapTable a) = HMapTable (f a)

src/Rel8/Schema/HTable/Maybe.hs+2−3

@@ -15,17 +15,16 @@ import Prelude

16-- rel8

17import Rel8.Schema.HTable ( HTable )

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

18+import Rel8.Schema.HTable.Identity ( HIdentity )

19import Rel8.Schema.HTable.Label ( HLabel )

20import Rel8.Schema.HTable.Nullify ( HNullify )

21import qualified Rel8.Schema.Kind as K

22−import Rel8.Schema.Spec ( Spec( Spec ) )

23import Rel8.Type.Tag ( MaybeTag )

22import Rel8.Type.Tag ( MaybeTag )

26type HMaybeTable :: K.HTable -> K.HTable

25type HMaybeTable :: K.HTable -> K.HTable

27data HMaybeTable table context = HMaybeTable

26data HMaybeTable table context = HMaybeTable

28− { htag :: HIdentity ('Spec '["isJust"] (Maybe MaybeTag)) context

27+ { htag :: HLabel "isJust" (HIdentity (Maybe MaybeTag)) context

29 , hjust :: HLabel "Just" (HNullify table) context

28 , hjust :: HLabel "Just" (HNullify table) context

30 }

29 }

31 deriving stock Generic

30 deriving stock Generic

src/Rel8/Schema/HTable/Nullify.hs+47−32

@@ -10,6 +10,7 @@

10{-# language NamedFieldPuns #-}

11{-# language QuantifiedConstraints #-}

12{-# language RankNTypes #-}

13+{-# language RecordWildCards #-}

13{-# language ScopedTypeVariables #-}

14{-# language ScopedTypeVariables #-}

14{-# language StandaloneKindSignatures #-}

15{-# language StandaloneKindSignatures #-}

15{-# language TypeFamilies #-}

16{-# language TypeFamilies #-}

@@ -18,25 +19,34 @@

18module Rel8.Schema.HTable.Nullify

19module Rel8.Schema.HTable.Nullify

19 ( HNullify( HNullify )

20 ( HNullify( HNullify )

20 , Nullify

21 , Nullify

22+ , hguard

23+ , hnulls

24+ , hnullify

21− , hnulls, hnullify, hunnullify

25+ , hunnullify

26+ , hproject

22 )

27 )

23where

28where

25-- base

30-- base

31+import Data.Kind ( Type )

32+import GHC.Generics ( Generic )

26import Prelude hiding ( null )

33import Prelude hiding ( null )

28-- rel8

35-- rel8

36+import Rel8.FCF ( Eval, Exp )

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

37import 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 )

30import qualified Rel8.Schema.Kind as K

43import qualified Rel8.Schema.Kind as K

31import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

44import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

32import qualified Rel8.Schema.Null as Type ( Nullify )

45import qualified Rel8.Schema.Null as Type ( Nullify )

33−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

46+import Rel8.Schema.Spec ( Spec(..) )

35-- semigroupoids

48-- semigroupoids

36import Data.Functor.Apply ( Apply )

49import Data.Functor.Apply ( Apply )

37−import Rel8.Schema.HTable.MapTable

38−import Rel8.FCF

39−import GHC.Generics (Generic)

42type HNullify :: K.HTable -> K.HTable

52type HNullify :: K.HTable -> K.HTable

@@ -45,58 +55,63 @@ newtype HNullify table context = HNullify (HMapTable Nullify table context)

45 deriving anyclass HTable

55 deriving anyclass HTable

48−

49−-- | Transform a 'Spec' by allowing it to be @null@.

58+-- | Transform a 'Type' by allowing it to be @null@.

50−data Nullify :: Spec -> Exp Spec

59+data Nullify :: Type -> Exp Type

51−

52−

53−type instance Eval (Nullify ('Spec labels a)) =

60+type instance Eval (Nullify a) = Type.Nullify a

54− 'Spec labels (Type.Nullify a)

57instance MapSpec Nullify where

63instance MapSpec Nullify where

58 mapInfo = \case

64 mapInfo = \case

59− SSpec{labels, info, nullity} -> SSpec

65+ Spec {nullity, ..} -> Spec

60− { labels

61− , info

62− , nullity = case nullity of

66+ { nullity = case nullity of

63 Null -> Null

67 Null -> Null

64 NotNull -> Null

68 NotNull -> Null

65− }

69+ , ..

70+ }

71+

72+

73+hguard :: HTable t

74+ => (forall a. context (Maybe a) -> context (Maybe a))

75+ -> HNullify t context -> HNullify t context

76+hguard guarder (HNullify as) = HNullify $ htabulate $ \(HMapTableField field) ->

77+ case hfield hspecs field of

78+ Spec {nullity} -> case hfield as (HMapTableField field) of

79+ a -> case nullity of

80+ Null -> guarder a

81+ NotNull -> guarder a

68hnulls :: HTable t

84hnulls :: HTable t

69− => (forall labels a. ()

70− => SSpec ('Spec labels a)

71− -> context ('Spec labels (Type.Nullify a)))

85+ => (forall a. Spec a -> context (Type.Nullify a))

72 -> HNullify t context

86 -> HNullify t context

73−hnulls null = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of

87+hnulls null = HNullify $ htabulate $ \(HMapTableField field) ->

88+ case hfield hspecs field of

74− spec@SSpec {} -> null spec

89+ spec@Spec {} -> null spec

75{-# INLINABLE hnulls #-}

90{-# INLINABLE hnulls #-}

78hnullify :: HTable t

93hnullify :: HTable t

79− => (forall labels a. ()

80− => SSpec ('Spec labels a)

81− -> context ('Spec labels a)

82− -> context ('Spec labels (Type.Nullify a)))

94+ => (forall a. Spec a -> context a -> context (Type.Nullify a))

83 -> t context

95 -> t context

84 -> HNullify t context

96 -> HNullify t context

85hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->

97hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->

86 case hfield hspecs field of

98 case hfield hspecs field of

87− spec@SSpec {} -> nullifier spec (hfield a field)

99+ spec@Spec {} -> nullifier spec (hfield a field)

88{-# INLINABLE hnullify #-}

100{-# INLINABLE hnullify #-}

101

102

91hunnullify :: (HTable t, Apply m)

103hunnullify :: (HTable t, Apply m)

92− => (forall labels a. ()

93− => SSpec ('Spec labels a)

94− -> context ('Spec labels (Type.Nullify a))

104+ => (forall a. Spec a -> context (Type.Nullify a) -> m (context a))

95− -> m (context ('Spec labels a)))

96 -> HNullify t context

105 -> HNullify t context

97 -> m (t context)

106 -> m (t context)

98hunnullify unnullifier (HNullify as) =

107hunnullify unnullifier (HNullify as) =

99 htabulateA $ \field -> case hfield hspecs field of

108 htabulateA $ \field -> case hfield hspecs field of

100− spec@SSpec {} -> case hfield as (HMapTableField field) of

109+ spec@Spec {} -> case hfield as (HMapTableField field) of

101 a -> unnullifier spec a

110 a -> unnullifier spec a

102{-# INLINABLE hunnullify #-}

111{-# INLINABLE hunnullify #-}

112+

113+

114+hproject :: ()

115+ => (forall ctx. t ctx -> t' ctx)

116+ -> HNullify t context -> HNullify t' context

117+hproject f (HNullify a) = HNullify (HMapTable.hproject f a)

src/Rel8/Schema/HTable/These.hs+2−3

@@ -19,15 +19,14 @@ import Rel8.Schema.HTable.Identity ( HIdentity )

19import Rel8.Schema.HTable.Label ( HLabel )

20import Rel8.Schema.HTable.Nullify ( HNullify )

21import qualified Rel8.Schema.Kind as K

22−import Rel8.Schema.Spec ( Spec( Spec ) )

23import Rel8.Type.Tag ( MaybeTag )

22import Rel8.Type.Tag ( MaybeTag )

26type HTheseTable :: K.HTable -> K.HTable -> K.HTable

25type HTheseTable :: K.HTable -> K.HTable -> K.HTable

27data HTheseTable here there context = HTheseTable

26data HTheseTable here there context = HTheseTable

28− { hhereTag :: HIdentity ('Spec '["hasHere"] (Maybe MaybeTag)) context

27+ { hhereTag :: HLabel "hereTag" (HIdentity (Maybe MaybeTag)) context

29 , hhere :: HLabel "Here" (HNullify here) context

28 , hhere :: HLabel "Here" (HNullify here) context

30− , hthereTag :: HIdentity ('Spec '["hasThere"] (Maybe MaybeTag)) context

29+ , hthereTag :: HLabel "thereTag" (HIdentity (Maybe MaybeTag)) context

31 , hthere :: HLabel "There" (HNullify there) context

30 , hthere :: HLabel "There" (HNullify there) context

32 }

31 }

33 deriving stock Generic

32 deriving stock Generic

src/Rel8/Schema/HTable/Vectorize.hs+37−45

@@ -9,8 +9,6 @@

9{-# language GADTs #-}

10{-# language LambdaCase #-}

11{-# language MultiParamTypeClasses #-}

12−{-# language NamedFieldPuns #-}

13−{-# language QuantifiedConstraints #-}

14{-# language RankNTypes #-}

12{-# language RankNTypes #-}

15{-# language RecordWildCards #-}

13{-# language RecordWildCards #-}

16{-# language ScopedTypeVariables #-}

14{-# language ScopedTypeVariables #-}

@@ -23,34 +21,39 @@ module Rel8.Schema.HTable.Vectorize

23 ( HVectorize

21 ( HVectorize

24 , hvectorize, hunvectorize

22 , hvectorize, hunvectorize

25 , happend, hempty

23 , happend, hempty

24+ , hproject

25+ , hcolumn

26 )

27where

29-- base

30−import Data.Kind ( Type )

30+import Data.Kind ( Constraint, Type )

31import Data.List.NonEmpty ( NonEmpty )

32+import GHC.Generics (Generic)

32import Prelude

33import Prelude

34-- rel8

35-- rel8

35−import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )

36+import Rel8.FCF ( Eval, Exp )

36import Rel8.Schema.Dict ( Dict( Dict ) )

37import Rel8.Schema.Dict ( Dict( Dict ) )

37import qualified Rel8.Schema.Kind as K

38import qualified Rel8.Schema.Kind as K

38−import Rel8.Schema.HTable

39− ( HTable

40− , hfield, htabulate, htabulateA, hspecs

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

40+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

41+import Rel8.Schema.HTable.MapTable

42+ ( HMapTable( HMapTable ), HMapTableField( HMapTableField )

43+ , MapSpec, mapInfo

44+ , Precompose( Precompose )

41 )

45 )

46+import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )

42import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )

47import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )

43−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

48+import Rel8.Schema.Spec ( Spec(..) )

44import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )

49import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )

45import Rel8.Type.Information ( TypeInformation )

50import Rel8.Type.Information ( TypeInformation )

47-- semialign

52-- semialign

48import Data.Zip ( Unzip, Zip, Zippy(..) )

53import Data.Zip ( Unzip, Zip, Zippy(..) )

49−import Rel8.FCF

50−import Rel8.Schema.HTable.MapTable

51−import GHC.Generics (Generic)

56+type Vector :: (Type -> Type) -> Constraint

54class Vector list where

57class Vector list where

55 listNotNull :: proxy a -> Dict NotNull (list a)

58 listNotNull :: proxy a -> Dict NotNull (list a)

56 vectorTypeInformation :: ()

59 vectorTypeInformation :: ()

@@ -75,16 +78,16 @@ newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) t

75 deriving anyclass HTable

78 deriving anyclass HTable

78−data Vectorize :: (Type -> Type) -> Spec -> Exp Spec

81+data Vectorize :: (Type -> Type) -> Type -> Exp Type

81−type instance Eval (Vectorize list ('Spec labels a)) = 'Spec labels (list a)

84+type instance Eval (Vectorize list a) = list a

84instance Vector list => MapSpec (Vectorize list) where

87instance Vector list => MapSpec (Vectorize list) where

85 mapInfo = \case

88 mapInfo = \case

86− SSpec {..} -> case listNotNull @list nullity of

89+ Spec {..} -> case listNotNull @list nullity of

87− Dict -> SSpec

90+ Dict -> Spec

88 { nullity = NotNull

91 { nullity = NotNull

89 , info = vectorTypeInformation nullity info

92 , info = vectorTypeInformation nullity info

90 , ..

93 , ..

@@ -92,60 +95,49 @@ instance Vector list => MapSpec (Vectorize list) where

94hvectorize :: (HTable t, Unzip f, Vector list)

97hvectorize :: (HTable t, Unzip f, Vector list)

95− => (forall labels a. ()

96− => SSpec ('Spec labels a)

97− -> f (context ('Spec labels a))

98− -> context' ('Spec labels (list a)))

98+ => (forall a. Spec a -> f (context a) -> context' (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@SSpec {} -> vectorizer spec (fmap (`hfield` field) as)

103+ spec -> vectorizer spec (fmap (`hfield` field) as)

104{-# INLINABLE hvectorize #-}

105

106

107hunvectorize :: (HTable t, Zip f, Vector list)

108− => (forall labels a. ()

109− => SSpec ('Spec labels a)

110− -> context ('Spec labels (list a))

108+ => (forall a. Spec a -> context (list a) -> f (context' a))

111− -> f (context' ('Spec labels a)))

112 -> HVectorize list t context

109 -> HVectorize list t context

113 -> f (t context')

110 -> f (t context')

114hunvectorize unvectorizer (HVectorize table) =

111hunvectorize unvectorizer (HVectorize table) =

115 getZippy $ htabulateA $ \field -> case hfield hspecs field of

112 getZippy $ htabulateA $ \field -> case hfield hspecs field of

116− spec@SSpec{} -> case hfield table (HMapTableField field) of

113+ spec -> case hfield table (HMapTableField field) of

117 a -> Zippy (unvectorizer spec a)

114 a -> Zippy (unvectorizer spec a)

118{-# INLINABLE hunvectorize #-}

115{-# INLINABLE hunvectorize #-}

119

116

120

117

121−happend :: (HTable t, Vector list) =>

118+happend :: (HTable t, Vector list)

122− ( forall labels a. ()

119+ => (forall a. Spec a -> context (list a) -> context (list a) -> context (list a))

123− => Nullity a

124− -> TypeInformation (Unnullify a)

125− -> context ('Spec labels (list a))

126− -> context ('Spec labels (list a))

127− -> context ('Spec labels (list a))

128− )

129 -> HVectorize list t context

120 -> HVectorize list t context

130 -> HVectorize list t context

121 -> HVectorize list t context

131 -> HVectorize list t context

122 -> HVectorize list t context

132happend append (HVectorize as) (HVectorize bs) = HVectorize $

123happend append (HVectorize as) (HVectorize bs) = HVectorize $

133 htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of

124 htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of

134 (a, b) -> case hfield hspecs j of

125 (a, b) -> case hfield hspecs j of

135− SSpec {nullity, info} -> append nullity info a b

126+ spec -> append spec a b

136

127

137

128

138−hempty :: HTable t =>

129+hempty :: HTable t

139− ( forall labels a. ()

130+ => (forall a. Spec a -> context [a])

140− => Nullity a

141− -> TypeInformation (Unnullify a)

142− -> context ('Spec labels [a])

143− )

144 -> HVectorize [] t context

131 -> HVectorize [] t context

145−hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of

132+hempty empty = HVectorize $ htabulate $ \(HMapTableField field) ->

146− SSpec {nullity, info} -> empty nullity info

133+ empty (hfield hspecs field)

134+

135+

136+hproject :: ()

137+ => (forall ctx. t ctx -> t' ctx)

138+ -> HVectorize list t context -> HVectorize list t' context

139+hproject f (HVectorize a) = HVectorize (HMapTable.hproject f a)

147

140

148

141

149−instance HLabelable g => HLabelable (Precompose (Vectorize list) g) where

142+hcolumn :: HVectorize list (HIdentity a) context -> context (list a)

150− hlabeler = Precompose . hlabeler . precomposed

143+hcolumn (HVectorize (HMapTable (HIdentity (Precompose a)))) = a

151− hunlabeler = Precompose . hunlabeler . precomposed

src/Rel8/Schema/Kind.hs+6−15

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

1{-# language StandaloneKindSignatures #-}

3module Rel8.Schema.Kind

4+ ( Rel8able

4− ( Context, Rel8able

5+ , Context

5− , HContext, HTable

6+ , HTable

6 )

7 )

7where

8where

@@ -10,23 +11,13 @@ where

10import Data.Kind ( Type )

11import Data.Kind ( Type )

11import Prelude ()

12import Prelude ()

13−-- rel8

14−import Rel8.Schema.Spec ( Spec )

16−

17−type HContext :: Type

15+type Context :: Type

18−type HContext = Spec -> Type

16+type Context = Type -> Type

21type HTable :: Type

19type HTable :: Type

22−type HTable = HContext -> Type

23−

24−

25−data X

26−

27−

28−type Context :: Type

29−type Context = X -> Type

20+type HTable = Context -> Type

32type Rel8able :: Type

23type Rel8able :: Type

src/Rel8/Schema/Name.hs+34−56

@@ -3,41 +3,44 @@

3{-# language FlexibleContexts #-}

4{-# language FlexibleInstances #-}

5{-# language GADTs #-}

6+{-# language GeneralizedNewtypeDeriving #-}

6{-# language MultiParamTypeClasses #-}

7{-# language MultiParamTypeClasses #-}

7−{-# language PolyKinds #-}

8{-# language RankNTypes #-}

9−{-# language StandaloneDeriving #-}

10{-# language StandaloneKindSignatures #-}

9{-# language StandaloneKindSignatures #-}

11{-# language TypeFamilies #-}

10{-# language TypeFamilies #-}

12{-# language UndecidableInstances #-}

11{-# language UndecidableInstances #-}

13−{-# language UndecidableSuperClasses #-}

15module Rel8.Schema.Name

13module Rel8.Schema.Name

16 ( Name(..)

14 ( Name(..)

17− , Col( N, unN )

18 , Selects

15 , Selects

16+ , ppColumn

19 )

17 )

20where

18where

22-- base

20-- base

23−import Data.Functor.Identity ( Identity )

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

24import Data.Kind ( Constraint, Type )

22import Data.Kind ( Constraint, Type )

25−import Data.String ( IsString, fromString )

23+import Data.String ( IsString )

26import Prelude

24import 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+

28-- rel8

33-- rel8

29import Rel8.Expr ( Expr )

34import Rel8.Expr ( Expr )

30−import Rel8.Schema.Context ( Interpretation, Col )

35+import qualified Rel8.Schema.Kind as K

31−import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )

32−import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )

36+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

33import Rel8.Schema.Null ( Sql )

37import Rel8.Schema.Null ( Sql )

34−import Rel8.Schema.Reify ( notReify )

35−import Rel8.Schema.Result ( Result )

36−import Rel8.Schema.Spec ( Spec( Spec ) )

37import Rel8.Table

38import Rel8.Table

38− ( Table, Columns, Context, fromColumns, toColumns, reify, unreify

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

40+ , FromExprs, fromResult, toResult

41+ , Transpose

39 )

42 )

40−import Rel8.Table.Recontextualize ( Recontextualize )

43+import Rel8.Table.Transpose ( Transposes )

41import Rel8.Type ( DBType )

44import Rel8.Type ( DBType )

@@ -45,55 +48,30 @@ import Rel8.Type ( DBType )

45-- schema definition. You can construct names by using the @OverloadedStrings@

48-- schema definition. You can construct names by using the @OverloadedStrings@

46-- extension and writing string literals. This is typically done when providing

49-- extension and writing string literals. This is typically done when providing

47-- a 'TableSchema' value.

50-- a 'TableSchema' value.

48−type Name :: k -> Type

51+type Name :: K.Context

49−data Name a where

50− Name :: k ~ Type => !String -> Name (a :: k)

52+newtype Name a = Name String

51−

52−

53−deriving stock instance Show (Name a)

53+ deriving stock Show

54−

54+ deriving newtype IsString

55−

56−instance k ~ Type => IsString (Name (a :: k)) where

57− fromString = Name

60instance Sql DBType a => Table Name (Name a) where

57instance Sql DBType a => Table Name (Name a) where

61− type Columns (Name a) = HType a

58+ type Columns (Name a) = HIdentity a

62 type Context (Name a) = Name

59 type Context (Name a) = Name

60+ type FromExprs (Name a) = a

61+ type Transpose to (Name a) = to a

64− toColumns a = HType (N a)

63+ toColumns a = HIdentity a

65− fromColumns (HType (N a)) = a

64+ fromColumns (HIdentity a) = a

66− reify = notReify

65+ toResult a = HIdentity (Identity a)

67− unreify = notReify

66+ fromResult (HIdentity (Identity a)) = a

68−

69−

70−instance Sql DBType a => Recontextualize Expr Name (Expr a) (Name a)

71−

72−

73−instance Sql DBType a => Recontextualize Result Name (Identity a) (Name a)

74−

75−

76−instance Sql DBType a => Recontextualize Name Expr (Name a) (Expr a)

77−

78−

79−instance Sql DBType a => Recontextualize Name Result (Name a) (Identity a)

80−

81−

82−instance Sql DBType a => Recontextualize Name Name (Name a) (Name a)

83−

84−

85−instance Interpretation Name where

86− data Col Name _spec where

87− N :: {unN :: !(Name a)} -> Col Name ('Spec labels a)

88−

89−

90−instance Labelable Name where

91− labeler (N a) = N a

92− unlabeler (N a) = N a

95-- | @Selects a b@ means that @a@ is a schema (i.e., a 'Table' of 'Name's) for

69-- | @Selects a b@ means that @a@ is a schema (i.e., a 'Table' of 'Name's) for

96-- the 'Expr' columns in @b@.

70-- the 'Expr' columns in @b@.

97type Selects :: Type -> Type -> Constraint

71type Selects :: Type -> Type -> Constraint

98−class Recontextualize Name Expr names exprs => Selects names exprs

72+class Transposes Name Expr names exprs => Selects names exprs

99−instance Recontextualize Name Expr names exprs => Selects names exprs

73+instance Transposes Name Expr names exprs => Selects names exprs

74+

75+

76+ppColumn :: String -> Doc

77+ppColumn = Opaleye.ppSqlExpr . Opaleye.ColumnSqlExpr . Opaleye.SqlColumn

src/Rel8/Schema/Reify.hsdeleted−74

@@ -1,74 +0,0 @@

1−{-# language AllowAmbiguousTypes #-}

2−{-# language EmptyCase #-}

3−{-# language DataKinds #-}

4−{-# language FlexibleInstances #-}

5−{-# language ScopedTypeVariables #-}

6−{-# language StandaloneKindSignatures #-}

7−{-# language TypeApplications #-}

8−{-# language TypeFamilies #-}

9−{-# language TypeOperators #-}

10−{-# language UndecidableInstances #-}

11−

12−module Rel8.Schema.Reify

13− ( Reify, Col( Reify ), hreify, hunreify

14− , UnwrapReify

15− , NotReify, notReify

16− )

17−where

18−

19−-- base

20−import Data.Kind ( Constraint )

21−import Data.Type.Equality ( (:~:)( Refl ) )

22−import Prelude

23−

24−-- rel8

25−import Rel8.Schema.Context ( Interpretation, Col )

26−import Rel8.Schema.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+20−41

@@ -5,71 +5,50 @@

5{-# language TypeFamilies #-}

7module Rel8.Schema.Result

8− ( Col( R, unR ), Result

8+ ( Result

9− , relabel

10 , null, nullifier, unnullifier

9 , null, nullifier, unnullifier

11 , vectorizer, unvectorizer

10 , vectorizer, unvectorizer

12 )

11 )

13where

12where

15-- base

14-- 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(..) )

21import Rel8.Schema.Kind ( Context )

19import Rel8.Schema.Kind ( Context )

22import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )

20import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )

23−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

21+import Rel8.Schema.Spec ( Spec(..) )

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.

26type Result :: Context

28type Result :: Context

27−data Result a

29+type Result = Identity

30−instance Interpretation Result where

32+null :: Result (Maybe a)

31− data Col Result _spec where

33+null = Identity Nothing

32− R :: {unR :: !a} -> Col Result ('Spec labels a)

35−relabel :: ()

36− => HIdentity ('Spec labels a) (Col Result)

37− -> HIdentity ('Spec relabels a) (Col Result)

38−relabel (HIdentity (R a)) = HIdentity (R a)

39−

40−

41−null :: Col Result ('Spec labels (Maybe a))

42−null = R Nothing

43−

44−

45−nullifier :: ()

46− => SSpec ('Spec labels a)

47− -> Col Result ('Spec labels a)

48− -> Col Result ('Spec labels (Nullify a))

36+nullifier :: Spec a -> Result a -> Result (Nullify a)

49−nullifier SSpec {nullity} (R a) = R $ case nullity of

37+nullifier Spec {nullity} (Identity a) = Identity $ case nullity of

50 Null -> a

38 Null -> a

51 NotNull -> Just a

39 NotNull -> Just a

54−unnullifier :: ()

42+unnullifier :: Spec a -> Result (Nullify a) -> Maybe (Result a)

55− => SSpec ('Spec labels a)

56− -> Col Result ('Spec labels (Nullify a))

57− -> Maybe (Col Result ('Spec labels a))

58−unnullifier SSpec {nullity} (R a) =

43+unnullifier Spec {nullity} (Identity a) =

59 case nullity of

44 case nullity of

60− Null -> pure $ R a

45+ Null -> pure $ Identity a

61− NotNull -> R <$> a

46+ NotNull -> Identity <$> a

64−vectorizer :: Functor f

49+vectorizer :: Functor f => Spec a -> f (Result a) -> Result (f a)

65− => SSpec ('Spec labels a)

66− -> f (Col Result ('Spec labels a))

67− -> Col Result ('Spec labels (f a))

68−vectorizer _ = R . fmap unR

50+vectorizer _ = Identity . fmap runIdentity

71−unvectorizer :: Functor f

53+unvectorizer :: Functor f => Spec a -> Result (f a) -> f (Result a)

72− => SSpec ('Spec labels a)

73− -> Col Result ('Spec labels (f a))

74− -> f (Col Result ('Spec labels a))

75−unvectorizer _ (R results) = R <$> results

54+unvectorizer _ (Identity results) = Identity <$> results

src/Rel8/Schema/Spec.hs+17−37

@@ -1,54 +1,34 @@

1−{-# language DataKinds #-}

2{-# language FlexibleContexts #-}

1{-# language FlexibleContexts #-}

3−{-# language GADTs #-}

2+{-# language MonoLocalBinds #-}

4{-# language StandaloneKindSignatures #-}

3{-# language StandaloneKindSignatures #-}

5−{-# language UndecidableInstances #-}

7module Rel8.Schema.Spec

5module Rel8.Schema.Spec

8− ( Spec( Spec )

9− , SSpec( SSpec, labels, info, nullity )

6+ ( Spec( Spec, labels, info, nullity )

10− , KnownSpec( specSing )

7+ , specification

11 )

8 )

12where

9where

14-- base

11-- base

15−import Data.Kind ( Constraint, Type )

12+import Data.Kind ( Type )

16−import Prelude ()

13+import Prelude

18-- rel8

15-- rel8

19−import Rel8.Kind.Labels ( Labels, SLabels, KnownLabels, labelsSing )

20import Rel8.Schema.Null ( Nullity, Sql, Unnullify, nullable )

16import Rel8.Schema.Null ( Nullity, Sql, Unnullify, nullable )

21import Rel8.Type ( DBType, typeInformation )

17import Rel8.Type ( DBType, typeInformation )

22import Rel8.Type.Information ( TypeInformation )

18import Rel8.Type.Information ( TypeInformation )

25−type Spec :: Type

21+type Spec :: Type -> Type

26−data Spec = Spec Labels Type

22+data Spec a = Spec

23+ { labels :: [String]

24+ , info :: TypeInformation (Unnullify a)

25+ , nullity :: Nullity a

26+ }

29−type SSpec :: Spec -> Type

30−data SSpec spec where

31− SSpec ::

32− { labels :: SLabels labels

33− , info :: TypeInformation (Unnullify a)

34− , nullity :: Nullity a

35− }

36− -> SSpec ('Spec labels a)

37−

38−

39−type KnownSpec :: Spec -> Constraint

40−class KnownSpec spec where

41− specSing :: SSpec spec

42−

43−

44−instance

45− ( KnownLabels labels

46− , Sql DBType a

29+specification :: Sql DBType a => Spec a

47− )

30+specification = Spec

48− => KnownSpec ('Spec labels a)

49− where

50− specSing = SSpec

51− { labels = labelsSing

31+ { labels = []

52− , info = typeInformation

32+ , info = typeInformation

53− , nullity = nullable

33+ , nullity = nullable

54− }

34+ }

src/Rel8/Schema/Spec/ConstrainDBType.hsdeleted−89

@@ -1,89 +0,0 @@

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 a. ()

35− => (spec ~ 'Spec labels a)

36− => (forall x. (constraint x => c x)) => Sql c a

37− )

38− => ConstrainDBType constraint spec

39−instance

40− ( spec ~ 'Spec labels a

41− , Sql constraint a

42− )

43− => ConstrainDBType constraint spec

44−

45−

46−dbTypeNullity :: Dict (ConstrainDBType c) ('Spec l a) -> Nullity a

47−dbTypeNullity = step2 . step1

48− where

49− step1 :: Dict (ConstrainDBType c) ('Spec l 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 a) -> Dict c (Unnullify a)

57−dbTypeDict = step2 . step1

58− where

59− step1 :: Dict (ConstrainDBType c) ('Spec l 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 a)

67−fromNullityDict Null Dict = Dict

68−fromNullityDict NotNull Dict = Dict

69−

70−

71−nullifier :: ()

72− => SSpec ('Spec labels a)

73− -> Dict (ConstrainDBType c) ('Spec labels a)

74− -> Dict (ConstrainDBType c) ('Spec labels (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 a)

83− -> Dict (ConstrainDBType c) ('Spec labels (Nullify a))

84− -> Dict (ConstrainDBType c) ('Spec labels 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/Table.hs+20

@@ -1,14 +1,26 @@

1{-# language DeriveFunctor #-}

2{-# language DerivingStrategies #-}

3+{-# language DisambiguateRecordFields #-}

4+{-# language NamedFieldPuns #-}

5+{-# language StandaloneKindSignatures #-}

4module Rel8.Schema.Table

7module Rel8.Schema.Table

5 ( TableSchema(..)

8 ( TableSchema(..)

9+ , ppTable

6 )

10 )

7where

11where

9-- base

13-- base

14+import Data.Kind ( Type )

10import Prelude

15import 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+

13-- | The schema for a table. This is used to specify the name and schema that a

25-- | The schema for a table. This is used to specify the name and schema that a

14-- table belongs to (the @FROM@ part of a SQL query), along with the schema of

26-- table belongs to (the @FROM@ part of a SQL query), along with the schema of

@@ -16,6 +28,7 @@ import Prelude

16--

28--

17-- For each selectable table in your database, you should provide a

29-- For each selectable table in your database, you should provide a

18-- @TableSchema@ in order to interact with the table via Rel8.

30-- @TableSchema@ in order to interact with the table via Rel8.

31+type TableSchema :: Type -> Type

19data TableSchema names = TableSchema

32data TableSchema names = TableSchema

20 { name :: String

33 { name :: String

21 -- ^ The name of the table.

34 -- ^ The name of the table.

@@ -27,3 +40,10 @@ data TableSchema names = TableSchema

27 -- data type here, parameterized by the 'Rel8.ColumnSchema.ColumnSchema' functor.

40 -- data type here, parameterized by the 'Rel8.ColumnSchema.ColumnSchema' functor.

28 }

41 }

29 deriving stock Functor

42 deriving stock Functor

43+

44+

45+ppTable :: TableSchema a -> Doc

46+ppTable TableSchema {name, schema} = Opaleye.ppTable Opaleye.SqlTable

47+ { sqlTableSchemaName = schema

48+ , sqlTableName = name

49+ }

src/Rel8/Statement/Delete.hs+35−48

@@ -1,40 +1,37 @@

1{-# language DuplicateRecordFields #-}

2{-# language GADTs #-}

3{-# language NamedFieldPuns #-}

4−{-# language ScopedTypeVariables #-}

4+{-# language RankNTypes #-}

5+{-# language RecordWildCards #-}

5{-# language StandaloneKindSignatures #-}

6{-# language StandaloneKindSignatures #-}

6−{-# language TypeApplications #-}

7+{-# language StrictData #-}

8module Rel8.Statement.Delete

9module Rel8.Statement.Delete

9 ( Delete(..)

10 ( Delete(..)

10 , delete

11 , delete

12+ , ppDelete

11 )

13 )

12where

14where

14-- base

16-- base

15−import Control.Exception ( throwIO )

16import Data.Kind ( Type )

17import Data.Kind ( Type )

17import Prelude

18import Prelude

19-- hasql

20-- hasql

20−import Hasql.Connection ( Connection )

21−import qualified Hasql.Decoders as Hasql

22import qualified Hasql.Encoders as Hasql

21import qualified Hasql.Encoders as Hasql

23−import qualified Hasql.Session as Hasql

24import qualified Hasql.Statement as Hasql

22import qualified Hasql.Statement as Hasql

26−-- opaleye

24+-- pretty

27−import qualified Opaleye.Internal.Manipulation as Opaleye

25+import Text.PrettyPrint ( Doc, (<+>), ($$), text )

29-- rel8

27-- rel8

30import Rel8.Expr ( Expr )

28import Rel8.Expr ( Expr )

31−import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )

29+import Rel8.Query ( Query )

32import Rel8.Schema.Name ( Selects )

30import Rel8.Schema.Name ( Selects )

33−import Rel8.Schema.Table ( TableSchema )

31+import Rel8.Schema.Table ( TableSchema, ppTable )

34−import Rel8.Statement.Returning ( Returning( NumberOfRowsAffected, Projection ) )

32+import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )

35−import Rel8.Table ( fromColumns, toColumns )

33+import Rel8.Statement.Using ( ppUsing )

36−import Rel8.Table.Opaleye ( castTable, table, unpackspec )

34+import Rel8.Statement.Where ( ppWhere )

37−import Rel8.Table.Serialize ( Serializable, parse )

39-- text

36-- text

40import qualified Data.Text as Text

37import qualified Data.Text as Text

@@ -47,7 +44,10 @@ data Delete a where

47 Delete :: Selects names exprs =>

44 Delete :: Selects names exprs =>

48 { from :: TableSchema names

45 { from :: TableSchema names

49 -- ^ Which table to delete from.

46 -- ^ Which table to delete from.

47+ , using :: Query using

48+ -- ^ @USING@ clause — this can be used to join against other tables,

49+ -- and its results can be referenced in the @WHERE@ clause

50− , deleteWhere :: exprs -> Expr Bool

50+ , deleteWhere :: using -> exprs -> Expr Bool

51 -- ^ Which rows should be selected for deletion.

52 , returning :: Returning names a

53 -- ^ What to return from the @DELETE@ statement.

@@ -55,38 +55,25 @@ data Delete a where

55 -> Delete a

58−-- | Run a @DELETE@ statement.

58+ppDelete :: Delete a -> Doc

59−delete :: Connection -> Delete a -> IO a

59+ppDelete Delete {..} = case ppUsing using of

60−delete c Delete {from, deleteWhere, returning} =

60+ Nothing ->

61− case returning of

61+ text "DELETE FROM" <+> ppTable from $$

62− NumberOfRowsAffected -> Hasql.run session c >>= either throwIO pure

62+ text "WHERE false"

63− where

63+ Just (usingDoc, i) ->

64− session = Hasql.statement () statement

64+ text "DELETE FROM" <+> ppTable from $$

65− statement = Hasql.Statement bytes params decode prepare

65+ usingDoc $$

66− bytes = encodeUtf8 $ Text.pack sql

66+ ppWhere from (deleteWhere i) $$

67− params = Hasql.noParams

67+ ppReturning from returning

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

75− Projection project -> Hasql.run session c >>= either throwIO pure

69+

76− where

70+-- | Run a 'Delete' statement.

77− session = Hasql.statement () statement

71+delete :: Delete a -> Hasql.Statement () a

78− statement = Hasql.Statement bytes params decode prepare

72+delete d@Delete {returning} = 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

89 where

73 where

90− decoder :: forall exprs projection a. Serializable projection a

74+ bytes = encodeUtf8 $ Text.pack sql

91− => (exprs -> projection) -> Hasql.Result [a]

75+ params = Hasql.noParams

92− decoder _ = Hasql.rowList (parse @projection @a)

76+ decode = decodeReturning returning

77+ prepare = False

78+ sql = show doc

79+ doc = ppDelete d

src/Rel8/Statement/Insert.hs+43−72

@@ -1,64 +1,59 @@

1{-# language DuplicateRecordFields #-}

2+{-# language FlexibleContexts #-}

2{-# language GADTs #-}

3{-# language GADTs #-}

3{-# language NamedFieldPuns #-}

4{-# language NamedFieldPuns #-}

4−{-# language ScopedTypeVariables #-}

5+{-# language RecordWildCards #-}

5{-# language StandaloneKindSignatures #-}

6{-# language StandaloneKindSignatures #-}

6−{-# language TypeApplications #-}

7+{-# language StrictData #-}

8module Rel8.Statement.Insert

9module Rel8.Statement.Insert

9 ( Insert(..)

10 ( Insert(..)

10− , OnConflict(..)

11 , insert

12+ , ppInsert

13+ , ppInto

12 )

14 )

13where

15where

15-- base

17-- base

16−import Control.Exception ( throwIO )

18+import Data.Foldable ( toList )

17−import Data.List.NonEmpty ( NonEmpty( (:|) ) )

18import Data.Kind ( Type )

19import Data.Kind ( Type )

19import Prelude

20import Prelude

21-- hasql

22-- hasql

22−import Hasql.Connection ( Connection )

23−import qualified Hasql.Decoders as Hasql

24import qualified Hasql.Encoders as Hasql

23import qualified Hasql.Encoders as Hasql

25−import qualified Hasql.Session as Hasql

26import qualified Hasql.Statement as Hasql

24import qualified Hasql.Statement as Hasql

28-- opaleye

26-- opaleye

29−import qualified Opaleye.Internal.Manipulation as Opaleye

27+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye

30−import qualified Opaleye.Manipulation as Opaleye

28+

29+-- pretty

30+import Text.PrettyPrint ( Doc, (<+>), ($$), parens, text )

32-- rel8

33+import Rel8.Query ( Query )

33−import Rel8.Schema.Name ( Selects )

34+import Rel8.Schema.Name ( Name, Selects, ppColumn )

34−import Rel8.Schema.Table ( TableSchema )

35+import Rel8.Schema.Table ( TableSchema(..), ppTable )

35−import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) )

36+import Rel8.Statement.OnConflict ( OnConflict, ppOnConflict )

36−import Rel8.Table ( fromColumns, toColumns )

37+import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )

38+import Rel8.Statement.Select ( ppRows )

37−import Rel8.Table.Opaleye ( castTable, table, unpackspec )

39+import Rel8.Table ( Table )

38−import Rel8.Table.Serialize ( Serializable, parse )

40+import Rel8.Table.Name ( showNames )

40-- text

42-- text

41import qualified Data.Text as Text ( pack )

43import qualified Data.Text as Text ( pack )

42import Data.Text.Encoding ( encodeUtf8 )

44import Data.Text.Encoding ( encodeUtf8 )

45−-- | @OnConflict@ allows you to add an @ON CONFLICT@ clause to an @INSERT@

46−-- statement.

47−type OnConflict :: Type

48−data OnConflict

49− = Abort -- ^ @ON CONFLICT ABORT@

50− | DoNothing -- ^ @ON CONFLICT DO NOTHING@

51−

52−

53-- | The constituent parts of a SQL @INSERT@ statement.

47-- | The constituent parts of a SQL @INSERT@ statement.

54type Insert :: Type -> Type

48type Insert :: Type -> Type

55data Insert a where

49data Insert a where

56 Insert :: Selects names exprs =>

50 Insert :: Selects names exprs =>

57 { into :: TableSchema names

51 { into :: TableSchema names

58 -- ^ Which table to insert into.

52 -- ^ Which table to insert into.

59− , rows :: [exprs]

53+ , rows :: Query exprs

60− -- ^ The rows to insert.

54+ -- ^ The rows to insert. This can be an arbitrary query — use

55+ -- 'Rel8.values' insert a static list of rows.

61− , onConflict :: OnConflict

56+ , onConflict :: OnConflict names

62 -- ^ What to do if the inserted rows conflict with data already in the

57 -- ^ What to do if the inserted rows conflict with data already in the

63 -- table.

58 -- table.

64 , returning :: Returning names a

59 , returning :: Returning names a

@@ -67,52 +62,28 @@ data Insert a where

67 -> Insert a

62 -> Insert a

70−-- | Run an @INSERT@ statement

65+ppInsert :: Insert a -> Doc

71−insert :: Connection -> Insert a -> IO a

66+ppInsert Insert {..} =

72−insert c Insert {into, rows, onConflict, returning} =

67+ text "INSERT INTO" <+>

73− case (rows, returning) of

68+ ppInto into $$

74− ([], NumberOfRowsAffected) -> pure 0

69+ ppRows rows $$

75− ([], Projection _) -> pure []

70+ ppOnConflict into onConflict $$

71+ ppReturning into returning

77− (x:xs, NumberOfRowsAffected) -> Hasql.run session c >>= either throwIO pure

78− where

79− session = Hasql.statement () statement

80− statement = Hasql.Statement bytes params decode prepare

81− bytes = encodeUtf8 $ Text.pack sql

82− params = Hasql.noParams

83− decode = Hasql.rowsAffected

84− prepare = False

85− sql = Opaleye.arrangeInsertManySql into' rows' onConflict'

86− where

87− into' = table $ toColumns <$> into

88− rows' = toColumns <$> x :| xs

90− (x:xs, Projection project) -> Hasql.run session c >>= either throwIO pure

74+ppInto :: Table Name a => TableSchema a -> Doc

91− where

75+ppInto table@TableSchema {columns} =

92− session = Hasql.statement () statement

76+ ppTable table <+>

93− statement = Hasql.Statement bytes params decode prepare

77+ parens (Opaleye.commaV ppColumn (toList (showNames columns)))

94− bytes = encodeUtf8 $ Text.pack sql

95− params = Hasql.noParams

96− decode = decoder project

97− prepare = False

98− sql =

99− Opaleye.arrangeInsertManyReturningSql

100− unpackspec

101− into'

102− rows'

103− project'

104− onConflict'

105− where

106− into' = table $ toColumns <$> into

107− rows' = toColumns <$> x :| xs

108− project' = castTable . toColumns . project . fromColumns

109

110− where

111− onConflict' =

112− case onConflict of

113− DoNothing -> Just Opaleye.DoNothing

114− Abort -> Nothing

115

116− decoder :: forall exprs projection a. Serializable projection a

80+-- | Run an 'Insert' statement.

117− => (exprs -> projection) -> Hasql.Result [a]

81+insert :: Insert a -> Hasql.Statement () a

118− decoder _ = Hasql.rowList (parse @projection @a)

82+insert i@Insert {returning} = Hasql.Statement bytes params decode prepare

83+ where

84+ bytes = encodeUtf8 $ Text.pack sql

85+ params = Hasql.noParams

86+ decode = decodeReturning returning

87+ prepare = False

88+ sql = show doc

89+ doc = ppInsert i

src/Rel8/Statement/OnConflict.hsnew file+106

@@ -0,0 +1,106 @@

1+{-# language DuplicateRecordFields #-}

2+{-# language FlexibleContexts #-}

3+{-# language GADTs #-}

4+{-# language LambdaCase #-}

5+{-# language NamedFieldPuns #-}

6+{-# language RecordWildCards #-}

7+{-# language StandaloneKindSignatures #-}

8+{-# language StrictData #-}

10+module Rel8.Statement.OnConflict

11+ ( OnConflict(..)

12+ , Upsert(..)

13+ , ppOnConflict

14+ )

15+where

16+

17+-- base

18+import Data.Foldable ( toList )

19+import Data.Kind ( Type )

20+import Prelude

21+

22+-- opaleye

23+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye

24+

25+-- pretty

26+import Text.PrettyPrint ( Doc, (<+>), ($$), parens, text )

27+

28+-- rel8

29+import Rel8.Expr ( Expr )

30+import Rel8.Schema.Name ( Name, Selects, ppColumn )

31+import Rel8.Schema.Table ( TableSchema(..) )

32+import Rel8.Statement.Set ( ppSet )

33+import Rel8.Statement.Where ( ppWhere )

34+import Rel8.Table ( Table, toColumns )

35+import Rel8.Table.Cols ( Cols( Cols ) )

36+import Rel8.Table.Name ( showNames )

37+import Rel8.Table.Opaleye ( attributes )

38+import Rel8.Table.Projection ( Projecting, Projection, apply )

39+

40+

41+-- | 'OnConflict' represents the @ON CONFLICT@ clause of an @INSERT@

42+-- statement. This specifies what ought to happen when one or more of the

43+-- rows proposed for insertion conflict with an existing row in the table.

44+type OnConflict :: Type -> Type

45+data OnConflict names

46+ = Abort

47+ -- ^ Abort the transaction if there are conflicting rows (Postgres' default)

48+ | DoNothing

49+ -- ^ @ON CONFLICT DO NOTHING@

50+ | DoUpdate (Upsert names)

51+ -- ^ @ON CONFLICT DO UPDATE@

52+

53+

54+-- | The @ON CONFLICT (...) DO UPDATE@ clause of an @INSERT@ statement, also

55+-- known as \"upsert\".

56+--

57+-- When an existing row conflicts with a row proposed for insertion,

58+-- @ON CONFLICT DO UPDATE@ allows you to instead update this existing row. The

59+-- conflicting row proposed for insertion is then \"excluded\", but its values

60+-- can still be referenced from the @SET@ and @WHERE@ clauses of the @UPDATE@

61+-- statement.

62+--

63+-- Upsert in Postgres requires an explicit set of \"conflict targets\" — the

64+-- set of columns comprising the @UNIQUE@ index from conflicts with which we

65+-- would like to recover.

66+type Upsert :: Type -> Type

67+data Upsert names where

68+ Upsert :: (Selects names exprs, Projecting names index, excluded ~ exprs) =>

69+ { index :: Projection names index

70+ -- ^ The set of conflict targets, projected from the set of columns for

71+ -- the whole table

72+ , set :: excluded -> exprs -> exprs

73+ -- ^ How to update each selected row.

74+ , updateWhere :: excluded -> exprs -> Expr Bool

75+ -- ^ Which rows to select for update.

76+ }

77+ -> Upsert names

78+

79+

80+ppOnConflict :: TableSchema names -> OnConflict names -> Doc

81+ppOnConflict schema = \case

82+ Abort -> mempty

83+ DoNothing -> text "ON CONFLICT DO NOTHING"

84+ DoUpdate upsert -> ppUpsert schema upsert

85+

86+

87+ppUpsert :: TableSchema names -> Upsert names -> Doc

88+ppUpsert schema@TableSchema {columns} Upsert {..} =

89+ text "ON CONFLICT" <+>

90+ ppIndex schema index <+>

91+ text "DO UPDATE" $$

92+ ppSet schema (set excluded) $$

93+ ppWhere schema (updateWhere excluded)

94+ where

95+ excluded = attributes TableSchema

96+ { schema = Nothing

97+ , name = "excluded"

98+ , columns

99+ }

100+

101+

102+ppIndex :: (Table Name names, Projecting names index)

103+ => TableSchema names -> Projection names index -> Doc

104+ppIndex TableSchema {columns} index =

105+ parens $ Opaleye.commaV ppColumn $ toList $

106+ showNames $ Cols $ apply index $ toColumns columns

src/Rel8/Statement/Returning.hs+114−10

@@ -1,29 +1,133 @@

1{-# language GADTs #-}

2+{-# language LambdaCase #-}

3+{-# language NamedFieldPuns #-}

4+{-# language RankNTypes #-}

5+{-# language ScopedTypeVariables #-}

2{-# language StandaloneKindSignatures #-}

6{-# language StandaloneKindSignatures #-}

7+{-# language StrictData #-}

8+{-# language TypeApplications #-}

4module Rel8.Statement.Returning

10module Rel8.Statement.Returning

5− ( Returning(..)

11+ ( Returning( NumberOfRowsAffected, Projection )

12+ , decodeReturning

13+ , ppReturning

6 )

14 )

7where

15where

9-- base

17-- base

18+import Control.Applicative ( liftA2 )

19+import Data.Foldable ( toList )

10import Data.Int ( Int64 )

20import Data.Int ( Int64 )

11import Data.Kind ( Type )

21import Data.Kind ( Type )

22+import Data.List.NonEmpty ( NonEmpty )

12−import Prelude ()

23+import Prelude

24+

25+-- hasql

26+import qualified Hasql.Decoders as Hasql

27+

28+-- opaleye

29+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

30+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye

31+import qualified Opaleye.Internal.Sql as Opaleye

32+

33+-- pretty

34+import Text.PrettyPrint ( Doc, (<+>), text )

14-- rel8

36-- rel8

15import Rel8.Schema.Name ( Selects )

37import Rel8.Schema.Name ( Selects )

38+import Rel8.Schema.Table ( TableSchema(..) )

39+import Rel8.Table.Opaleye ( castTable, exprs, view )

16−import Rel8.Table.Serialize ( Serializable )

40+import Rel8.Table.Serialize ( Serializable, parse )

42+-- semigropuoids

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

45+

19−-- | @INSERT@, @UPDATE@ and @DELETE@ all support returning either the number of

46+-- | 'Rel8.Insert', 'Rel8.Update' and 'Rel8.Delete' all support returning either

20−-- rows affected, or the actual rows modified. 'Projection' allows you to

47+-- the number of rows affected, or the actual rows modified.

21−-- project out of these returned rows, which can be useful if you want to log

22−-- exactly which rows were deleted, or to view a generated id (for example, if

23−-- using a column with an autoincrementing counter as a default value).

24type Returning :: Type -> Type -> Type

48type Returning :: Type -> Type -> Type

25data Returning names a where

49data Returning names a where

50+ Pure :: a -> Returning names a

51+ Ap :: Returning names (a -> b) -> Returning names a -> Returning names b

52+

53+ -- | Return the number of rows affected.

26 NumberOfRowsAffected :: Returning names Int64

54 NumberOfRowsAffected :: Returning names Int64

55+

56+ -- | 'Projection' allows you to project out of the affected rows, which can

57+ -- be useful if you want to log exactly which rows were deleted, or to view

58+ -- a generated id (for example, if using a column with an autoincrementing

59+ -- counter via 'Rel8.nextval').

27− Projection :: (Selects names exprs, Serializable projection a)

60+ Projection :: (Selects names exprs, Serializable returning a)

28− => (exprs -> projection)

61+ => (exprs -> returning)

29 -> Returning names [a]

62 -> Returning names [a]

63+

64+

65+instance Functor (Returning names) where

66+ fmap f = \case

67+ Pure a -> Pure (f a)

68+ Ap g a -> Ap (fmap (f .) g) a

69+ m -> Ap (Pure f) m

70+

71+

72+instance Apply (Returning names) where

73+ (<.>) = Ap

74+

75+

76+instance Applicative (Returning names) where

77+ pure = Pure

78+ (<*>) = Ap

79+

80+

81+projections :: ()

82+ => TableSchema names -> Returning names a -> Maybe (NonEmpty Opaleye.PrimExpr)

83+projections schema@TableSchema {columns} = \case

84+ Pure _ -> Nothing

85+ Ap f a -> projections schema f <> projections schema a

86+ NumberOfRowsAffected -> Nothing

87+ Projection f -> Just (exprs (castTable (f (view columns))))

88+

89+

90+runReturning :: ()

91+ => ((Int64 -> a) -> r)

92+ -> (forall x. Hasql.Row x -> ([x] -> a) -> r)

93+ -> Returning names a

94+ -> r

95+runReturning rowCount rowList = \case

96+ Pure a -> rowCount (const a)

97+ Ap fs as ->

98+ runReturning

99+ (\withCount ->

100+ runReturning

101+ (\withCount' -> rowCount (withCount <*> withCount'))

102+ (\decoder -> rowList decoder . liftA2 withCount length64)

103+ as)

104+ (\decoder withRows ->

105+ runReturning

106+ (\withCount -> rowList decoder $ withRows <*> withCount . length64)

107+ (\decoder' withRows' ->

108+ rowList (liftA2 (,) decoder decoder') $

109+ withRows <$> fmap fst <*> withRows' . fmap snd)

110+ as)

111+ fs

112+ NumberOfRowsAffected -> rowCount id

113+ Projection (_ :: exprs -> returning) -> rowList decoder' id

114+ where

115+ decoder' = parse @returning

116+ where

117+ length64 :: Foldable f => f x -> Int64

118+ length64 = fromIntegral . length

119+

120+

121+decodeReturning :: Returning names a -> Hasql.Result a

122+decodeReturning = runReturning

123+ (<$> Hasql.rowsAffected)

124+ (\decoder withRows -> withRows <$> Hasql.rowList decoder)

125+

126+

127+ppReturning :: TableSchema names -> Returning names a -> Doc

128+ppReturning schema returning = case projections schema returning of

129+ Nothing -> mempty

130+ Just columns ->

131+ text "RETURNING" <+> Opaleye.commaV Opaleye.ppSqlExpr (toList sqlExprs)

132+ where

133+ sqlExprs = Opaleye.sqlExpr <$> columns

src/Rel8/Statement/SQL.hsnew file+29

@@ -0,0 +1,29 @@

1+module Rel8.Statement.SQL

2+ ( showDelete

3+ , showInsert

4+ , showUpdate

5+ )

6+where

8+-- base

9+import Prelude

10+

11+-- rel8

12+import Rel8.Statement.Delete ( Delete, ppDelete )

13+import Rel8.Statement.Insert ( Insert, ppInsert )

14+import Rel8.Statement.Update ( Update, ppUpdate )

15+

16+

17+-- | Convert a 'Delete' to a 'String' containing a @DELETE@ statement.

18+showDelete :: Delete a -> String

19+showDelete = show . ppDelete

20+

21+

22+-- | Convert an 'Insert' to a 'String' containing an @INSERT@ statement.

23+showInsert :: Insert a -> String

24+showInsert = show . ppInsert

25+

26+

27+-- | Convert an 'Update' to a 'String' containing an @UPDATE@ statement.

28+showUpdate :: Update a -> String

29+showUpdate = show . ppUpdate

src/Rel8/Statement/Select.hs+120−35

@@ -1,62 +1,147 @@

1+{-# language DeriveTraversable #-}

2+{-# language DerivingStrategies #-}

3+{-# language FlexibleContexts #-}

1{-# language MonoLocalBinds #-}

4{-# language MonoLocalBinds #-}

2{-# language ScopedTypeVariables #-}

5{-# language ScopedTypeVariables #-}

6+{-# language StandaloneKindSignatures #-}

3{-# language TypeApplications #-}

7{-# language TypeApplications #-}

5module Rel8.Statement.Select

9module Rel8.Statement.Select

6 ( select

10 ( select

7− , selectWithNames

11+ , ppSelect

12+

13+ , Optimized(..)

14+ , ppPrimSelect

15+ , ppRows

8 )

16 )

9where

17where

11-- base

19-- base

12−import Control.Exception ( throwIO )

20+import Data.Foldable ( toList )

21+import Data.Kind ( Type )

22+import Data.Void ( Void )

13−import Prelude

23+import Prelude hiding ( undefined )

15-- hasql

25-- hasql

16−import Hasql.Connection ( Connection )

17import qualified Hasql.Decoders as Hasql

26import qualified Hasql.Decoders as Hasql

18import qualified Hasql.Encoders as Hasql

27import qualified Hasql.Encoders as Hasql

19−import qualified Hasql.Session as Hasql

20import qualified Hasql.Statement as Hasql

28import 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+

22-- rel8

44-- rel8

45+import Rel8.Expr ( Expr )

46+import Rel8.Expr.Bool ( false )

47+import Rel8.Expr.Opaleye ( toPrimExpr )

23import Rel8.Query ( Query )

48import Rel8.Query ( Query )

24−import Rel8.Query.SQL ( sqlForQuery, sqlForQueryWithNames )

49+import Rel8.Query.Opaleye ( toOpaleye )

25import Rel8.Schema.Name ( Selects )

50import Rel8.Schema.Name ( Selects )

51+import Rel8.Table ( Table )

52+import Rel8.Table.Cols ( toCols )

53+import Rel8.Table.Name ( namesFromLabels )

54+import Rel8.Table.Opaleye ( castTable, exprsWithNames )

55+import qualified Rel8.Table.Opaleye as T

26import Rel8.Table.Serialize ( Serializable, parse )

56import Rel8.Table.Serialize ( Serializable, parse )

57+import Rel8.Table.Undefined ( undefined )

28-- text

59-- text

29import qualified Data.Text as Text

60import qualified Data.Text as Text

30import Data.Text.Encoding ( encodeUtf8 )

61import Data.Text.Encoding ( encodeUtf8 )

33−-- | Run a @SELECT@ query, returning all rows.

64+-- | Run a @SELECT@ statement, returning all rows.

34select :: forall exprs a. Serializable exprs a

65select :: forall exprs a. Serializable exprs a

35− => Connection -> Query exprs -> IO [a]

66+ => Query exprs -> Hasql.Statement () [a]

36−select c query = case sqlForQuery query of

67+select query = Hasql.Statement bytes params decode prepare

37− Nothing -> pure []

68+ where

38− Just sql -> Hasql.run session c >>= either throwIO pure

69+ bytes = encodeUtf8 (Text.pack sql)

39− where

70+ params = Hasql.noParams

40− session = Hasql.statement () statement

71+ decode = Hasql.rowList (parse @exprs @a)

41− statement = Hasql.Statement bytes params decode prepare

72+ prepare = False

42− bytes = encodeUtf8 (Text.pack sql)

73+ sql = show doc

43− params = Hasql.noParams

74+ doc = ppSelect query

44− decode = Hasql.rowList (parse @exprs @a)

75+

45− prepare = False

76+

46−

77+ppSelect :: Table Expr a => Query a -> Doc

47−

78+ppSelect query =

48−selectWithNames :: forall exprs a names.

79+ Opaleye.ppSql $ primSelectWith names (toCols exprs') primQuery'

80+ where

81+ names = namesFromLabels

82+ (exprs, primQuery, _) =

83+ Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

84+ (exprs', primQuery') = case optimize primQuery of

85+ Empty -> (undefined, Opaleye.Product (pure (pure Opaleye.Unit)) never)

86+ Unit -> (exprs, Opaleye.Unit)

87+ Optimized pq -> (exprs, pq)

88+ never = pure (toPrimExpr false)

89+

90+

91+ppRows :: Table Expr a => Query a -> Doc

92+ppRows query = case optimize primQuery of

93+ -- Special case VALUES because we can't use DEFAULT inside a SELECT

94+ Optimized (Opaleye.Values symbols rows)

95+ | eqSymbols symbols (toList (T.exprs a)) ->

96+ Opaleye.ppValues_ (map Opaleye.sqlExpr <$> toList rows)

97+ _ -> ppSelect query

98+ where

99+ (a, primQuery, _) = Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

100+

101+ eqSymbols (symbol : symbols) (Opaleye.AttrExpr symbol' : exprs)

102+ | eqSymbol symbol symbol' = eqSymbols symbols exprs

103+ | otherwise = False

104+ eqSymbols [] [] = True

105+ eqSymbols _ _ = False

106+

107+ eqSymbol

108+ (Opaleye.Symbol name (Opaleye.UnsafeTag tag))

109+ (Opaleye.Symbol name' (Opaleye.UnsafeTag tag'))

110+ = name == name' && tag == tag'

111+

112+

113+ppPrimSelect :: Query a -> (Optimized Doc, a)

114+ppPrimSelect query =

115+ (Opaleye.ppSql . primSelect <$> optimize primQuery, a)

116+ where

117+ (a, primQuery, _) = Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

118+

119+

120+type Optimized :: Type -> Type

121+data Optimized a = Empty | Unit | Optimized a

122+ deriving stock (Functor, Foldable, Traversable, Show)

123+

124+

125+optimize :: Opaleye.PrimQuery' a -> Optimized (Opaleye.PrimQuery' Void)

126+optimize query = case Opaleye.removeEmpty (Opaleye.optimize query) of

127+ Nothing -> Empty

128+ Just Opaleye.Unit -> Unit

129+ Just query' -> Optimized query'

130+

131+

132+primSelect :: Opaleye.PrimQuery' Void -> Opaleye.Select

133+primSelect = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator

134+

135+

49− ( Selects names exprs

136+primSelectWith :: Selects names exprs

50− , Serializable exprs a

137+ => names -> exprs -> Opaleye.PrimQuery' Void -> Opaleye.Select

51− )

138+primSelectWith names exprs query =

52− => Connection -> names -> Query exprs -> IO [a]

139+ Opaleye.SelectFrom $ Opaleye.newSelect

53−selectWithNames c names query = case sqlForQueryWithNames names query of

140+ { Opaleye.attrs = Opaleye.SelectAttrs attrs

54− Nothing -> pure []

141+ , Opaleye.tables = Opaleye.oneTable (primSelect query)

55− Just sql -> Hasql.run session c >>= either throwIO pure

142+ }

56− where

143+ where

57− session = Hasql.statement () statement

144+ attrs = makeAttr <$> exprsWithNames names (castTable exprs)

58− statement = Hasql.Statement bytes params decode prepare

145+ where

59− bytes = encodeUtf8 (Text.pack sql)

146+ makeAttr (label, expr) =

60− params = Hasql.noParams

147+ (Opaleye.sqlExpr expr, Just (Opaleye.SqlColumn label))

61− decode = Hasql.rowList (parse @exprs @a)

62− prepare = False

src/Rel8/Statement/Set.hsnew file+33

@@ -0,0 +1,33 @@

1+{-# language MonoLocalBinds #-}

2+{-# language NamedFieldPuns #-}

4+module Rel8.Statement.Set

5+ ( ppSet

6+ )

7+where

9+-- base

10+import Data.Foldable ( toList )

11+import Prelude ()

12+

13+-- opaleye

14+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye

15+import qualified Opaleye.Internal.Sql as Opaleye

16+

17+-- pretty

18+import Text.PrettyPrint ( Doc, (<+>), equals, text )

19+

20+-- rel8

21+import Rel8.Schema.Name ( Selects, ppColumn )

22+import Rel8.Schema.Table ( TableSchema(..) )

23+import Rel8.Table.Opaleye ( attributes, exprsWithNames )

24+

25+

26+ppSet :: Selects names exprs

27+ => TableSchema names -> (exprs -> exprs) -> Doc

28+ppSet schema@TableSchema {columns} f =

29+ text "SET" <+> Opaleye.commaV ppAssign (toList assigns)

30+ where

31+ assigns = exprsWithNames columns (f (attributes schema))

32+ ppAssign (column, expr) =

33+ ppColumn column <+> equals <+> Opaleye.ppSqlExpr (Opaleye.sqlExpr expr)

src/Rel8/Statement/Update.hs+38−56

@@ -1,39 +1,37 @@

1+{-# language DuplicateRecordFields #-}

1{-# language GADTs #-}

2{-# language GADTs #-}

2{-# language NamedFieldPuns #-}

3{-# language NamedFieldPuns #-}

3−{-# language ScopedTypeVariables #-}

4+{-# language RecordWildCards #-}

4{-# language StandaloneKindSignatures #-}

5{-# language StandaloneKindSignatures #-}

5−{-# language TypeApplications #-}

6+{-# language StrictData #-}

7module Rel8.Statement.Update

8module Rel8.Statement.Update

8 ( Update(..)

9 ( Update(..)

9 , update

10 , update

11+ , ppUpdate

10 )

12 )

11where

13where

13-- base

15-- base

14−import Control.Exception ( throwIO )

15import Data.Kind ( Type )

16import Data.Kind ( Type )

16import Prelude

17import Prelude

18-- hasql

19-- hasql

19−import Hasql.Connection ( Connection )

20−import qualified Hasql.Decoders as Hasql

21import qualified Hasql.Encoders as Hasql

20import qualified Hasql.Encoders as Hasql

22−import qualified Hasql.Session as Hasql

23import qualified Hasql.Statement as Hasql

21import qualified Hasql.Statement as Hasql

25−-- opaleye

23+-- pretty

26−import qualified Opaleye.Internal.Manipulation as Opaleye

24+import Text.PrettyPrint ( Doc, (<+>), ($$), text )

28-- rel8

26-- rel8

29import Rel8.Expr ( Expr )

27import Rel8.Expr ( Expr )

30−import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )

28+import Rel8.Query ( Query )

31import Rel8.Schema.Name ( Selects )

29import Rel8.Schema.Name ( Selects )

32−import Rel8.Schema.Table ( TableSchema )

30+import Rel8.Schema.Table ( TableSchema(..), ppTable )

33−import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) )

31+import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )

34−import Rel8.Table ( fromColumns, toColumns )

32+import Rel8.Statement.Set ( ppSet )

35−import Rel8.Table.Opaleye ( castTable, table, unpackspec )

33+import Rel8.Statement.Using ( ppFrom )

36−import Rel8.Table.Serialize ( Serializable, parse )

34+import Rel8.Statement.Where ( ppWhere )

38-- text

36-- text

39import qualified Data.Text as Text

37import qualified Data.Text as Text

@@ -46,9 +44,12 @@ data Update a where

46 Update :: Selects names exprs =>

44 Update :: Selects names exprs =>

47 { target :: TableSchema names

45 { target :: TableSchema names

48 -- ^ Which table to update.

46 -- ^ 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.

49− , set :: exprs -> exprs

50+ , set :: from -> exprs -> exprs

50 -- ^ How to update each selected row.

51 -- ^ How to update each selected row.

51− , updateWhere :: exprs -> Expr Bool

52+ , updateWhere :: from -> exprs -> Expr Bool

52 -- ^ Which rows to select for update.

53 -- ^ Which rows to select for update.

53 , returning :: Returning names a

54 , returning :: Returning names a

54 -- ^ What to return from the @UPDATE@ statement.

55 -- ^ What to return from the @UPDATE@ statement.

@@ -56,46 +57,27 @@ data Update a where

56 -> Update a

57 -> Update a

59−-- | Run an @UPDATE@ statement.

60+ppUpdate :: Update a -> Doc

60−update :: Connection -> Update a -> IO a

61+ppUpdate Update {..} = case ppFrom from of

61−update c Update {target, set, updateWhere, returning} =

62+ Nothing ->

62− case returning of

63+ text "UPDATE" <+> ppTable target $$

63− NumberOfRowsAffected -> Hasql.run session c >>= either throwIO pure

64+ ppSet target id $$

64− where

65+ text "WHERE false"

65− session = Hasql.statement () statement

66+ Just (fromDoc, i) ->

66− statement = Hasql.Statement bytes params decode prepare

67+ text "UPDATE" <+> ppTable target $$

67− bytes = encodeUtf8 $ Text.pack sql

68+ ppSet target (set i) $$

68− params = Hasql.noParams

69+ fromDoc $$

69− decode = Hasql.rowsAffected

70+ ppWhere target (updateWhere i) $$

70− prepare = False

71+ ppReturning target returning

71− sql = Opaleye.arrangeUpdateSql target' set' where'

72− where

73− target' = table $ toColumns <$> target

74− set' = toColumns . set . fromColumns

75− where' = toColumn . toPrimExpr . updateWhere . fromColumns

77− Projection project -> Hasql.run session c >>= either throwIO pure

78− where

79− session = Hasql.statement () statement

80− statement = Hasql.Statement bytes params decode prepare

81− bytes = encodeUtf8 $ Text.pack sql

82− params = Hasql.noParams

83− decode = decoder project

84− prepare = False

85− sql =

86− Opaleye.arrangeUpdateReturningSql

87− unpackspec

88− target'

89− set'

90− where'

91− project'

92− where

93− target' = table $ toColumns <$> target

94− set' = toColumns . set . fromColumns

95− where' = toColumn . toPrimExpr . updateWhere . fromColumns

96− project' = castTable . toColumns . project . fromColumns

74+-- | Run an @UPDATE@ statement.

75+update :: Update a -> Hasql.Statement () a

76+update u@Update {returning} = Hasql.Statement bytes params decode prepare

98 where

77 where

99− decoder :: forall exprs projection a. Serializable projection a

78+ bytes = encodeUtf8 $ Text.pack sql

100− => (exprs -> projection) -> Hasql.Result [a]

79+ params = Hasql.noParams

101− decoder _ = Hasql.rowList (parse @projection @a)

80+ decode = decodeReturning returning

81+ prepare = False

82+ sql = show doc

83+ doc = ppUpdate u

src/Rel8/Statement/Using.hsnew file+36

@@ -0,0 +1,36 @@

1+module Rel8.Statement.Using

2+ ( ppFrom

3+ , ppUsing

4+ )

5+where

7+-- base

8+import Prelude

10+-- pretty

11+import Text.PrettyPrint ( Doc, (<+>), parens, text )

12+

13+-- rel8

14+import Rel8.Query ( Query )

15+import Rel8.Schema.Table ( TableSchema(..), ppTable )

16+import Rel8.Statement.Select ( Optimized(..), ppPrimSelect )

17+

18+

19+ppFrom :: Query a -> Maybe (Doc, a)

20+ppFrom = ppJoin "FROM"

21+

22+

23+ppUsing :: Query a -> Maybe (Doc, a)

24+ppUsing = ppJoin "USING"

25+

26+

27+ppJoin :: String -> Query a -> Maybe (Doc, a)

28+ppJoin clause join = do

29+ doc <- case ofrom of

30+ Empty -> Nothing

31+ Unit -> Just mempty

32+ Optimized doc -> Just $ text clause <+> parens doc <+> ppTable alias

33+ pure (doc, a)

34+ where

35+ alias = TableSchema {name = "T1", schema = Nothing, columns = ()}

36+ (ofrom, a) = ppPrimSelect join

src/Rel8/Statement/View.hs+43−28

@@ -3,61 +3,76 @@

4module Rel8.Statement.View

5 ( createView

6+ , createOrReplaceView

6 )

7 )

7where

8where

9-- base

10-- base

10−import Control.Exception ( throwIO )

11−import Control.Monad ( (>=>) )

12−import Data.Foldable ( fold )

13−import Data.Maybe ( fromMaybe )

14import Prelude

11import Prelude

16-- hasql

13-- hasql

17−import Hasql.Connection ( Connection )

18import qualified Hasql.Decoders as Hasql

14import qualified Hasql.Decoders as Hasql

19import qualified Hasql.Encoders as Hasql

15import qualified Hasql.Encoders as Hasql

20−import qualified Hasql.Session as Hasql

21import qualified Hasql.Statement as Hasql

16import qualified Hasql.Statement as Hasql

23-- rel8

18-- rel8

24import Rel8.Query ( Query )

19import Rel8.Query ( Query )

25−import Rel8.Query.SQL ( sqlForQueryWithNames )

26import Rel8.Schema.Name ( Selects )

20import Rel8.Schema.Name ( Selects )

27−import Rel8.Schema.Table ( TableSchema( TableSchema ) )

21+import Rel8.Schema.Table ( TableSchema )

28−import Rel8.Table.Alternative ( emptyTable )

22+import Rel8.Statement.Insert ( ppInto )

23+import Rel8.Statement.Select ( ppSelect )

24+

25+-- pretty

26+import Text.PrettyPrint ( Doc, (<+>), ($$), text )

30-- text

28-- text

31import qualified Data.Text as Text

29import qualified Data.Text as Text

32import Data.Text.Encoding ( encodeUtf8 )

30import Data.Text.Encoding ( encodeUtf8 )

33+data CreateView = Create | CreateOrReplace

34+

35+

35-- | Given a 'TableSchema' and 'Query', @createView@ runs a @CREATE VIEW@

36-- | Given a 'TableSchema' and 'Query', @createView@ runs a @CREATE VIEW@

36-- statement that will save the given query as a view. This can be useful if

37-- statement that will save the given query as a view. This can be useful if

37-- you want to share Rel8 queries with other applications.

38-- you want to share Rel8 queries with other applications.

38createView :: Selects names exprs

39createView :: Selects names exprs

39− => TableSchema names -> Query exprs -> Connection -> IO ()

40+ => TableSchema names -> Query exprs -> Hasql.Statement () ()

40−createView (TableSchema name mschema names) query =

41+createView =

41− Hasql.run session >=> either throwIO pure

42+ createViewGeneric Create

43+

44+

45+-- | Given a 'TableSchema' and 'Query', @createOrReplaceView@ runs a

46+-- @CREATE OR REPLACE VIEW@ statement that will save the given query

47+-- as a view, replacing the current view definition if it exists and

48+-- adheres to the restrictions in place for replacing a view in

49+-- PostgreSQL.

50+createOrReplaceView :: Selects names exprs

51+ => TableSchema names -> Query exprs -> Hasql.Statement () ()

52+createOrReplaceView =

53+ createViewGeneric CreateOrReplace

54+

55+

56+createViewGeneric :: Selects names exprs

57+ => CreateView -> TableSchema names -> Query exprs -> Hasql.Statement () ()

58+createViewGeneric replace schema query =

59+ Hasql.Statement bytes params decode prepare

42 where

60 where

43− session = Hasql.statement () statement

44− statement = Hasql.Statement bytes params decode prepare

45 bytes = encodeUtf8 (Text.pack sql)

61 bytes = encodeUtf8 (Text.pack sql)

46 params = Hasql.noParams

62 params = Hasql.noParams

47 decode = Hasql.noResult

63 decode = Hasql.noResult

48 prepare = False

64 prepare = False

49− sql = "CREATE VIEW " <> title <> " AS " <> select

65+ sql = show doc

50− where

66+ doc = ppCreateView schema query replace

51− title = case mschema of

67+

52− Nothing -> quote name

68+

53− Just schema -> quote schema <> "." <> quote name

69+ppCreateView :: Selects names exprs

54− select = fromMaybe fallback $ sqlForQueryWithNames names query

70+ => TableSchema names -> Query exprs -> CreateView -> Doc

55− where

71+ppCreateView schema query replace =

56− fallback = fold $ sqlForQueryWithNames names emptyTable

72+ createOrReplace replace <+>

57−

73+ ppInto schema $$

58−

74+ text "AS" <+>

59−quote :: String -> String

75+ ppSelect query

60−quote string = "\"" <> concatMap go string <> "\""

61 where

76 where

62− go '"' = "\"\""

77+ createOrReplace Create = text "CREATE VIEW"

63− go c = [c]

78+ createOrReplace CreateOrReplace = text "CREATE OR REPLACE VIEW"

src/Rel8/Statement/Where.hsnew file+31

@@ -0,0 +1,31 @@

1+{-# language MonoLocalBinds #-}

3+module Rel8.Statement.Where

4+ ( ppWhere

5+ )

6+where

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+88−252

@@ -1,77 +1,47 @@

1{-# language AllowAmbiguousTypes #-}

2{-# language DataKinds #-}

3{-# language DefaultSignatures #-}

4−{-# language DisambiguateRecordFields #-}

5{-# language FlexibleContexts #-}

4{-# language FlexibleContexts #-}

6{-# language FlexibleInstances #-}

5{-# language FlexibleInstances #-}

7{-# language FunctionalDependencies #-}

6{-# language FunctionalDependencies #-}

8−{-# language LambdaCase #-}

9−{-# language NamedFieldPuns #-}

10{-# language ScopedTypeVariables #-}

7{-# language ScopedTypeVariables #-}

11{-# language StandaloneKindSignatures #-}

8{-# language StandaloneKindSignatures #-}

12{-# language TypeApplications #-}

9{-# language TypeApplications #-}

13{-# language TypeFamilies #-}

10{-# language TypeFamilies #-}

14−{-# language TypeOperators #-}

15{-# language UndecidableInstances #-}

11{-# language UndecidableInstances #-}

17module Rel8.Table

13module Rel8.Table

14+ ( Table

18− ( Table (Columns, Context, Unreify, toColumns, fromColumns, reify, unreify)

15+ ( Columns, Context, fromColumns, toColumns

16+ , FromExprs, fromResult, toResult

17+ , Transpose

18+ )

19 , Congruent

20− , TTable, TColumns, TContext, TUnreify

20+ , TTable, TColumns, TContext, TFromExprs, TTranspose

21+ , TSerialize

21 )

22 )

22where

23where

24-- base

25-- 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 ) )

31import GHC.Generics ( Generic, Rep, from, to )

28import GHC.Generics ( Generic, Rep, from, to )

32import Prelude hiding ( null )

29import Prelude hiding ( null )

34-- rel8

31-- rel8

35import Rel8.FCF ( Eval, Exp )

32import Rel8.FCF ( Eval, Exp )

36−import Rel8.Kind.Algebra ( KnownAlgebra )

33+import Rel8.Generic.Map ( Map )

37−import Rel8.Generic.Map ( GMap, GMappable, gmap, gunmap )

38−import Rel8.Generic.Table

34+import Rel8.Generic.Table.Record

39− ( GGTable, GGColumns, GGContext, ggfromColumns, ggtoColumns

35+ ( GTable, GColumns, GContext, gfromColumns, gtoColumns

40− , GAlgebra

36+ , GSerialize, gfromResult, gtoResult

41 )

37 )

42import Rel8.Generic.Record ( Record(..) )

38import Rel8.Generic.Record ( Record(..) )

43−import Rel8.Generic.Reify ( ARep )

44−import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )

45import Rel8.Schema.HTable ( HTable )

39import Rel8.Schema.HTable ( HTable )

46−import Rel8.Schema.HTable.Either ( HEitherTable(..) )

40+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

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 )

55import qualified Rel8.Schema.Kind as K

41import qualified Rel8.Schema.Kind as K

56import Rel8.Schema.Null ( Sql )

42import Rel8.Schema.Null ( Sql )

57−import Rel8.Schema.Reify

43+import Rel8.Schema.Result ( Result )

58− ( Reify, Col( Reify ), hreify, hunreify

59− , UnwrapReify

60− , notReify

61− )

62−import Rel8.Schema.Result

63− ( Col( R ), Result

64− , relabel

65− , null, nullifier, unnullifier

66− , vectorizer, unvectorizer

67− )

68−import Rel8.Schema.Spec ( KnownSpec )

69import Rel8.Type ( DBType )

44import 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 )

77-- | @Table@s are one of the foundational elements of Rel8, and describe data

47-- | @Table@s are one of the foundational elements of Rel8, and describe data

@@ -86,90 +56,102 @@ import Data.These.Combinators ( justHere, justThere )

86-- yourself, as anything that's an instance of 'Rel8.Rel8able' is always a

56-- yourself, as anything that's an instance of 'Rel8.Rel8able' is always a

87-- 'Table'.

57-- 'Table'.

88type Table :: K.Context -> Type -> Constraint

58type Table :: K.Context -> Type -> Constraint

59+class

60+ ( HTable (Columns a)

61+ , context ~ Context a

62+ , a ~ Transpose context a

63+ )

89−class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where

64+ => Table context a | a -> context

65+ where

90 -- | The 'HTable' functor that describes the schema of this table.

66 -- | The 'HTable' functor that describes the schema of this table.

91 type Columns a :: K.HTable

67 type Columns a :: K.HTable

93 -- | The common context that all columns use as an interpretation.

69 -- | The common context that all columns use as an interpretation.

94 type Context a :: K.Context

70 type Context a :: K.Context

96− type Unreify a :: Type

72+ -- | The @FromExprs@ type family maps a type in the @Expr@ context to the

73+ -- corresponding Haskell type.

74+ type FromExprs a :: Type

75+

76+ type Transpose (context' :: K.Context) a :: Type

98− toColumns :: a -> Columns a (Col context)

99− fromColumns :: Columns a (Col context) -> a

100

101− reify :: context :~: Reify ctx -> Unreify a -> a

79+ toColumns :: a -> Columns a context

102− unreify :: context :~: Reify ctx -> a -> Unreify a

80+ fromColumns :: Columns a context -> a

103

104− type Columns a = Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))

82+ fromResult :: Columns a Result -> FromExprs a

83+ toResult :: FromExprs a -> Columns a Result

84+

85+ type Columns a = GColumns TColumns (Rep (Record a))

105− type Context a = Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))

86+ type Context a = GContext TContext (Rep (Record a))

106− type Unreify a = DefaultUnreify a

87+ type FromExprs a = Map TFromExprs a

88+ type Transpose context a = Map (TTranspose context) a

107

108 default toColumns ::

90 default toColumns ::

109 ( Generic (Record a)

91 ( Generic (Record a)

110− , KnownAlgebra (GAlgebra (Rep (Record a)))

111− , Eval (GGTable (GAlgebra (Rep (Record a))) (TTable context) TColumns (Col context) (Rep (Record a)))

92+ , GTable (TTable context) TColumns (Rep (Record a))

112− , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))

93+ , Columns a ~ GColumns TColumns (Rep (Record a))

113− , Context a ~ Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))

114 )

94 )

115− => a -> Columns a (Col context)

95+ => a -> Columns a context

116 toColumns =

96 toColumns =

117− ggtoColumns

118− @(GAlgebra (Rep (Record a)))

119− @(TTable context)

97+ gtoColumns @(TTable context) @TColumns toColumns .

120− @TColumns

121− id

122− id

123− toColumns .

124 from .

98 from .

125 Record

99 Record

126

100

127 default fromColumns ::

101 default fromColumns ::

128 ( Generic (Record a)

102 ( Generic (Record a)

129− , KnownAlgebra (GAlgebra (Rep (Record a)))

130− , Eval (GGTable (GAlgebra (Rep (Record a))) (TTable context) TColumns (Col context) (Rep (Record a)))

103+ , GTable (TTable context) TColumns (Rep (Record a))

131− , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))

104+ , Columns a ~ GColumns TColumns (Rep (Record a))

132− , Context a ~ Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))

133 )

105 )

134− => Columns a (Col context) -> a

106+ => Columns a context -> a

135 fromColumns =

107 fromColumns =

136 unrecord .

108 unrecord .

137 to .

109 to .

138− ggfromColumns

139− @(GAlgebra (Rep (Record a)))

140− @(TTable context)

110+ gfromColumns @(TTable context) @TColumns fromColumns

141− @TColumns

142− id

143− id

144− fromColumns

145

111

146− default reify ::

112+ default toResult ::

147− ( Generic (Record a)

113+ ( Generic (Record (FromExprs a))

148− , Generic (Record (Unreify a))

114+ , GSerialize TSerialize TColumns (Rep (Record a)) (Rep (Record (FromExprs a)))

149− , GMappable (TTable context) (Rep (Record a))

115+ , Columns a ~ GColumns TColumns (Rep (Record a))

150− , Rep (Record (Unreify a)) ~ GMap TUnreify (Rep (Record a))

151 )

116 )

152− => context :~: Reify ctx -> Unreify a -> a

117+ => FromExprs a -> Columns a Result

153− reify Refl =

118+ toResult =

154− unrecord .

119+ gtoResult

155− to .

120+ @TSerialize

156− gunmap @(TTable context) (Proxy @TUnreify) (reify Refl) .

121+ @TColumns

122+ @(Rep (Record a))

123+ @(Rep (Record (FromExprs a)))

124+ (\(_ :: proxy x) -> toResult @(Context x) @x) .

157 from .

125 from .

158 Record

126 Record

159

127

160− default unreify ::

128+ default fromResult ::

161− ( Generic (Record a)

129+ ( Generic (Record (FromExprs a))

162− , Generic (Record (Unreify a))

130+ , GSerialize TSerialize TColumns (Rep (Record a)) (Rep (Record (FromExprs a)))

163− , GMappable (TTable context) (Rep (Record a))

131+ , Columns a ~ GColumns TColumns (Rep (Record a))

164− , Rep (Record (Unreify a)) ~ GMap TUnreify (Rep (Record a))

165 )

132 )

166− => context :~: Reify ctx -> a -> Unreify a

133+ => Columns a Result -> FromExprs a

167− unreify Refl =

134+ fromResult =

168 unrecord .

135 unrecord .

169 to .

136 to .

170− gmap @(TTable context) (Proxy @TUnreify) (unreify Refl) .

137+ gfromResult

171− from .

138+ @TSerialize

172− Record

139+ @TColumns

140+ @(Rep (Record a))

141+ @(Rep (Record (FromExprs a)))

142+ (\(_ :: proxy x) -> fromResult @(Context x) @x)

143+

144+

145+instance Sql DBType a => Table Result (Identity a) where

146+ type Columns (Identity a) = HIdentity a

147+ type Context (Identity a) = Result

148+ type FromExprs (Identity a) = a

149+ type Transpose to (Identity a) = to a

150+

151+ toColumns = HIdentity

152+ fromColumns (HIdentity a) = a

153+ toResult a = HIdentity (Identity a)

154+ fromResult (HIdentity (Identity a)) = a

173

155

174

156

175data TTable :: K.Context -> Type -> Exp Constraint

157data TTable :: K.Context -> Type -> Exp Constraint

@@ -184,175 +166,32 @@ data TContext :: Type -> Exp K.Context

184type instance Eval (TContext a) = Context a

166type instance Eval (TContext a) = Context a

185

167

186

168

187−data TUnreify :: Type -> Exp Type

169+data TFromExprs :: Type -> Exp Type

188−type instance Eval (TUnreify a) = Unreify a

170+type instance Eval (TFromExprs a) = FromExprs a

189−

190−

191−type DefaultUnreify :: Type -> Type

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))

205−

206

171

207−-- | Any 'HTable' is also a 'Table'.

208−instance HTable t => Table context (t (Col context)) where

209− type Columns (t (Col context)) = t

210− type Context (t (Col context)) = context

211− type Unreify (t (Col context)) = t (Col (UnwrapReify context))

212

172

213− toColumns = id

173+data TTranspose :: K.Context -> Type -> Exp Type

214− fromColumns = id

174+type instance Eval (TTranspose context a) = Transpose context a

215

175

216− reify Refl = hreify

217− unreify Refl = hunreify

218−

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

176

177+data TSerialize :: Type -> Type -> Exp Constraint

178+type instance Eval (TSerialize expr a) =

179+ ( Table (Context expr) expr

180+ , a ~ FromExprs expr

181+ )

232

182

233−instance Sql DBType a => Table Result (Identity a) where

234− type Columns (Identity a) = HType a

235− type Context (Identity a) = Result

236

183

237− toColumns (Identity a) = HType (R a)

238− fromColumns (HType (R 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 (R IsLeft)

251− , hleft = hlabel labeler (hnullify nullifier (toColumns table))

252− , hright = hlabel labeler (hnulls (const null))

253− }

254− Right table -> HEitherTable

255− { htag = HIdentity (R 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 (R 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 (R Nothing)

283− , hjust = hlabel labeler (hnulls (const null))

284− }

285− Just table -> HMaybeTable

286− { htag = HIdentity (R (Just IsJust))

287− , hjust = hlabel labeler (hnullify nullifier (toColumns table))

288− }

289−

290− fromColumns HMaybeTable {htag, hjust} = case htag of

291− HIdentity (R 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−

342−instance (Table context a, Table context b, Labelable context)

184+instance (Table context a, Table context b) => Table context (a, b)

343− => Table context (a, b)

344

185

345

186

346instance

187instance

347 ( Table context a, Table context b, Table context c

188 ( Table context a, Table context b, Table context c

348− , Labelable context

349 )

189 )

350 => Table context (a, b, c)

190 => Table context (a, b, c)

351

191

352

192

353instance

193instance

354 ( Table context a, Table context b, Table context c, Table context d

194 ( Table context a, Table context b, Table context c, Table context d

355− , Labelable context

356 )

195 )

357 => Table context (a, b, c, d)

196 => Table context (a, b, c, d)

358

197

@@ -360,7 +199,6 @@ instance

360instance

199instance

361 ( Table context a, Table context b, Table context c, Table context d

200 ( Table context a, Table context b, Table context c, Table context d

362 , Table context e

201 , Table context e

363− , Labelable context

364 )

202 )

365 => Table context (a, b, c, d, e)

203 => Table context (a, b, c, d, e)

366

204

@@ -368,7 +206,6 @@ instance

368instance

206instance

369 ( Table context a, Table context b, Table context c, Table context d

207 ( Table context a, Table context b, Table context c, Table context d

370 , Table context e, Table context f

208 , Table context e, Table context f

371− , Labelable context

372 )

209 )

373 => Table context (a, b, c, d, e, f)

210 => Table context (a, b, c, d, e, f)

374

211

@@ -376,7 +213,6 @@ instance

376instance

213instance

377 ( Table context a, Table context b, Table context c, Table context d

214 ( Table context a, Table context b, Table context c, Table context d

378 , Table context e, Table context f, Table context g

215 , Table context e, Table context f, Table context g

379− , Labelable context

380 )

216 )

381 => Table context (a, b, c, d, e, f, g)

217 => Table context (a, b, c, d, e, f, g)

382

218

src/Rel8/Table/ADT.hs+33−65

@@ -7,13 +7,13 @@

7{-# language ScopedTypeVariables #-}

8{-# language StandaloneKindSignatures #-}

9{-# language TypeApplications #-}

10−{-# language TypeFamilies #-}

10+{-# language TypeFamilyDependencies #-}

11{-# language UndecidableInstances #-}

12{-# language UndecidableSuperClasses #-}

14module Rel8.Table.ADT

15 ( ADT( ADT )

16− , ADTable, fromADT, toADT

16+ , ADTable

17 , BuildableADT

18 , BuildADT, buildADT

19 , ConstructableADT

@@ -27,9 +27,7 @@ where

28-- base

29import Data.Kind ( Constraint, Type )

30−import Data.Proxy ( Proxy( Proxy ) )

31−import Data.Type.Equality ( (:~:)( Refl ) )

32−import GHC.Generics ( Generic, Rep, from, to )

30+import GHC.Generics ( Generic, from, to )

33import GHC.TypeLits ( Symbol )

31import GHC.TypeLits ( Symbol )

34import Prelude

32import Prelude

@@ -46,95 +44,65 @@ import Rel8.Generic.Construction

46 , GGName, ggname

44 , GGName, ggname

47 , GGAggregate, ggaggregate

45 , GGAggregate, ggaggregate

48 )

46 )

49−import Rel8.Generic.Map ( GMappable, GMap, gmap, gunmap )

47+import Rel8.Generic.Record ( Record( Record ), unrecord )

50−import Rel8.Generic.Record ( GRecordable, GRecord, grecord, gunrecord )

51import Rel8.Generic.Rel8able

48import Rel8.Generic.Rel8able

52 ( Rel8able

49 ( Rel8able

53 , GRep, GColumns, gfromColumns, gtoColumns

50 , GRep, GColumns, gfromColumns, gtoColumns

54− , greify, gunreify

51+ , GFromExprs, gfromResult, gtoResult

52+ , TSerialize, deserialize, serialize

55 )

53 )

56import qualified Rel8.Generic.Table.ADT as G

54import qualified Rel8.Generic.Table.ADT as G

57import qualified Rel8.Kind.Algebra as K

55import qualified Rel8.Kind.Algebra as K

58−import Rel8.Schema.Context ( Col )

59import Rel8.Schema.HTable ( HTable )

56import Rel8.Schema.HTable ( HTable )

60import qualified Rel8.Schema.Kind as K

57import qualified Rel8.Schema.Kind as K

61import Rel8.Schema.Name ( Name )

58import Rel8.Schema.Name ( Name )

62−import Rel8.Schema.Reify ( Col( Reify ), Reify, hreify, hunreify )

63import Rel8.Schema.Result ( Result )

59import Rel8.Schema.Result ( Result )

64−import Rel8.Table

60+import Rel8.Table ( Table, TColumns )

65− ( Table

66− , fromColumns, toColumns, reify, unreify

67− , TTable, TColumns, TUnreify

68− )

71type ADT :: K.Rel8able -> K.Rel8able

63type ADT :: K.Rel8able -> K.Rel8able

72−newtype ADT t context = ADT (GColumnsADT t (Col context))

64+newtype ADT t context = ADT (GColumnsADT t context)

75instance ADTable t => Rel8able (ADT t) where

67instance ADTable t => Rel8able (ADT t) where

76 type GColumns (ADT t) = GColumnsADT t

68 type GColumns (ADT t) = GColumnsADT t

69+ type GFromExprs (ADT t) = t Result

78− gfromColumns = ADT

71+ gfromColumns _ = ADT

79− gtoColumns (ADT a) = a

72+ gtoColumns _ (ADT a) = a

80−

81− greify (ADT a) = ADT (hreify a)

82− gunreify (ADT a) = ADT (hunreify a)

83−

85−instance (ADTable t, context ~ Result) => Generic (ADT t context) where

74+ gfromResult =

86− type Rep (ADT t context) = Rep (t context)

75+ unrecord .

87−

88− from =

89− gmap @(TTable (Reify Result)) (Proxy @TUnreify) (unreify Refl) .

90− gunrecord @(Rep (t (Reify Result))) .

91− G.gfromColumnsADT

92− @(TTable (Reify Result))

93− @TColumns

94− (\(Reify a) -> a)

95− Reify

96− fromColumns .

97− hreify .

98− (\(ADT a) -> a)

99−

100− to =

76+ to .

101− ADT .

77+ G.gfromResultADT

102− hunreify .

78+ @TSerialize

103− G.gtoColumnsADT

104− @(TTable (Reify Result))

105 @TColumns

79 @TColumns

106− (\(Reify a) -> a)

80+ @(Eval (ADTRep t Expr))

107− Reify

81+ @(Eval (ADTRep t Result))

108− toColumns .

82+ (\(_ :: proxy x) -> deserialize @_ @x)

109− grecord @(Rep (t (Reify Result))) .

110− gunmap @(TTable (Reify Result)) (Proxy @TUnreify) (reify Refl)

111

112−

84+ gtoResult =

113−fromADT :: ADTable t => ADT t Result -> t Result

85+ G.gtoResultADT

114−fromADT = to . from

86+ @TSerialize

115−

87+ @TColumns

116−

88+ @(Eval (ADTRep t Expr))

117−toADT :: ADTable t => t Result -> ADT t Result

89+ @(Eval (ADTRep t Result))

118−toADT = to . from

90+ (\(_ :: proxy x) -> serialize @_ @x) .

91+ from .

92+ Record

119

120

121type ADTable :: K.Rel8able -> Constraint

95type ADTable :: K.Rel8able -> Constraint

122class

96class

123− ( Generic (t Result)

97+ ( Generic (Record (t Result))

124 , HTable (GColumnsADT t)

98 , HTable (GColumnsADT t)

125− , G.GTableADT (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRecord (Rep (t (Reify Result))))

99+ , G.GSerializeADT TSerialize TColumns (Eval (ADTRep t Expr)) (Eval (ADTRep t Result))

126− , GRecordable (Rep (t (Reify Result)))

127− , GMappable (TTable (Reify Result)) (Rep (t (Reify Result)))

128− , GMap TUnreify (Rep (t (Reify Result))) ~ Rep (t Result)

129 )

100 )

130 => ADTable t

101 => ADTable t

131instance

102instance

132− ( Generic (t Result)

103+ ( Generic (Record (t Result))

133 , HTable (GColumnsADT t)

104 , HTable (GColumnsADT t)

134− , G.GTableADT (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRecord (Rep (t (Reify Result))))

105+ , G.GSerializeADT TSerialize TColumns (Eval (ADTRep t Expr)) (Eval (ADTRep t Result))

135− , GRecordable (Rep (t (Reify Result)))

136− , GMappable (TTable (Reify Result)) (Rep (t (Reify Result)))

137− , GMap TUnreify (Rep (t (Reify Result))) ~ Rep (t Result)

138 )

106 )

139 => ADTable t

107 => ADTable t

140

108

@@ -202,4 +170,4 @@ type instance Eval (ADTRep t context) = GRep t context

202

170

203

171

204type GColumnsADT :: K.Rel8able -> K.HTable

172type GColumnsADT :: K.Rel8able -> K.HTable

205−type GColumnsADT t = G.GColumnsADT TColumns (GRep t (Reify Result))

173+type GColumnsADT t = G.GColumnsADT TColumns (GRep t Expr)

src/Rel8/Table/Aggregate.hs+24−13

@@ -16,8 +16,8 @@ import Data.Functor.Identity ( Identity( Identity ) )

16import Prelude

18-- rel8

19−import Rel8.Aggregate ( Aggregate, Aggregates, Col( A ) )

19+import Rel8.Aggregate ( Aggregate, Aggregates )

20−import Rel8.Expr ( Expr, Col( E ) )

20+import Rel8.Expr ( Expr )

21import Rel8.Expr.Aggregate

22 ( groupByExpr

23 , slistAggExpr

@@ -26,8 +26,8 @@ import Rel8.Expr.Aggregate

26import Rel8.Schema.Dict ( Dict( Dict ) )

27import Rel8.Schema.HTable ( HTable, hfield, htabulate )

28import Rel8.Schema.HTable.Vectorize ( hvectorize )

29−import Rel8.Schema.Spec ( SSpec( SSpec, info ) )

29+import Rel8.Schema.Null ( Sql )

30−import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )

30+import Rel8.Schema.Spec ( Spec( Spec, info ) )

31import Rel8.Table ( toColumns, fromColumns )

32import Rel8.Table.Eq ( EqTable, eqTable )

33import Rel8.Table.List ( ListTable )

@@ -37,17 +37,28 @@ 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+-- @

40groupBy :: forall exprs aggregates. (EqTable exprs, Aggregates aggregates exprs)

52groupBy :: forall exprs aggregates. (EqTable exprs, Aggregates aggregates exprs)

41 => exprs -> aggregates

53 => exprs -> aggregates

42groupBy = fromColumns . hgroupBy (eqTable @exprs) . toColumns

54groupBy = fromColumns . hgroupBy (eqTable @exprs) . toColumns

45−hgroupBy :: HTable t

46− => t (Dict (ConstrainDBType DBEq)) -> t (Col Expr) -> t (Col Aggregate)

57+hgroupBy :: HTable t => t (Dict (Sql DBEq)) -> t Expr -> t Aggregate

47−hgroupBy eqs exprs = fromColumns $ htabulate $ \field ->

58+hgroupBy eqs exprs = htabulate $ \field ->

48 case hfield eqs field of

59 case hfield eqs field of

49 Dict -> case hfield exprs field of

60 Dict -> case hfield exprs field of

50− E expr -> A $ groupByExpr expr

61+ expr -> groupByExpr expr

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

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

@@ -60,22 +71,22 @@ hgroupBy eqs exprs = fromColumns $ htabulate $ \field ->

60-- items:

71-- items:

61--

72--

62-- @

73-- @

63−-- ordersWithItems :: Query (Order Expr, ListTable (Item Expr))

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

64-- ordersWithItems = do

75-- ordersWithItems = do

65-- order <- each orderSchema

76-- order <- each orderSchema

66-- items <- aggregate $ listAgg <$> itemsFromOrder order

77-- items <- aggregate $ listAgg <$> itemsFromOrder order

67-- return (order, items)

78-- return (order, items)

68-- @

79-- @

69−listAgg :: Aggregates aggregates exprs => exprs -> ListTable aggregates

80+listAgg :: Aggregates aggregates exprs => exprs -> ListTable Aggregate aggregates

70listAgg (toColumns -> exprs) = fromColumns $

81listAgg (toColumns -> exprs) = fromColumns $

71 hvectorize

82 hvectorize

72− (\SSpec {info} (Identity (E a)) -> A $ slistAggExpr info a)

83+ (\Spec {info} (Identity a) -> slistAggExpr info a)

73 (pure exprs)

84 (pure exprs)

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

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

77−nonEmptyAgg :: Aggregates aggregates exprs => exprs -> NonEmptyTable aggregates

88+nonEmptyAgg :: Aggregates aggregates exprs => exprs -> NonEmptyTable Aggregate aggregates

78nonEmptyAgg (toColumns -> exprs) = fromColumns $

89nonEmptyAgg (toColumns -> exprs) = fromColumns $

79 hvectorize

90 hvectorize

80− (\SSpec {info} (Identity (E a)) -> A $ snonEmptyAggExpr info a)

91+ (\Spec {info} (Identity a) -> snonEmptyAggExpr info a)

81 (pure exprs)

92 (pure exprs)

src/Rel8/Table/Bool.hs+5−6

@@ -13,7 +13,7 @@ where

13import Prelude

15-- rel8

16−import Rel8.Expr ( Expr, Col( E, unE ) )

16+import Rel8.Expr ( Expr )

17import Rel8.Expr.Bool ( boolExpr, caseExpr )

18import Rel8.Expr.Null ( isNull, unsafeUnnullify )

19import Rel8.Schema.HTable ( htabulate, hfield )

@@ -28,8 +28,7 @@ bool :: Table Expr a => a -> a -> Expr Bool -> a

28bool (toColumns -> false) (toColumns -> true) condition =

29 fromColumns $ htabulate $ \field ->

30 case (hfield false field, hfield true field) of

31− (E falseExpr, E trueExpr) ->

32− E (boolExpr falseExpr trueExpr condition)

31+ (falseExpr, trueExpr) -> boolExpr falseExpr trueExpr condition

33{-# INLINABLE bool #-}

32{-# INLINABLE bool #-}

@@ -39,9 +38,9 @@ bool (toColumns -> false) (toColumns -> true) condition =

39case_ :: Table Expr a => [(Expr Bool, a)] -> a -> a

38case_ :: Table Expr a => [(Expr Bool, a)] -> a -> a

40case_ (map (fmap toColumns) -> branches) (toColumns -> fallback) =

39case_ (map (fmap toColumns) -> branches) (toColumns -> fallback) =

41 fromColumns $ htabulate $ \field -> case hfield fallback field of

40 fromColumns $ htabulate $ \field -> case hfield fallback field of

42− E fallbackExpr ->

41+ fallbackExpr ->

43− case map (fmap (unE . (`hfield` field))) branches of

42+ case map (fmap (`hfield` field)) branches of

44− branchExprs -> E (caseExpr branchExprs fallbackExpr)

43+ branchExprs -> caseExpr branchExprs fallbackExpr

47-- | Like 'maybe', but to eliminate @null@.

46-- | Like 'maybe', but to eliminate @null@.

src/Rel8/Table/Cols.hsnew file+50

@@ -0,0 +1,50 @@

1+{-# language DataKinds #-}

2+{-# language FlexibleInstances #-}

3+{-# language MultiParamTypeClasses #-}

4+{-# language StandaloneKindSignatures #-}

5+{-# language TypeFamilies #-}

6+{-# language UndecidableInstances #-}

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+146−128

@@ -18,46 +18,44 @@ module Rel8.Table.Either

18 ( EitherTable(..)

19 , eitherTable, leftTable, rightTable

20 , isLeftTable, isRightTable

21+ , aggregateEitherTable

21 , nameEitherTable

22 , nameEitherTable

22 )

23 )

23where

24where

25-- base

26-- base

26−import Control.Applicative ( liftA2 )

27import Data.Bifunctor ( Bifunctor, bimap )

28−import Data.Functor.Identity ( runIdentity )

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

29import Data.Kind ( Type )

30import Prelude hiding ( undefined )

32+-- comonad

33+import Control.Comonad ( extract )

34+

32-- rel8

35-- rel8

36+import Rel8.Aggregate ( Aggregate )

33import Rel8.Expr ( Expr )

37import Rel8.Expr ( Expr )

38+import Rel8.Expr.Aggregate ( groupByExpr )

34import Rel8.Expr.Serialize ( litExpr )

39import Rel8.Expr.Serialize ( litExpr )

35−import Rel8.Schema.Context.Label

40+import Rel8.Kind.Context ( Reifiable )

36− ( Labelable

37− , HLabelable, hlabeler, hunlabeler

38− )

39−import Rel8.Schema.Context.Nullify

41+import Rel8.Schema.Context.Nullify ( Nullifiable )

40− ( Nullifiable, ConstrainTag

41− , HNullifiable, HConstrainTag

42− , hencodeTag, hdecodeTag

43− , hnullifier, hunnullifier

44− )

45−import Rel8.Schema.HTable ( HTable )

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

46import Rel8.Schema.HTable.Either ( HEitherTable(..) )

43import Rel8.Schema.HTable.Either ( HEitherTable(..) )

47import Rel8.Schema.HTable.Identity ( HIdentity(..) )

44import Rel8.Schema.HTable.Identity ( HIdentity(..) )

48import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

45import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

49−import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )

46+import qualified Rel8.Schema.Kind as K

50import Rel8.Schema.Name ( Name )

47import Rel8.Schema.Name ( Name )

51import Rel8.Table

48import Rel8.Table

52 ( Table, Columns, Context, fromColumns, toColumns

49 ( Table, Columns, Context, fromColumns, toColumns

53− , reify, unreify

50+ , FromExprs, fromResult, toResult

51+ , Transpose

54 )

52 )

55import Rel8.Table.Bool ( bool )

53import Rel8.Table.Bool ( bool )

56import Rel8.Table.Eq ( EqTable, eqTable )

54import Rel8.Table.Eq ( EqTable, eqTable )

55+import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )

57import Rel8.Table.Ord ( OrdTable, ordTable )

56import Rel8.Table.Ord ( OrdTable, ordTable )

58−import Rel8.Table.Recontextualize ( Recontextualize )

57+import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )

59−import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )

58+import Rel8.Table.Serialize ( ToExprs )

60−import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )

61import Rel8.Table.Undefined ( undefined )

59import Rel8.Table.Undefined ( undefined )

62import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )

60import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )

@@ -66,160 +64,180 @@ import Data.Functor.Apply ( Apply, (<.>) )

66import Data.Functor.Bind ( Bind, (>>-) )

64import 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.

69−type EitherTable :: Type -> Type -> Type

73+type EitherTable :: K.Context -> Type -> Type -> Type

70−data EitherTable a b = EitherTable

74+data EitherTable context a b = EitherTable

71− { tag :: Tag "isRight" EitherTag

75+ { tag :: context EitherTag

72− , left :: a

76+ , left :: Nullify context a

73− , right :: b

77+ , right :: Nullify context b

74 }

78 }

75 deriving stock Functor

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+

78−instance Bifunctor EitherTable where

87+instance Nullifiable context => Bifunctor (EitherTable context) where

79− bimap f g (EitherTable tag a b) = EitherTable tag (f a) (g b)

88+ bimap f g (EitherTable tag a b) = EitherTable tag (fmap f a) (fmap g b)

89+

90+

91+instance Projectable (EitherTable context a) where

92+ project f (EitherTable tag a b) = EitherTable tag a (project f b)

82−instance Table Expr a => Apply (EitherTable a) where

95+instance (context ~ Expr, Table Expr a) => Apply (EitherTable context a) where

83 EitherTable tag l1 f <.> EitherTable tag' l2 a =

96 EitherTable tag l1 f <.> EitherTable tag' l2 a =

84− EitherTable (tag <> tag') (bool l1 l2 (isLeft (expr tag))) (f a)

97+ EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f <.> a)

87−instance Table Expr a => Applicative (EitherTable a) where

100+instance (context ~ Expr, Table Expr a) => Applicative (EitherTable context a) where

88 pure = rightTable

101 pure = rightTable

89 (<*>) = (<.>)

102 (<*>) = (<.>)

103

104

92−instance Table Expr a => Bind (EitherTable a) where

105+instance (context ~ Expr, Table Expr a) => Bind (EitherTable context a) where

93− EitherTable tag l1 a >>- f = case f a of

106+ EitherTable tag l1 a >>- f = case f (extract a) of

94 EitherTable tag' l2 b ->

107 EitherTable tag' l2 b ->

95− EitherTable (tag <> tag') (bool l1 l2 (isRight (expr tag))) b

108+ EitherTable (tag <> tag') (bool l1 l2 (isRight tag)) b

109

110

98−instance Table Expr a => Monad (EitherTable a) where

111+instance (context ~ Expr, Table Expr a) => Monad (EitherTable context a) where

99 (>>=) = (>>-)

112 (>>=) = (>>-)

100

113

101

114

102−instance (Table Expr a, Table Expr b) => Semigroup (EitherTable a b) where

115+instance (context ~ Expr, Table Expr a, Table Expr b) =>

116+ Semigroup (EitherTable context a b)

117+ where

103 a <> b = bool a b (isRightTable a)

118 a <> b = bool a b (isRightTable a)

104

119

105

120

106instance

121instance

107 ( Table context a, Table context b

122 ( Table context a, Table context b

108− , Labelable context, Nullifiable context, ConstrainTag context EitherTag

123+ , Reifiable context, context ~ context'

109− ) =>

110− Table context (EitherTable a b)

111− where

112− type Columns (EitherTable a b) = HEitherTable (Columns a) (Columns b)

113− type Context (EitherTable a b) = Context a

114−

115− toColumns = toColumns2 toColumns toColumns

116− fromColumns = fromColumns2 fromColumns fromColumns

117− reify = liftA2 bimap reify reify

118− unreify = liftA2 bimap unreify unreify

119−

120−

121−instance

122− ( Nullifiable from, Labelable from, ConstrainTag from EitherTag

123− , Nullifiable to, Labelable to, ConstrainTag to EitherTag

124− , Recontextualize from to a1 b1

125− , Recontextualize from to a2 b2

126 )

124 )

127− => Recontextualize from to (EitherTable a1 a2) (EitherTable b1 b2)

125+ => Table context' (EitherTable context a b)

128−

126+ where

129−

127+ type Columns (EitherTable context a b) = HEitherTable (Columns a) (Columns b)

130−instance (EqTable a, EqTable b) => EqTable (EitherTable a b) where

128+ type Context (EitherTable context a b) = Context a

131− eqTable = toColumns2 id id (rightTableWith (eqTable @a) (eqTable @b))

129+ type FromExprs (EitherTable context a b) = Either (FromExprs a) (FromExprs b)

132−

130+ type Transpose to (EitherTable context a b) =

133−

131+ EitherTable to (Transpose to a) (Transpose to b)

134−instance (OrdTable a, OrdTable b) => OrdTable (EitherTable a b) where

132+

135− ordTable = toColumns2 id id (rightTableWith (ordTable @a) (ordTable @b))

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

168+ eqTable = HEitherTable

169+ { htag = hlabel (HIdentity Dict)

170+ , hleft = hlabel (eqTable @(Nullify context a))

171+ , hright = hlabel (eqTable @(Nullify context b))

172+ }

136

173

137

174

138−type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)

175+instance (OrdTable a, OrdTable b, context ~ Expr) =>

176+ OrdTable (EitherTable context a b)

177+ where

178+ ordTable = HEitherTable

179+ { htag = hlabel (HIdentity Dict)

180+ , hleft = hlabel (ordTable @(Nullify context a))

181+ , hright = hlabel (ordTable @(Nullify context b))

182+ }

139

183

140

184

141−instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable exprs1 exprs2) =>

185+instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable Expr exprs1 exprs2) =>

142 ToExprs x (Either a b)

186 ToExprs x (Either a b)

143− where

144− fromResult =

145− bimap (fromResult @exprs1) (fromResult @exprs2) .

146− fromColumns

147− toResult =

148− toColumns .

149− bimap (toResult @exprs1) (toResult @exprs2)

150

187

151

188

189+-- | Test if an 'EitherTable' is a 'leftTable'.

152−isLeftTable :: EitherTable a b -> Expr Bool

190+isLeftTable :: EitherTable Expr a b -> Expr Bool

153−isLeftTable = isLeft . expr . tag

191+isLeftTable EitherTable {tag} = isLeft tag

154

192

155

193

194+-- | Test if an 'EitherTable' is a 'rightTable'.

156−isRightTable :: EitherTable a b -> Expr Bool

195+isRightTable :: EitherTable Expr a b -> Expr Bool

157−isRightTable = isRight . expr . tag

196+isRightTable EitherTable {tag} = isRight tag

158

197

159

198

199+-- | Pattern match/eliminate an 'EitherTable', by providing mappings from a

200+-- 'leftTable' and 'rightTable'.

160eitherTable :: Table Expr c

201eitherTable :: Table Expr c

161− => (a -> c) -> (b -> c) -> EitherTable a b -> c

202+ => (a -> c) -> (b -> c) -> EitherTable Expr a b -> c

162eitherTable f g EitherTable {tag, left, right} =

203eitherTable f g EitherTable {tag, left, right} =

163− bool (f left) (g right) (isRight (expr tag))

204+ bool (f (extract left)) (g (extract right)) (isRight tag)

164

205

165

206

207+-- | Construct a left 'EitherTable'. Like 'Left'.

166−leftTable :: Table Expr b => a -> EitherTable a b

208+leftTable :: Table Expr b => a -> EitherTable Expr a b

167−leftTable a = EitherTable (fromExpr (litExpr IsLeft)) a undefined

209+leftTable a = EitherTable (litExpr IsLeft) (pure a) undefined

168

210

169

211

212+-- | Construct a right 'EitherTable'. Like 'Right'.

170−rightTable :: Table Expr a => b -> EitherTable a b

213+rightTable :: Table Expr a => b -> EitherTable Expr a b

171−rightTable = rightTableWith undefined

214+rightTable = EitherTable (litExpr IsRight) undefined . pure

172

215

173

216

174−rightTableWith :: a -> b -> EitherTable a b

217+-- | Lift a pair of aggregating functions to operate on an 'EitherTable'.

175−rightTableWith = EitherTable (fromExpr (litExpr IsRight))

218+-- @leftTable@s and @rightTable@s are grouped separately.

176−

219+aggregateEitherTable :: ()

177−

220+ => (exprs -> aggregates)

178−nameEitherTable :: Name EitherTag -> a -> b -> EitherTable a b

221+ -> (exprs' -> aggregates')

179−nameEitherTable = EitherTable . fromName

180−

181−

182−toColumns2 ::

183− ( HTable t

184− , HTable u

185− , HConstrainTag context EitherTag

186− , HLabelable context

187− , HNullifiable context

188− )

189− => (a -> t context)

190− -> (b -> u context)

191− -> EitherTable a b

222+ -> EitherTable Expr exprs exprs'

192− -> HEitherTable t u context

223+ -> EitherTable Aggregate aggregates aggregates'

193−toColumns2 f g EitherTable {tag, left, right} = HEitherTable

224+aggregateEitherTable f g (EitherTable tag a b) = EitherTable

194− { htag

225+ { tag = groupByExpr tag

195− , hleft = hlabel hlabeler $ hnullify (hnullifier tag isLeft) $ f left

226+ , left = aggregateNullify f a

196− , hright = hlabel hlabeler $ hnullify (hnullifier tag isRight) $ g right

227+ , right = aggregateNullify g b

197 }

228 }

198− where

199− htag = HIdentity (hencodeTag tag)

200

229

201

230

202−fromColumns2 ::

231+-- | Construct a 'EitherTable' in the 'Name' context. This can be useful if you

203− ( HTable t

232+-- have a 'EitherTable' that you are storing in a table and need to construct a

204− , HTable u

233+-- 'TableSchema'.

234+nameEitherTable

205− , HConstrainTag context EitherTag

235+ :: Name EitherTag

206− , HLabelable context

236+ -- ^ The name of the column to track whether a row is a 'leftTable' or

207− , HNullifiable context

237+ -- 'rightTable'.

208− )

238+ -> a

209− => (t context -> a)

239+ -- ^ Names of the columns in the @a@ table.

210− -> (u context -> b)

240+ -> b

211− -> HEitherTable t u context

241+ -- ^ Names of the columns in the @b@ table.

212− -> EitherTable a b

242+ -> EitherTable Name a b

213−fromColumns2 f g HEitherTable {htag, hleft, hright} = EitherTable

243+nameEitherTable tag left right = EitherTable tag (pure left) (pure right)

214− { tag

215− , left = f $ runIdentity $

216− hunnullify (\a -> pure . hunnullifier a) $

217− hunlabel hunlabeler

218− hleft

219− , right = g $ runIdentity $

220− hunnullify (\a -> pure . hunnullifier a) $

221− hunlabel hunlabeler

222− hright

223− }

224− where

225− tag = hdecodeTag $ unHIdentity htag

src/Rel8/Table/Eq.hs+12−39

@@ -11,7 +11,6 @@

11{-# language TypeFamilies #-}

12{-# language TypeOperators #-}

13{-# language UndecidableInstances #-}

14−{-# language UndecidableSuperClasses #-}

15{-# language ViewPatterns #-}

14{-# language ViewPatterns #-}

17module Rel8.Table.Eq

16module Rel8.Table.Eq

@@ -28,24 +27,16 @@ import GHC.Generics ( Rep )

28import Prelude

27import Prelude

30-- rel8

29-- rel8

31−import Rel8.Expr ( Expr, Col( E ) )

30+import Rel8.Expr ( Expr )

32import Rel8.Expr.Bool ( (||.), (&&.) )

31import Rel8.Expr.Bool ( (||.), (&&.) )

33import Rel8.Expr.Eq ( (==.), (/=.) )

32import Rel8.Expr.Eq ( (==.), (/=.) )

34import Rel8.FCF ( Eval, Exp )

33import Rel8.FCF ( Eval, Exp )

35import Rel8.Generic.Record ( Record )

34import Rel8.Generic.Record ( Record )

36−import Rel8.Generic.Table

35+import Rel8.Generic.Table.Record ( GTable, GColumns, gtable )

37− ( GGTable, GGColumns, ggtable

38− , GAlgebra

39− )

40−import Rel8.Kind.Algebra ( KnownAlgebra )

41import Rel8.Schema.Dict ( Dict( Dict ) )

36import Rel8.Schema.Dict ( Dict( Dict ) )

42−import Rel8.Schema.HTable

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

43− ( HTable, HConstrainTable

44− , htabulateA, hfield, hdicts

45− )

46−import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )

38+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

47import Rel8.Schema.Null ( Sql )

39import Rel8.Schema.Null ( Sql )

48−import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType, nullifier )

49import Rel8.Table ( Table, Columns, toColumns, TColumns )

40import Rel8.Table ( Table, Columns, toColumns, TColumns )

50import Rel8.Type.Eq ( DBEq )

41import Rel8.Type.Eq ( DBEq )

@@ -55,22 +46,14 @@ import Rel8.Type.Eq ( DBEq )

55-- means "all columns in a 'Table' have an instance of 'DBEq'".

46-- means "all columns in a 'Table' have an instance of 'DBEq'".

56type EqTable :: Type -> Constraint

47type EqTable :: Type -> Constraint

57class Table Expr a => EqTable a where

48class Table Expr a => EqTable a where

58− eqTable :: Columns a (Dict (ConstrainDBType DBEq))

49+ eqTable :: Columns a (Dict (Sql DBEq))

60 default eqTable ::

51 default eqTable ::

61− ( KnownAlgebra (GAlgebra (Rep (Record a)))

62− , Eval (GGTable (GAlgebra (Rep (Record a))) TEqTable TColumns (Dict (ConstrainDBType DBEq)) (Rep (Record a)))

52+ ( GTable TEqTable TColumns (Rep (Record a))

63− , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))

53+ , Columns a ~ GColumns TColumns (Rep (Record a))

64 )

54 )

65− => Columns a (Dict (ConstrainDBType DBEq))

55+ => Columns a (Dict (Sql DBEq))

66− eqTable =

56+ eqTable = gtable @TEqTable @TColumns @(Rep (Record a)) table

67− ggtable

68− @(GAlgebra (Rep (Record a)))

69− @TEqTable

70− @TColumns

71− @(Rep (Record a))

72− table

73− nullifier

74 where

57 where

75 table (_ :: proxy x) = eqTable @x

58 table (_ :: proxy x) = eqTable @x

@@ -79,18 +62,8 @@ data TEqTable :: Type -> Exp Constraint

79type instance Eval (TEqTable a) = EqTable a

62type 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−

92instance Sql DBEq a => EqTable (Expr a) where

65instance Sql DBEq a => EqTable (Expr a) where

93− eqTable = HType Dict

66+ eqTable = HIdentity Dict

96instance (EqTable a, EqTable b) => EqTable (a, b)

69instance (EqTable a, EqTable b) => EqTable (a, b)

@@ -124,7 +97,7 @@ instance

124(toColumns -> as) ==: (toColumns -> bs) =

97(toColumns -> as) ==: (toColumns -> bs) =

125 foldl1' (&&.) $ getConst $ htabulateA $ \field ->

98 foldl1' (&&.) $ getConst $ htabulateA $ \field ->

126 case (hfield as field, hfield bs field) of

99 case (hfield as field, hfield bs field) of

127− (E a, E b) -> case hfield (eqTable @a) field of

100+ (a, b) -> case hfield (eqTable @a) field of

128 Dict -> Const (pure (a ==. b))

101 Dict -> Const (pure (a ==. b))

129infix 4 ==:

102infix 4 ==:

130

103

@@ -136,7 +109,7 @@ infix 4 ==:

136(toColumns -> as) /=: (toColumns -> bs) =

109(toColumns -> as) /=: (toColumns -> bs) =

137 foldl1' (||.) $ getConst $ htabulateA $ \field ->

110 foldl1' (||.) $ getConst $ htabulateA $ \field ->

138 case (hfield as field, hfield bs field) of

111 case (hfield as field, hfield bs field) of

139− (E a, E b) -> case hfield (eqTable @a) field of

112+ (a, b) -> case hfield (eqTable @a) field of

140 Dict -> Const (pure (a /=. b))

113 Dict -> Const (pure (a /=. b))

141infix 4 /=:

114infix 4 /=:

142

115

src/Rel8/Table/HKD.hs+65−105

@@ -13,7 +13,7 @@

14module Rel8.Table.HKD

15 ( HKD( HKD )

16− , HKDable, fromHKD, toHKD, HKDT(..)

16+ , HKDable

17 , BuildableHKD

18 , BuildHKD, buildHKD

19 , ConstructableHKD

@@ -27,9 +27,6 @@ where

28-- base

29import Data.Kind ( Constraint, Type )

30−import Data.Proxy ( Proxy( Proxy ) )

31−import Data.Type.Equality ( (:~:)( Refl ) )

32−import Data.Void ( Void )

33import GHC.Generics ( Generic, Rep, from, to )

30import GHC.Generics ( Generic, Rep, from, to )

34import GHC.TypeLits ( Symbol )

31import GHC.TypeLits ( Symbol )

35import Prelude

32import Prelude

@@ -49,163 +46,126 @@ import Rel8.Generic.Construction

49 , GGName, ggname

46 , GGName, ggname

50 , GGAggregate, ggaggregate

47 , GGAggregate, ggaggregate

51 )

48 )

52−import Rel8.Generic.Map ( GMap, GMappable, gmap, gunmap )

49+import Rel8.Generic.Map ( GMap )

50+import Rel8.Generic.Record

53−import Rel8.Generic.Record ( GRecord, GRecordable, grecord, gunrecord )

51+ ( GRecord, GRecordable, grecord, gunrecord

52+ , Record( Record ), unrecord

53+ )

54import Rel8.Generic.Rel8able

55 ( Rel8able

56 , GColumns, gfromColumns, gtoColumns

57− , greify, gunreify

57+ , GFromExprs, gfromResult, gtoResult

58− , TUnreifyContext

59 )

58 )

60import Rel8.Generic.Table

59import Rel8.Generic.Table

61− ( GGTable, GGColumns, GGContext, ggfromColumns, ggtoColumns

60+ ( GGSerialize, GGColumns, GAlgebra, ggfromResult, ggtoResult

62− , GAlgebra

63 )

61 )

64−import Rel8.Schema.Context ( Col )

62+import Rel8.Generic.Table.Record ( GTable, GContext )

63+import qualified Rel8.Generic.Table.Record as G

65import qualified Rel8.Schema.Kind as K

64import qualified Rel8.Schema.Kind as K

66import Rel8.Schema.HTable ( HTable )

65import Rel8.Schema.HTable ( HTable )

67import Rel8.Schema.Name ( Name )

66import Rel8.Schema.Name ( Name )

68−import Rel8.Schema.Reify ( Col( Reify ), Reify, hreify, hunreify, notReify )

69import Rel8.Schema.Result ( Result )

67import Rel8.Schema.Result ( Result )

70import Rel8.Table

68import Rel8.Table

71− ( Table, Columns, Context, Unreify

72− , fromColumns, toColumns, reify, unreify

69+ ( Table, fromColumns, toColumns, fromResult, toResult

73− , TTable, TColumns, TUnreify

70+ , TTable, TColumns, TContext

71+ , TSerialize

74 )

72 )

75−import Rel8.Table.Serialize ( ToExprs, fromResult, toResult )

78type GColumnsHKD :: Type -> K.HTable

75type GColumnsHKD :: Type -> K.HTable

79type GColumnsHKD a =

76type GColumnsHKD a =

80− Eval (GGColumns (GAlgebra (Rep a)) TColumns (GRecord (GMap (TColumn (Reify Result)) (Rep a))))

77+ Eval (GGColumns (GAlgebra (Rep a)) TColumns (GRecord (GMap (TColumn Expr) (Rep a))))

83type HKD :: Type -> K.Rel8able

80type HKD :: Type -> K.Rel8able

84−newtype HKD a f = HKD (GColumnsHKD a (Col f))

81+newtype HKD a f = HKD (GColumnsHKD a f)

87instance HKDable a => Rel8able (HKD a) where

84instance HKDable a => Rel8able (HKD a) where

88 type GColumns (HKD a) = GColumnsHKD a

85 type GColumns (HKD a) = GColumnsHKD a

86+ type GFromExprs (HKD a) = a

90− gfromColumns = HKD

88+ gfromColumns _ = HKD

91− gtoColumns (HKD a) = a

89+ gtoColumns _ (HKD a) = a

93− greify (HKD a) = HKD (hreify a)

91+ gfromResult =

94− gunreify (HKD a) = HKD (hunreify a)

92+ unrecord .

93+ to .

94+ ggfromResult

95+ @(GAlgebra (Rep a))

96+ @TSerialize

97+ @TColumns

98+ @(Eval (HKDRep a Expr))

99+ @(Eval (HKDRep a Result))

100+ (\(_ :: proxy x) -> fromResult @_ @x)

101+

102+ gtoResult =

103+ ggtoResult

104+ @(GAlgebra (Rep a))

105+ @TSerialize

106+ @TColumns

107+ @(Eval (HKDRep a Expr))

108+ @(Eval (HKDRep a Result))

109+ (\(_ :: proxy x) -> toResult @_ @x) .

110+ from .

111+ Record

112

113

97instance

114instance

98− ( KnownAlgebra (GAlgebra (Rep a))

99− , HTable (GColumnsHKD a)

100− , Eval (GGTable (GAlgebra (Rep a)) (TTable (Reify f)) TColumns (Col (Reify f)) (GRecord (GMap (TColumn (Reify f)) (Rep a))))

115+ ( GTable (TTable f) TColumns (GRecord (GMap (TColumn f) (Rep a)))

101− , Eval (GGColumns (GAlgebra (Rep a)) TColumns (GRecord (GMap (TColumn (Reify f)) (Rep a)))) ~ GColumnsHKD a

116+ , G.GColumns TColumns (GRecord (GMap (TColumn f) (Rep a))) ~ GColumnsHKD a

102− , Eval (GGContext (GAlgebra (Rep a)) TUnreifyContext (GRecord (GMap (TColumn (Reify f)) (Rep a)))) ~ f

117+ , GContext TContext (GRecord (GMap (TColumn f) (Rep a))) ~ f

103− , GRecordable (GMap (TColumn (Reify f)) (Rep a))

118+ , GRecordable (GMap (TColumn f) (Rep a))

104− , GMappable (TTable (Reify f)) (GMap (TColumn (Reify f)) (Rep a))

105− , GMap TUnreify (GMap (TColumn (Reify f)) (Rep a)) ~ GMap (TColumn f) (Rep a)

106 )

119 )

107 => Generic (HKD a f)

120 => Generic (HKD a f)

108 where

121 where

109 type Rep (HKD a f) = GMap (TColumn f) (Rep a)

122 type Rep (HKD a f) = GMap (TColumn f) (Rep a)

110

123

111 from =

124 from =

112− gmap @(TTable (Reify f)) (Proxy @TUnreify) (unreify Refl) .

113− gunrecord @(GMap (TColumn (Reify f)) (Rep a)) .

125+ gunrecord @(GMap (TColumn f) (Rep a)) .

114− ggfromColumns

126+ G.gfromColumns

115− @(GAlgebra (Rep a))

116− @(TTable (Reify f))

127+ @(TTable f)

117 @TColumns

128 @TColumns

118− (\(Reify a) -> a)

119− Reify

120 fromColumns .

129 fromColumns .

121− hreify .

122 (\(HKD a) -> a)

130 (\(HKD a) -> a)

123

131

124 to =

132 to =

125 HKD .

133 HKD .

126− hunreify .

134+ G.gtoColumns

127− ggtoColumns

128− @(GAlgebra (Rep a))

129− @(TTable (Reify f))

135+ @(TTable f)

130 @TColumns

136 @TColumns

131− (\(Reify a) -> a)

132− Reify

133 toColumns .

137 toColumns .

134− grecord @(GMap (TColumn (Reify f)) (Rep a)) .

138+ grecord @(GMap (TColumn f) (Rep a))

135− gunmap @(TTable (Reify f)) (Proxy @TUnreify) (reify Refl)

136−

137−

138−type HKDT :: Type -> Type

139−newtype HKDT a = HKDT

140− { unHKDT :: a

141− }

142−

143−

144−instance HKDable a => Table Result (HKDT a) where

145− type Columns (HKDT a) = GColumnsHKD a

146− type Context (HKDT a) = Result

147− type Unreify (HKDT a) = Void

148−

149− fromColumns = HKDT . fromHKD . HKD

150− toColumns = (\(HKD a) -> a) . toHKD . (\(HKDT a) -> a)

151− reify = notReify

152− unreify = notReify

153−

154−

155−instance

156− ( Table Expr (HKD a Expr)

157− , Columns (HKD a Expr) ~ GColumns (HKD a)

158− , HKDable a

159− , x ~ HKD a Expr

160− )

161− => ToExprs x (HKDT a)

162− where

163− toResult = (\(HKD a) -> a) . toHKD . (\(HKDT a) -> a)

164− fromResult = HKDT . fromHKD . HKD

165−

166−

167−fromHKD :: HKDable a => HKD a Result -> a

168−fromHKD = to . gunmap @Top (Proxy @(TColumn Result)) id . from

169−

170−

171−toHKD :: HKDable a => a -> HKD a Result

172−toHKD = to . gmap @Top (Proxy @(TColumn Result)) id . from

173−

174−

175−class Top_

176−instance Top_

177−

178−

179−data Top :: Type -> Exp Constraint

180−type instance Eval (Top _) = Top_

181

139

182

140

141+type HKDable :: Type -> Constraint

183class

142class

184− ( Generic a

143+ ( Generic (Record a)

185 , HTable (GColumns (HKD a))

144 , HTable (GColumns (HKD a))

186 , KnownAlgebra (GAlgebra (Rep a))

145 , KnownAlgebra (GAlgebra (Rep a))

187− , Eval (GGTable (GAlgebra (Rep a)) (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRecord (GMap (TColumn (Reify Result)) (Rep a))))

146+ , Eval (GGSerialize (GAlgebra (Rep a)) TSerialize TColumns (Eval (HKDRep a Expr)) (Eval (HKDRep a Result)))

188− , Eval (GGContext (GAlgebra (Rep a)) TUnreifyContext (GRecord (GMap (TColumn (Reify Result)) (Rep a)))) ~ Result

189− , GRecordable (GMap (TColumn (Reify Result)) (Rep a))

190− , GMappable Top (Rep a)

191− , GMappable (TTable (Reify Result)) (GMap (TColumn (Reify Result)) (Rep a))

192− , GMap TUnreify (GMap (TColumn (Reify Result)) (Rep a)) ~ GMap (TColumn Result) (Rep a)

147+ , GRecord (GMap (TColumn Result) (Rep a)) ~ Rep (Record a)

193 )

148 )

194 => HKDable a

149 => HKDable a

195instance

150instance

196− ( Generic a

151+ ( Generic (Record a)

197 , HTable (GColumns (HKD a))

152 , HTable (GColumns (HKD a))

198 , KnownAlgebra (GAlgebra (Rep a))

153 , KnownAlgebra (GAlgebra (Rep a))

199− , Eval (GGTable (GAlgebra (Rep a)) (TTable (Reify Result)) TColumns (Col (Reify Result)) (GRecord (GMap (TColumn (Reify Result)) (Rep a))))

154+ , Eval (GGSerialize (GAlgebra (Rep a)) TSerialize TColumns (Eval (HKDRep a Expr)) (Eval (HKDRep a Result)))

200− , Eval (GGContext (GAlgebra (Rep a)) TUnreifyContext (GRecord (GMap (TColumn (Reify Result)) (Rep a)))) ~ Result

201− , GRecordable (GMap (TColumn (Reify Result)) (Rep a))

202− , GMappable Top (Rep a)

203− , GMappable (TTable (Reify Result)) (GMap (TColumn (Reify Result)) (Rep a))

204− , GMap TUnreify (GMap (TColumn (Reify Result)) (Rep a)) ~ GMap (TColumn Result) (Rep a)

155+ , GRecord (GMap (TColumn Result) (Rep a)) ~ Rep (Record a)

205 )

156 )

206 => HKDable a

157 => HKDable a

207

158

208

159

160+type Top_ :: Constraint

161+class Top_

162+instance Top_

163+

164+

165+data Top :: Type -> Exp Constraint

166+type instance Eval (Top _) = Top_

167+

168+

209type BuildableHKD :: Type -> Symbol -> Constraint

169type BuildableHKD :: Type -> Symbol -> Constraint

210class GGBuildable (GAlgebra (Rep a)) name (HKDRep a) => BuildableHKD a name

170class GGBuildable (GAlgebra (Rep a)) name (HKDRep a) => BuildableHKD a name

211instance GGBuildable (GAlgebra (Rep a)) name (HKDRep a) => BuildableHKD a name

171instance GGBuildable (GAlgebra (Rep a)) name (HKDRep a) => BuildableHKD a name

src/Rel8/Table/List.hs+72−55

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

1+{-# language DataKinds #-}

1{-# language FlexibleContexts #-}

2{-# language FlexibleContexts #-}

2{-# language FlexibleInstances #-}

3{-# language FlexibleInstances #-}

3{-# language MultiParamTypeClasses #-}

4{-# language MultiParamTypeClasses #-}

@@ -10,30 +11,36 @@

11module Rel8.Table.List

12module Rel8.Table.List

12 ( ListTable(..)

13 ( ListTable(..)

14+ , ($*)

15+ , listTable

13− , listTable, nameListTable

16+ , nameListTable

14 )

17 )

15where

18where

17-- base

20-- base

18import Data.Functor.Identity ( Identity( Identity ) )

21import Data.Functor.Identity ( Identity( Identity ) )

19import Data.Kind ( Type )

22import Data.Kind ( Type )

20−import Data.Type.Equality ( (:~:)( Refl ) )

21import Prelude

23import Prelude

23-- rel8

25-- rel8

24−import Rel8.Expr ( Expr, Col( E, unE ) )

26+import Rel8.Expr ( Expr )

25import Rel8.Expr.Array ( sappend, sempty, slistOf )

27import Rel8.Expr.Array ( sappend, sempty, slistOf )

26import Rel8.Schema.Dict ( Dict( Dict ) )

28import Rel8.Schema.Dict ( Dict( Dict ) )

27import Rel8.Schema.HTable.List ( HListTable )

29import Rel8.Schema.HTable.List ( HListTable )

28−import Rel8.Schema.HTable.Vectorize ( happend, hempty, hvectorize )

30+import Rel8.Schema.HTable.Vectorize

31+ ( hvectorize, hunvectorize

32+ , happend, hempty

33+ , hproject, hcolumn

34+ )

29−import Rel8.Schema.Name ( Col( N ), Name( Name ) )

35+import qualified Rel8.Schema.Kind as K

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

30import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

37import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

31−import Rel8.Schema.Spec ( SSpec(..) )

38+import Rel8.Schema.Result ( vectorizer, unvectorizer )

32−import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullity )

39+import Rel8.Schema.Spec ( Spec(..) )

33−import Rel8.Schema.Reify ( hreify, hunreify )

34import Rel8.Table

40import Rel8.Table

35 ( Table, Context, Columns, fromColumns, toColumns

41 ( Table, Context, Columns, fromColumns, toColumns

36− , reify, unreify

42+ , FromExprs, fromResult, toResult

43+ , Transpose

37 )

44 )

38import Rel8.Table.Alternative

45import Rel8.Table.Alternative

39 ( AltTable, (<|>:)

46 ( AltTable, (<|>:)

@@ -41,92 +48,102 @@ import Rel8.Table.Alternative

41 )

48 )

42import Rel8.Table.Eq ( EqTable, eqTable )

49import Rel8.Table.Eq ( EqTable, eqTable )

43import Rel8.Table.Ord ( OrdTable, ordTable )

50import Rel8.Table.Ord ( OrdTable, ordTable )

44−import Rel8.Table.Recontextualize ( Recontextualize )

51+import Rel8.Table.Projection

52+ ( Projectable, Projecting, Projection, project, apply

53+ )

45−import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )

54+import Rel8.Table.Serialize ( ToExprs )

46−import Rel8.Table.Unreify ( Unreifies )

49-- | A @ListTable@ value contains zero or more instances of @a@. You construct

57-- | A @ListTable@ value contains zero or more instances of @a@. You construct

50-- @ListTable@s with 'Rel8.many' or 'Rel8.listAgg'.

58-- @ListTable@s with 'Rel8.many' or 'Rel8.listAgg'.

51−type ListTable :: Type -> Type

59+type ListTable :: K.Context -> Type -> Type

60+newtype ListTable context a =

52−newtype ListTable a = ListTable (HListTable (Columns a) (Col (Context a)))

61+ ListTable (HListTable (Columns a) (Context a))

62+

63+

64+instance Projectable (ListTable context) where

65+ project f (ListTable a) = ListTable (hproject (apply f) a)

55−instance (Table context a, Unreifies context a) =>

68+instance (Table context a, context ~ context') =>

56− Table context (ListTable a)

69+ Table context' (ListTable context a)

57 where

70 where

58− type Columns (ListTable a) = HListTable (Columns a)

71+ type Columns (ListTable context a) = HListTable (Columns a)

59− type Context (ListTable a) = Context a

72+ type Context (ListTable context a) = Context a

73+ type FromExprs (ListTable context a) = [FromExprs a]

74+ type Transpose to (ListTable context a) = ListTable to (Transpose to a)

61 fromColumns = ListTable

76 fromColumns = ListTable

62 toColumns (ListTable a) = a

77 toColumns (ListTable a) = a

63−

78+ fromResult = fmap (fromResult @_ @a) . hunvectorize unvectorizer

64− reify Refl (ListTable a) = ListTable (hreify a)

79+ toResult = hvectorize vectorizer . fmap (toResult @_ @a)

65− unreify Refl (ListTable a) = ListTable (hunreify a)

66−

67−

68−instance

69− ( Unreifies from a, Unreifies to b

70− , Recontextualize from to a b

71− )

72− => Recontextualize from to (ListTable a) (ListTable b)

75−instance EqTable a => EqTable (ListTable a) where

82+instance (EqTable a, context ~ Expr) => EqTable (ListTable context a) where

76 eqTable =

83 eqTable =

77 hvectorize

84 hvectorize

78− (\SSpec {} (Identity dict) -> case dbTypeDict dict of

85+ (\Spec {nullity} (Identity Dict) -> case nullity of

79− Dict -> case dbTypeNullity dict of

80− Null -> Dict

86+ Null -> Dict

81− NotNull -> Dict)

87+ NotNull -> Dict)

82 (Identity (eqTable @a))

88 (Identity (eqTable @a))

85−instance OrdTable a => OrdTable (ListTable a) where

91+instance (OrdTable a, context ~ Expr) => OrdTable (ListTable context a) where

86 ordTable =

92 ordTable =

87 hvectorize

93 hvectorize

88− (\SSpec {} (Identity dict) -> case dbTypeDict dict of

94+ (\Spec {nullity} (Identity Dict) -> case nullity of

89− Dict -> case dbTypeNullity dict of

90− Null -> Dict

95+ Null -> Dict

91− NotNull -> Dict)

96+ NotNull -> Dict)

92 (Identity (ordTable @a))

97 (Identity (ordTable @a))

95−type instance FromExprs (ListTable a) = [FromExprs a]

100+instance (ToExprs exprs a, context ~ Expr) =>

96−

101+ ToExprs (ListTable context exprs) [a]

102

98−instance ToExprs exprs a => ToExprs (ListTable exprs) [a] where

99− fromResult = fmap (fromResult @exprs) . fromColumns

100− toResult = toColumns . fmap (toResult @exprs)

101

103

102−

103−instance AltTable ListTable where

104+instance context ~ Expr => AltTable (ListTable context) where

104 (<|>:) = (<>)

105 (<|>:) = (<>)

105

106

107

107−instance AlternativeTable ListTable where

108+instance context ~ Expr => AlternativeTable (ListTable context) where

108 emptyTable = mempty

109 emptyTable = mempty

109

110

111

111−instance Table Expr a => Semigroup (ListTable a) where

112+instance (context ~ Expr, Table Expr a) => Semigroup (ListTable context a)

113+ where

112− ListTable as <> ListTable bs = ListTable $

114+ ListTable as <> ListTable bs = ListTable $ happend (const sappend) as bs

113− happend (\_ _ (E a) (E b) -> E (sappend a b)) as bs

115+

116+

117+instance (context ~ Expr, Table Expr a) =>

118+ Monoid (ListTable context a)

119+ where

120+ mempty = ListTable $ hempty $ \Spec {info} -> sempty info

114

121

115

122

116−instance Table Expr a => Monoid (ListTable a) where

123+-- | Project a single expression out of a 'ListTable'.

117− mempty = ListTable $ hempty $ \_ -> E . sempty

124+($*) :: Projecting a (Expr b)

125+ => Projection a (Expr b) -> ListTable Expr a -> Expr [b]

126+f $* ListTable a = hcolumn $ hproject (apply f) a

127+infixl 4 $*

118

128

119

129

130+-- | Construct a @ListTable@ from a list of expressions.

120−listTable :: Table Expr a => [a] -> ListTable a

131+listTable :: Table Expr a => [a] -> ListTable Expr a

121listTable =

132listTable =

122 ListTable .

133 ListTable .

123− hvectorize (\SSpec {info} -> E . slistOf info . fmap unE) .

134+ hvectorize (\Spec {info} -> slistOf info) .

124 fmap toColumns

135 fmap toColumns

125

136

126

137

138+-- | Construct a 'ListTable' in the 'Name' context. This can be useful if you

139+-- have a 'ListTable' that you are storing in a table and need to construct a

140+-- 'TableSchema'.

127−nameListTable :: Table Name a => a -> ListTable a

141+nameListTable

142+ :: Table Name a

143+ => a -- ^ The names of the columns of elements of the list.

144+ -> ListTable Name a

128nameListTable =

145nameListTable =

129 ListTable .

146 ListTable .

130− hvectorize (\_ (Identity (N (Name a))) -> N (Name a)) .

147+ hvectorize (\_ (Identity (Name a)) -> Name a) .

131 pure .

148 pure .

132 toColumns

149 toColumns

src/Rel8/Table/Maybe.hs+120−120

@@ -3,7 +3,6 @@

3{-# language DerivingStrategies #-}

4{-# language FlexibleContexts #-}

5{-# language FlexibleInstances #-}

6−{-# language LambdaCase #-}

7{-# language MultiParamTypeClasses #-}

6{-# language MultiParamTypeClasses #-}

8{-# language NamedFieldPuns #-}

7{-# language NamedFieldPuns #-}

9{-# language ScopedTypeVariables #-}

8{-# language ScopedTypeVariables #-}

@@ -16,39 +15,42 @@ module Rel8.Table.Maybe

16 ( MaybeTable(..)

15 ( MaybeTable(..)

17 , maybeTable, nothingTable, justTable

16 , maybeTable, nothingTable, justTable

18 , isNothingTable, isJustTable

17 , isNothingTable, isJustTable

18+ , fromMaybeTable

19 , ($?)

20+ , aggregateMaybeTable

20 , nameMaybeTable

21 , nameMaybeTable

21 )

22 )

22where

23where

24-- base

25-- base

25−import Data.Functor.Identity ( runIdentity )

26+import Data.Functor ( ($>) )

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

26import Data.Kind ( Type )

28import Data.Kind ( Type )

29+import Data.Maybe ( fromMaybe, isJust )

27import Prelude hiding ( null, undefined )

30import Prelude hiding ( null, undefined )

32+-- comonad

33+import Control.Comonad ( extract )

34+

29-- rel8

35-- rel8

36+import Rel8.Aggregate ( Aggregate )

30import Rel8.Expr ( Expr )

37import Rel8.Expr ( Expr )

38+import Rel8.Expr.Aggregate ( groupByExpr )

31import Rel8.Expr.Bool ( boolExpr )

39import Rel8.Expr.Bool ( boolExpr )

32import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )

40import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )

33−import Rel8.Schema.Context.Label

41+import Rel8.Kind.Context ( Reifiable )

34− ( Labelable, HLabelable, hlabeler, hunlabeler

35− )

36−import Rel8.Schema.Context.Nullify

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

37− ( Nullifiable, ConstrainTag

38− , HNullifiable, HConstrainTag

39− , hencodeTag, hdecodeTag

40− , hnullifier, hunnullifier

41− )

42−import Rel8.Schema.HTable ( HTable )

43+import qualified Rel8.Schema.Kind as K

43import Rel8.Schema.HTable.Identity ( HIdentity(..) )

44import Rel8.Schema.HTable.Identity ( HIdentity(..) )

44import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

45import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

45import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )

46import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )

46−import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )

47import Rel8.Schema.Name ( Name )

48−import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql, nullable )

48+import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )

49+import qualified Rel8.Schema.Null as N

49import Rel8.Table

50import Rel8.Table

50 ( Table, Columns, Context, fromColumns, toColumns

51 ( Table, Columns, Context, fromColumns, toColumns

51− , reify, unreify

52+ , FromExprs, fromResult, toResult

53+ , Transpose

52 )

54 )

53import Rel8.Table.Alternative

55import Rel8.Table.Alternative

54 ( AltTable, (<|>:)

56 ( AltTable, (<|>:)

@@ -57,12 +59,12 @@ import Rel8.Table.Alternative

57import Rel8.Table.Bool ( bool )

59import Rel8.Table.Bool ( bool )

58import Rel8.Table.Eq ( EqTable, eqTable )

60import Rel8.Table.Eq ( EqTable, eqTable )

59import Rel8.Table.Ord ( OrdTable, ordTable )

61import Rel8.Table.Ord ( OrdTable, ordTable )

60−import Rel8.Table.Recontextualize ( Recontextualize )

62+import Rel8.Table.Projection ( Projectable, project )

63+import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )

61−import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )

64+import Rel8.Table.Serialize ( ToExprs )

62−import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )

63import Rel8.Table.Undefined ( undefined )

65import Rel8.Table.Undefined ( undefined )

64import Rel8.Type ( DBType )

66import Rel8.Type ( DBType )

65−import Rel8.Type.Tag ( MaybeTag )

67+import Rel8.Type.Tag ( MaybeTag( IsJust ) )

67-- semigroupoids

69-- semigroupoids

68import Data.Functor.Apply ( Apply, (<.>) )

70import Data.Functor.Apply ( Apply, (<.>) )

@@ -77,170 +79,168 @@ import Data.Functor.Bind ( Bind, (>>-) )

77-- entirely of nulls, you can't distinguish if you matched an all null row, or

79-- entirely of nulls, you can't distinguish if you matched an all null row, or

78-- if the match failed. For this reason @MaybeTable@ contains an extra field -

80-- if the match failed. For this reason @MaybeTable@ contains an extra field -

79-- a "nullTag" - to track whether or not the outer join produced any rows.

81-- a "nullTag" - to track whether or not the outer join produced any rows.

80−type MaybeTable :: Type -> Type

82+type MaybeTable :: K.Context -> Type -> Type

81−data MaybeTable a = MaybeTable

83+data MaybeTable context a = MaybeTable

82− { tag :: Tag "isJust" (Maybe MaybeTag)

84+ { tag :: context (Maybe MaybeTag)

83− , just :: a

85+ , just :: Nullify context a

84 }

86 }

85 deriving stock Functor

87 deriving stock Functor

90+instance Projectable (MaybeTable context) where

91+ project f (MaybeTable tag a) = MaybeTable tag (project f a)

92+

93+

88−instance Apply MaybeTable where

94+instance context ~ Expr => Apply (MaybeTable context) where

89− MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f a)

95+ MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f <.> a)

92-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:

98-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:

93-- 'Rel8.traverseMaybeTable'.

99-- 'Rel8.traverseMaybeTable'.

94−instance Applicative MaybeTable where

100+instance context ~ Expr => Applicative (MaybeTable context) where

95 (<*>) = (<.>)

101 (<*>) = (<.>)

96 pure = justTable

102 pure = justTable

103

104

99−instance Bind MaybeTable where

105+instance context ~ Expr => Bind (MaybeTable context) where

100− MaybeTable tag a >>- f = case f a of

106+ MaybeTable tag a >>- f = case f (extract a) of

101 MaybeTable tag' b -> MaybeTable (tag <> tag') b

107 MaybeTable tag' b -> MaybeTable (tag <> tag') b

102

108

103

109

104−-- | Has the same behavior as the @Monad@ instance for @Maybe@. See also:

110+-- | Has the same behavior as the @Monad@ instance for @Maybe@.

105−-- 'Rel8.bindMaybeTable'.

106−instance Monad MaybeTable where

111+instance context ~ Expr => Monad (MaybeTable context) where

107 (>>=) = (>>-)

112 (>>=) = (>>-)

108

113

109

114

110−instance AltTable MaybeTable where

115+instance context ~ Expr => AltTable (MaybeTable context) where

111− ma@(MaybeTable tag a) <|>: MaybeTable tag' b = MaybeTable

112− { tag = (tag <> tag')

113− { expr = boolExpr (expr tag) (expr tag') condition

114− }

115− , just = bool a b condition

116− }

117− where

118− condition = isNothingTable ma

116+ ma <|>: mb = bool ma mb (isNothingTable ma)

119

117

120

118

121−instance AlternativeTable MaybeTable where

119+instance context ~ Expr => AlternativeTable (MaybeTable context) where

122 emptyTable = nothingTable

120 emptyTable = nothingTable

123

121

124

122

125−instance (Table Expr a, Semigroup a) => Semigroup (MaybeTable a) where

123+instance (context ~ Expr, Table Expr a, Semigroup a) =>

124+ Semigroup (MaybeTable context a)

125+ where

126 ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma

127

128

129−instance (Table Expr a, Semigroup a) => Monoid (MaybeTable a) where

129+instance (context ~ Expr, Table Expr a, Semigroup a) =>

130+ Monoid (MaybeTable context a)

131+ where

130 mempty = nothingTable

132 mempty = nothingTable

131

133

132

134

133−instance

134− ( Table context a

135+instance (Table context a, Reifiable context, context ~ context') =>

135− , Labelable context, Nullifiable context

136− , ConstrainTag context MaybeTag

137− ) => Table context (MaybeTable a)

136+ Table context' (MaybeTable context a)

138 where

137 where

139− type Columns (MaybeTable a) = HMaybeTable (Columns a)

138+ type Columns (MaybeTable context a) = HMaybeTable (Columns a)

140− type Context (MaybeTable a) = Context a

139+ type Context (MaybeTable context a) = Context a

141−

140+ type FromExprs (MaybeTable context a) = Maybe (FromExprs a)

142− toColumns = toColumns1 toColumns

141+ type Transpose to (MaybeTable context a) = MaybeTable to (Transpose to a)

143− fromColumns = fromColumns1 fromColumns

142+

144− reify = fmap fmap reify

143+ toColumns MaybeTable {tag, just} = HMaybeTable

145− unreify = fmap fmap unreify

144+ { htag = hlabel $ HIdentity tag

146−

145+ , hjust = hlabel $ guard tag isJust isNonNull $ toColumns just

146+ }

147

148−instance

148+ fromColumns HMaybeTable {htag, hjust} = MaybeTable

149− ( Labelable from, Nullifiable from, ConstrainTag from MaybeTag

149+ { tag = unHIdentity $ hunlabel htag

150− , Labelable to, Nullifiable to, ConstrainTag to MaybeTag

150+ , just = fromColumns $ hunlabel hjust

151− , Recontextualize from to a b

151+ }

152− )

153− => Recontextualize from to (MaybeTable a) (MaybeTable b)

154

152

153+ toResult ma = HMaybeTable

154+ { htag = hlabel (HIdentity (Identity (IsJust <$ ma)))

155+ , hjust = hlabel (toResult @_ @(Nullify context a) ma)

156+ }

155

157

156−instance EqTable a => EqTable (MaybeTable a) where

158+ fromResult HMaybeTable {htag, hjust} = case hunlabel htag of

157− eqTable = toColumns1 id (justTable (eqTable @a))

159+ HIdentity (Identity tag) -> tag $>

160+ fromMaybe err (fromResult @_ @(Nullify context a) (hunlabel hjust))

161+ where

162+ err = error "Maybe.fromColumns: mismatch between tag and data"

158

163

159

164

160−instance OrdTable a => OrdTable (MaybeTable a) where

165+instance (EqTable a, context ~ Expr) => EqTable (MaybeTable context a) where

161− ordTable = toColumns1 id (justTable (ordTable @a))

166+ eqTable = HMaybeTable

167+ { htag = hlabel (HIdentity Dict)

168+ , hjust = hlabel (eqTable @(Nullify context a))

169+ }

162

170

163

171

164−type instance FromExprs (MaybeTable a) = Maybe (FromExprs a)

172+instance (OrdTable a, context ~ Expr) => OrdTable (MaybeTable context a) where

173+ ordTable = HMaybeTable

174+ { htag = hlabel (HIdentity Dict)

175+ , hjust = hlabel (ordTable @(Nullify context a))

176+ }

165

177

166

178

179+instance (ToExprs exprs a, context ~ Expr) =>

167−instance ToExprs exprs a => ToExprs (MaybeTable exprs) (Maybe a) where

180+ ToExprs (MaybeTable context exprs) (Maybe a)

168− fromResult = fmap (fromResult @exprs) . fromColumns

169− toResult = toColumns . fmap (toResult @exprs)

170

181

171

182

172-- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.

183-- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.

173−isNothingTable :: MaybeTable a -> Expr Bool

184+isNothingTable :: MaybeTable Expr a -> Expr Bool

174−isNothingTable (MaybeTable tag _) = isNull (expr tag)

185+isNothingTable (MaybeTable tag _) = isNull tag

175

186

176

187

177-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.

188-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.

178−isJustTable :: MaybeTable a -> Expr Bool

189+isJustTable :: MaybeTable Expr a -> Expr Bool

179−isJustTable (MaybeTable tag _) = isNonNull (expr tag)

190+isJustTable (MaybeTable tag _) = isNonNull tag

180

191

181

192

182-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.

193-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.

183−maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable a -> b

194+maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable Expr a -> b

184−maybeTable b f ma@(MaybeTable _ a) = bool (f a) b (isNothingTable ma)

195+maybeTable b f ma@(MaybeTable _ a) = bool (f (extract a)) b (isNothingTable ma)

185{-# INLINABLE maybeTable #-}

196{-# INLINABLE maybeTable #-}

186

197

187

198

188-- | The null table. Like 'Nothing'.

199-- | The null table. Like 'Nothing'.

189−nothingTable :: Table Expr a => MaybeTable a

200+nothingTable :: Table Expr a => MaybeTable Expr a

190−nothingTable = MaybeTable (fromExpr null) undefined

201+nothingTable = MaybeTable null (pure undefined)

191

202

192

203

193-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use

204-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use

194-- 'pure'.

205-- 'pure'.

195−justTable :: a -> MaybeTable a

206+justTable :: a -> MaybeTable Expr a

196−justTable = MaybeTable (fromExpr mempty)

207+justTable = MaybeTable mempty . pure

208+

209+

210+-- | 'Data.Maybe.fromMaybe' for 'MaybeTable's.

211+fromMaybeTable :: Table Expr a => a -> MaybeTable Expr a -> a

212+fromMaybeTable fallback = maybeTable fallback id

197

213

198

214

199-- | Project a single expression out of a 'MaybeTable'. You can think of this

215-- | Project a single expression out of a 'MaybeTable'. You can think of this

200-- operator like the '$' operator, but it also has the ability to return

216-- operator like the '$' operator, but it also has the ability to return

201-- @null@.

217-- @null@.

202($?) :: forall a b. Sql DBType b

218($?) :: forall a b. Sql DBType b

203− => (a -> Expr b) -> MaybeTable a -> Expr (Nullify b)

219+ => (a -> Expr b) -> MaybeTable Expr a -> Expr (N.Nullify b)

204f $? ma@(MaybeTable _ a) = case nullable @b of

220f $? ma@(MaybeTable _ a) = case nullable @b of

205− Null -> boolExpr (f a) null (isNothingTable ma)

221+ Null -> boolExpr (f (extract a)) null (isNothingTable ma)

206− NotNull -> boolExpr (nullify (f a)) null (isNothingTable ma)

222+ NotNull -> boolExpr (nullify (f (extract a))) null (isNothingTable ma)

207infixl 4 $?

223infixl 4 $?

208

224

209

225

226+-- | Lift an aggregating function to operate on a 'MaybeTable'.

227+-- @nothingTable@s and @justTable@s are grouped separately.

228+aggregateMaybeTable :: ()

229+ => (exprs -> aggregates)

230+ -> MaybeTable Expr exprs

231+ -> MaybeTable Aggregate aggregates

232+aggregateMaybeTable f (MaybeTable tag a) =

233+ MaybeTable (groupByExpr tag) (aggregateNullify f a)

234+

235+

236+-- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you

237+-- have a 'MaybeTable' that you are storing in a table and need to construct a

238+-- 'TableSchema'.

239+nameMaybeTable

210−nameMaybeTable :: Name (Maybe MaybeTag) -> a -> MaybeTable a

240+ :: Name (Maybe MaybeTag)

211−nameMaybeTable = MaybeTable . fromName

241+ -- ^ The name of the column to track whether a row is a 'justTable' or

212−

242+ -- 'nothingTable'.

213−

243+ -> a

214−toColumns1 ::

244+ -- ^ Names of the columns in @a@.

215− ( HTable t

245+ -> MaybeTable Name a

216− , HConstrainTag context MaybeTag

246+nameMaybeTable tag = MaybeTable tag . pure

217− , HLabelable context

218− , HNullifiable context

219− )

220− => (a -> t context)

221− -> MaybeTable a

222− -> HMaybeTable t context

223−toColumns1 f MaybeTable {tag, just} = HMaybeTable

224− { htag

225− , hjust = hlabel hlabeler $ hnullify (hnullifier tag isNonNull) $ f just

226− }

227− where

228− htag = HIdentity (hencodeTag tag)

229−

230−

231−fromColumns1 ::

232− ( HTable t

233− , HConstrainTag context MaybeTag

234− , HLabelable context

235− , HNullifiable context

236− )

237− => (t context -> a)

238− -> HMaybeTable t context

239− -> MaybeTable a

240−fromColumns1 f HMaybeTable {htag = HIdentity htag, hjust} = MaybeTable

241− { tag

242− , just = f $ runIdentity $

243− hunnullify (\a -> pure . hunnullifier a) (hunlabel hunlabeler hjust)

244− }

245− where

246− tag = hdecodeTag htag

src/Rel8/Table/Name.hs+36−22

@@ -1,14 +1,17 @@

1+{-# language DataKinds #-}

1{-# language FlexibleContexts #-}

2{-# language FlexibleContexts #-}

3+{-# language FlexibleInstances #-}

4+{-# language MultiParamTypeClasses #-}

2{-# language NamedFieldPuns #-}

5{-# language NamedFieldPuns #-}

3{-# language ScopedTypeVariables #-}

6{-# language ScopedTypeVariables #-}

4{-# language TypeApplications #-}

7{-# language TypeApplications #-}

5{-# language TypeFamilies #-}

8{-# language TypeFamilies #-}

9+{-# language UndecidableInstances #-}

6{-# language ViewPatterns #-}

10{-# language ViewPatterns #-}

8module Rel8.Table.Name

12module Rel8.Table.Name

9 ( namesFromLabels

13 ( namesFromLabels

10 , namesFromLabelsWith

14 , namesFromLabelsWith

11− , showExprs

12 , showLabels

15 , showLabels

13 , showNames

16 , showNames

14 )

17 )

@@ -17,49 +20,60 @@ where

17-- base

20-- base

18import Data.Foldable ( fold )

21import Data.Foldable ( fold )

19import Data.Functor.Const ( Const( Const ), getConst )

22import Data.Functor.Const ( Const( Const ), getConst )

20−import Data.List.NonEmpty ( NonEmpty, intersperse )

23+import Data.List.NonEmpty ( NonEmpty, intersperse, nonEmpty )

24+import Data.Maybe ( fromMaybe )

21import Prelude

25import Prelude

23−-- opaleye

24−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

25−

26-- rel8

27-- rel8

27−import Rel8.Expr ( Expr, Col( E ) )

28−import Rel8.Expr.Opaleye ( toPrimExpr )

29−import Rel8.Kind.Labels ( renderLabels )

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

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

31−import Rel8.Schema.Name ( Name( Name ), Col( N ) )

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

32−import Rel8.Schema.Spec ( SSpec(..) )

30+import Rel8.Schema.Spec ( Spec(..) )

33−import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )

31+import Rel8.Table ( Table(..) )

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'.

36namesFromLabels :: Table Name a => a

38namesFromLabels :: Table Name a => a

37namesFromLabels = namesFromLabelsWith go

39namesFromLabels = namesFromLabelsWith go

38 where

40 where

39 go = fold . intersperse "/"

41 go = fold . intersperse "/"

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.

42namesFromLabelsWith :: Table Name a

59namesFromLabelsWith :: Table Name a

43 => (NonEmpty String -> String) -> a

60 => (NonEmpty String -> String) -> a

44namesFromLabelsWith f = fromColumns $ htabulate $ \field ->

61namesFromLabelsWith f = fromColumns $ htabulate $ \field ->

45 case hfield hspecs field of

62 case hfield hspecs field of

46− SSpec {labels} -> N (Name (f (renderLabels labels)))

63+ Spec {labels} -> Name (f (renderLabels labels))

47−

48−

49−showExprs :: Table Expr a => a -> [(String, Opaleye.PrimExpr)]

50−showExprs as = case (namesFromLabels, toColumns as) of

51− (names, exprs) -> getConst $ htabulateA $ \field ->

52− case (hfield names field, hfield exprs field) of

53− (N (Name name), E expr) -> Const [(name, toPrimExpr expr)]

56showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]

66showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]

57showLabels _ = getConst $

67showLabels _ = getConst $

58 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

68 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

59− SSpec {labels} -> Const [renderLabels labels]

69+ Spec {labels} -> Const (pure (renderLabels labels))

62−showNames :: forall a. Table Name a => a -> [String]

72+showNames :: forall a. Table Name a => a -> NonEmpty String

63showNames (toColumns -> names) = getConst $

73showNames (toColumns -> names) = getConst $

64 htabulateA @(Columns a) $ \field -> case hfield names field of

74 htabulateA @(Columns a) $ \field -> case hfield names field of

65− N (Name name) -> Const [name]

75+ Name name -> Const (pure name)

76+

77+

78+renderLabels :: [String] -> NonEmpty String

79+renderLabels labels = fromMaybe (pure "anon") (nonEmpty labels )

src/Rel8/Table/NonEmpty.hs+73−54

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

1+{-# language DataKinds #-}

1{-# language FlexibleContexts #-}

2{-# language FlexibleContexts #-}

2{-# language FlexibleInstances #-}

3{-# language FlexibleInstances #-}

3{-# language MultiParamTypeClasses #-}

4{-# language MultiParamTypeClasses #-}

@@ -10,7 +11,9 @@

11module Rel8.Table.NonEmpty

12module Rel8.Table.NonEmpty

12 ( NonEmptyTable(..)

13 ( NonEmptyTable(..)

14+ , ($+)

15+ , nonEmptyTable

13− , nonEmptyTable, nameNonEmptyTable

16+ , nameNonEmptyTable

14 )

17 )

15where

18where

@@ -18,107 +21,123 @@ where

18import Data.Functor.Identity ( Identity( Identity ) )

21import Data.Functor.Identity ( Identity( Identity ) )

19import Data.Kind ( Type )

22import Data.Kind ( Type )

20import Data.List.NonEmpty ( NonEmpty )

23import Data.List.NonEmpty ( NonEmpty )

21−import Data.Type.Equality ( (:~:)( Refl ) )

22−import Prelude

24+import Prelude hiding ( id )

24-- rel8

26-- rel8

25−import Rel8.Expr ( Expr, Col( E, unE ) )

27+import Rel8.Expr ( Expr )

26import Rel8.Expr.Array ( sappend1, snonEmptyOf )

28import Rel8.Expr.Array ( sappend1, snonEmptyOf )

27import Rel8.Schema.Dict ( Dict( Dict ) )

29import Rel8.Schema.Dict ( Dict( Dict ) )

28import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )

30import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )

29−import Rel8.Schema.HTable.Vectorize ( happend, hvectorize )

31+import Rel8.Schema.HTable.Vectorize

32+ ( hvectorize, hunvectorize

33+ , happend

34+ , hproject, hcolumn

35+ )

30−import Rel8.Schema.Name ( Col( N ), Name( Name ) )

36+import qualified Rel8.Schema.Kind as K

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

31import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

38import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

32−import Rel8.Schema.Reify ( hreify, hunreify )

39+import Rel8.Schema.Result ( vectorizer, unvectorizer )

33−import Rel8.Schema.Spec ( SSpec(..) )

40+import Rel8.Schema.Spec ( Spec(..) )

34−import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullity )

35import Rel8.Table

41import Rel8.Table

36 ( Table, Context, Columns, fromColumns, toColumns

42 ( Table, Context, Columns, fromColumns, toColumns

37− , reify, unreify

43+ , FromExprs, fromResult, toResult

44+ , Transpose

38 )

45 )

39import Rel8.Table.Alternative ( AltTable, (<|>:) )

46import Rel8.Table.Alternative ( AltTable, (<|>:) )

40import Rel8.Table.Eq ( EqTable, eqTable )

47import Rel8.Table.Eq ( EqTable, eqTable )

41import Rel8.Table.Ord ( OrdTable, ordTable )

48import Rel8.Table.Ord ( OrdTable, ordTable )

42−import Rel8.Table.Recontextualize ( Recontextualize )

49+import Rel8.Table.Projection

50+ ( Projectable, Projecting, Projection, project, apply

51+ )

43−import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )

52+import Rel8.Table.Serialize ( ToExprs )

44−import Rel8.Table.Unreify ( Unreifies )

47-- | A @NonEmptyTable@ value contains one or more instances of @a@. You

55-- | A @NonEmptyTable@ value contains one or more instances of @a@. You

48-- construct @NonEmptyTable@s with 'Rel8.some' or 'nonEmptyAgg'.

56-- construct @NonEmptyTable@s with 'Rel8.some' or 'nonEmptyAgg'.

49−type NonEmptyTable :: Type -> Type

57+type NonEmptyTable :: K.Context -> Type -> Type

50−newtype NonEmptyTable a =

58+newtype NonEmptyTable context a =

51− NonEmptyTable (HNonEmptyTable (Columns a) (Col (Context a)))

59+ NonEmptyTable (HNonEmptyTable (Columns a) (Context a))

60+

61+

62+instance Projectable (NonEmptyTable context) where

63+ project f (NonEmptyTable a) = NonEmptyTable (hproject (apply f) a)

54−instance (Table context a, Unreifies context a) =>

66+instance (Table context a, context ~ context') =>

55− Table context (NonEmptyTable a)

67+ Table context' (NonEmptyTable context a)

56 where

68 where

57− type Columns (NonEmptyTable a) = HNonEmptyTable (Columns a)

69+ type Columns (NonEmptyTable context a) = HNonEmptyTable (Columns a)

58− type Context (NonEmptyTable a) = Context a

70+ type Context (NonEmptyTable context a) = Context a

71+ type FromExprs (NonEmptyTable context a) = NonEmpty (FromExprs a)

72+ type Transpose to (NonEmptyTable context a) =

73+ NonEmptyTable to (Transpose to a)

60 fromColumns = NonEmptyTable

75 fromColumns = NonEmptyTable

61 toColumns (NonEmptyTable a) = a

76 toColumns (NonEmptyTable a) = a

62−

77+ fromResult = fmap (fromResult @_ @a) . hunvectorize unvectorizer

63− reify Refl (NonEmptyTable a) = NonEmptyTable (hreify a)

78+ toResult = hvectorize vectorizer . fmap (toResult @_ @a)

64− unreify Refl (NonEmptyTable a) = NonEmptyTable (hunreify a)

65−

66−

67−instance

68− ( Unreifies from a, Unreifies to b

69− , Recontextualize from to a b

70− )

71− => Recontextualize from to (NonEmptyTable a) (NonEmptyTable b)

81+instance (EqTable a, context ~ Expr) =>

74−instance EqTable a => EqTable (NonEmptyTable a) where

82+ EqTable (NonEmptyTable context a)

83+ where

75 eqTable =

84 eqTable =

76 hvectorize

85 hvectorize

77− (\SSpec {} (Identity dict) -> case dbTypeDict dict of

86+ (\Spec {nullity} (Identity Dict) -> case nullity of

78− Dict -> case dbTypeNullity dict of

79− Null -> Dict

87+ Null -> Dict

80− NotNull -> Dict)

88+ NotNull -> Dict)

81 (Identity (eqTable @a))

89 (Identity (eqTable @a))

92+instance (OrdTable a, context ~ Expr) =>

84−instance OrdTable a => OrdTable (NonEmptyTable a) where

93+ OrdTable (NonEmptyTable context a)

94+ where

85 ordTable =

95 ordTable =

86 hvectorize

96 hvectorize

87− (\SSpec {} (Identity dict) -> case dbTypeDict dict of

97+ (\Spec {nullity} (Identity Dict) -> case nullity of

88− Dict -> case dbTypeNullity dict of

89− Null -> Dict

98+ Null -> Dict

90− NotNull -> Dict)

99+ NotNull -> Dict)

91 (Identity (ordTable @a))

100 (Identity (ordTable @a))

101

102

94−type instance FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)

103+instance (ToExprs exprs a, context ~ Expr) =>

95−

96−

97−instance ToExprs exprs a => ToExprs (NonEmptyTable exprs) (NonEmpty a)

104+ ToExprs (NonEmptyTable context exprs) (NonEmpty a)

98− where

99− fromResult = fmap (fromResult @exprs) . fromColumns

100− toResult = toColumns . fmap (toResult @exprs)

101

105

102

106

103−instance AltTable NonEmptyTable where

107+instance context ~ Expr => AltTable (NonEmptyTable context) where

104 (<|>:) = (<>)

108 (<|>:) = (<>)

105

109

106

110

107−instance Table Expr a => Semigroup (NonEmptyTable a) where

111+instance (Table Expr a, context ~ Expr) => Semigroup (NonEmptyTable context a)

112+ where

108 NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $

113 NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $

109− happend (\_ _ (E a) (E b) -> E (sappend1 a b)) as bs

114+ happend (const sappend1) as bs

115+

116+

117+-- | Project a single expression out of a 'NonEmptyTable'.

118+($+) :: Projecting a (Expr b)

119+ => Projection a (Expr b) -> NonEmptyTable Expr a -> Expr (NonEmpty b)

120+f $+ NonEmptyTable a = hcolumn $ hproject (apply f) a

121+infixl 4 $+

110

122

111

123

124+-- | Construct a @NonEmptyTable@ from a non-empty list of expressions.

112−nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable a

125+nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable Expr a

113nonEmptyTable =

126nonEmptyTable =

114 NonEmptyTable .

127 NonEmptyTable .

115− hvectorize (\SSpec {info} -> E . snonEmptyOf info . fmap unE) .

128+ hvectorize (\Spec {info} -> snonEmptyOf info) .

116 fmap toColumns

129 fmap toColumns

117

130

118

131

132+-- | Construct a 'NonEmptyTable' in the 'Name' context. This can be useful if

133+-- you have a 'NonEmptyTable' that you are storing in a table and need to

134+-- construct a 'TableSchema'.

119−nameNonEmptyTable :: Table Name a => a -> NonEmptyTable a

135+nameNonEmptyTable

136+ :: Table Name a

137+ => a -- ^ The names of the columns of elements of the list.

138+ -> NonEmptyTable Name a

120nameNonEmptyTable =

139nameNonEmptyTable =

121 NonEmptyTable .

140 NonEmptyTable .

122− hvectorize (\_ (Identity (N (Name a))) -> N (Name a)) .

141+ hvectorize (\_ (Identity (Name a)) -> Name a) .

123 pure .

142 pure .

124 toColumns

143 toColumns

src/Rel8/Table/Null.hsnew file+147

@@ -0,0 +1,147 @@

1+{-# language DataKinds #-}

2+{-# language FlexibleContexts #-}

3+{-# language FlexibleInstances #-}

4+{-# language MultiParamTypeClasses #-}

5+{-# language ScopedTypeVariables #-}

6+{-# language StandaloneKindSignatures #-}

7+{-# language TypeApplications #-}

8+{-# language TypeFamilies #-}

9+{-# language UndecidableInstances #-}

10+

11+module Rel8.Table.Null

12+ ( NullTable(..)

13+ , nullableTable, nullTable, nullifyTable, unsafeUnnullifyTable

14+ , isNullTable, isNonNullTable

15+ , nameNullTable

16+ , toMaybeTable, toNullTable

17+ )

18+where

19+

20+-- base

21+import Data.Kind ( Type )

22+import Prelude hiding ( null, undefined )

23+

24+-- comonad

25+import Control.Comonad ( extract )

26+

27+-- rel8

28+import Rel8.Expr ( Expr )

29+import Rel8.Expr.Bool ( not_ )

30+import Rel8.Kind.Context ( Reifiable )

31+import qualified Rel8.Schema.Kind as K

32+import Rel8.Schema.Name ( Name )

33+import Rel8.Table

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

35+ , FromExprs, fromResult, toResult

36+ , Transpose

37+ )

38+import Rel8.Table.Alternative

39+ ( AltTable, (<|>:)

40+ , AlternativeTable, emptyTable

41+ )

42+import Rel8.Table.Bool ( bool )

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

44+import Rel8.Table.Maybe ( MaybeTable, justTable, maybeTable, nothingTable )

45+import Rel8.Table.Nullify ( Nullify, isNull )

46+import Rel8.Table.Ord ( OrdTable, ordTable )

47+import Rel8.Table.Projection ( Projectable, project )

48+import Rel8.Table.Serialize ( ToExprs )

49+import Rel8.Table.Undefined ( undefined )

50+

51+

52+-- | @NullTable t@ is the table @t@, but where all the columns in @t@ have the

53+-- possibility of being 'Rel8.null'. This is very similar to

54+-- 'Rel8.MaybeTable', except that it does not use an extra tag field, so it

55+-- cannot distinguish between @Nothing@ and @Just Nothing@ if nested. In other

56+-- words, if all of the columns of the @t@ passed to @NullTable@ are already

57+-- nullable, then @NullTable@ has no effect.

58+type NullTable :: K.Context -> Type -> Type

59+newtype NullTable context a = NullTable (Nullify context a)

60+

61+

62+instance Projectable (NullTable context) where

63+ project f (NullTable a) = NullTable (project f a)

64+

65+

66+instance context ~ Expr => AltTable (NullTable context) where

67+ ma <|>: mb = bool ma mb (isNullTable ma)

68+

69+

70+instance context ~ Expr => AlternativeTable (NullTable context) where

71+ emptyTable = nullTable

72+

73+

74+instance (Table context a, Reifiable context, context ~ context') =>

75+ Table context' (NullTable context a)

76+ where

77+ type Columns (NullTable context a) = Columns (Nullify context a)

78+ type Context (NullTable context a) = Context (Nullify context a)

79+ type FromExprs (NullTable context a) = FromExprs (Nullify context a)

80+ type Transpose to (NullTable context a) = NullTable to (Transpose to a)

81+

82+ toColumns (NullTable a) = toColumns a

83+ fromColumns = NullTable . fromColumns

84+

85+ toResult = toResult @_ @(Nullify context a)

86+ fromResult = fromResult @_ @(Nullify context a)

87+

88+

89+instance (EqTable a, context ~ Expr) => EqTable (NullTable context a) where

90+ eqTable = eqTable @(Nullify context a)

91+

92+

93+instance (OrdTable a, context ~ Expr) => OrdTable (NullTable context a) where

94+ ordTable = ordTable @(Nullify context a)

95+

96+

97+instance (ToExprs exprs a, context ~ Expr) =>

98+ ToExprs (NullTable context exprs) (Maybe a)

99+

100+

101+-- | Check if any of the non-nullable fields of @a@ are 'Rel8.null' under the

102+-- 'NullTable'. Returns 'Rel8.false' if @a@ has no non-nullable fields.

103+isNullTable :: Table Expr a => NullTable Expr a -> Expr Bool

104+isNullTable (NullTable a) = isNull a

105+

106+

107+-- | The inverse of 'isNullTable'.

108+isNonNullTable :: Table Expr a => NullTable Expr a -> Expr Bool

109+isNonNullTable = not_ . isNullTable

110+

111+

112+-- | Like 'Rel8.nullable'.

113+nullableTable :: (Table Expr a, Table Expr b)

114+ => b -> (a -> b) -> NullTable Expr a -> b

115+nullableTable b f ma@(NullTable a) = bool (f (extract a)) b (isNullTable ma)

116+

117+

118+-- | The null table. Like 'Rel8.null'.

119+nullTable :: Table Expr a => NullTable Expr a

120+nullTable = NullTable (pure undefined)

121+

122+

123+-- | Lift any table into 'NullTable'. Like 'Rel8.nullify'.

124+nullifyTable :: a -> NullTable Expr a

125+nullifyTable = NullTable . pure

126+

127+

128+unsafeUnnullifyTable :: NullTable Expr a -> a

129+unsafeUnnullifyTable (NullTable a) = extract a

130+

131+

132+-- | Construct a 'NullTable' in the 'Name' context. This can be useful if you

133+-- have a 'NullTable' that you are storing in a table and need to construct a

134+-- 'TableSchema'.

135+nameNullTable :: a -> NullTable Name a

136+nameNullTable = NullTable . pure

137+

138+

139+-- | Convert a 'NullTable' to a 'MaybeTable'.

140+toMaybeTable :: Table Expr a => NullTable Expr a -> MaybeTable Expr a

141+toMaybeTable = nullableTable nothingTable justTable

142+

143+

144+-- | Convert a 'MaybeTable' to a 'NullTable'. Note that if the underlying @a@

145+-- has no non-nullable fields, this is a lossy conversion.

146+toNullTable :: Table Expr a => MaybeTable Expr a -> NullTable Expr a

147+toNullTable = maybeTable nullTable nullifyTable

src/Rel8/Table/Nullify.hsnew file+211

@@ -0,0 +1,211 @@

1+{-# language DataKinds #-}

2+{-# language FlexibleContexts #-}

3+{-# language FlexibleInstances #-}

4+{-# language LambdaCase #-}

5+{-# language MultiParamTypeClasses #-}

6+{-# language NamedFieldPuns #-}

7+{-# language ScopedTypeVariables #-}

8+{-# language StandaloneKindSignatures #-}

9+{-# language TypeApplications #-}

10+{-# language TypeFamilies #-}

11+{-# language UndecidableInstances #-}

12+

13+module Rel8.Table.Nullify

14+ ( Nullify

15+ , aggregateNullify

16+ , guard

17+ , isNull

18+ )

19+where

20+

21+-- base

22+import Control.Applicative ( liftA2 )

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

24+import Data.Functor.Identity ( runIdentity )

25+import Data.Kind ( Type )

26+import Prelude

27+

28+-- comonad

29+import Control.Comonad ( Comonad, duplicate, extract, ComonadApply, (<@>) )

30+

31+-- rel8

32+import Rel8.Aggregate ( Aggregate )

33+import Rel8.Expr ( Expr )

34+import Rel8.Expr.Bool ( (||.), false )

35+import qualified Rel8.Expr.Null as Expr

36+import Rel8.Kind.Context ( Reifiable, contextSing )

37+import Rel8.Schema.Context.Nullify

38+ ( Nullifiability( NAggregate, NExpr )

39+ , NonNullifiability

40+ , Nullifiable, nullifiability

41+ , nullifiableOrNot, absurd

42+ , guarder

43+ , nullifier

44+ , unnullifier

45+ )

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

47+import Rel8.Schema.HTable ( HTable )

48+import Rel8.Schema.HTable.Nullify

49+ ( HNullify, hnulls, hnullify, hunnullify

50+ , hguard

51+ , hproject

52+ )

53+import qualified Rel8.Schema.Kind as K

54+import Rel8.Schema.Null ( Nullity( NotNull, Null ) )

55+import qualified Rel8.Schema.Result as R

56+import Rel8.Table

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

58+ , FromExprs, fromResult, toResult

59+ , Transpose

60+ )

61+import Rel8.Schema.Spec ( Spec( Spec, nullity ) )

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

63+import Rel8.Table.Ord ( OrdTable, ordTable )

64+import Rel8.Table.Projection ( Projectable, apply, project )

65+

66+-- semigroupoids

67+import Data.Functor.Apply ( Apply, (<.>), liftF2 )

68+import Data.Functor.Bind ( Bind, (>>-) )

69+import Data.Functor.Extend ( Extend, duplicated )

70+

71+

72+type Nullify :: K.Context -> Type -> Type

73+data Nullify context a

74+ = Table (Nullifiability context) a

75+ | Fields (NonNullifiability context) (HNullify (Columns a) (Context a))

76+

77+

78+instance Projectable (Nullify context) where

79+ project f = \case

80+ Table nullifiable a -> Table nullifiable (fromColumns (apply f (toColumns a)))

81+ Fields nonNullifiable a -> Fields nonNullifiable (hproject (apply f) a)

82+

83+

84+instance Nullifiable context => Functor (Nullify context) where

85+ fmap f = \case

86+ Table nullifiable a -> Table nullifiable (f a)

87+ Fields notNullifiable _ -> absurd nullifiability notNullifiable

88+

89+

90+instance Nullifiable context => Foldable (Nullify context) where

91+ foldMap f = \case

92+ Table _ a -> f a

93+ Fields notNullifiable _ -> absurd nullifiability notNullifiable

94+

95+

96+instance Nullifiable context => Traversable (Nullify context) where

97+ traverse f = \case

98+ Table nullifiable a -> Table nullifiable <$> f a

99+ Fields notNullifiable _ -> absurd nullifiability notNullifiable

100+

101+

102+instance Nullifiable context => Apply (Nullify context) where

103+ liftF2 f = \case

104+ Table nullifiable a -> \case

105+ Table _ b -> Table nullifiable (f a b)

106+ Fields notNullifiable _ -> absurd nullifiable notNullifiable

107+ Fields notNullifiable _ -> absurd nullifiability notNullifiable

108+

109+

110+instance Nullifiable context => Applicative (Nullify context) where

111+ pure = Table nullifiability

112+ liftA2 = liftF2

113+

114+

115+instance Nullifiable context => Bind (Nullify context) where

116+ Table _ a >>- f = f a

117+ Fields notNullifiable _ >>- _ = absurd nullifiability notNullifiable

118+

119+

120+instance Nullifiable context => Monad (Nullify context) where

121+ (>>=) = (>>-)

122+

123+

124+instance Nullifiable context => Extend (Nullify context) where

125+ duplicated = \case

126+ Table nullifiable a -> Table nullifiable (Table nullifiable a)

127+ Fields notNullifiable _ -> absurd nullifiability notNullifiable

128+

129+

130+instance Nullifiable context => Comonad (Nullify context) where

131+ extract = \case

132+ Table _ a -> a

133+ Fields notNullifiable _ -> absurd nullifiability notNullifiable

134+ duplicate = duplicated

135+

136+

137+instance Nullifiable context => ComonadApply (Nullify context) where

138+ (<@>) = (<.>)

139+

140+

141+instance (Table context a, Reifiable context, context ~ context') =>

142+ Table context' (Nullify context a)

143+ where

144+ type Columns (Nullify context a) = HNullify (Columns a)

145+ type Context (Nullify context a) = Context a

146+ type FromExprs (Nullify context a) = Maybe (FromExprs a)

147+ type Transpose to (Nullify context a) = Nullify to (Transpose to a)

148+

149+ fromColumns = case nullifiableOrNot contextSing of

150+ Left notNullifiable -> Fields notNullifiable

151+ Right nullifiable ->

152+ Table nullifiable .

153+ fromColumns .

154+ runIdentity .

155+ hunnullify (\spec -> pure . unnullifier nullifiable spec)

156+

157+ toColumns = \case

158+ Table nullifiable a -> hnullify (nullifier nullifiable) (toColumns a)

159+ Fields _ a -> a

160+

161+ fromResult = fmap (fromResult @_ @a) . hunnullify R.unnullifier

162+

163+ toResult =

164+ maybe (hnulls (const R.null)) (hnullify R.nullifier) .

165+ fmap (toResult @_ @a)

166+

167+

168+instance (EqTable a, context ~ Expr) => EqTable (Nullify context a) where

169+ eqTable = hnullify (\_ Dict -> Dict) (eqTable @a)

170+

171+

172+instance (OrdTable a, context ~ Expr) => OrdTable (Nullify context a) where

173+ ordTable = hnullify (\_ Dict -> Dict) (ordTable @a)

174+

175+

176+aggregateNullify :: ()

177+ => (exprs -> aggregates)

178+ -> Nullify Expr exprs

179+ -> Nullify Aggregate aggregates

180+aggregateNullify f = \case

181+ Table _ a -> Table NAggregate (f a)

182+ Fields notNullifiable _ -> absurd NExpr notNullifiable

183+

184+

185+guard :: (Reifiable context, HTable t)

186+ => context tag

187+ -> (tag -> Bool)

188+ -> (Expr tag -> Expr Bool)

189+ -> HNullify t context

190+ -> HNullify t context

191+guard tag isNonNull isNonNullExpr =

192+ hguard (guarder contextSing tag isNonNull isNonNullExpr)

193+

194+

195+isNull :: forall a. Table Expr a => Nullify Expr a -> Expr Bool

196+isNull =

197+ maybe false getAny .

198+ getConst .

199+ hunnullify (\Spec {nullity} a -> Const $ case nullity of

200+ NotNull -> Just $ Any $ Expr.isNull a

201+ Null -> Nothing) .

202+ toColumns

203+

204+

205+newtype Any = Any

206+ { getAny :: Expr Bool

207+ }

208+

209+

210+instance Semigroup Any where

211+ Any a <> Any b = Any (a ||. b)

src/Rel8/Table/Opaleye.hs+78−64

@@ -1,136 +1,150 @@

1{-# language BlockArguments #-}

2+{-# language DataKinds #-}

2{-# language DisambiguateRecordFields #-}

3{-# language DisambiguateRecordFields #-}

3{-# language FlexibleContexts #-}

4{-# language FlexibleContexts #-}

4−{-# language LambdaCase #-}

5{-# language NamedFieldPuns #-}

6+{-# language RankNTypes #-}

6{-# language TypeFamilies #-}

7{-# language TypeFamilies #-}

7{-# language ViewPatterns #-}

8{-# language ViewPatterns #-}

10+{-# options_ghc -Wno-deprecations #-}

11+

9module Rel8.Table.Opaleye

12module Rel8.Table.Opaleye

10 ( aggregator

13 ( aggregator

14+ , attributes

11 , binaryspec

15 , binaryspec

12 , distinctspec

16 , distinctspec

17+ , exprs

18+ , exprsWithNames

13 , table

19 , table

14 , tableFields

20 , tableFields

15 , unpackspec

21 , unpackspec

16 , valuesspec

22 , valuesspec

23+ , view

17 , castTable

24 , castTable

18 )

25 )

19where

26where

21-- base

28-- base

22−import Prelude hiding ( undefined )

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

30+import Data.List.NonEmpty ( NonEmpty )

31+import Prelude

24-- opaleye

33-- opaleye

34+import qualified Opaleye.Adaptors as Opaleye

35+import qualified Opaleye.Field as Opaleye ( Field_ )

25import qualified Opaleye.Internal.Aggregate as Opaleye

36import qualified Opaleye.Internal.Aggregate as Opaleye

26−import qualified Opaleye.Internal.Binary as Opaleye

27−import qualified Opaleye.Internal.Distinct as Opaleye

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

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

29−import qualified Opaleye.Internal.PackMap as Opaleye

30−import qualified Opaleye.Internal.Unpackspec as Opaleye

31import qualified Opaleye.Internal.Values as Opaleye

38import qualified Opaleye.Internal.Values as Opaleye

32−import qualified Opaleye.Internal.Table as Opaleye

39+import qualified Opaleye.Table as Opaleye

34-- profunctors

41-- profunctors

35import Data.Profunctor ( dimap, lmap )

42import Data.Profunctor ( dimap, lmap )

37-- rel8

44-- rel8

38−import Rel8.Aggregate ( Col( A ), Aggregate( Aggregate ), Aggregates )

45+import Rel8.Aggregate ( Aggregate( Aggregate ), Aggregates )

39−import Rel8.Expr ( Expr, Col(..) )

46+import Rel8.Expr ( Expr )

40import Rel8.Expr.Opaleye

47import Rel8.Expr.Opaleye

41 ( fromPrimExpr, toPrimExpr

48 ( fromPrimExpr, toPrimExpr

42− , traversePrimExpr

43− , fromColumn, toColumn

44− , scastExpr

49+ , scastExpr, traverseFieldP

45 )

50 )

46−import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs, htabulate )

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

52+ htraverseP, htraversePWithField )

47−import Rel8.Schema.Name ( Col( N ), Name( Name ), Selects )

53+import Rel8.Schema.Name ( Name( Name ), Selects, ppColumn )

48−import Rel8.Schema.Spec ( SSpec(..) )

54+import Rel8.Schema.Spec ( Spec(..) )

49−import Rel8.Schema.Table ( TableSchema(..) )

55+import Rel8.Schema.Table ( TableSchema(..), ppTable )

50import Rel8.Table ( Table, fromColumns, toColumns )

56import Rel8.Table ( Table, fromColumns, toColumns )

51−import Rel8.Table.Undefined ( undefined )

57+import Rel8.Type.Information ( typeName )

53-- semigroupoids

59-- semigroupoids

54import Data.Functor.Apply ( WrappedApplicative(..) )

60import Data.Functor.Apply ( WrappedApplicative(..) )

61+import Data.Profunctor.Product ( ProductProfunctor )

57aggregator :: Aggregates aggregates exprs => Opaleye.Aggregator aggregates exprs

64aggregator :: Aggregates aggregates exprs => Opaleye.Aggregator aggregates exprs

58−aggregator = Opaleye.Aggregator $ Opaleye.PackMap $ \f aggregates ->

65+aggregator = dimap toColumns fromColumns $

59− fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->

66+ htraverseP $

67+ lmap (\(Aggregate a) -> (a, ())) Opaleye.aggregatorApply

68+

69+

70+attributes :: Selects names exprs => TableSchema names -> exprs

71+attributes schema@TableSchema {columns} = fromColumns $ htabulate $ \field ->

60− WrapApplicative $ case hfield (toColumns aggregates) field of

72+ case hfield (toColumns columns) field of

61− A (Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner))) ->

73+ Name column -> fromPrimExpr $ Opaleye.ConstExpr $

62− E <$> inner f ()

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))

65binaryspec :: Table Expr a => Opaleye.Binaryspec a a

85binaryspec :: Table Expr a => Opaleye.Binaryspec a a

66−binaryspec = Opaleye.Binaryspec $ Opaleye.PackMap $ \f (as, bs) ->

86+binaryspec = fromOpaleyespec Opaleye.binaryspecField

67− fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->

68− WrapApplicative $

69− case (hfield (toColumns as) field, hfield (toColumns bs) field) of

70− (E a, E b) -> E . fromPrimExpr <$> f (toPrimExpr a, toPrimExpr b)

73distinctspec :: Table Expr a => Opaleye.Distinctspec a a

89distinctspec :: Table Expr a => Opaleye.Distinctspec a a

74−distinctspec =

90+distinctspec = fromOpaleyespec Opaleye.distinctspecField

75− Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap $ \f ->

91+

76− fmap fromColumns .

92+

77− unwrapApplicative .

93+exprs :: Table Expr a => a -> NonEmpty Opaleye.PrimExpr

78− htraverse

94+exprs (toColumns -> as) = getConst $ htabulateA $ \field ->

79− (\(E a) ->

95+ case hfield as field of

80− WrapApplicative $ E . fromPrimExpr <$> f (Nothing, toPrimExpr a)) .

96+ expr -> Const (pure (toPrimExpr expr))

81− toColumns

97+

98+

99+exprsWithNames :: Selects names exprs

100+ => names -> exprs -> NonEmpty (String, Opaleye.PrimExpr)

101+exprsWithNames names as = getConst $ htabulateA $ \field ->

102+ case (hfield (toColumns names) field, hfield (toColumns as) field) of

103+ (Name name, expr) -> Const (pure (name, toPrimExpr expr))

104

105

84−table ::Selects names exprs => TableSchema names -> Opaleye.Table exprs exprs

106+table :: Selects names exprs => TableSchema names -> Opaleye.Table exprs exprs

85table (TableSchema name schema columns) =

107table (TableSchema name schema columns) =

86 case schema of

108 case schema of

87− Nothing -> Opaleye.Table name (tableFields columns)

109+ Nothing -> Opaleye.table name (tableFields columns)

88− Just schemaName -> Opaleye.TableWithSchema schemaName name (tableFields columns)

110+ Just schemaName -> Opaleye.tableWithSchema schemaName name (tableFields columns)

111

112

91−tableFields ::Selects names exprs

113+tableFields :: Selects names exprs

92 => names -> Opaleye.TableFields exprs exprs

114 => names -> Opaleye.TableFields exprs exprs

93tableFields (toColumns -> names) = dimap toColumns fromColumns $

115tableFields (toColumns -> names) = dimap toColumns fromColumns $

94 unwrapApplicative $ htabulateA $ \field -> WrapApplicative $

116 unwrapApplicative $ htabulateA $ \field -> WrapApplicative $

95 case hfield names field of

117 case hfield names field of

96 name -> lmap (`hfield` field) (go name)

118 name -> lmap (`hfield` field) (go name)

97 where

119 where

98− go :: Col Name spec -> Opaleye.TableFields (Col Expr spec) (Col Expr spec)

120+ go :: Name a -> Opaleye.TableFields (Expr a) (Expr a)

99− go (N (Name name)) =

121+ go (Name name) =

100− lmap (\(E a) -> toColumn $ toPrimExpr a) $

122+ traverseFieldP $

101− E . fromPrimExpr . fromColumn <$>

102− Opaleye.requiredTableField name

123+ Opaleye.requiredTableField name

103

124

104

125

105unpackspec :: Table Expr a => Opaleye.Unpackspec a a

126unpackspec :: Table Expr a => Opaleye.Unpackspec a a

106−unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->

127+unpackspec = fromOpaleyespec Opaleye.unpackspecField

107− fmap fromColumns .

108− unwrapApplicative .

109− htraverse (\(E a) -> WrapApplicative $ E <$> traversePrimExpr f a) .

110− toColumns

111{-# INLINABLE unpackspec #-}

128{-# INLINABLE unpackspec #-}

112

129

113

130

114−valuesspec :: Table Expr a => Opaleye.ValuesspecSafe a a

131+valuesspec :: Table Expr a => Opaleye.Valuesspec a a

115−valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec

132+valuesspec = dimap toColumns fromColumns $

133+ htraversePWithField (traverseFieldP . Opaleye.valuesspecFieldType . typeName)

134+ where typeName = Rel8.Type.Information.typeName . info . hfield hspecs

116

135

117

136

118−toPackMap :: Table Expr a

137+view :: Selects names exprs => names -> exprs

119− => a -> Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () a

120−toPackMap as = Opaleye.PackMap $ \f () ->

121− fmap fromColumns $

138+view columns = fromColumns $ htabulate $ \field ->

122− unwrapApplicative .

123− htraverse (\(E a) -> WrapApplicative $ E <$> traversePrimExpr f a) $

124− toColumns as

139+ case hfield (toColumns columns) field of

140+ Name column -> fromPrimExpr $ Opaleye.BaseTableAttrExpr column

125

141

126

142

127-- | Transform a table by adding 'CAST' to all columns. This is most useful for

143-- | Transform a table by adding 'CAST' to all columns. This is most useful for

128-- finalising a SELECT or RETURNING statement, guaranteed that the output

144-- finalising a SELECT or RETURNING statement, guaranteed that the output

129-- matches what is encoded in each columns TypeInformation.

145-- matches what is encoded in each columns TypeInformation.

130castTable :: Table Expr a => a -> a

146castTable :: Table Expr a => a -> a

131−castTable (toColumns -> as) = fromColumns $ htabulate \i ->

147+castTable (toColumns -> as) = fromColumns $ htabulate \field ->

132− case hfield hspecs i of

148+ case hfield hspecs field of

133− SSpec{info} ->

134− case hfield as i of

149+ Spec {info} -> case hfield as field of

135− E expr ->

136− E (scastExpr info expr)

150+ expr -> scastExpr info expr

src/Rel8/Table/Ord.hs+16−45

@@ -10,7 +10,6 @@

10{-# language TypeFamilies #-}

11{-# language TypeOperators #-}

12{-# language UndecidableInstances #-}

13−{-# language UndecidableSuperClasses #-}

14{-# language ViewPatterns #-}

13{-# language ViewPatterns #-}

16module Rel8.Table.Ord

15module Rel8.Table.Ord

@@ -25,29 +24,20 @@ import GHC.Generics ( Rep )

25import Prelude hiding ( seq )

24import Prelude hiding ( seq )

27-- rel8

26-- rel8

28−import Rel8.Expr ( Expr, Col( E ) )

27+import Rel8.Expr ( Expr )

29import Rel8.Expr.Bool ( (||.), (&&.), false, true )

28import Rel8.Expr.Bool ( (||.), (&&.), false, true )

30import Rel8.Expr.Eq ( (==.) )

29import Rel8.Expr.Eq ( (==.) )

31import Rel8.Expr.Ord ( (<.), (>.) )

30import Rel8.Expr.Ord ( (<.), (>.) )

32import Rel8.FCF ( Eval, Exp )

31import Rel8.FCF ( Eval, Exp )

33import Rel8.Generic.Record ( Record )

32import Rel8.Generic.Record ( Record )

34−import Rel8.Generic.Table

33+import Rel8.Generic.Table.Record ( GTable, GColumns, gtable )

35− ( GGTable, GGColumns, ggtable

36− , GAlgebra

37− )

38−import Rel8.Kind.Algebra ( KnownAlgebra )

39import Rel8.Schema.Dict ( Dict( Dict ) )

34import Rel8.Schema.Dict ( Dict( Dict ) )

40−import Rel8.Schema.HTable

35+import Rel8.Schema.HTable ( htabulateA, hfield )

41− ( HTable, HConstrainTable

42− , htabulateA, hfield, hdicts

43− )

44−import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )

36+import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )

45import Rel8.Schema.Null (Sql)

37import Rel8.Schema.Null (Sql)

46−import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType, nullifier )

47import Rel8.Table ( Columns, toColumns, TColumns )

38import Rel8.Table ( Columns, toColumns, TColumns )

48import Rel8.Table.Bool ( bool )

39import Rel8.Table.Bool ( bool )

49import Rel8.Table.Eq ( EqTable )

40import Rel8.Table.Eq ( EqTable )

50−import Rel8.Type.Eq ( DBEq )

51import Rel8.Type.Ord ( DBOrd )

41import Rel8.Type.Ord ( DBOrd )

@@ -56,22 +46,14 @@ import Rel8.Type.Ord ( DBOrd )

56-- columns in a 'Table' have an instance of 'DBOrd'".

46-- columns in a 'Table' have an instance of 'DBOrd'".

57type OrdTable :: Type -> Constraint

47type OrdTable :: Type -> Constraint

58class EqTable a => OrdTable a where

48class EqTable a => OrdTable a where

59− ordTable :: Columns a (Dict (ConstrainDBType DBOrd))

49+ ordTable :: Columns a (Dict (Sql DBOrd))

61 default ordTable ::

51 default ordTable ::

62− ( KnownAlgebra (GAlgebra (Rep (Record a)))

63− , Eval (GGTable (GAlgebra (Rep (Record a))) TOrdTable TColumns (Dict (ConstrainDBType DBOrd)) (Rep (Record a)))

52+ ( GTable TOrdTable TColumns (Rep (Record a))

64− , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))

53+ , Columns a ~ GColumns TColumns (Rep (Record a))

65 )

54 )

66− => Columns a (Dict (ConstrainDBType DBOrd))

55+ => Columns a (Dict (Sql DBOrd))

67− ordTable =

56+ ordTable = gtable @TOrdTable @TColumns @(Rep (Record a)) table

68− ggtable

69− @(GAlgebra (Rep (Record a)))

70− @TOrdTable

71− @TColumns

72− @(Rep (Record a))

73− table

74− nullifier

75 where

57 where

76 table (_ :: proxy x) = ordTable @x

58 table (_ :: proxy x) = ordTable @x

@@ -80,19 +62,8 @@ data TOrdTable :: Type -> Exp Constraint

80type instance Eval (TOrdTable a) = OrdTable a

62type 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−

94instance Sql DBOrd a => OrdTable (Expr a) where

65instance Sql DBOrd a => OrdTable (Expr a) where

95− ordTable = HType Dict

66+ ordTable = HIdentity Dict

98instance (OrdTable a, OrdTable b) => OrdTable (a, b)

69instance (OrdTable a, OrdTable b) => OrdTable (a, b)

@@ -127,7 +98,7 @@ instance

127(toColumns -> as) <: (toColumns -> bs) =

98(toColumns -> as) <: (toColumns -> bs) =

128 foldr @[] go false $ getConst $ htabulateA $ \field ->

99 foldr @[] go false $ getConst $ htabulateA $ \field ->

129 case (hfield as field, hfield bs field) of

100 case (hfield as field, hfield bs field) of

130− (E a, E b) -> case hfield (ordTable @a) field of

101+ (a, b) -> case hfield (ordTable @a) field of

131 Dict -> Const [(a <. b, a ==. b)]

102 Dict -> Const [(a <. b, a ==. b)]

132 where

103 where

133 go (lt, eq) a = lt ||. (eq &&. a)

104 go (lt, eq) a = lt ||. (eq &&. a)

@@ -140,7 +111,7 @@ infix 4 <:

140(toColumns -> as) <=: (toColumns -> bs) =

111(toColumns -> as) <=: (toColumns -> bs) =

141 foldr @[] go true $ getConst $ htabulateA $ \field ->

112 foldr @[] go true $ getConst $ htabulateA $ \field ->

142 case (hfield as field, hfield bs field) of

113 case (hfield as field, hfield bs field) of

143− (E a, E b) -> case hfield (ordTable @a) field of

114+ (a, b) -> case hfield (ordTable @a) field of

144 Dict -> Const [(a <. b, a ==. b)]

115 Dict -> Const [(a <. b, a ==. b)]

145 where

116 where

146 go (lt, eq) a = lt ||. (eq &&. a)

117 go (lt, eq) a = lt ||. (eq &&. a)

@@ -153,7 +124,7 @@ infix 4 <=:

153(toColumns -> as) >: (toColumns -> bs) =

124(toColumns -> as) >: (toColumns -> bs) =

154 foldr @[] go false $ getConst $ htabulateA $ \field ->

125 foldr @[] go false $ getConst $ htabulateA $ \field ->

155 case (hfield as field, hfield bs field) of

126 case (hfield as field, hfield bs field) of

156− (E a, E b) -> case hfield (ordTable @a) field of

127+ (a, b) -> case hfield (ordTable @a) field of

157 Dict -> Const [(a >. b, a ==. b)]

128 Dict -> Const [(a >. b, a ==. b)]

158 where

129 where

159 go (gt, eq) a = gt ||. (eq &&. a)

130 go (gt, eq) a = gt ||. (eq &&. a)

@@ -166,7 +137,7 @@ infix 4 >:

166(toColumns -> as) >=: (toColumns -> bs) =

137(toColumns -> as) >=: (toColumns -> bs) =

167 foldr @[] go true $ getConst $ htabulateA $ \field ->

138 foldr @[] go true $ getConst $ htabulateA $ \field ->

168 case (hfield as field, hfield bs field) of

139 case (hfield as field, hfield bs field) of

169− (E a, E b) -> case hfield (ordTable @a) field of

140+ (a, b) -> case hfield (ordTable @a) field of

170 Dict -> Const [(a >. b, a ==. b)]

141 Dict -> Const [(a >. b, a ==. b)]

171 where

142 where

172 go (gt, eq) a = gt ||. (eq &&. a)

143 go (gt, eq) a = gt ||. (eq &&. a)

@@ -175,9 +146,9 @@ infix 4 >=:

175

146

176-- | Given two 'Table's, return the table that sorts before the other.

147-- | Given two 'Table's, return the table that sorts before the other.

177least :: OrdTable a => a -> a -> a

148least :: OrdTable a => a -> a -> a

178−least a b = bool a b (a <: b)

149+least a b = bool b a (a <: b)

179

150

180

151

181-- | Given two 'Table's, return the table that sorts after the other.

152-- | Given two 'Table's, return the table that sorts after the other.

182greatest :: OrdTable a => a -> a -> a

153greatest :: OrdTable a => a -> a -> a

183−greatest a b = bool a b (a >: b)

154+greatest a b = bool b a (a >: b)

src/Rel8/Table/Order.hs+13−16

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

1{-# language DataKinds #-}

2+{-# language NamedFieldPuns #-}

2{-# language ScopedTypeVariables #-}

3{-# language ScopedTypeVariables #-}

3{-# language TypeApplications #-}

4{-# language TypeApplications #-}

4{-# language TypeFamilies #-}

5{-# language TypeFamilies #-}

@@ -15,16 +16,14 @@ import Data.Functor.Contravariant ( (>$<), contramap )

15import Prelude

16import Prelude

17-- rel8

18-- rel8

18−import Rel8.Expr ( unE )

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 ( SSpec( SSpec ) )

24+import Rel8.Schema.Spec ( Spec( Spec, nullity ) )

25−import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullity )

26import Rel8.Table ( Columns, toColumns )

25import Rel8.Table ( Columns, toColumns )

27−import Rel8.Table.Ord

26+import Rel8.Table.Ord ( OrdTable, ordTable )

30-- | Construct an 'Order' for a 'Table' by sorting all columns into ascending

29-- | Construct an 'Order' for a 'Table' by sorting all columns into ascending

@@ -32,12 +31,11 @@ import Rel8.Table.Ord

32ascTable :: forall a. OrdTable a => Order a

31ascTable :: forall a. OrdTable a => Order a

33ascTable = contramap toColumns $ getConst $

32ascTable = contramap toColumns $ getConst $

34 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

33 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

35− SSpec {} -> case hfield (ordTable @a) field of

34+ Spec {nullity} -> case hfield (ordTable @a) field of

36− dict@Dict -> case dbTypeDict dict of

37− Dict -> Const $ unE . (`hfield` field) >$<

35+ Dict -> Const $ (`hfield` field) >$<

38− case dbTypeNullity dict of

36+ case nullity of

39− Null -> nullsFirst asc

37+ Null -> nullsFirst asc

40− NotNull -> asc

38+ NotNull -> asc

43-- | Construct an 'Order' for a 'Table' by sorting all columns into descending

41-- | Construct an 'Order' for a 'Table' by sorting all columns into descending

@@ -45,9 +43,8 @@ ascTable = contramap toColumns $ getConst $

45descTable :: forall a. OrdTable a => Order a

43descTable :: forall a. OrdTable a => Order a

46descTable = contramap toColumns $ getConst $

44descTable = contramap toColumns $ getConst $

47 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

45 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

48− SSpec {} -> case hfield (ordTable @a) field of

46+ Spec {nullity} -> case hfield (ordTable @a) field of

49− dict@Dict -> case dbTypeDict dict of

50− Dict -> Const $ unE . (`hfield` field) >$<

47+ Dict -> Const $ (`hfield` field) >$<

51− case dbTypeNullity dict of

48+ case nullity of

52− Null -> nullsLast desc

49+ Null -> nullsLast desc

53− NotNull -> desc

50+ NotNull -> desc

src/Rel8/Table/Projection.hsnew file+73

@@ -0,0 +1,73 @@

1+{-# language FlexibleContexts #-}

2+{-# language FlexibleInstances #-}

3+{-# language MonoLocalBinds #-}

4+{-# language MultiParamTypeClasses #-}

5+{-# language StandaloneKindSignatures #-}

6+{-# language UndecidableInstances #-}

8+module Rel8.Table.Projection

9+ ( Projection

10+ , Projectable( project )

11+ , Biprojectable( biproject )

12+ , Projecting

13+ , apply

14+ )

15+where

16+

17+-- base

18+import Data.Kind ( Constraint, Type )

19+import Prelude

20+

21+-- rel8

22+import Rel8.Schema.Field ( Field( Field ), fields )

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

24+import Rel8.Table ( Columns, Context, Transpose, toColumns )

25+import Rel8.Table.Transpose ( Transposes )

26+

27+

28+-- | The constraint @'Projecting' a b@ ensures that @'Projection' a b@ is a

29+-- usable 'Projection'.

30+type Projecting :: Type -> Type -> Constraint

31+class

32+ ( Transposes (Context a) (Field a) a (Transpose (Field a) a)

33+ , Transposes (Context a) (Field a) b (Transpose (Field a) b)

34+ )

35+ => Projecting a b

36+instance

37+ ( Transposes (Context a) (Field a) a (Transpose (Field a) a)

38+ , Transposes (Context a) (Field a) b (Transpose (Field a) b)

39+ )

40+ => Projecting a b

41+

42+

43+-- | A @'Projection' a b@s is a special type of function @a -> b@ whereby the

44+-- resulting @b@ is guaranteed to be composed only from columns contained in

45+-- @a@.

46+type Projection :: Type -> Type -> Type

47+type Projection a b = Transpose (Field a) a -> Transpose (Field a) b

48+

49+

50+-- | @'Projectable' f@ means that @f@ is a kind of functor on 'Rel8.Table's

51+-- that allows the mapping of a 'Projection' over its underlying columns.

52+type Projectable :: (Type -> Type) -> Constraint

53+class Projectable f where

54+ -- | Map a 'Projection' over @f@.

55+ project :: Projecting a b

56+ => Projection a b -> f a -> f b

57+

58+

59+-- | @'Biprojectable' p@ means that @p@ is a kind of bifunctor on

60+-- 'Rel8.Table's that allows the mapping of a pair of 'Projection's over its

61+-- underlying columns.

62+type Biprojectable :: (Type -> Type -> Type) -> Constraint

63+class Biprojectable p where

64+ -- | Map a pair of 'Projection's over @p@.

65+ biproject :: (Projecting a b, Projecting c d)

66+ => Projection a b -> Projection c d -> p a c -> p b d

67+

68+

69+apply :: Projecting a b

70+ => Projection a b -> Columns a context -> Columns b context

71+apply f a = case toColumns (f fields) of

72+ bs -> htabulate $ \field -> case hfield bs field of

73+ Field field' -> hfield a field'

src/Rel8/Table/Recontextualize.hsdeleted−87

@@ -1,87 +0,0 @@

1−{-# language DataKinds #-}

2−{-# language FlexibleInstances #-}

3−{-# language FunctionalDependencies #-}

4−{-# language StandaloneKindSignatures #-}

5−{-# language TypeFamilies #-}

6−{-# language UndecidableInstances #-}

7−{-# language UndecidableSuperClasses #-}

8−

9−module Rel8.Table.Recontextualize

10− ( Recontextualize

11− )

12−where

13−

14−-- base

15−import Data.Functor.Identity ( Identity )

16−import Data.Kind ( Constraint, Type )

17−import Prelude ()

18−

19−-- rel8

20−import Rel8.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+29−85

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

1{-# language DataKinds #-}

2{-# language FlexibleInstances #-}

3−{-# language FunctionalDependencies #-}

3+{-# language MultiParamTypeClasses #-}

4{-# language ScopedTypeVariables #-}

5{-# language StandaloneKindSignatures #-}

6{-# language TypeApplications #-}

@@ -15,134 +15,78 @@ module Rel8.Table.Rel8able

15where

17-- base

18−import Data.Kind ( Constraint, Type )

19−import Data.Type.Equality ( (:~:)( Refl ) )

20−import Prelude

18+import Prelude ()

22-- rel8

20-- rel8

23import Rel8.Expr ( Expr )

21import Rel8.Expr ( Expr )

24import qualified Rel8.Kind.Algebra as K

22import qualified Rel8.Kind.Algebra as K

25−import Rel8.Kind.Context

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

26− ( SContext( SReify )

27− , Reifiable, contextSing

28− , sLabelable, sReifiable

29− )

30import Rel8.Generic.Rel8able

24import Rel8.Generic.Rel8able

31 ( Rel8able, Algebra

25 ( Rel8able, Algebra

32 , GColumns, gfromColumns, gtoColumns

26 , GColumns, gfromColumns, gtoColumns

33− , greify, gunreify

27+ , GFromExprs, gfromResult, gtoResult

34 )

28 )

35−import Rel8.Schema.Context ( Col )

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

37−import Rel8.Schema.Dict ( Dict( Dict ) )

38import qualified Rel8.Schema.Kind as K

29import qualified Rel8.Schema.Kind as K

39import Rel8.Schema.HTable ( HConstrainTable, hdicts )

30import Rel8.Schema.HTable ( HConstrainTable, hdicts )

40−import Rel8.Schema.Reify ( hreify, hunreify, UnwrapReify )

31+import Rel8.Schema.Null ( Sql )

41import Rel8.Schema.Result ( Result )

32import Rel8.Schema.Result ( Result )

42import Rel8.Table

33import Rel8.Table

43− ( Table, Columns, Context, Congruent, fromColumns, toColumns

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

44− , Unreify, reify, unreify

35+ , FromExprs, fromResult, toResult

36+ , Transpose

45 )

37 )

46−import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )

38+import Rel8.Table.ADT ( ADT )

47−import Rel8.Table.ADT ( ADT( ADT ), ADTable, fromADT, toADT )

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

39import Rel8.Table.Eq ( EqTable, eqTable )

49−import Rel8.Table.HKD ( HKD )

50import Rel8.Table.Ord ( OrdTable, ordTable )

40import Rel8.Table.Ord ( OrdTable, ordTable )

51−import Rel8.Table.Recontextualize ( Recontextualize )

41+import Rel8.Table.Serialize ( ToExprs )

52−import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )

53import Rel8.Type.Eq ( DBEq )

42import Rel8.Type.Eq ( DBEq )

54import Rel8.Type.Ord ( DBOrd )

43import Rel8.Type.Ord ( DBOrd )

57−instance (Rel8able t, Labelable context, Reifiable context) =>

46+instance (Rel8able t, Reifiable context, context ~ context') =>

58− Table context (t context)

47+ Table context' (t context)

59 where

48 where

60 type Columns (t context) = GColumns t

49 type Columns (t context) = GColumns t

61 type Context (t context) = context

50 type Context (t context) = context

62− type Unreify (t context) = t (UnwrapReify context)

51+ type FromExprs (t context) = GFromExprs t

63−

52+ type Transpose to (t context) = t to

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−

78−instance

54+ fromColumns = gfromColumns contextSing

79− ( Rel8able t

55+ toColumns = gtoColumns contextSing

80− , Labelable from, Reifiable from

56+ fromResult = gfromResult @t

81− , Labelable to, Reifiable to

57+ toResult = gtoResult @t

82− , Congruent (t from) (t to)

83− )

84− => Recontextualize from to (t from) (t to)

87instance

60instance

88 ( context ~ Expr

61 ( context ~ Expr

89 , Rel8able t

62 , Rel8able t

90− , HConstrainTable (Columns (t context)) (ConstrainDBType DBEq)

63+ , HConstrainTable (Columns (t context)) (Sql DBEq)

91 )

64 )

92 => EqTable (t context)

65 => EqTable (t context)

93 where

66 where

94− eqTable = hdicts @(Columns (t context)) @(ConstrainDBType DBEq)

67+ eqTable = hdicts @(Columns (t context)) @(Sql DBEq)

97instance

70instance

98 ( context ~ Expr

71 ( context ~ Expr

99 , Rel8able t

72 , Rel8able t

100− , HConstrainTable (Columns (t context)) (ConstrainDBType DBEq)

73+ , HConstrainTable (Columns (t context)) (Sql DBEq)

101− , HConstrainTable (Columns (t context)) (ConstrainDBType DBOrd)

74+ , HConstrainTable (Columns (t context)) (Sql DBOrd)

102 )

75 )

103 => OrdTable (t context)

76 => OrdTable (t context)

104 where

77 where

105− ordTable = hdicts @(Columns (t context)) @(ConstrainDBType DBOrd)

78+ ordTable = hdicts @(Columns (t context)) @(Sql DBOrd)

106−

107−

108−type instance FromExprs (t Expr) = FromExprs' t

109

110

111instance

81instance

82+ ( Rel8able t', t' ~ Choose (Algebra t) t

112− ( x ~ t' Expr

83+ , x ~ t' Expr

113 , result ~ Result

84 , result ~ Result

114− , ToExprs' (Algebra t) t' t

115 )

85 )

116 => ToExprs x (t result)

86 => ToExprs x (t result)

117− where

118− fromResult = fromResult' @(Algebra t) @t'

119− toResult = toResult' @(Algebra t) @t'

120

121

122−type FromExprs' :: K.Rel8able -> Type

89+type Choose :: K.Algebra -> K.Rel8able -> K.Rel8able

123−type family FromExprs' t where

90+type family Choose algebra t where

124− FromExprs' (ADT t) = t Result

91+ Choose 'K.Sum t = ADT t

125− FromExprs' (HKD a) = a

92+ Choose 'K.Product t = t

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+24−119

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

1{-# language AllowAmbiguousTypes #-}

2−{-# language DataKinds #-}

3−{-# language DefaultSignatures #-}

4−{-# language DisambiguateRecordFields #-}

5{-# language FlexibleContexts #-}

2{-# language FlexibleContexts #-}

6{-# language FlexibleInstances #-}

3{-# language FlexibleInstances #-}

7{-# language FunctionalDependencies #-}

4{-# language FunctionalDependencies #-}

@@ -10,111 +7,54 @@

10{-# language StandaloneKindSignatures #-}

7{-# language StandaloneKindSignatures #-}

11{-# language TypeApplications #-}

8{-# language TypeApplications #-}

12{-# language TypeFamilies #-}

9{-# language TypeFamilies #-}

13−{-# language TypeOperators #-}

14{-# language UndecidableInstances #-}

10{-# language UndecidableInstances #-}

16module Rel8.Table.Serialize

12module Rel8.Table.Serialize

17− ( Serializable, lit, parse

13+ ( Serializable, lit, litHTable, parse

18− , ToExprs(..), FromExprs

14+ , ToExprs

19− , TToExprs

20 )

15 )

21where

16where

23-- base

18-- base

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

24import Data.Kind ( Constraint, Type )

20import Data.Kind ( Constraint, Type )

25import Data.List.NonEmpty ( NonEmpty )

21import Data.List.NonEmpty ( NonEmpty )

26−import GHC.Generics ( Generic, Rep, from, to )

27import Prelude

22import Prelude

29-- hasql

24-- hasql

30import qualified Hasql.Decoders as Hasql

25import qualified Hasql.Decoders as Hasql

32-- rel8

27-- rel8

33−import Rel8.Expr ( Expr, Col( E ) )

28+import Rel8.Expr ( Expr )

34import Rel8.Expr.Serialize ( slitExpr, sparseValue )

29import 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 )

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

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

43−import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )

44import Rel8.Schema.Null ( NotNull, Sql )

31import Rel8.Schema.Null ( NotNull, Sql )

45−import Rel8.Schema.Result ( Col( R ), Result )

32+import Rel8.Schema.Result ( Result )

46−import Rel8.Schema.Spec ( SSpec(..), KnownSpec )

33+import Rel8.Schema.Spec ( Spec(..) )

47−import Rel8.Table ( Table, Columns, fromColumns, toColumns, TColumns )

34+import Rel8.Table ( Table, fromColumns, FromExprs, fromResult, toResult )

48import Rel8.Type ( DBType )

35import Rel8.Type ( DBType )

50-- semigroupoids

37-- semigroupoids

51import Data.Functor.Apply ( WrappedApplicative(..) )

38import 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.

54type ToExprs :: Type -> Type -> Constraint

44type ToExprs :: Type -> Type -> Constraint

55−class Table Expr exprs => ToExprs exprs a where

45+class Table Expr exprs => ToExprs exprs a

56− fromResult :: Columns exprs (Col Result) -> a

46+

57− toResult :: a -> Columns exprs (Col Result)

47+

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−

98−instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a where

48+instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a

99− fromResult (HType (R a)) = a

49+

100− toResult = HType . R

50+

101−

102−

103−instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a] where

51+instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a]

104− fromResult (HType (R a)) = a

105− toResult = HType . R

106

107

108instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a)

54instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a)

109− where

110− fromResult (HType (R a)) = a

111− toResult = HType . R

112

113

114instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a)

57instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a)

115− where

116− fromResult (HType (R a)) = a

117− toResult = HType . R

118

119

120instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>

60instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>

@@ -176,41 +116,6 @@ instance

176 => ToExprs x (a, b, c, d, e, f, g)

116 => ToExprs x (a, b, c, d, e, f, g)

177

117

178

118

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−

214-- | @Serializable@ witnesses the one-to-one correspondence between the type

119-- | @Serializable@ witnesses the one-to-one correspondence between the type

215-- @sql@, which contains SQL expressions, and the type @haskell@, which

120-- @sql@, which contains SQL expressions, and the type @haskell@, which

216-- contains the Haskell decoding of rows containing @sql@ SQL expressions.

121-- contains the Haskell decoding of rows containing @sql@ SQL expressions.

@@ -223,21 +128,21 @@ instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a

223-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is

128-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is

224-- capable of lifting single @Expr@s to full tables.

129-- capable of lifting single @Expr@s to full tables.

225lit :: forall exprs a. Serializable exprs a => a -> exprs

130lit :: forall exprs a. Serializable exprs a => a -> exprs

226−lit = fromColumns . litHTable . toResult @exprs

131+lit = fromColumns . litHTable . toResult @_ @exprs

227

132

228

133

229parse :: forall exprs a. Serializable exprs a => Hasql.Row a

134parse :: forall exprs a. Serializable exprs a => Hasql.Row a

230−parse = fromResult @exprs <$> parseHTable

135+parse = fromResult @_ @exprs <$> parseHTable

231

136

232

137

233−litHTable :: HTable t => t (Col Result) -> t (Col Expr)

138+litHTable :: HTable t => t Result -> t Expr

234litHTable as = htabulate $ \field ->

139litHTable as = htabulate $ \field ->

235 case hfield hspecs field of

140 case hfield hspecs field of

236− SSpec {nullity, info} -> case hfield as field of

141+ Spec {nullity, info} -> case hfield as field of

237− R value -> E (slitExpr nullity info value)

142+ Identity value -> slitExpr nullity info value

238

143

239

144

240−parseHTable :: HTable t => Hasql.Row (t (Col Result))

145+parseHTable :: HTable t => Hasql.Row (t Result)

241parseHTable = unwrapApplicative $ htabulateA $ \field ->

146parseHTable = unwrapApplicative $ htabulateA $ \field ->

242 WrapApplicative $ case hfield hspecs field of

147 WrapApplicative $ case hfield hspecs field of

243− SSpec {nullity, info} -> R <$> sparseValue nullity info

148+ Spec {nullity, info} -> Identity <$> sparseValue nullity info

src/Rel8/Table/Tag.hsdeleted−97

@@ -1,97 +0,0 @@

1−{-# language DataKinds #-}

2−{-# language FlexibleInstances #-}

3−{-# language GADTs #-}

4−{-# language InstanceSigs #-}

5−{-# language NamedFieldPuns #-}

6−{-# language ScopedTypeVariables #-}

7−{-# language StandaloneKindSignatures #-}

8−{-# language TypeApplications #-}

9−{-# language UndecidableInstances #-}

10−

11−module Rel8.Table.Tag

12− ( Tag(..), Taggable

13− , fromAggregate

14− , fromExpr

15− , fromName

16− )

17−where

18−

19−-- base

20−import Control.Applicative ( (<|>), empty )

21−import Data.Kind ( Constraint, Type )

22−import Data.Foldable ( fold )

23−import Data.Monoid ( getFirst )

24−import Data.Proxy ( Proxy( Proxy ) )

25−import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )

26−import Prelude

27−

28−-- rel8

29−import Rel8.Aggregate ( Aggregate, Aggregator, foldInputs )

30−import Rel8.Expr ( Expr )

31−import Rel8.Expr.Opaleye ( fromPrimExpr )

32−import Rel8.Schema.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 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+205−150

@@ -5,7 +5,6 @@

5{-# language FlexibleInstances #-}

6{-# language MultiParamTypeClasses #-}

7{-# language NamedFieldPuns #-}

8−{-# language RecordWildCards #-}

9{-# language ScopedTypeVariables #-}

8{-# language ScopedTypeVariables #-}

10{-# language StandaloneKindSignatures #-}

9{-# language StandaloneKindSignatures #-}

11{-# language TupleSections #-}

10{-# language TupleSections #-}

@@ -21,52 +20,49 @@ module Rel8.Table.These

21 , isThisTable, isThatTable, isThoseTable

20 , isThisTable, isThatTable, isThoseTable

22 , hasHereTable, hasThereTable

21 , hasHereTable, hasThereTable

23 , justHereTable, justThereTable

22 , justHereTable, justThereTable

23+ , alignMaybeTable

24+ , aggregateTheseTable

24 , nameTheseTable

25 , nameTheseTable

25 )

26 )

26where

27where

28-- base

29-- base

29−import Control.Applicative ( liftA2 )

30import Data.Bifunctor ( Bifunctor, bimap )

31−import Data.Functor.Identity ( runIdentity )

32import Data.Kind ( Type )

31import Data.Kind ( Type )

32+import Data.Maybe ( isJust )

33−import Prelude hiding ( undefined )

33+import Prelude hiding ( null, undefined )

35-- rel8

36+import Rel8.Aggregate ( Aggregate )

36import Rel8.Expr ( Expr )

37import Rel8.Expr ( Expr )

37−import Rel8.Expr.Bool ( (&&.), not_ )

38+import Rel8.Expr.Bool ( (&&.), (||.), boolExpr, not_ )

38−import Rel8.Expr.Null ( isNonNull )

39+import Rel8.Expr.Null ( null, isNonNull )

39−import Rel8.Schema.Context.Label

40+import Rel8.Kind.Context ( Reifiable )

40− ( Labelable

41− , HLabelable, hlabeler, hunlabeler

42− )

43−import Rel8.Schema.Context.Nullify

41+import Rel8.Schema.Context.Nullify ( Nullifiable )

44− ( Nullifiable, ConstrainTag

45− , HNullifiable, HConstrainTag

46− , hencodeTag, hdecodeTag

47− , hnullifier, hunnullifier

48− )

49−import Rel8.Schema.HTable ( HTable )

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

50−import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

43+import Rel8.Schema.HTable.Label ( hlabel, hrelabel, hunlabel )

51import Rel8.Schema.HTable.Identity ( HIdentity(..) )

44import Rel8.Schema.HTable.Identity ( HIdentity(..) )

52−import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )

45+import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )

53import Rel8.Schema.HTable.These ( HTheseTable(..) )

46import Rel8.Schema.HTable.These ( HTheseTable(..) )

47+import qualified Rel8.Schema.Kind as K

54import Rel8.Schema.Name ( Name )

48import Rel8.Schema.Name ( Name )

55import Rel8.Table

49import Rel8.Table

56 ( Table, Columns, Context, fromColumns, toColumns

50 ( Table, Columns, Context, fromColumns, toColumns

57− , reify, unreify

51+ , FromExprs, fromResult, toResult

52+ , Transpose

58 )

53 )

59import Rel8.Table.Eq ( EqTable, eqTable )

54import Rel8.Table.Eq ( EqTable, eqTable )

60import Rel8.Table.Maybe

55import Rel8.Table.Maybe

61 ( MaybeTable(..)

56 ( MaybeTable(..)

62 , maybeTable, justTable, nothingTable

57 , maybeTable, justTable, nothingTable

63 , isJustTable

58 , isJustTable

59+ , aggregateMaybeTable

64 , nameMaybeTable

60 , nameMaybeTable

65 )

61 )

62+import Rel8.Table.Nullify ( Nullify, guard )

66import Rel8.Table.Ord ( OrdTable, ordTable )

63import Rel8.Table.Ord ( OrdTable, ordTable )

67−import Rel8.Table.Recontextualize ( Recontextualize )

64+import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )

68−import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )

65+import Rel8.Table.Serialize ( ToExprs )

69−import Rel8.Table.Tag ( Tag(..) )

70import Rel8.Table.Undefined ( undefined )

66import Rel8.Table.Undefined ( undefined )

71import Rel8.Type.Tag ( MaybeTag )

67import Rel8.Type.Tag ( MaybeTag )

@@ -75,35 +71,56 @@ import Data.Functor.Apply ( Apply, (<.>) )

75import Data.Functor.Bind ( Bind, (>>-) )

71import Data.Functor.Bind ( Bind, (>>-) )

77-- these

73-- these

78−import Data.These ( These )

74+import Data.These ( These( This, That, These ) )

79−

75+import Data.These.Combinators ( justHere, justThere )

80−

76+

77+

78+-- | @TheseTable a b@ is a Rel8 table that contains either the table @a@, the

79+-- table @b@, or both tables @a@ and @b@. You can construct @TheseTable@s using

80+-- 'thisTable', 'thatTable' and 'thoseTable'. @TheseTable@s can be

81+-- eliminated/pattern matched using 'theseTable'.

82+--

83+-- @TheseTable@ is operationally the same as Haskell's 'These' type, but

84+-- adapted to work with Rel8.

81−type TheseTable :: Type -> Type -> Type

85+type TheseTable :: K.Context -> Type -> Type -> Type

82−data TheseTable a b = TheseTable

86+data TheseTable context a b = TheseTable

83− { here :: MaybeTable a

87+ { here :: MaybeTable context a

84− , there :: MaybeTable b

88+ , there :: MaybeTable context b

85 }

89 }

86 deriving stock Functor

90 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+

89−instance Bifunctor TheseTable where

97+instance Nullifiable context => Bifunctor (TheseTable context) where

90 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)

98 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)

100

101+instance Projectable (TheseTable context a) where

102+ project f (TheseTable a b) = TheseTable a (project f b)

103+

104+

93−instance (Table Expr a, Semigroup a) => Apply (TheseTable a) where

105+instance (context ~ Expr, Table Expr a, Semigroup a) =>

106+ Apply (TheseTable context a)

107+ where

94 fs <.> as = TheseTable

108 fs <.> as = TheseTable

95 { here = here fs <> here as

109 { here = here fs <> here as

96 , there = there fs <.> there as

110 , there = there fs <.> there as

97 }

111 }

112

113

100−instance (Table Expr a, Semigroup a) => Applicative (TheseTable a)

114+instance (context ~ Expr, Table Expr a, Semigroup a) =>

115+ Applicative (TheseTable context a)

101 where

116 where

102 pure = thatTable

117 pure = thatTable

103 (<*>) = (<.>)

118 (<*>) = (<.>)

104

119

105

120

106−instance (Table Expr a, Semigroup a) => Bind (TheseTable a) where

121+instance (context ~ Expr, Table Expr a, Semigroup a) =>

122+ Bind (TheseTable context a)

123+ where

107 TheseTable here1 ma >>- f = case ma >>- f' of

124 TheseTable here1 ma >>- f = case ma >>- f' of

108 mtb -> TheseTable

125 mtb -> TheseTable

109 { here = maybeTable here1 ((here1 <>) . fst) mtb

126 { here = maybeTable here1 ((here1 <>) . fst) mtb

@@ -114,12 +131,14 @@ instance (Table Expr a, Semigroup a) => Bind (TheseTable a) where

114 TheseTable here2 mb -> (here2,) <$> mb

131 TheseTable here2 mb -> (here2,) <$> mb

115

132

116

133

117−instance (Table Expr a, Semigroup a) => Monad (TheseTable a) where

134+instance (context ~ Expr, Table Expr a, Semigroup a) =>

135+ Monad (TheseTable context a)

136+ where

118 (>>=) = (>>-)

137 (>>=) = (>>-)

119

138

120

139

121−instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>

140+instance (context ~ Expr, Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>

122− Semigroup (TheseTable a b)

141+ Semigroup (TheseTable context a b)

123 where

142 where

124 a <> b = TheseTable

143 a <> b = TheseTable

125 { here = here a <> here b

144 { here = here a <> here b

@@ -129,99 +148,175 @@ instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>

129

148

130instance

149instance

131 ( Table context a, Table context b

150 ( Table context a, Table context b

132− , Labelable context, Nullifiable context, ConstrainTag context MaybeTag

151+ , Reifiable context, context ~ context'

152+ )

133− ) => Table context (TheseTable a b)

153+ => Table context' (TheseTable context a b)

134 where

154 where

135− type Columns (TheseTable a b) = HTheseTable (Columns a) (Columns b)

155+ type Columns (TheseTable context a b) = HTheseTable (Columns a) (Columns b)

136− type Context (TheseTable a b) = Context a

156+ type Context (TheseTable context a b) = Context a

137−

157+ type FromExprs (TheseTable context a b) =

138− toColumns = toColumns2 toColumns toColumns

139− fromColumns = fromColumns2 fromColumns fromColumns

140− reify = liftA2 bimap reify reify

141− unreify = liftA2 bimap unreify unreify

142−

143−

144−instance

145− ( Labelable from, Nullifiable from, ConstrainTag from MaybeTag

146− , Labelable to, Nullifiable to, ConstrainTag to MaybeTag

147− , Recontextualize from to a1 b1

148− , Recontextualize from to a2 b2

149− ) =>

150− Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2)

151−

152−

153−instance (EqTable a, EqTable b) => EqTable (TheseTable a b) where

154− eqTable = toColumns2 id id (thoseTable (eqTable @a) (eqTable @b))

155−

156−

157−instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where

158− ordTable = toColumns2 id id (thoseTable (ordTable @a) (ordTable @b))

159−

160−

161−type instance FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs 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+ }

162

170

171+ fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable

172+ { here = MaybeTable

173+ { tag = unHIdentity $ hunlabel hhereTag

174+ , just = fromColumns $ hunlabel hhere

175+ }

176+ , there = MaybeTable

177+ { tag = unHIdentity $ hunlabel hthereTag

178+ , just = fromColumns $ hunlabel hthere

179+ }

180+ }

163

181

164−instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable exprs1 exprs2) =>

182+ toResult tables = HTheseTable

165− ToExprs x (These a b)

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)

166 where

219 where

167− fromResult =

220+ eqTable = HTheseTable

168− bimap (fromResult @exprs1) (fromResult @exprs2) .

221+ { hhereTag = hlabel (HIdentity Dict)

169− fromColumns

222+ , hhere = hlabel (eqTable @(Nullify context a))

170− toResult =

223+ , hthereTag = hlabel (HIdentity Dict)

171− toColumns .

224+ , hthere = hlabel (eqTable @(Nullify context b))

172− bimap (toResult @exprs1) (toResult @exprs2)

225+ }

173

226

174

227

175−toHereTag :: Tag "isJust" a -> Tag "hasHere" a

228+instance (OrdTable a, OrdTable b, context ~ Expr) =>

176−toHereTag Tag {..} = Tag {..}

229+ OrdTable (TheseTable context a b)

230+ where

231+ ordTable = HTheseTable

232+ { hhereTag = hlabel (HIdentity Dict)

233+ , hhere = hlabel (ordTable @(Nullify context a))

234+ , hthereTag = hlabel (HIdentity Dict)

235+ , hthere = hlabel (ordTable @(Nullify context b))

236+ }

177

237

178

238

179−toThereTag :: Tag "isJust" a -> Tag "hasThere" a

239+instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable Expr exprs1 exprs2) =>

180−toThereTag Tag {..} = Tag {..}

240+ ToExprs x (These a b)

181

241

182

242

243+-- | Test if a 'TheseTable' was constructed with 'thisTable'.

244+--

245+-- Corresponds to 'Data.These.Combinators.isThis'.

183−isThisTable :: TheseTable a b -> Expr Bool

246+isThisTable :: TheseTable Expr a b -> Expr Bool

184isThisTable a = hasHereTable a &&. not_ (hasThereTable a)

247isThisTable a = hasHereTable a &&. not_ (hasThereTable a)

185

248

186

249

250+-- | Test if a 'TheseTable' was constructed with 'thatTable'.

251+--

252+-- Corresponds to 'Data.These.Combinators.isThat'.

187−isThatTable :: TheseTable a b -> Expr Bool

253+isThatTable :: TheseTable Expr a b -> Expr Bool

188isThatTable a = not_ (hasHereTable a) &&. hasThereTable a

254isThatTable a = not_ (hasHereTable a) &&. hasThereTable a

189

255

190

256

257+-- | Test if a 'TheseTable' was constructed with 'thoseTable'.

258+--

259+-- Corresponds to 'Data.These.Combinators.isThese'.

191−isThoseTable :: TheseTable a b -> Expr Bool

260+isThoseTable :: TheseTable Expr a b -> Expr Bool

192isThoseTable a = hasHereTable a &&. hasThereTable a

261isThoseTable a = hasHereTable a &&. hasThereTable a

193

262

194

263

264+-- | Test if the @a@ side of @TheseTable a b@ is present.

265+--

266+-- Corresponds to 'Data.These.Combinators.hasHere'.

195−hasHereTable :: TheseTable a b -> Expr Bool

267+hasHereTable :: TheseTable Expr a b -> Expr Bool

196hasHereTable TheseTable {here} = isJustTable here

268hasHereTable TheseTable {here} = isJustTable here

197

269

198

270

271+-- | Test if the @b@ table of @TheseTable a b@ is present.

272+--

273+-- Corresponds to 'Data.These.Combinators.hasThere'.

199−hasThereTable :: TheseTable a b -> Expr Bool

274+hasThereTable :: TheseTable Expr a b -> Expr Bool

200hasThereTable TheseTable {there} = isJustTable there

275hasThereTable TheseTable {there} = isJustTable there

201

276

202

277

278+-- | Attempt to project out the @a@ table of a @TheseTable a b@.

279+--

280+-- Corresponds to 'Data.These.Combinators.justHere'.

203−justHereTable :: TheseTable a b -> MaybeTable a

281+justHereTable :: TheseTable context a b -> MaybeTable context a

204justHereTable = here

282justHereTable = here

205

283

206

284

285+-- | Attempt to project out the @b@ table of a @TheseTable a b@.

286+--

287+-- Corresponds to 'Data.These.Combinators.justThere'.

207−justThereTable :: TheseTable a b -> MaybeTable b

288+justThereTable :: TheseTable context a b -> MaybeTable context b

208justThereTable = there

289justThereTable = there

209

290

210

291

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'.

211−thisTable :: Table Expr b => a -> TheseTable a b

303+thisTable :: Table Expr b => a -> TheseTable Expr a b

212thisTable a = TheseTable (justTable a) nothingTable

304thisTable a = TheseTable (justTable a) nothingTable

213

305

214

306

307+-- | Construct a @TheseTable@. Corresponds to 'That'.

215−thatTable :: Table Expr a => b -> TheseTable a b

308+thatTable :: Table Expr a => b -> TheseTable Expr a b

216thatTable b = TheseTable nothingTable (justTable b)

309thatTable b = TheseTable nothingTable (justTable b)

217

310

218

311

312+-- | Construct a @TheseTable@. Corresponds to 'These'.

219−thoseTable :: a -> b -> TheseTable a b

313+thoseTable :: a -> b -> TheseTable Expr a b

220thoseTable a b = TheseTable (justTable a) (justTable b)

314thoseTable a b = TheseTable (justTable a) (justTable b)

221

315

222

316

317+-- | Pattern match on a 'TheseTable'. Corresponds to 'these'.

223theseTable :: Table Expr c

318theseTable :: Table Expr c

224− => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable a b -> c

319+ => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable Expr a b -> c

225theseTable f g h TheseTable {here, there} =

320theseTable f g h TheseTable {here, there} =

226 maybeTable

321 maybeTable

227 (maybeTable undefined f here)

322 (maybeTable undefined f here)

@@ -229,74 +324,34 @@ theseTable f g h TheseTable {here, there} =

229 there

324 there

230

325

231

326

327+-- | Lift a pair of aggregating functions to operate on an 'TheseTable'.

328+-- @thisTable@s, @thatTable@s and @thoseTable@s are grouped separately.

329+aggregateTheseTable :: ()

330+ => (exprs -> aggregates)

331+ -> (exprs' -> aggregates')

332+ -> TheseTable Expr exprs exprs'

333+ -> TheseTable Aggregate aggregates aggregates'

334+aggregateTheseTable f g (TheseTable here there) = TheseTable

335+ { here = aggregateMaybeTable f here

336+ , there = aggregateMaybeTable g there

337+ }

338+

339+

340+-- | Construct a 'TheseTable' in the 'Name' context. This can be useful if you

341+-- have a 'TheseTable' that you are storing in a table and need to construct a

342+-- 'TableSchema'.

232nameTheseTable :: ()

343nameTheseTable :: ()

233 => Name (Maybe MaybeTag)

344 => Name (Maybe MaybeTag)

345+ -- ^ The name of the column to track the presence of the @a@ table.

234 -> Name (Maybe MaybeTag)

346 -> Name (Maybe MaybeTag)

347+ -- ^ The name of the column to track the presence of the @b@ table.

235 -> a

348 -> a

349+ -- ^ Names of the columns in the @a@ table.

236 -> b

350 -> b

351+ -- ^ Names of the columns in the @b@ table.

237− -> TheseTable a b

352+ -> TheseTable Name a b

238nameTheseTable here there a b =

353nameTheseTable here there a b =

239 TheseTable

354 TheseTable

240 { here = nameMaybeTable here a

355 { here = nameMaybeTable here a

241 , there = nameMaybeTable there b

356 , there = nameMaybeTable there b

242 }

357 }

243−

244−

245−toColumns2 ::

246− ( HTable t

247− , HTable u

248− , HConstrainTag context MaybeTag

249− , HLabelable context

250− , HNullifiable context

251− )

252− => (a -> t context)

253− -> (b -> u context)

254− -> TheseTable a b

255− -> HTheseTable t u context

256−toColumns2 f g TheseTable {here, there} = HTheseTable

257− { hhereTag = HIdentity $ hencodeTag (toHereTag (tag here))

258− , hhere =

259− hlabel hlabeler $ hnullify (hnullifier (tag here) isNonNull) $ f (just here)

260− , hthereTag = HIdentity $ hencodeTag (toThereTag (tag there))

261− , hthere =

262− hlabel hlabeler $ hnullify (hnullifier (tag there) isNonNull) $ g (just there)

263− }

264−

265−

266−fromColumns2 ::

267− ( HTable t

268− , HTable u

269− , HConstrainTag context MaybeTag

270− , HLabelable context

271− , HNullifiable context

272− )

273− => (t context -> a)

274− -> (u context -> b)

275− -> HTheseTable t u context

276− -> TheseTable a b

277−fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable

278− { here =

279− let

280− tag = hdecodeTag $ unHIdentity hhereTag

281− in

282− MaybeTable

283− { tag

284− , just = f $

285− runIdentity $

286− hunnullify (\a -> pure . hunnullifier a) $

287− hunlabel hunlabeler

288− hhere

289− }

290− , there =

291− let

292− tag = hdecodeTag $ unHIdentity hthereTag

293− in

294− MaybeTable

295− { tag

296− , just = g $

297− runIdentity $

298− hunnullify (\a -> pure . hunnullifier a) $

299− hunlabel hunlabeler

300− hthere

301− }

302− }

src/Rel8/Table/Transpose.hsnew file+46

@@ -0,0 +1,46 @@

1+{-# language DataKinds #-}

2+{-# language FlexibleInstances #-}

3+{-# language FunctionalDependencies #-}

4+{-# language StandaloneKindSignatures #-}

5+{-# language TypeFamilies #-}

6+{-# language UndecidableInstances #-}

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, Col( E ) )

14+import Rel8.Expr ( Expr )

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 ( SSpec(..) )

18+import Rel8.Schema.Spec ( Spec(..) )

19import Rel8.Table ( Table, fromColumns )

22undefined :: Table Expr a => a

23undefined = fromColumns $ htabulate $ \field -> case hfield hspecs field of

24− SSpec {nullity, info} -> case nullity of

24+ Spec {nullity, info} -> case nullity of

25− Null -> E (snull info)

25+ Null -> snull info

26− NotNull -> E (unsafeUnnullify (snull info))

26+ NotNull -> unsafeUnnullify (snull info)

src/Rel8/Table/Unreify.hsdeleted−102

@@ -1,102 +0,0 @@

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

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 qualified Rel8.Schema.Kind as K

45−import Rel8.Schema.Name ( Name )

46−import Rel8.Schema.Reify ( Reify )

47−import Rel8.Schema.Result ( Result )

48−import Rel8.Table ( Table, Context, Congruent, Unreify )

49−

50−

51−type Unreifies :: K.Context -> Type -> Constraint

52−type family Unreifies context a where

53− Unreifies (Reify context) a = Unreifier context a

54− Unreifies _ _ = ()

55−

56−

57−type Unreifiable :: Type -> Constraint

58−class

59− ( Context a ~ Reify Aggregate => Unreifier Aggregate a

60− , Context a ~ Reify Expr => Unreifier Expr a

61− , Context a ~ Reify Name => Unreifier Name a

62− , (forall ctx. (Context a ~ Reify (Reify ctx), Reifiable ctx) => Unreifier (Reify ctx) a)

63− )

64− => Unreifiable a

65−instance

66− ( Context a ~ Reify Aggregate => Unreifier Aggregate a

67− , Context a ~ Reify Expr => Unreifier Expr a

68− , Context a ~ Reify Name => Unreifier Name a

69− , (forall ctx. (Context a ~ Reify (Reify ctx), Reifiable ctx) => Unreifier (Reify ctx) a)

70− )

71− => Unreifiable a

72−

73−

74−type Unreifier :: K.Context -> Type -> Constraint

75−class

76− ( Table context (Unreify a)

77− , Congruent a (Unreify a)

78− )

79− => Unreifier context a

80−instance

81− ( Table context (Unreify a)

82− , Congruent a (Unreify a)

83− )

84− => Unreifier context a

85−

86−

87−type Unreifiability :: K.Context -> Type -> Type

88−data Unreifiability context a where

89− UResult :: Unreifiability Result a

90− Unreifiability :: Unreifier context a

91− => SContext context -> Unreifiability context a

92−

93−

94−unreifiability :: (Context a ~ Reify context, Unreifiable a)

95− => SContext context -> Unreifiability context a

96−unreifiability = \case

97− SAggregate -> Unreifiability SAggregate

98− SExpr -> Unreifiability SExpr

99− SName -> Unreifiability SName

100− SResult -> UResult

101− SReify context -> case sReifiable context of

102− Dict -> Unreifiability (SReify context)

src/Rel8/Table/Window.hsnew file+43

@@ -0,0 +1,43 @@

1+{-# language MonoLocalBinds #-}

3+module Rel8.Table.Window

4+ ( cumulative

5+ , cumulative_

6+ , currentRow

7+ )

8+where

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+496−260

@@ -1,61 +1,99 @@

1−{-# language DeriveFunctor #-}

2−{-# language DerivingStrategies #-}

3{-# language FlexibleContexts #-}

1{-# language FlexibleContexts #-}

4{-# language MonoLocalBinds #-}

2{-# language MonoLocalBinds #-}

5{-# language ScopedTypeVariables #-}

3{-# language ScopedTypeVariables #-}

4+{-# language StandaloneKindSignatures #-}

6{-# language TypeApplications #-}

5{-# language TypeApplications #-}

7{-# language TupleSections #-}

6{-# language TupleSections #-}

8{-# language UndecidableInstances #-}

7{-# language UndecidableInstances #-}

9+-- | "Rel8.Tabulate" provides an alternative API ('Tabulation') for writing

10+-- queries that complements the main "Rel8" API ('Query').

11+

10module Rel8.Tabulate

12module Rel8.Tabulate

13+ (

11− ( Tabulation

14+ Tabulation

12− , tabulate

15+

13− , tabulateA

16+ -- * Interfacing with 'Query's

14− , runTabulation

15 , fromQuery

17 , fromQuery

18+ , toQuery

16 , liftQuery

19 , liftQuery

17− , prebind

20+ , through

18− , postbind

19− , indexed

20− , ifilter

21 , lookup

22+

23+ -- * Aggregation and Ordering

24+ , aggregate

25+ , distinct

26+ , order

27+

28+ -- ** Magic 'Tabulation's

29+ -- $magic

30+ , count

31+ , optional

32+ , many

33+ , some

34+ , exists

35+ , present

36+ , absent

37+

38+ -- * Natural joins

22 , align

39 , align

23 , alignWith

40 , alignWith

24 , leftAlign

41 , leftAlign

25 , leftAlignWith

42 , leftAlignWith

43+ , rightAlign

44+ , rightAlignWith

26 , zip

45 , zip

27 , zipWith

46 , zipWith

28 , similarity

47 , similarity

29 , difference

48 , difference

30− , aggregateTabulation

31− , orderTabulation

32− , distinctTabulation

33− , optionalTabulation

34− , manyTabulation

35− , someTabulation

36 )

49 )

37where

50where

39-- base

52-- base

40−import Control.Applicative ( liftA2 )

53+import Control.Applicative ( (<|>), empty, liftA2 )

41−import Control.Monad ( join, liftM2 )

54+import Control.Monad ( liftM2 )

42−import Data.Bifunctor ( bimap, first )

55+import Data.Bifunctor ( Bifunctor, bimap, first, second )

43import Data.Foldable ( traverse_ )

56import Data.Foldable ( traverse_ )

57+import Data.Function ( on )

44−import Data.Functor.Contravariant ( (>$<) )

58+import Data.Functor.Contravariant ( Contravariant, (>$<), contramap )

59+import Data.Int ( Int64 )

60+import Data.Kind ( Type )

45−import Data.Maybe ( fromMaybe )

61+import Data.Maybe ( fromJust, fromMaybe )

46−import Prelude hiding ( filter, lookup, zip, zipWith )

62+import Prelude hiding ( lookup, zip, zipWith )

63+

64+-- bifunctors

65+import Data.Bifunctor.Clown ( Clown( Clown ), runClown )

66+

67+-- comonad

68+import Control.Comonad ( extract )

69+

70+-- opaleye

71+import qualified Opaleye.Aggregate as Opaleye

72+import qualified Opaleye.Order as Opaleye ( orderBy, distinctOnExplicit )

73+

74+-- profunctors

75+import Data.Profunctor ( dimap, lmap )

76+

77+-- product-profunctors

78+import Data.Profunctor.Product

79+ ( ProductProfunctor, (***!)

80+ , SumProfunctor, (+++!)

81+ )

82+import qualified Data.Profunctor.Product as PP

48-- rel8

84-- rel8

49import Rel8.Aggregate ( Aggregates )

85import Rel8.Aggregate ( Aggregates )

50import Rel8.Expr ( Expr )

86import Rel8.Expr ( Expr )

87+import Rel8.Expr.Aggregate ( countStar )

88+import Rel8.Expr.Bool ( true )

51−import Rel8.Order ( Order )

89+import Rel8.Order ( Order( Order ) )

52import Rel8.Query ( Query )

90import Rel8.Query ( Query )

53−import Rel8.Query.Aggregate ( aggregate )

91+import qualified Rel8.Query.Exists as Q ( exists, present, absent )

54−import Rel8.Query.Distinct ( distinctOn )

55−import Rel8.Query.Exists ( withBy, withoutBy )

56−import Rel8.Query.Filter ( filter, where_ )

92+import Rel8.Query.Filter ( where_ )

57−import Rel8.Query.Maybe ( optional )

93+import Rel8.Query.List ( catNonEmptyTable )

94+import qualified Rel8.Query.Maybe as Q ( optional )

58−import Rel8.Query.Order ( orderBy )

95+import Rel8.Query.Opaleye ( mapOpaleye, unsafePeekQuery )

96+import Rel8.Query.Rebind ( rebind )

59import Rel8.Query.These ( alignBy )

97import Rel8.Query.These ( alignBy )

60import Rel8.Table ( Table, fromColumns, toColumns )

98import Rel8.Table ( Table, fromColumns, toColumns )

61import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )

99import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )

@@ -63,71 +101,154 @@ import Rel8.Table.Alternative

63 ( AltTable, (<|>:)

101 ( AltTable, (<|>:)

64 , AlternativeTable, emptyTable

102 , AlternativeTable, emptyTable

65 )

103 )

104+import Rel8.Table.Cols ( fromCols, toCols )

66import Rel8.Table.Eq ( EqTable, (==:), eqTable )

105import Rel8.Table.Eq ( EqTable, (==:), eqTable )

67import Rel8.Table.List ( ListTable( ListTable ) )

106import Rel8.Table.List ( ListTable( ListTable ) )

68−import Rel8.Table.Maybe ( MaybeTable, maybeTable )

107+import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), maybeTable )

69import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )

108import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )

109+import Rel8.Table.Opaleye ( aggregator, unpackspec )

70import Rel8.Table.Ord ( OrdTable )

110import Rel8.Table.Ord ( OrdTable )

71import Rel8.Table.Order ( ascTable )

111import Rel8.Table.Order ( ascTable )

112+import Rel8.Table.Projection

113+ ( Biprojectable, biproject

114+ , Projectable, project

115+ , apply

116+ )

72−import Rel8.Table.These ( TheseTable, theseTable )

117+import Rel8.Table.These ( TheseTable( TheseTable ), theseTable )

118

74-- semigroupoids

119-- semigroupoids

75import Data.Functor.Apply ( Apply, liftF2 )

120import Data.Functor.Apply ( Apply, liftF2 )

76−import Data.Functor.Bind ( Bind )

121+import Data.Functor.Bind ( Bind, (>>-) )

77−import qualified Data.Functor.Bind

122+

123+

124+type Key :: Type -> Type

125+type Key = Maybe

126+

127+

128+cat :: Table Expr k => Key k -> Query k

129+cat = maybe emptyTable pure

130+

131+

132+key :: (ProductProfunctor p, SumProfunctor p)

133+ => p a b -> p (Key a) (Key b)

134+key a = dimap from to (PP.empty +++! a)

135+ where

136+ from = maybe (Left ()) Right

137+ to = either (const Nothing) Just

138+

139+

140+keyed :: (ProductProfunctor p, SumProfunctor p)

141+ => p k l -> p a b -> p (Key k, a) (Key l, b)

142+keyed k a = key k ***! a

143+

144

145+type Predicate :: Type -> Type

146+newtype Predicate a = Predicate (Maybe (a -> Expr Bool))

147

148+

149+instance Contravariant Predicate where

150+ contramap f (Predicate a) = Predicate (lmap f <$> a)

151+

152+

153+instance Semigroup (Predicate k) where

154+ Predicate ma <> Predicate mb = Predicate $ ma <|> mb

155+

156+

157+instance Monoid (Predicate k) where

158+ mempty = Predicate Nothing

159+

160+

161+match :: EqTable k => Key k -> Predicate k

162+match = Predicate . fmap (==:)

163+

164+

165+ensure :: Predicate k -> Key k -> Query ()

166+ensure (Predicate mp) = traverse_ (\k -> traverse_ (\p -> where_ (p k)) mp)

167+

168+

80−-- | @'Tabulation' k a@ is denotionally a @MultiMap k a@ — a @Map@ where each

169+-- | A @'Tabulation' k a@ is like a @'Query' a@, except that each row also

81−-- key @k@ corresponds to potentially multiple @a@ (i.e., @'Query' a@). This

170+-- has a key @k@ in addition to the value @a@. 'Tabulation's can be composed

82−-- @MultiMap@ supports 'lookup' and other operations you would expect it to.

171+-- monadically just like 'Query's, but the resulting join is more like a

172+-- @NATURAL JOIN@ (based on the common key column(s) @k@) than the

173+-- @CROSS JOIN@ given by 'Query'.

174+--

175+-- Another way to think of @'Tabulation' k a@ is as analogous to @Map k a@ in

176+-- the same way @'Query' a@ is analogous to @[a]@. However, there's nothing

177+-- stopping a 'Tabulation' from containing multiple rows with the same key, so

178+-- technically @Map k (NonEmpty a)@ is more accurate.

83--

179--

84−-- \"Identity\" 'Tabulation's are created using 'tabulate'. 'Tabulation's can

180+-- 'Tabulation's can be created from 'Query's with 'fromQuery' and 'liftQuery'

85−-- be composed with 'Query's with 'prebind' or 'postbind' to form new

181+-- and converted back to 'Query's with 'lookup' and 'toQuery' (though note the

182+-- caveats that come with the latter).

86−-- 'Tabulation's.

183+type Tabulation :: Type -> Type -> Type

87−newtype Tabulation k a = Tabulation (k -> Query (Maybe k, a))

184+newtype Tabulation k a = Tabulation (Predicate k -> Query (Key k, a))

88− deriving stock Functor

185+

186+

187+instance Biprojectable Tabulation where

188+ biproject f g =

189+ bimap

190+ (fromColumns . apply f . toColumns)

191+ (fromColumns . apply g . toColumns)

192+

193

194+instance Bifunctor Tabulation where

195+ bimap f g (Tabulation a) = Tabulation $ \p ->

196+ bimap (fmap f) g <$> a (f >$< p)

197

198+

199+instance Functor (Tabulation k) where

200+ fmap = second

201+

202+

203+instance Projectable (Tabulation k) where

204+ project f = fmap (fromColumns . apply f . toColumns)

205+

206+

207+-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<.>)@ is

208+-- @intersectionWith (liftA2 (<*>))@

91instance EqTable k => Apply (Tabulation k) where

209instance EqTable k => Apply (Tabulation k) where

92 liftF2 = liftA2

210 liftF2 = liftA2

211

212

213+-- | @pure = 'liftQuery' . pure@

95instance EqTable k => Applicative (Tabulation k) where

214instance EqTable k => Applicative (Tabulation k) where

96 pure = liftQuery . pure

215 pure = liftQuery . pure

97 liftA2 = liftM2

216 liftA2 = liftM2

217

218

100instance EqTable k => Bind (Tabulation k) where

219instance EqTable k => Bind (Tabulation k) where

101− join = join

220+ Tabulation as >>- f = Tabulation $ \p -> do

221+ (k, a) <- as p

222+ case f a of

223+ Tabulation bs -> do

224+ let p' = match k

225+ (k', b) <- bs (p' <> p)

226+ ensure p' k'

227+ pure (k' <|> k, b)

102

228

103

229

104instance EqTable k => Monad (Tabulation k) where

230instance EqTable k => Monad (Tabulation k) where

105− Tabulation as >>= f = Tabulation $ \i -> do

231+ (>>=) = (>>-)

106− (mk, a) <- as i

107− case mk of

108− Nothing -> case f a of

109− Tabulation bs -> bs i

110− Just k -> case f a of

111− Tabulation bs -> do

112− (mk', b) <- bs k

113− case mk' of

114− Nothing -> pure (mk, b)

115− Just k' -> do

116− where_ $ k ==: k'

117− pure (mk', b)

118

232

119

233

234+-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<|>:)@ is

235+-- @unionWith (<>)@.

120instance EqTable k => AltTable (Tabulation k) where

236instance EqTable k => AltTable (Tabulation k) where

121− kas <|>: kbs = do

237+ tas <|>: tbs = do

122− as <- toQuery kas

238+ eas <- peek tas

123− bs <- toQuery kbs

239+ ebs <- peek tbs

240+ case (eas, ebs) of

241+ (Left as, Left bs) -> liftQuery $ as <|>: bs

124− fromQuery $ as <|>: bs

242+ (Right as, Right bs) -> fromQuery $ as <|>: bs

243+ _ -> catNonEmptyTable `through` ((<>) `on` some) tas tbs

125

244

126

245

127instance EqTable k => AlternativeTable (Tabulation k) where

246instance EqTable k => AlternativeTable (Tabulation k) where

128− emptyTable = fromQuery emptyTable

247+ emptyTable = Tabulation $ const $ fmap (empty,) emptyTable

129

248

130

249

250+-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<>)@ is

251+-- @unionWith (liftA2 (<>))@.

131instance (EqTable k, Table Expr a, Semigroup a) => Semigroup (Tabulation k a)

252instance (EqTable k, Table Expr a, Semigroup a) => Semigroup (Tabulation k a)

132 where

253 where

133 (<>) = alignWith (theseTable id id (<>))

254 (<>) = alignWith (theseTable id id (<>))

@@ -138,267 +259,382 @@ instance (EqTable k, Table Expr a, Semigroup a) => Monoid (Tabulation k a)

138 mempty = emptyTable

259 mempty = emptyTable

139

260

140

261

262+-- | Any 'Query' of key-value pairs @(k, a)@ can be a @'Tabulation' k a@.

263+fromQuery :: Query (k, a) -> Tabulation k a

264+fromQuery = Tabulation . const . fmap (first pure)

265+

266+

267+-- | Convert a @'Tabulation' k a@ back into a 'Query' of key-value pairs.

268+--

269+-- Note that the result of a 'toQuery' is undefined (will always return zero

270+-- rows) on 'Tabulation's constructed with 'liftQuery' or 'pure'. So while

271+-- @toQuery . fromQuery@ is always @id@, @fromQuery . toQuery@ is not.

272+--

273+-- A safer, more predictable alternative to 'toQuery' is to use 'lookup' with

274+-- an explicit set of keys:

275+--

276+-- @

277+-- do

278+-- k <- keys

279+-- a <- lookup k tabulation

280+-- pure (k, a)

281+-- @

282+--

283+-- Having said that, in practice, most legitimate uses of 'Tabulation' will

284+-- have a well-defined 'toQuery'. It would be possible in theory to encode

285+-- the necessary invariants at the type level using an indexed monad, but we

286+-- would lose the ability to use @do@-notation, which is the main benefit

287+-- of having 'Tabulation' as a monad in the first place.

288+--

289+-- In particular, @'toQuery' t@ is well-defined for any 'Tabulation' @t@

290+-- defined as @t = fromQuery _@. @'toQuery' t@ is also well-defined for any

291+-- 'Tabulation' @t@ defined as @t = t' >>= _@ or @t = t' *> _@ where

292+-- @'toQuery' t'@ is well-defined. There are other valid permutations too.

293+-- Generally, anything that uses 'fromQuery' at some point, unless wrapped in

294+-- a top-level 'present' or 'absent', will have a well-defined 'toQuery'.

141−runTabulation :: EqTable k => Query k -> Tabulation k a -> Query (k, a)

295+toQuery :: Table Expr k => Tabulation k a -> Query (k, a)

142−runTabulation ks tabulation = do

296+toQuery (Tabulation f) = do

143− k <- ks

297+ (mk, a) <- f mempty

144− a <- lookup k tabulation

298+ k <- cat mk

145 pure (k, a)

299 pure (k, a)

146

300

147

301

302+-- | A @'Query' a@ can be treated as a @'Tabulation' k a@ where the given @a@

303+-- values exist at every possible key @k@.

148liftQuery :: Query a -> Tabulation k a

304liftQuery :: Query a -> Tabulation k a

149−liftQuery query = Tabulation $ const $ fmap (Nothing,) query

305+liftQuery = Tabulation . const . fmap (empty,)

150

306

151

307

152−-- | 'tabulate' creates an \"identity\" @'Tabulation' k a@ that allows @a@ be

308+-- | Run a Kleisli arrow in the the 'Query' monad \"through\" a 'Tabulation'.

153−-- indexed by one or more of its columns @k@. Some examples:

309+-- Useful for 'Rel8.filter'ing a 'Tabulation'.

154--

310--

155−-- [Tabulation by primary key]:

311+-- @

156−-- @

312+-- 'Rel8.filter' ((>=. 30) . userAge) `'through'` usersById

157−-- projectsById :: Project 'Expr' -> 'Tabulation' ('Expr' ProjectId) (Project 'Expr')

313+-- @

158−-- projectsById = 'tabulate' projectId

314+through :: (a -> Query b) -> Tabulation k a -> Tabulation k b

159−-- @

315+through f (Tabulation as) = Tabulation $ \p -> do

316+ (k, a) <- as p

317+ b <- f a

318+ pure (k, b)

319+infixr 1 `through`

320+

321+

322+-- | @'lookup' k t@ returns the value(s) at the key @k@ in the tabulation @t@.

323+lookup :: EqTable k => k -> Tabulation k a -> Query a

324+lookup k (Tabulation f) = do

325+ (k', a) <- f p

326+ ensure p k'

327+ pure a

328+ where

329+ p = match (pure k)

330+

331+

332+-- | 'aggregate' aggregates the values within each key of a

333+-- 'Tabulation'. There is an implicit @GROUP BY@ on all the key columns.

334+aggregate :: forall k aggregates exprs.

335+ ( EqTable k

336+ , Aggregates aggregates exprs

337+ )

338+ => Tabulation k aggregates -> Tabulation k exprs

339+aggregate (Tabulation f) = Tabulation $

340+ mapOpaleye (Opaleye.aggregate (keyed haggregator aggregator)) .

341+ fmap (first (fmap (hgroupBy (eqTable @k) . toColumns))) .

342+ f

343+ where

344+ haggregator = dimap fromColumns fromCols aggregator

345+

346+

347+-- | 'distinct' ensures a 'Tabulation' has at most one value for

348+-- each key, i.e., it drops duplicates. In general it keeps only the

349+-- \"first\" value it encounters for each key, but note that \"first\" is

350+-- undefined unless you first call 'order'.

351+distinct :: EqTable k => Tabulation k a -> Tabulation k a

352+distinct (Tabulation f) = Tabulation $

353+ mapOpaleye (Opaleye.distinctOnExplicit (key unpackspec) fst) . f

354+

355+

356+-- | 'order' orders the /values/ of a 'Tabulation' within their

357+-- respective keys. This specifies a defined order for 'distinct'.

358+-- It also defines the order of the lists produced by 'many' and

359+-- 'some'.

360+order :: OrdTable k => Order a -> Tabulation k a -> Tabulation k a

361+order ordering (Tabulation f) =

362+ Tabulation $ mapOpaleye (Opaleye.orderBy ordering') . f

363+ where

364+ Order ordering' = runClown (keyed (Clown ascTable) (Clown ordering))

365+

366+

367+-- $magic

160--

368--

161−-- Note: the nature of primary keys means that each key will be mapped to a

369+-- Some of the following combinators produce \"magic\" 'Tabulation's. Let's

162−-- singleton value in this case.

370+-- use 'count' as an example to demonstrate this concept. Consider

371+-- the following:

163--

372--

164−-- [Tabulation by other unique key]:

373+-- @

374+-- count $ fromQuery $ values

375+-- [ (lit 'a', lit True)

376+-- , (lit 'a', lit False)

377+-- , (lit 'b', lit True)

378+-- ]

165−-- @

379+-- @

166−-- projectsByName :: Project 'Expr' -> 'Tabulation' ('Expr' Text) (Project 'Expr')

167−-- projectsByName = 'tabulate' projectName

168−-- @

169--

380--

170−-- [Tabulation by foreign key (tabulate a child table by parent key)]:

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+-- ]

171−-- @

388+-- @

172−-- revisionsByProjectId :: Revision 'Expr' -> 'Tabulation' ('Expr' ProjectId) (Revision 'Expr')

389+--

173−-- revisionsByProjectId = 'tabulate' revisionProjectId

390+-- However, it isn't quite. While the resulting 'Tabulation' does effectively

174−-- @

391+-- contain the above entries, it also behaves as though it contained the value

175−tabulate :: (a -> k) -> a -> Tabulation k a

392+-- @0@ at every other possible key.

176−tabulate key a = fromQuery $ pure (key a, a)

393+--

177−

178−

179−-- | Like 'tabulate' but takes a monadic 'Query' function instead of a pure

180−-- one. This means you can filter rows while calculating the key, which is

394+-- This means you can do:

181−-- useful in conjunction with 'Rel8.Extra.catNulls'.

395+--

182−tabulateA :: (a -> Query k) -> a -> Tabulation k a

396+-- @

183−tabulateA key a = fromQuery $ (,a) <$> key a

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).

184

403

185

404

186−-- | Analgous to 'Data.Map.Strict.fromList'.

405+-- | 'count' returns a count of how many entries are in the given

187−fromQuery :: Query (k, a) -> Tabulation k a

406+-- 'Tabulation' at each key.

188−fromQuery = Tabulation . const . fmap (first Just)

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)

189

416

190

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'.

191−indexed :: Tabulation k a -> Tabulation k (k, a)

423+optional :: Tabulation k a -> Tabulation k (MaybeTable Expr a)

192−indexed (Tabulation query) = Tabulation $ \i ->

424+optional (Tabulation f) = Tabulation $ \p -> case p of

193− (\(mk, a) -> (mk, (fromMaybe i mk, a))) <$> query i

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)

194

447

195

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)

196−ifilter :: (k -> a -> Expr Bool) -> Tabulation k a -> Tabulation k a

454+ => Tabulation k a -> Tabulation k (NonEmptyTable Expr a)

197−ifilter f tabulation = snd <$> do

455+some =

198− filter (uncurry f) `postbind` indexed tabulation

456+ fmap (\(NonEmptyTable a) -> NonEmptyTable a) .

457+ aggregate .

458+ fmap (nonEmptyAgg . toCols)

199

459

200

460

201−-- | Map a 'Query' over the input side of a 'Tabulation'.

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.

202−prebind :: (a -> Tabulation k b) -> Query a -> Tabulation k b

464+exists :: Tabulation k a -> Tabulation k (Expr Bool)

203−prebind f as = Tabulation $ \k -> do

465+exists (Tabulation f) = Tabulation $ \p -> case p of

204− a <- as

466+ Predicate Nothing -> (true <$) <$> f p

205− case f a of

467+ _ -> fmap (empty,) $ Q.exists $ do

206− Tabulation query -> query k

468+ (k, _) <- f p

207−infixr 1 `prebind`

469+ ensure p k

208

470

209

471

210−-- | Map a 'Query' over the output side of a 'Tabulation'.

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'.

211−postbind :: (a -> Query b) -> Tabulation k a -> Tabulation k b

476+present :: Tabulation k a -> Tabulation k ()

212−postbind f (Tabulation as) = Tabulation $ \i -> do

477+present (Tabulation f) = Tabulation $ \p -> do

213− (k, a) <- as i

478+ Q.present $ do

214− case f a of

479+ (k, _) <- f p

215− bs -> do

480+ ensure p k

216− b <- bs

217− pure (k, b)

481+ pure (empty, ())

218−infixr 1 `postbind`

219

482

220

483

221−-- | Note that because 'Tabulation' is a @MultiMap@, the 'Query' returned by

484+-- | 'absent' produces a 'Tabulation' where a single @()@ row exists

222−-- 'lookup' can and often does contain multiple results.

485+-- at every possible key that absent from the given 'Tabulation'.

223−lookup :: EqTable k => k -> Tabulation k a -> Query a

486+--

487+-- This is used to implement 'difference'.

488+absent :: Tabulation k a -> Tabulation k ()

224−lookup key (Tabulation query) = do

489+absent (Tabulation f) = Tabulation $ \p -> do

225− (mk, a) <- query key

490+ Q.absent $ do

226− traverse_ (where_ . (key ==:)) mk

491+ (k, _) <- f p

492+ ensure p k

227− pure a

493+ pure (empty, ())

228

494

229

495

230−-- | Analagous to

496+-- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns.

231−-- [@align@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:align).

232--

497--

233−-- If 'zip' makes an @INNER JOIN@, then 'align' makes a @FULL OUTER JOIN@.

498+-- Analogous to 'Data.Semialign.align'.

234−align :: (EqTable k, Table Expr a, Table Expr b)

499+align :: EqTable k

235− => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable a b)

500+ => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable Expr a b)

236align = alignWith id

501align = alignWith id

237

502

238

503

239−-- | Analagous to

504+-- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns.

240−-- [@alignWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:alignWith).

241--

505--

242−-- See 'zipWith' and 'align'.

506+-- Analogous to 'Data.Semialign.alignWith'.

243−alignWith :: (EqTable k, Table Expr a, Table Expr b)

507+alignWith :: EqTable k

244− => (TheseTable a b -> c)

508+ => (TheseTable Expr a b -> c)

245 -> Tabulation k a -> Tabulation k b -> Tabulation k c

509 -> Tabulation k a -> Tabulation k b -> Tabulation k c

246−alignWith f kas kbs = do

510+alignWith f (Tabulation as) (Tabulation bs) = Tabulation $ \p -> do

247− as <- toQuery kas

248− bs <- toQuery kbs

249− fromQuery $ do

250− tkab <- alignBy (\(l, _) (m, _) -> l ==: m) as bs

511+ tkab <- liftF2 (alignBy condition) as bs p

251− let

512+ k <- traverse (rebind "key") $ recover $ bimap fst fst tkab

252− k' = theseTable fst fst (const fst) tkab

513+ let

253− tab = bimap snd snd tkab

514+ tab = bimap snd snd tkab

254− pure (k', f tab)

515+ pure (k, f tab)

255−

516+ where

256−

517+ condition (k, _) (k', _) = fromMaybe true (liftA2 (==:) k k')

257−-- | If 'zip' makes an @INNER JOIN@, then 'leftAlign' makes a @LEFT JOIN@.

518+ recover (TheseTable mma@(MaybeTable _ ma) mmb@(MaybeTable _ mb)) =

258−-- This means it will return at least one row for every row in the left

519+ case extract ma of

259−-- 'Tabulation', even if there is no corresponding row in the right (hence the

520+ Nothing -> extract mb

260−-- 'Rel8.MaybeTable').

521+ Just a -> case extract mb of

261−--

522+ Nothing -> extract ma

262−-- Analagous to

523+ Just b -> case a <$ mma <|>: b <$ mmb of

263−-- [@rpadZip@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:rpadZip).

524+ MaybeTable _ c -> pure (extract c)

525+

526+

527+-- | Performs a @NATURAL LEFT OUTER JOIN@ based on the common key columns.

528+--

529+-- Analogous to 'Data.Semialign.rpadZip'.

530+--

531+-- Note that you can achieve the same effect with 'optional' and the

532+-- 'Applicative' instance for 'Tabulation', i.e., this is just

533+-- @\left right -> liftA2 (,) left (optional right). You can also

534+-- use @do@-notation.

264leftAlign :: EqTable k

535leftAlign :: EqTable k

265− => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable b)

536+ => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable Expr b)

266leftAlign = leftAlignWith (,)

537leftAlign = leftAlignWith (,)

267

538

268

539

269−-- | See 'zipWith' and 'leftAlign'.

540+-- | Performs a @NATURAL LEFT OUTER JOIN@ based on the common key columns.

270--

541--

271−-- Analagous to

272−-- [@rpadZipWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:rpadZipWith).

542+-- Analogous to 'Data.Semialign.rpadZipWith'.

543+--

544+-- Note that you can achieve the same effect with 'optional' and the

545+-- 'Applicative' instance for 'Tabulation', i.e., this is just

546+-- @\f left right -> liftA2 f left (optional right). You can also

547+-- use @do@-notation.

273leftAlignWith :: EqTable k

548leftAlignWith :: EqTable k

274− => (a -> MaybeTable b -> c)

549+ => (a -> MaybeTable Expr b -> c)

275 -> Tabulation k a -> Tabulation k b -> Tabulation k c

550 -> Tabulation k a -> Tabulation k b -> Tabulation k c

276−leftAlignWith f left right = liftA2 f left (optionalTabulation right)

551+leftAlignWith f left right = liftA2 f left (optional right)

277

552

278

553

279−-- | Analagous to

554+-- | Performs a @NATURAL RIGHT OUTER JOIN@ based on the common key columns.

280−-- [@zip@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:zip).

281--

555--

282−-- There are multiple correct ways of understanding what this does.

556+-- Analogous to 'Data.Semialign.lpadZip'.

283--

557--

284−-- You can think of it as @'Data.Map.Strict.intersectionWith'

558+-- Note that you can achieve the same effect with 'optional' and the

285−-- ('Control.Applicative.liftA2' (,))@. That is, @intersect@ the two

559+-- 'Applicative' instance for 'Tabulation', i.e., this is just

286−-- `Tabulation`s by matching their keys together (with 'Rel8.==:'), and combine

560+-- @\left right -> liftA2 (flip (,)) right (optional left). You can

287−-- their values (remembering that 'Tabulation' is a 'MultiMap' so that the

561+-- also use @do@-notation.

288−-- values are keys) by getting their cartesian product.

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.

289--

568--

290−-- You can think of it as performing a cross product of the underlying 'Query's

569+-- Analogous to 'Data.Semialign.lpadZipWith'.

291−-- of the given 'Tabulation's and filtering the results for 'match'ing keys.

292--

570--

293−-- You can think of it as a natural join in SQL terms.

571+-- Note that you can achieve the same effect with 'optional' and the

572+-- 'Applicative' instance for 'Tabulation', i.e., this is just

573+-- @\f left right -> liftA2 (flip f) right (optional left). You can

574+-- also use @do@-notation.

575+rightAlignWith :: EqTable k

576+ => (MaybeTable Expr a -> b -> c)

577+ -> Tabulation k a -> Tabulation k b -> Tabulation k c

578+rightAlignWith f left right = liftA2 (flip f) right (optional left)

579+

580+

581+-- | Performs a @NATURAL INNER JOIN@ based on the common key columns.

582+--

583+-- Analagous to 'Data.Semialign.zip'.

294--

584--

295−-- The size of the resulting 'Tabulation' will be $\sum_{k} min(n_k, m_k) $

585+-- Note that you can achieve the same effect with the 'Applicative' instance

296−-- in terms of the number of keys, but $\sum_{k} n_k \times m_k$ in terms of

586+-- of 'Tabulation', i.e., this is just @'liftA2 (,)'@. You can also use

297−-- the number of values.

587+-- @do@-notation.

298zip :: EqTable k

588zip :: EqTable k

299 => Tabulation k a -> Tabulation k b -> Tabulation k (a, b)

589 => Tabulation k a -> Tabulation k b -> Tabulation k (a, b)

300zip = zipWith (,)

590zip = zipWith (,)

301

591

302

592

303−-- | Analagous to

593+-- | Performs a @NATURAL INNER JOIN@ based on the common key columns.

304−-- [@zipWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:zipWith).

305--

594--

306−-- See 'zip'.

595+-- Analagous to 'Data.Semialign.zipWith'.

596+--

597+-- Note that you can achieve the same effect with the 'Applicative' instance

598+-- of 'Tabulation', i.e., this is just @'liftA2'@. You can also use

599+-- @do@-notation.

307zipWith :: EqTable k

600zipWith :: EqTable k

308 => (a -> b -> c) -> Tabulation k a -> Tabulation k b -> Tabulation k c

601 => (a -> b -> c) -> Tabulation k a -> Tabulation k b -> Tabulation k c

309zipWith = liftA2

602zipWith = liftA2

310

603

311

604

312−-- | 'similarity' returns all the entries in the left 'Tabulation' that have a

605+-- | Performs a [@NATURAL SEMI JOIN@](https://en.wikipedia.org/wiki/Relational_algebra#Semijoin_%28%E2%8B%89%29%28%E2%8B%8A%29)

313−-- corresponding entry in the right 'Tabulation'. This corresponds to a

606+-- based on the common key columns.

314−-- semijoin in relational algebra.

315--

607--

316−-- This differs from @'zipWith' const x y@ when the right 'Tabulation' @y@

608+-- The result is a subset of the left tabulation where only entries which have

317−-- contains an entry with multiple rows. For 'similarity', the entries in the

609+-- a corresponding entry in the right tabulation are kept.

318−-- resulting 'Tabulation' will contain the same number of rows as their

319−-- respective entries in the left 'Tabulation' @x@. With `zipWith const x y`,

320−-- each entry would contain the /product/ of the number of rows of their

321−-- respective entries in @x@ and @y@.

322--

610--

323−-- See 'Rel8.with'.

611+-- Note that you can achieve a similar effect with 'present' and the

612+-- 'Applicative' instance of 'Tabulation', i.e., this is just

613+-- @\left right -> left <* present right@. You can also use

614+-- @do@-notation.

324similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a

615similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a

325−similarity kas kbs = do

616+similarity a b = a <* present b

326− as <- toQuery kas

327− bs <- toQuery kbs

328− fromQuery $ as >>= withBy (\(k, _) (l, _) -> k ==: l) bs

329

617

330

618

331−-- | 'difference' returns all the entries in the left 'Tabulation' that don't

619+-- | Performs a [@NATURAL ANTI JOIN@](https://en.wikipedia.org/wiki/Relational_algebra#Antijoin_%28%E2%96%B7%29)

332−-- exist in the right 'Tabulation'. This corresponds to an antijoin in

620+-- based on the common key columns.

333−-- relational algebra.

334--

621--

335−-- See 'Rel8.without'.

622+-- The result is a subset of the left tabulation where only entries which do

336−difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a

623+-- not have a corresponding entry in the right tabulation are kept.

337−difference kas kbs = do

338− as <- toQuery kas

339− bs <- toQuery kbs

340− fromQuery $ as >>= withoutBy (\(k, _) (l, _) -> k ==: l) bs

341−

342−

343−aggregateTabulation :: forall k aggregates exprs.

344− ( EqTable k

345− , Aggregates aggregates exprs

346− )

347− => Tabulation k aggregates -> Tabulation k exprs

348−aggregateTabulation = mapQuery $

349− fmap (first fromColumns) .

350− aggregate .

351− fmap (first (hgroupBy (eqTable @k) . toColumns))

352−

353−

354−-- | 'orderTabulation' orders the /values/ of a 'Tabulation' within each key.

355--

624--

356−-- In general this is meaningless, but if used together with 'manyTabulation'

625+-- Note that you can achieve a similar effect with 'absent' and the

357−-- or 'someTabulation', the resulting lists will be ordered according to

626+-- 'Applicative' instance of 'Tabulation', i.e., this is just

358−-- ordering given to 'orderTabulation'.

627+-- @\left right -> left <* absent right@. You can also use

359−orderTabulation :: OrdTable k => Order a -> Tabulation k a -> Tabulation k a

628+-- @do@-notation.

360−orderTabulation ordering = mapQuery $ orderBy ordering'

361− where

362− ordering' = (fst >$< ascTable) <> (snd >$< ordering)

363−

364−

365−-- | Turns the given 'Tabulation' from a \"multimap\" into a \"map\". If there

366−-- is more than one value at a particular key, only the first one is kept.

367−-- \"First\" is in general undefined, but 'orderTabulation' can be used to

368−-- make it deterministic.

369−distinctTabulation :: EqTable k => Tabulation k a -> Tabulation k a

370−distinctTabulation = mapQuery (distinctOn fst)

371−

372−

373−optionalTabulation :: EqTable k

374− => Tabulation k a -> Tabulation k (MaybeTable a)

375−optionalTabulation as = Tabulation $ \k -> do

376− ma <- optional $ lookup k as

377− pure (Just k, ma)

378−

379−

380−manyTabulation :: (EqTable k, Table Expr a)

381− => Tabulation k a -> Tabulation k (ListTable a)

629+difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a

382−manyTabulation =

630+difference a b = a <* absent b

383− fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .

384− optionalTabulation .

385− aggregateTabulation .

386− fmap (listAgg . toColumns)

387−

388−

389−someTabulation :: (EqTable k, Table Expr a)

390− => Tabulation k a -> Tabulation k (NonEmptyTable a)

391−someTabulation =

392− fmap (\(NonEmptyTable a) -> NonEmptyTable a) .

393− aggregateTabulation .

394− fmap (nonEmptyAgg . toColumns)

395−

396−

397−mapQuery :: (Query (k, a) -> Query (k, b)) -> Tabulation k a -> Tabulation k b

398−mapQuery f (Tabulation query) = Tabulation $ \k ->

399− first Just <$> f (first (fromMaybe k) <$> query k)

400

631

401

632

633+-- | 'Tabulation's can be produced with either 'fromQuery' or 'liftQuery', and

634+-- in some cases we might want to treat these differently. 'peek' uses

635+-- 'unsafePeekQuery' to determine which type of 'Tabulation' we have.

402−toQuery :: Tabulation k a -> Tabulation k (Query (k, a))

636+peek :: Tabulation k a -> Tabulation k (Either (Query a) (Query (k, a)))

403−toQuery (Tabulation as) = Tabulation $ \k ->

637+peek (Tabulation f) = Tabulation $ \p ->

404− pure (Nothing, first (fromMaybe k) <$> as k)

638+ pure $ (empty,) $ case unsafePeekQuery (f p) of

639+ (Nothing, _) -> Left $ fmap snd (f p)

640+ (Just _, _) -> Right $ fmap (first fromJust) (f p)

src/Rel8/Type.hs+9−8

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

1+{-# language FlexibleContexts #-}

1{-# language FlexibleInstances #-}

2{-# language FlexibleInstances #-}

2{-# language MonoLocalBinds #-}

3{-# language MonoLocalBinds #-}

3{-# language MultiWayIf #-}

4{-# language MultiWayIf #-}

@@ -127,10 +128,10 @@ instance DBType Int64 where

127instance DBType Float where

128instance DBType Float where

128 typeInformation = TypeInformation

129 typeInformation = TypeInformation

129 { encode = \x -> Opaleye.ConstExpr

130 { encode = \x -> Opaleye.ConstExpr

130− if | x == (1 /0) -> Opaleye.OtherLit "'Infinity'"

131+ if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'"

131− | isNaN x -> Opaleye.OtherLit "'NaN'"

132+ | isNaN x -> Opaleye.OtherLit "'NaN'"

132− | x == (-1/0) -> Opaleye.OtherLit "'-Infinity'"

133+ | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"

133− | otherwise -> Opaleye.NumericLit $ realToFrac x

134+ | otherwise -> Opaleye.NumericLit $ realToFrac x

134 , decode = Hasql.float4

135 , decode = Hasql.float4

135 , typeName = "float4"

136 , typeName = "float4"

136 }

137 }

@@ -140,10 +141,10 @@ instance DBType Float where

140instance DBType Double where

141instance DBType Double where

141 typeInformation = TypeInformation

142 typeInformation = TypeInformation

142 { encode = \x -> Opaleye.ConstExpr

143 { encode = \x -> Opaleye.ConstExpr

143− if | x == (1 /0) -> Opaleye.OtherLit "'Infinity'"

144+ if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'"

144− | isNaN x -> Opaleye.OtherLit "'NaN'"

145+ | isNaN x -> Opaleye.OtherLit "'NaN'"

145− | x == (-1/0) -> Opaleye.OtherLit "'-Infinity'"

146+ | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"

146− | otherwise -> Opaleye.NumericLit $ realToFrac x

147+ | otherwise -> Opaleye.NumericLit $ realToFrac x

147 , decode = Hasql.float8

148 , decode = Hasql.float8

148 , typeName = "float8"

149 , typeName = "float8"

149 }

150 }

src/Rel8/Type/Composite.hs+34−19

@@ -20,6 +20,7 @@ where

21-- base

22import Data.Functor.Const ( Const( Const ), getConst )

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

23import Data.Kind ( Constraint, Type )

24import Data.Kind ( Constraint, Type )

24import Prelude

25import Prelude

@@ -30,19 +31,19 @@ import qualified Hasql.Decoders as Hasql

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

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

32-- rel8

33-- rel8

33−import Rel8.Expr ( Col( E ), Expr )

34+import Rel8.Expr ( Expr )

34import Rel8.Expr.Opaleye ( castExpr, fromPrimExpr, toPrimExpr )

35import Rel8.Expr.Opaleye ( castExpr, fromPrimExpr, toPrimExpr )

35−import Rel8.Schema.HTable ( hfield, hspecs, htabulate, htabulateA )

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

36−import Rel8.Schema.Name ( Col( N ), Name( Name ) )

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

37import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

38import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

38−import Rel8.Schema.Result ( Col( R ), Result )

39+import Rel8.Schema.Result ( Result )

39−import Rel8.Schema.Spec ( SSpec( SSpec, nullity, info ) )

40+import Rel8.Schema.Spec ( Spec( Spec, nullity, info ) )

40−import Rel8.Table ( Table, fromColumns, toColumns )

41+import Rel8.Table ( fromColumns, toColumns, fromResult, toResult )

41import Rel8.Table.Eq ( EqTable )

42import Rel8.Table.Eq ( EqTable )

42−import Rel8.Table.HKD ( HKD, HKDable, fromHKD, toHKD )

43+import Rel8.Table.HKD ( HKD, HKDable )

43import Rel8.Table.Ord ( OrdTable )

44import Rel8.Table.Ord ( OrdTable )

44import Rel8.Table.Rel8able ()

45import Rel8.Table.Rel8able ()

45−import Rel8.Table.Serialize ( lit )

46+import Rel8.Table.Serialize ( litHTable )

46import Rel8.Type ( DBType, typeInformation )

47import Rel8.Type ( DBType, typeInformation )

47import Rel8.Type.Eq ( DBEq )

48import Rel8.Type.Eq ( DBEq )

48import Rel8.Type.Information ( TypeInformation(..) )

49import Rel8.Type.Information ( TypeInformation(..) )

@@ -67,8 +68,8 @@ newtype Composite a = Composite

68instance DBComposite a => DBType (Composite a) where

69instance DBComposite a => DBType (Composite a) where

69 typeInformation = TypeInformation

70 typeInformation = TypeInformation

70− { decode = Hasql.composite (Composite . fromHKD <$> decoder)

71+ { decode = Hasql.composite (Composite . fromResult @_ @(HKD a Expr) <$> decoder)

71− , encode = encoder . lit . toColumns . toHKD . unComposite

72+ , encode = encoder . litHTable . toResult @_ @(HKD a Expr) . unComposite

72 , typeName = compositeTypeName @a

73 , typeName = compositeTypeName @a

73 }

74 }

@@ -85,36 +86,50 @@ instance (DBComposite a, OrdTable (HKD a Expr)) => DBMax (Composite a)

85instance (DBComposite a, OrdTable (HKD a Expr)) => DBMin (Composite a)

86instance (DBComposite a, OrdTable (HKD a Expr)) => DBMin (Composite a)

89+-- | 'DBComposite' is used to associate composite type metadata with a Haskell

90+-- type.

88type DBComposite :: Type -> Constraint

91type DBComposite :: Type -> Constraint

89class (DBType a, HKDable a) => DBComposite a where

92class (DBType a, HKDable a) => DBComposite a where

93+ -- | The names of all fields in the composite type that @a@ maps to.

90 compositeFields :: HKD a Name

94 compositeFields :: HKD a Name

95+

96+ -- | The name of the composite type that @a@ maps to.

91 compositeTypeName :: String

97 compositeTypeName :: String

100+-- | Collapse a 'HKD' into a PostgreSQL composite type.

101+--

102+-- 'HKD' values are represented in queries by having a column for each field in

103+-- the corresponding Haskell type. 'compose' collapses these columns into a

104+-- single column expression, by combining them into a PostgreSQL composite

105+-- type.

94compose :: DBComposite a => HKD a Expr -> Expr a

106compose :: DBComposite a => HKD a Expr -> Expr a

95−compose = castExpr . fromPrimExpr . encoder

107+compose = castExpr . fromPrimExpr . encoder . toColumns

108

109

110+-- | Expand a composite type into a 'HKD'.

111+--

112+-- 'decompose' is the inverse of 'compose'.

98decompose :: forall a. DBComposite a => Expr a -> HKD a Expr

113decompose :: forall a. DBComposite a => Expr a -> HKD a Expr

99decompose (toPrimExpr -> a) = fromColumns $ htabulate \field ->

114decompose (toPrimExpr -> a) = fromColumns $ htabulate \field ->

100 case hfield names field of

115 case hfield names field of

101− N (Name name) -> case hfield hspecs field of

116+ Name name -> case hfield hspecs field of

102− SSpec {} -> E $ fromPrimExpr $ Opaleye.CompositeExpr a name

117+ Spec {} -> fromPrimExpr $ Opaleye.CompositeExpr a name

103 where

118 where

104 names = toColumns (compositeFields @a)

119 names = toColumns (compositeFields @a)

105

120

106

121

107−decoder :: Table Result a => Hasql.Composite a

122+decoder :: HTable t => Hasql.Composite (t Result)

108−decoder = fmap fromColumns $ unwrapApplicative $ htabulateA \field ->

123+decoder = unwrapApplicative $ htabulateA \field ->

109 case hfield hspecs field of

124 case hfield hspecs field of

110− SSpec {nullity, info} -> WrapApplicative $ R <$>

125+ Spec {nullity, info} -> WrapApplicative $ Identity <$>

111 case nullity of

126 case nullity of

112 Null -> Hasql.field $ Hasql.nullable $ decode info

127 Null -> Hasql.field $ Hasql.nullable $ decode info

113 NotNull -> Hasql.field $ Hasql.nonNullable $ decode info

128 NotNull -> Hasql.field $ Hasql.nonNullable $ decode info

114

129

115

130

116−encoder :: Table Expr a => a -> Opaleye.PrimExpr

131+encoder :: HTable t => t Expr -> Opaleye.PrimExpr

117−encoder (toColumns -> a) = Opaleye.FunExpr "ROW" exprs

132+encoder a = Opaleye.FunExpr "ROW" exprs

118 where

133 where

119 exprs = getConst $ htabulateA \field -> case hfield a field of

134 exprs = getConst $ htabulateA \field -> case hfield a field of

120− E (toPrimExpr -> expr) -> Const [expr]

135+ expr -> Const [toPrimExpr expr]

src/Rel8/Type/Enum.hs+8

@@ -91,14 +91,22 @@ instance DBEnum a => DBMax (Enum a)

91instance DBEnum a => DBMin (Enum a)

94+-- | @DBEnum@ contains the necessary metadata to describe a PostgreSQL @enum@ type.

94type DBEnum :: Type -> Constraint

95type DBEnum :: Type -> Constraint

95class (DBType a, Enumable a) => DBEnum a where

96class (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.

96 enumValue :: a -> String

100 enumValue :: a -> String

97 enumValue = gshow @(Rep a) . from

101 enumValue = gshow @(Rep a) . from

102

103+ -- | The name of the PostgreSQL @enum@ type that @a@ maps to.

99 enumTypeName :: String

104 enumTypeName :: String

100

105

101

106

107+-- | Types that are sum types, where each constructor is unary (that is, has no

108+-- fields).

109+type Enumable :: Type -> Constraint

102class (Generic a, GEnumable (Rep a)) => Enumable a

110class (Generic a, GEnumable (Rep a)) => Enumable a

103instance (Generic a, GEnumable (Rep a)) => Enumable a

111instance (Generic a, GEnumable (Rep a)) => Enumable a

104

112

src/Rel8/Type/JSONBEncoded.hs+4

@@ -1,3 +1,5 @@

1+{-# language StandaloneKindSignatures #-}

1module Rel8.Type.JSONBEncoded ( JSONBEncoded(..) ) where

3module Rel8.Type.JSONBEncoded ( JSONBEncoded(..) ) where

3-- aeson

5-- aeson

@@ -6,6 +8,7 @@ import Data.Aeson.Types ( parseEither )

7-- base

9-- base

8import Data.Bifunctor ( first )

10import Data.Bifunctor ( first )

11+import Data.Kind ( Type )

9import Prelude

12import Prelude

11-- hasql

14-- hasql

@@ -20,6 +23,7 @@ import Data.Text ( pack )

22-- | Like 'Rel8.JSONEncoded', but works for @jsonb@ columns.

25-- | Like 'Rel8.JSONEncoded', but works for @jsonb@ columns.

26+type JSONBEncoded :: Type -> Type

23newtype JSONBEncoded a = JSONBEncoded { fromJSONBEncoded :: a }

27newtype JSONBEncoded a = JSONBEncoded { fromJSONBEncoded :: a }

src/Rel8/Type/JSONEncoded.hs+4

@@ -1,3 +1,5 @@

1+{-# language StandaloneKindSignatures #-}

1module Rel8.Type.JSONEncoded ( JSONEncoded(..) ) where

3module Rel8.Type.JSONEncoded ( JSONEncoded(..) ) where

3-- aeson

5-- aeson

@@ -5,6 +7,7 @@ import Data.Aeson ( FromJSON, ToJSON, parseJSON, toJSON )

5import Data.Aeson.Types ( parseEither )

7import Data.Aeson.Types ( parseEither )

7-- base

9-- base

10+import Data.Kind ( Type )

8import Prelude

11import Prelude

10-- rel8

13-- rel8

@@ -15,6 +18,7 @@ import Rel8.Type.Information ( parseTypeInformation )

15-- | A deriving-via helper type for column types that store a Haskell value

18-- | A deriving-via helper type for column types that store a Haskell value

16-- using a JSON encoding described by @aeson@'s 'ToJSON' and 'FromJSON' type

19-- using a JSON encoding described by @aeson@'s 'ToJSON' and 'FromJSON' type

17-- classes.

20-- classes.

21+type JSONEncoded :: Type -> Type

18newtype JSONEncoded a = JSONEncoded { fromJSONEncoded :: a }

22newtype JSONEncoded a = JSONEncoded { fromJSONEncoded :: a }

src/Rel8/Type/Num.hs+4−1

@@ -18,6 +18,7 @@ import Prelude

19-- rel8

20import Rel8.Type ( DBType )

21+import Rel8.Type.Ord ( DBOrd )

22-- scientific

23-- scientific

23import Data.Scientific ( Scientific )

24import Data.Scientific ( Scientific )

@@ -39,13 +40,14 @@ instance DBNum Scientific

39-- expressions. This is a Rel8 concept, and allows us to provide

40-- expressions. This is a Rel8 concept, and allows us to provide

40-- 'fromIntegral'.

41-- 'fromIntegral'.

41type DBIntegral :: Type -> Constraint

42type DBIntegral :: Type -> Constraint

42−class DBNum a => DBIntegral a

43+class (DBNum a, DBOrd a) => DBIntegral a

43instance DBIntegral Int16

44instance DBIntegral Int16

44instance DBIntegral Int32

45instance DBIntegral Int32

45instance DBIntegral Int64

46instance DBIntegral Int64

48-- | The class of database types that support the @/@ operator.

49-- | The class of database types that support the @/@ operator.

50+type DBFractional :: Type -> Constraint

49class DBNum a => DBFractional a

51class DBNum a => DBFractional a

50instance DBFractional Float

52instance DBFractional Float

51instance DBFractional Double

53instance DBFractional Double

@@ -53,6 +55,7 @@ instance DBFractional Scientific

55-- | The class of database types that support the @/@ operator.

57-- | The class of database types that support the @/@ operator.

58+type DBFloating :: Type -> Constraint

56class DBFractional a => DBFloating a

59class DBFractional a => DBFloating a

57instance DBFloating Float

60instance DBFloating Float

58instance DBFloating Double

61instance DBFloating Double

src/Rel8/Type/Ord.hs−2

@@ -75,7 +75,6 @@ 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

79instance DBMax Char

78instance DBMax Char

80instance DBMax Int16

79instance DBMax Int16

81instance DBMax Int32

80instance DBMax Int32

@@ -101,7 +100,6 @@ instance Sql DBMax a => DBMax (NonEmpty a)

101-- | The class of database types that support the @min@ aggregation function.

100-- | The class of database types that support the @min@ aggregation function.

102type DBMin :: Type -> Constraint

101type DBMin :: Type -> Constraint

103class DBOrd a => DBMin a

102class DBOrd a => DBMin a

104−instance DBMin Bool

105instance DBMin Char

103instance DBMin Char

106instance DBMin Int16

104instance DBMin Int16

107instance DBMin Int32

105instance DBMin Int32

src/Rel8/Type/ReadShow.hs+3

@@ -1,10 +1,12 @@

1{-# language ScopedTypeVariables #-}

2+{-# language StandaloneKindSignatures #-}

2{-# language TypeApplications #-}

3{-# language TypeApplications #-}

3{-# language ViewPatterns #-}

4{-# language ViewPatterns #-}

5module Rel8.Type.ReadShow ( ReadShow(..) ) where

6module Rel8.Type.ReadShow ( ReadShow(..) ) where

7-- base

8-- base

9+import Data.Kind ( Type )

8import Data.Proxy ( Proxy( Proxy ) )

10import Data.Proxy ( Proxy( Proxy ) )

9import Data.Typeable ( Typeable, typeRep )

11import Data.Typeable ( Typeable, typeRep )

10import Prelude

12import Prelude

@@ -20,6 +22,7 @@ import qualified Data.Text as Text

21-- | A deriving-via helper type for column types that store a Haskell value

23-- | A deriving-via helper type for column types that store a Haskell value

22-- using a Haskell's 'Read' and 'Show' type classes.

24-- using a Haskell's 'Read' and 'Show' type classes.

25+type ReadShow :: Type -> Type

23newtype ReadShow a = ReadShow { fromReadShow :: a }

26newtype ReadShow a = ReadShow { fromReadShow :: a }

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

@@ -21,7 +21,7 @@ import Prelude

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

23-- rel8

24−import {-# SOURCE #-} Rel8.Expr ( Expr )

24+import Rel8.Expr ( Expr )

25import Rel8.Expr.Eq ( (==.) )

26import Rel8.Expr.Opaleye ( zipPrimExprsWith )

27import Rel8.Expr.Serialize ( litExpr )

@@ -90,6 +90,7 @@ instance DBMonoid MaybeTag where

90 memptyExpr = litExpr mempty

93+type Tag :: Type

93newtype Tag = Tag Text

94newtype Tag = Tag Text

94 deriving newtype

95 deriving newtype

95 ( Eq, Ord, Read, Show

96 ( Eq, Ord, Read, Show

src/Rel8/Window.hsnew file+97

@@ -0,0 +1,97 @@

1+{-# language DerivingVia #-}

2+{-# language FlexibleContexts #-}

3+{-# language GeneralizedNewtypeDeriving #-}

4+{-# language ScopedTypeVariables #-}

5+{-# language StandaloneKindSignatures #-}

6+{-# language TypeApplications #-}

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+321−162

@@ -1,12 +1,11 @@

1+{-# language BangPatterns #-}

1{-# language BlockArguments #-}

2{-# language BlockArguments #-}

2−{-# language DataKinds #-}

3{-# language DeriveAnyClass #-}

4{-# language DeriveGeneric #-}

5{-# language DerivingStrategies #-}

6−{-# language DisambiguateRecordFields #-}

7{-# language FlexibleContexts #-}

6{-# language FlexibleContexts #-}

8{-# language FlexibleInstances #-}

7{-# language FlexibleInstances #-}

9−{-# language GADTs #-}

8+{-# language MonoLocalBinds #-}

10{-# language NamedFieldPuns #-}

9{-# language NamedFieldPuns #-}

11{-# language OverloadedStrings #-}

10{-# language OverloadedStrings #-}

12{-# language RecordWildCards #-}

11{-# language RecordWildCards #-}

@@ -14,17 +13,15 @@

14{-# language StandaloneDeriving #-}

13{-# language StandaloneDeriving #-}

15{-# language TypeApplications #-}

14{-# language TypeApplications #-}

17−{-# options_ghc -fno-warn-redundant-constraints #-}

18−

19module Main

16module Main

20 ( main

17 ( main

21 )

18 )

22where

19where

24-- base

21-- base

25−import Control.Applicative ( liftA2, liftA3 )

22+import Control.Applicative ( empty, liftA2, liftA3 )

26−import Control.Monad (void)

23+import Control.Exception ( bracket, throwIO )

27−import Control.Monad.IO.Class ( MonadIO, liftIO )

24+import Control.Monad ( (>=>), void )

28import Data.Bifunctor ( bimap )

25import Data.Bifunctor ( bimap )

29import Data.Foldable ( for_ )

26import Data.Foldable ( for_ )

30import Data.Int ( Int32, Int64 )

27import Data.Int ( Int32, Int64 )

@@ -38,25 +35,27 @@ import GHC.Generics ( Generic )

38import qualified Data.ByteString.Lazy

35import qualified Data.ByteString.Lazy

40-- case-insensitive

37-- case-insensitive

41−import Data.CaseInsensitive (mk)

38+import Data.CaseInsensitive ( mk )

43-- containers

40-- containers

41+import Data.Containers.ListUtils ( nubOrdOn )

44import qualified Data.Map.Strict as Map

42import qualified Data.Map.Strict as Map

46-- hasql

44-- hasql

47−import Hasql.Connection ( Connection, acquire, release )

45+import Hasql.Connection ( Connection, acquire, release )

48import Hasql.Session ( sql, run )

46import Hasql.Session ( sql, run )

48+-- hasql-transaction

49+import Hasql.Transaction ( Transaction, condemn, statement )

50+import qualified Hasql.Transaction.Sessions as Hasql

51+

50-- hedgehog

52-- hedgehog

51import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )

53import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )

52import qualified Hedgehog.Gen as Gen

54import qualified Hedgehog.Gen as Gen

53import qualified Hedgehog.Range as Range

55import qualified Hedgehog.Range as Range

55−-- lifted-base

57+-- mmorph

56−import Control.Exception.Lifted ( bracket, throwIO, bracket_ )

57−

58−-- monad-control

59−import Control.Monad.Trans.Control ( MonadBaseControl )

58+import Control.Monad.Morph ( hoist )

61-- rel8

60-- rel8

62import Rel8 ( Result )

61import Rel8 ( Result )

@@ -72,12 +71,16 @@ import Test.Tasty

72import Test.Tasty.Hedgehog ( testProperty )

71import Test.Tasty.Hedgehog ( testProperty )

74-- text

73-- text

75−import Data.Text (Text, pack)

74+import Data.Text ( Text, pack, unpack )

76import qualified Data.Text.Lazy

75import 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+

81-- tmp-postgres

84-- tmp-postgres

82import qualified Database.Postgres.Temp as TmpPostgres

85import qualified Database.Postgres.Temp as TmpPostgres

@@ -113,14 +116,17 @@ tests =

113 , testCatMaybeTable getTestDatabase

116 , testCatMaybeTable getTestDatabase

114 , testCatMaybe getTestDatabase

117 , testCatMaybe getTestDatabase

115 , testMaybeTable getTestDatabase

118 , testMaybeTable getTestDatabase

119+ , testAggregateMaybeTable getTestDatabase

116 , testNestedTables getTestDatabase

120 , testNestedTables getTestDatabase

117 , testMaybeTableApplicative getTestDatabase

121 , testMaybeTableApplicative getTestDatabase

118 , testLogicalFixities getTestDatabase

122 , testLogicalFixities getTestDatabase

119 , testUpdate getTestDatabase

123 , testUpdate getTestDatabase

120 , testDelete getTestDatabase

124 , testDelete getTestDatabase

125+ , testUpsert getTestDatabase

121 , testSelectNestedPairs getTestDatabase

126 , testSelectNestedPairs getTestDatabase

122 , testSelectArray getTestDatabase

127 , testSelectArray getTestDatabase

123 , testNestedMaybeTable getTestDatabase

128 , testNestedMaybeTable getTestDatabase

129+ , testEvaluate getTestDatabase

124 ]

130 ]

125

131

126 where

132 where

@@ -132,25 +138,29 @@ tests =

132 flip run conn do

138 flip run conn do

133 sql "CREATE EXTENSION citext"

139 sql "CREATE EXTENSION citext"

134 sql "CREATE TABLE test_table ( column1 text not null, column2 bool not null )"

140 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"

135

143

136 return db

144 return db

137

145

138 stopTestDatabase = TmpPostgres.stop

146 stopTestDatabase = TmpPostgres.stop

139

147

140

148

149+connect :: TmpPostgres.DB -> IO Connection

150+connect = acquire . TmpPostgres.toConnectionString >=> either (maybe empty (fail . unpack . decodeUtf8)) pure

151+

152+

141databasePropertyTest

153databasePropertyTest

142 :: TestName

154 :: TestName

143− -> (((Connection -> TestT IO ()) -> PropertyT IO ()) -> PropertyT IO ())

155+ -> ((TestT Transaction () -> PropertyT IO ()) -> PropertyT IO ())

144 -> IO TmpPostgres.DB -> TestTree

156 -> IO TmpPostgres.DB -> TestTree

145databasePropertyTest testName f getTestDatabase =

157databasePropertyTest testName f getTestDatabase =

146− withResource connect release $ \c ->

158+ withResource (connect =<< getTestDatabase) release $ \c ->

147 testProperty testName $ property do

159 testProperty testName $ property do

148− connection <- liftIO c

160+ connection <- lift c

149− f \g -> test $ rollingBack connection $ g connection

161+ f $ test . hoist \m -> do

150−

162+ e <- run (Hasql.transaction Hasql.Serializable Hasql.Write (m <* condemn)) connection

151− where

163+ either throwIO pure e

152−

153− connect = either (error . show) return =<< acquire . TmpPostgres.toConnectionString =<< getTestDatabase

154

164

155

165

156data TestTable f = TestTable

166data TestTable f = TestTable

@@ -182,18 +192,17 @@ testSelectTestTable :: IO TmpPostgres.DB -> TestTree

182testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do

192testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do

183 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

193 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

184

194

185− transaction \connection -> do

195+ transaction do

186− void do

196+ selected <- lift do

187− liftIO $ Rel8.insert connection

188− Rel8.Insert

197+ statement () $ Rel8.insert Rel8.Insert

189− { into = testTableSchema

198+ { into = testTableSchema

190− , rows = map (Rel8.toInsert . Rel8.lit) rows

199+ , rows = Rel8.values $ map Rel8.lit rows

191− , onConflict = Rel8.DoNothing

200+ , onConflict = Rel8.DoNothing

192− , returning = Rel8.NumberOfRowsAffected

201+ , returning = pure ()

193− }

202+ }

194

203

195− selected <- liftIO $ Rel8.select connection do

204+ statement () $ Rel8.select do

196− Rel8.each testTableSchema

205+ Rel8.each testTableSchema

197

206

198 sort selected === sort rows

207 sort selected === sort rows

199

208

@@ -210,11 +219,12 @@ testWhere_ = databasePropertyTest "WHERE (Rel8.where_)" \transaction -> do

210

219

211 let expected = filter (\t -> testTableColumn2 t == magicBool) rows

220 let expected = filter (\t -> testTableColumn2 t == magicBool) rows

212

221

213− transaction \connection -> do

222+ transaction do

223+ selected <- lift do

214− selected <- liftIO $ Rel8.select connection do

224+ statement () $ Rel8.select do

215− t <- Rel8.values $ Rel8.lit <$> rows

225+ t <- Rel8.values $ Rel8.lit <$> rows

216− Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool

226+ Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool

217− return t

227+ return t

218

228

219 sort selected === sort expected

229 sort selected === sort expected

220

230

@@ -227,11 +237,12 @@ testFilter :: IO TmpPostgres.DB -> TestTree

227testFilter = databasePropertyTest "filter" \transaction -> do

237testFilter = databasePropertyTest "filter" \transaction -> do

228 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable

238 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable

229

239

230− transaction \connection -> do

240+ transaction do

231 let expected = filter testTableColumn2 rows

241 let expected = filter testTableColumn2 rows

232

242

233− selected <- liftIO $ Rel8.select connection

243+ selected <- lift do

244+ statement () $ Rel8.select do

234− $ Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)

245+ Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)

235

246

236 sort selected === sort expected

247 sort selected === sort expected

237

248

@@ -246,9 +257,10 @@ testLimit = databasePropertyTest "LIMIT (Rel8.limit)" \transaction -> do

246

257

247 n <- forAll $ Gen.integral (Range.linear 0 10)

258 n <- forAll $ Gen.integral (Range.linear 0 10)

248

259

249− transaction \connection -> do

260+ transaction do

261+ selected <- lift do

250− selected <- liftIO $ Rel8.select connection do

262+ statement () $ Rel8.select do

251− Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)

263+ Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)

252

264

253 diff (length selected) (<=) (fromIntegral n)

265 diff (length selected) (<=) (fromIntegral n)

254

266

@@ -266,9 +278,10 @@ testUnion = databasePropertyTest "UNION (Rel8.union)" \transaction -> evalM do

266 left <- forAll $ Gen.list (Range.linear 0 10) genTestTable

278 left <- forAll $ Gen.list (Range.linear 0 10) genTestTable

267 right <- forAll $ Gen.list (Range.linear 0 10) genTestTable

279 right <- forAll $ Gen.list (Range.linear 0 10) genTestTable

268

280

269− transaction \connection -> do

281+ transaction do

282+ selected <- lift do

270− selected <- liftIO $ Rel8.select connection do

283+ statement () $ Rel8.select do

271− Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)

284+ Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)

272

285

273 sort selected === sort (nub (left ++ right))

286 sort selected === sort (nub (left ++ right))

274

287

@@ -277,9 +290,11 @@ testDistinct :: IO TmpPostgres.DB -> TestTree

277testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do

290testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do

278 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

291 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

279

292

280− transaction \connection -> do

293+ transaction do

294+ selected <- lift do

295+ statement () $ Rel8.select do

281− selected <- liftIO $ Rel8.select connection $ Rel8.distinct do

296+ Rel8.distinct do

282− Rel8.values (Rel8.lit <$> rows)

297+ Rel8.values (Rel8.lit <$> rows)

283

298

284 sort selected === nub (sort rows)

299 sort selected === nub (sort rows)

285

300

@@ -292,8 +307,10 @@ testExists :: IO TmpPostgres.DB -> TestTree

292testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do

307testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do

293 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

308 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

294

309

295− transaction \connection -> do

310+ transaction do

311+ exists <- lift do

312+ statement () $ Rel8.select do

296− exists <- liftIO $ Rel8.select connection $ Rel8.exists $ Rel8.values $ Rel8.lit <$> rows

313+ Rel8.exists $ Rel8.values $ Rel8.lit <$> rows

297

314

298 case rows of

315 case rows of

299 [] -> exists === [False]

316 [] -> exists === [False]

@@ -304,9 +321,10 @@ testOptional :: IO TmpPostgres.DB -> TestTree

304testOptional = databasePropertyTest "Rel8.optional" \transaction -> do

321testOptional = databasePropertyTest "Rel8.optional" \transaction -> do

305 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

322 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

306

323

307− transaction \connection -> do

324+ transaction do

325+ selected <- lift do

308− selected <- liftIO $ Rel8.select connection do

326+ statement () $ Rel8.select do

309− Rel8.optional $ Rel8.values (Rel8.lit <$> rows)

327+ Rel8.optional $ Rel8.values (Rel8.lit <$> rows)

310

328

311 case rows of

329 case rows of

312 [] -> selected === [Nothing]

330 [] -> selected === [Nothing]

@@ -317,9 +335,10 @@ testAnd :: IO TmpPostgres.DB -> TestTree

317testAnd = databasePropertyTest "AND (&&.)" \transaction -> do

335testAnd = databasePropertyTest "AND (&&.)" \transaction -> do

318 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool

336 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool

319

337

320− transaction \connection -> do

338+ transaction do

321− [result] <- liftIO $ Rel8.select connection $ pure $

339+ [result] <- lift do

340+ statement () $ Rel8.select do

322− Rel8.lit x Rel8.&&. Rel8.lit y

341+ pure $ Rel8.lit x Rel8.&&. Rel8.lit y

323

342

324 result === (x && y)

343 result === (x && y)

325

344

@@ -328,9 +347,10 @@ testOr :: IO TmpPostgres.DB -> TestTree

328testOr = databasePropertyTest "OR (||.)" \transaction -> do

347testOr = databasePropertyTest "OR (||.)" \transaction -> do

329 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool

348 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool

330

349

331− transaction \connection -> do

350+ transaction do

351+ [result] <- lift do

332− [result] <- liftIO $ Rel8.select connection $ pure $

352+ statement () $ Rel8.select $ pure $

333− Rel8.lit x Rel8.||. Rel8.lit y

353+ Rel8.lit x Rel8.||. Rel8.lit y

334

354

335 result === (x || y)

355 result === (x || y)

336

356

@@ -339,9 +359,10 @@ testLogicalFixities :: IO TmpPostgres.DB -> TestTree

339testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do

359testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do

340 (u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool

360 (u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool

341

361

342− transaction \connection -> do

362+ transaction do

343− [result] <- liftIO $ Rel8.select connection $ pure $

363+ [result] <- lift do

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

345

366

346 result === (u || v && w == x)

367 result === (u || v && w == x)

347

368

@@ -350,9 +371,10 @@ testNot :: IO TmpPostgres.DB -> TestTree

350testNot = databasePropertyTest "NOT (not_)" \transaction -> do

371testNot = databasePropertyTest "NOT (not_)" \transaction -> do

351 x <- forAll Gen.bool

372 x <- forAll Gen.bool

352

373

353− transaction \connection -> do

374+ transaction do

354− [result] <- liftIO $ Rel8.select connection $ pure $

375+ [result] <- lift do

376+ statement () $ Rel8.select do

355− Rel8.not_ $ Rel8.lit x

377+ pure $ Rel8.not_ $ Rel8.lit x

356

378

357 result === not x

379 result === not x

358

380

@@ -361,9 +383,10 @@ testBool :: IO TmpPostgres.DB -> TestTree

361testBool = databasePropertyTest "ifThenElse_" \transaction -> do

383testBool = databasePropertyTest "ifThenElse_" \transaction -> do

362 (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool

384 (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool

363

385

364− transaction \connection -> do

386+ transaction do

365− [result] <- liftIO $ Rel8.select connection $ pure $

387+ [result] <- lift do

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)

367

390

368 result === if x then y else z

391 result === if x then y else z

369

392

@@ -375,9 +398,10 @@ testAp = databasePropertyTest "Cartesian product (<*>)" \transaction -> do

375 (Gen.list (Range.linear 1 10) genTestTable)

398 (Gen.list (Range.linear 1 10) genTestTable)

376 (Gen.list (Range.linear 1 10) genTestTable)

399 (Gen.list (Range.linear 1 10) genTestTable)

377

400

378− transaction \connection -> do

401+ transaction 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))

381

405

382 sort result === sort (liftA2 (,) rows1 rows2)

406 sort result === sort (liftA2 (,) rows1 rows2)

383

407

@@ -406,21 +430,22 @@ testDBType getTestDatabase = testGroup "DBType instances"

406 where

430 where

407 dbTypeTest :: (Eq a, Show a, Rel8.DBType a) => TestName -> Gen a -> TestTree

431 dbTypeTest :: (Eq a, Show a, Rel8.DBType a) => TestName -> Gen a -> TestTree

408 dbTypeTest name generator = testGroup name

432 dbTypeTest name generator = testGroup name

409− [ databasePropertyTest name (t (==) generator) getTestDatabase

433+ [ databasePropertyTest name (t generator) getTestDatabase

410− , databasePropertyTest ("Maybe " <> name) (t (==) (Gen.maybe generator)) getTestDatabase

434+ , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase

411 ]

435 ]

412

436

413− t :: forall a b. (Show a, Rel8.Sql Rel8.DBType a)

437+ t :: forall a b. (Eq a, Show a, Rel8.Sql Rel8.DBType a)

414− => (a -> a -> Bool)

415− -> Gen a

438+ => Gen a

416− -> ((Connection -> TestT IO ()) -> PropertyT IO b)

439+ -> (TestT Transaction () -> PropertyT IO b)

417 -> PropertyT IO b

440 -> PropertyT IO b

418− t eq generator transaction = do

441+ t generator transaction = do

419 x <- forAll generator

442 x <- forAll generator

420

443

421− transaction \connection -> do

444+ transaction do

445+ [res] <- lift do

446+ statement () $ Rel8.select do

422− [res] <- liftIO $ Rel8.select connection $ pure (Rel8.litExpr x)

447+ pure (Rel8.litExpr x)

423− diff res eq x

448+ diff res (==) x

424

449

425 genDay :: Gen Day

450 genDay :: Gen Day

426 genDay = do

451 genDay = do

@@ -462,39 +487,38 @@ testDBEq getTestDatabase = testGroup "DBEq instances"

462

487

463 t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBEq a)

488 t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBEq a)

464 => Gen a

489 => Gen a

465− -> ((Connection -> TestT IO ()) -> PropertyT IO ())

490+ -> (TestT Transaction () -> PropertyT IO ())

466 -> PropertyT IO ()

491 -> PropertyT IO ()

467 t generator transaction = do

492 t generator transaction = do

468 (x, y) <- forAll (liftA2 (,) generator generator)

493 (x, y) <- forAll (liftA2 (,) generator generator)

469

494

470− transaction \connection -> do

495+ transaction do

496+ [res] <- lift do

497+ statement () $ Rel8.select do

471− [res] <- liftIO $ Rel8.select connection $ pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y

498+ pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y

472 res === (x == y)

499 res === (x == y)

473

500

474− cover 1 "Equal" $ x == y

475− cover 1 "Not Equal" $ x /= y

476−

477

501

478testTableEquality :: IO TmpPostgres.DB -> TestTree

502testTableEquality :: IO TmpPostgres.DB -> TestTree

479testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do

503testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do

480 (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable

504 (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable

481

505

482− transaction \connection -> do

506+ transaction 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

485

510

486 eq === (x == y)

511 eq === (x == y)

487

512

488− cover 1 "Equal" $ x == y

489− cover 1 "Not Equal" $ x /= y

490−

491

513

492testFromString :: IO TmpPostgres.DB -> TestTree

514testFromString :: IO TmpPostgres.DB -> TestTree

493testFromString = databasePropertyTest "FromString" \transaction -> do

515testFromString = databasePropertyTest "FromString" \transaction -> do

494 str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode

516 str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode

495

517

496− transaction \connection -> do

518+ transaction do

519+ [result] <- lift do

520+ statement () $ Rel8.select do

497− [result] <- liftIO $ Rel8.select connection $ pure $ fromString str

521+ pure $ fromString str

498 result === pack str

522 result === pack str

499

523

500

524

@@ -502,10 +526,11 @@ testCatMaybeTable :: IO TmpPostgres.DB -> TestTree

502testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do

526testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do

503 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

527 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

504

528

505− transaction \connection -> do

529+ transaction 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)

509

534

510 sort selected === sort (filter testTableColumn2 rows)

535 sort selected === sort (filter testTableColumn2 rows)

511

536

@@ -514,9 +539,10 @@ testCatMaybe :: IO TmpPostgres.DB -> TestTree

514testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do

539testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do

515 rows <- forAll $ Gen.list (Range.linear 0 10) $ Gen.maybe Gen.bool

540 rows <- forAll $ Gen.list (Range.linear 0 10) $ Gen.maybe Gen.bool

516

541

517− transaction \connection -> do

542+ transaction do

518− selected <- evalM $ liftIO $ Rel8.select connection do

543+ selected <- lift do

544+ statement () $ Rel8.select do

519− Rel8.catNull =<< Rel8.values (map Rel8.lit rows)

545+ Rel8.catNull =<< Rel8.values (map Rel8.lit rows)

520

546

521 sort selected === sort (catMaybes rows)

547 sort selected === sort (catMaybes rows)

522

548

@@ -525,21 +551,44 @@ testMaybeTable :: IO TmpPostgres.DB -> TestTree

525testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do

551testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do

526 (rows, def) <- forAll $ liftA2 (,) (Gen.list (Range.linear 0 10) genTestTable) genTestTable

552 (rows, def) <- forAll $ liftA2 (,) (Gen.list (Range.linear 0 10) genTestTable) genTestTable

527

553

528− transaction \connection -> do

554+ transaction do

529− selected <- liftIO $ Rel8.select connection $

555+ selected <- lift do

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))

531

558

532 case rows of

559 case rows of

533 [] -> selected === [def]

560 [] -> selected === [def]

534 _ -> sort selected === sort rows

561 _ -> sort selected === sort rows

535

562

536

563

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+

537data TwoTestTables f =

586data TwoTestTables f =

538 TwoTestTables

587 TwoTestTables

539 { testTable1 :: TestTable f

588 { testTable1 :: TestTable f

540 , testTable2 :: TestTable f

589 , testTable2 :: TestTable f

541 }

590 }

542− deriving stock Generic

591+ deriving stock Generic

543 deriving anyclass Rel8.Rel8able

592 deriving anyclass Rel8.Rel8able

544

593

545

594

@@ -554,9 +603,10 @@ testNestedTables = databasePropertyTest "Nested TestTables" \transaction -> eval

554 Gen.list (Range.linear 0 10) $

603 Gen.list (Range.linear 0 10) $

555 liftA2 TwoTestTables genTestTable genTestTable

604 liftA2 TwoTestTables genTestTable genTestTable

556

605

557− transaction \connection -> do

606+ transaction 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)

560

610

561 sort selected === sort rows

611 sort selected === sort rows

562

612

@@ -566,11 +616,12 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction

566 rows1 <- genRows

616 rows1 <- genRows

567 rows2 <- genRows

617 rows2 <- genRows

568

618

569− transaction \connection -> do

619+ transaction 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

574

625

575 case (rows1, rows2) of

626 case (rows1, rows2) of

576 ([], []) -> selected === [Nothing]

627 ([], []) -> selected === [Nothing]

@@ -582,14 +633,6 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction

582 genRows = forAll do

633 genRows = forAll do

583 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)

634 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)

584

635

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−

593

636

594genTestTable :: Gen (TestTable Result)

637genTestTable :: Gen (TestTable Result)

595genTestTable = do

638genTestTable = do

@@ -602,19 +645,19 @@ testUpdate :: IO TmpPostgres.DB -> TestTree

602testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do

645testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do

603 rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable

646 rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable

604

647

605− transaction \connection -> do

648+ transaction do

606− void $ liftIO $ Rel8.insert connection

649+ selected <- lift do

607− Rel8.Insert

650+ statement () $ Rel8.insert Rel8.Insert

608 { into = testTableSchema

651 { into = testTableSchema

609− , rows = map (Rel8.toInsert . Rel8.lit) $ Map.keys rows

652+ , rows = Rel8.values $ map Rel8.lit $ Map.keys rows

610 , onConflict = Rel8.DoNothing

653 , onConflict = Rel8.DoNothing

611− , returning = Rel8.NumberOfRowsAffected

654+ , returning = pure ()

612 }

655 }

613

656

614− void $ liftIO $ Rel8.update connection

615− Rel8.Update

657+ statement () $ Rel8.update Rel8.Update

616 { target = testTableSchema

658 { target = testTableSchema

659+ , from = pure ()

617− , set = \r ->

660+ , set = \_ r ->

618 let updates = map (bimap Rel8.lit Rel8.lit) $ Map.toList rows

661 let updates = map (bimap Rel8.lit Rel8.lit) $ Map.toList rows

619 in

662 in

620 foldl

663 foldl

@@ -628,12 +671,12 @@ testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do

628 )

671 )

629 r

672 r

630 updates

673 updates

631− , updateWhere = \_ -> Rel8.lit True

674+ , updateWhere = \_ _ -> Rel8.lit True

632− , returning = Rel8.NumberOfRowsAffected

675+ , returning = pure ()

633 }

676 }

634

677

635− selected <- liftIO $ Rel8.select connection do

678+ statement () $ Rel8.select do

636− Rel8.each testTableSchema

679+ Rel8.each testTableSchema

637

680

638 sort selected === sort (Map.elems rows)

681 sort selected === sort (Map.elems rows)

639

682

@@ -646,29 +689,96 @@ testDelete :: IO TmpPostgres.DB -> TestTree

646testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do

689testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do

647 rows <- forAll $ Gen.list (Range.linear 0 5) genTestTable

690 rows <- forAll $ Gen.list (Range.linear 0 5) genTestTable

648

691

649− transaction \connection -> do

692+ transaction do

650− void $ liftIO $ Rel8.insert connection

693+ (deleted, selected) <- lift do

651− Rel8.Insert

694+ statement () $ Rel8.insert Rel8.Insert

652 { into = testTableSchema

695 { into = testTableSchema

653− , rows = map (Rel8.toInsert . Rel8.lit) rows

696+ , rows = Rel8.values $ map Rel8.lit rows

654 , onConflict = Rel8.DoNothing

697 , onConflict = Rel8.DoNothing

655− , returning = Rel8.NumberOfRowsAffected

698+ , returning = pure ()

656 }

699 }

657

700

658− deleted <-

659− liftIO $ Rel8.delete connection

660− Rel8.Delete

701+ deleted <- statement () $ Rel8.delete Rel8.Delete

661 { from = testTableSchema

702 { from = testTableSchema

703+ , using = pure ()

662− , deleteWhere = testTableColumn2

704+ , deleteWhere = const testTableColumn2

663 , returning = Rel8.Projection id

705 , returning = Rel8.Projection id

664 }

706 }

665

707

666− selected <- liftIO $ Rel8.select connection do

708+ selected <- statement () $ Rel8.select do

667− Rel8.each testTableSchema

709+ Rel8.each testTableSchema

710+

711+ pure (deleted, selected)

668

712

669 sort (deleted <> selected) === sort rows

713 sort (deleted <> selected) === sort rows

670

714

671

715

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+

672newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }

782newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }

673 deriving stock Generic

783 deriving stock Generic

674 deriving anyclass Rel8.Rel8able

784 deriving anyclass Rel8.Rel8able

@@ -682,9 +792,10 @@ testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree

682testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do

792testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do

683 rows <- forAll $ Gen.list (Range.linear 0 10) $ HKNestedPair <$> liftA2 (,) genTestTable genTestTable

793 rows <- forAll $ Gen.list (Range.linear 0 10) $ HKNestedPair <$> liftA2 (,) genTestTable genTestTable

684

794

685− transaction \connection -> do

795+ transaction 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

688

799

689 sort selected === sort rows

800 sort selected === sort rows

690

801

@@ -693,16 +804,22 @@ testSelectArray :: IO TmpPostgres.DB -> TestTree

693testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do

804testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do

694 rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool

805 rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool

695

806

696− transaction \connection -> do

807+ transaction do

808+ selected <- lift do

697− selected <- liftIO $ Rel8.select connection do

809+ statement () $ Rel8.select do

698− Rel8.many $ Rel8.values (map Rel8.lit rows)

810+ Rel8.many $ Rel8.values (map Rel8.lit rows)

699

811

700 selected === [foldMap pure rows]

812 selected === [foldMap pure rows]

701

813

702− selected' <- liftIO $ Rel8.select connection $ Rel8.catListTable =<< do

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

703− Rel8.many $ Rel8.values (map Rel8.lit rows)

819+ Rel8.many $ Rel8.values (map Rel8.lit rows)

820+ pure (a, b)

704

821

705− selected' === rows

822+ selected' === liftA2 (,) rows rows

706

823

707

824

708data NestedMaybeTable f = NestedMaybeTable

825data NestedMaybeTable f = NestedMaybeTable

@@ -722,9 +839,51 @@ testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree

722testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do

839testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do

723 let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) }

840 let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) }

724

841

725− transaction \connection -> do

842+ transaction do

843+ selected <- lift do

726− selected <- liftIO $ Rel8.select connection do

844+ statement () $ Rel8.select do

727− x <- Rel8.values [Rel8.lit example]

845+ x <- Rel8.values [Rel8.lit example]

728− pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)

846+ pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)

729

847

730 selected === [True]

848 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

src/Rel8/Generic/Rel8able/Test.hs → tests/Rel8/Generic/Rel8able/Test.hsrenamed+47−16

@@ -1,11 +1,11 @@

1{-# language DataKinds #-}

2{-# language DeriveAnyClass #-}

3{-# language DeriveGeneric #-}

4−{-# language DerivingVia #-}

4+{-# language DerivingStrategies #-}

5{-# language DuplicateRecordFields #-}

6{-# language FlexibleInstances #-}

7{-# language MultiParamTypeClasses #-}

8−{-# language StandaloneDeriving #-}

8+{-# language StandaloneKindSignatures #-}

9{-# language TypeFamilies #-}

10{-# language UndecidableInstances #-}

@@ -98,30 +98,20 @@ data S3Object = S3Object

98 deriving stock Generic

100

101−deriving via HKDT S3Object

102− instance Table Result S3Object

103−

104−

105−deriving via HKDT S3Object

106− instance x ~ HKD S3Object Expr => ToExprs x S3Object

101+instance x ~ HKD S3Object Expr => ToExprs x S3Object

107

102

108

103

109data HKDSum = HKDSumA Text | HKDSumB Bool Char | HKDSumC

104data HKDSum = HKDSumA Text | HKDSumB Bool Char | HKDSumC

110 deriving stock Generic

105 deriving stock Generic

111

106

112

107

113−deriving via HKDT HKDSum

114− instance Table Result HKDSum

115−

116−

117−deriving via HKDT HKDSum

118− instance x ~ HKD HKDSum Expr => ToExprs x HKDSum

108+instance x ~ HKD HKDSum Expr => ToExprs x HKDSum

119

109

120

110

121data HKDTest f = HKDTest

111data HKDTest f = HKDTest

122 { s3Object :: Lift f S3Object

112 { s3Object :: Lift f S3Object

123 , hkdSum :: Lift f HKDSum

113 , hkdSum :: Lift f HKDSum

124− }

114+ }

125 deriving stock Generic

115 deriving stock Generic

126 deriving anyclass Rel8able

116 deriving anyclass Rel8able

127

117

@@ -148,10 +138,51 @@ data TableSum f

148 deriving stock Generic

138 deriving stock Generic

149

139

150

140

141+data BarbieSum f

142+ = BarbieSumA (f Bool) (f Text)

143+ | BarbieSumB

144+ | BarbieSumC (f Text)

145+ deriving stock Generic

146+

147+

151data TableProduct f = TableProduct

148data TableProduct f = TableProduct

152− { sum :: HADT f TableSum

149+ { sum :: HADT f BarbieSum

153 , list :: TableList f

150 , list :: TableList f

154 , foos :: HList f (HADT f TableSum, Lift f HKDSum, HKDTest f)

151 , foos :: HList f (HADT f TableSum, Lift f HKDSum, HKDTest f)

155 }

152 }

156 deriving stock Generic

153 deriving stock Generic

157 deriving anyclass Rel8able

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+ }

187+ deriving stock Generic

188+ deriving anyclass Rel8able