716d9f1...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.md+128−1

@@ -1,13 +1,140 @@

1−# 1.1.0.0 (??)

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+

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

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

123

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

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

125

9* 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))

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+

11## Bug fixes

138## Bug fixes

139

13* 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))

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

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

@@ -1,11 +1,11 @@

1let

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 = "ghc901";

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

10 pkgs = import nixpkgsSrc nixpkgsArgs;

docs/concepts/insert.rst+37−10

@@ -21,9 +21,16 @@ using ``delete``. ``Delete`` takes:

21``from``

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

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+

24``deleteWhere``

30``deleteWhere``

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

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

26− takes a single ``Expr`` table as input.

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

33+ of the row.

28``returning``

35``returning``

29 What to return - see :ref:`returning`.

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

@@ -37,16 +44,23 @@ using ``update``. ``Update`` takes:

37``target``

44``target``

38 The ``TableSchema`` for the table to update rows in.

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

40−``updateWhere``

47+``from``

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

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

42− takes a single ``Expr`` table as input.

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 ()``.

44``set``

53``set``

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

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

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

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

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

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

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

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.

51``returning``

65``returning``

52 What to return - see :ref:`returning`.

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

@@ -64,11 +78,11 @@ using ``insert``. ``Insert`` takes:

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

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

65 context. You can construct rows from their individual fields::

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

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

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

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

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

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

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

73``onConflict``

87``onConflict``

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

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

@@ -80,6 +94,10 @@ using ``insert``. ``Insert`` takes:

80 ``DoNothing``

94 ``DoNothing``

81 PostgreSQL should not insert the duplicate rows.

95 PostgreSQL should not insert the duplicate rows.

97+ ``DoUpdate``

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

99+ with rows proposed for insertion.

100+

83``returning``

101``returning``

84 What to return - see :ref:`returning`.

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

103

@@ -99,11 +117,20 @@ For example, if we are inserting orders, we might want the order ids returned::

117

100 insert Insert

118 insert Insert

101 { into = orderSchema

119 { into = orderSchema

102− , rows = [ order ]

120+ , rows = values [ order ]

103 , onConflict = Abort

121 , onConflict = Abort

104 , returning = Projection orderId

122 , returning = Projection orderId

105 }

123 }

106

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+

107Default values

134Default values

108--------------

135--------------

109

136

@@ -119,7 +146,7 @@ construct the ``DEFAULT`` expression::

119

146

120 insert Insert

147 insert Insert

121 { into = orderSchema

148 { into = orderSchema

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

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

123 , onConflict = Abort

150 , onConflict = Abort

124 , returning = Projection orderId

151 , returning = Projection orderId

125 }

152 }

@@ -148,7 +175,7 @@ them in Rel8, rather than in your database schema.

148

175

149 insert Insert

176 insert Insert

150 { into = orderSchema

177 { into = orderSchema

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

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

152 , onConflict = Abort

179 , onConflict = Abort

153 , returning = Projection orderId

180 , returning = Projection orderId

154 }

181 }

docs/cookbook.rst+9−7

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

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": "3856d2d24dca0ecc71fcfc314253a2a2d07a3c4f",

8+ "rev": "0837156c56cb5350dd9bd84eb424187e00aa1e8a",

9− "sha256": "0s69nasqhkv8n0qmdv075k83p3z584ja9vkzdnp2291mymghvx87",

9+ "sha256": "1djmv5a0vfj78csw2cad6nicrs8iqrp928b9b3v4h7lwwhhzliwl",

10 "type": "tarball",

11− "url": "https://github.com/input-output-hk/haskell.nix/archive/3856d2d24dca0ecc71fcfc314253a2a2d07a3c4f.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": "e0ca65c81a2d7a4d82a189f1e23a48d59ad42070",

20+ "rev": "acdb1726783637852c01e0ad639ac9cbec28d8c8",

21− "sha256": "1pq9nh1d8nn3xvbdny8fafzw87mj7gsmp6pxkdl65w2g18rmcmzx",

21+ "sha256": "1wszl8q70z6wfgkh2dvgmhhry6qp9nar421qq2ifd17hq2jj9ck3",

22 "type": "tarball",

23− "url": "https://github.com/nmattia/niv/archive/e0ca65c81a2d7a4d82a189f1e23a48d59ad42070.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": "59b8d9cf24e9fcf10341a0923c9bdca088dca8c8",

32+ "rev": "1c1f5649bb9c1b0d98637c8c365228f57126f361",

33− "sha256": "08f38v4b2kcxnbapdwrb54bglka92cxj9qlnqlk5px206jyq9v4c",

33+ "sha256": "0f2nvdijyxfgl5kwyb4465pppd5vkhqxddx6v40k2s0z9jfhj0xl",

34 "type": "tarball",

35− "url": "https://github.com/nixos/nixpkgs/archive/59b8d9cf24e9fcf10341a0923c9bdca088dca8c8.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+21−1

@@ -31,8 +31,28 @@ let

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;

34 in

53 in

54+ builtins.fetchGit

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

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

37 fetch_local = spec: spec.path;

57 fetch_local = spec: spec.path;

rel8.cabal+35−15

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

1cabal-version: 2.0

2name: rel8

3−version: 1.0.0.1

3+version: 1.4.0.0

4synopsis: Hey! Hey! Can u rel8?

5license: BSD3

6license-file: LICENSE

@@ -20,28 +20,33 @@ source-repository head

20library

21 build-depends:

22 aeson

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

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

24+ , bifunctors

24 , bytestring

25 , bytestring

25 , case-insensitive

26 , case-insensitive

27+ , comonad

26 , contravariant

28 , contravariant

27− , hasql ^>= 1.4.5.1

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

28− , opaleye ^>= 0.7.3.0

30+ , opaleye ^>= 0.9.6.1

31+ , pretty

29 , profunctors

32 , profunctors

33+ , product-profunctors

30 , scientific

34 , scientific

31 , semialign

35 , semialign

32 , semigroupoids

36 , semigroupoids

33 , text

37 , text

34 , these

38 , these

35 , time

39 , time

36− , transformers

37 , uuid

40 , uuid

38 default-language:

41 default-language:

39 Haskell2010

42 Haskell2010

40 ghc-options:

43 ghc-options:

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

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

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

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

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

43 -Wno-monomorphism-restriction

47 -Wno-monomorphism-restriction

44 -Wno-missing-local-signatures

48 -Wno-missing-local-signatures

49+ -Wno-missing-kind-signatures

45 hs-source-dirs:

50 hs-source-dirs:

46 src

51 src

47 exposed-modules:

52 exposed-modules:

@@ -49,6 +54,7 @@ library

49 Rel8.Expr.Num

54 Rel8.Expr.Num

50 Rel8.Expr.Text

55 Rel8.Expr.Text

51 Rel8.Expr.Time

56 Rel8.Expr.Time

57+ Rel8.Tabulate

53 other-modules:

59 other-modules:

54 Rel8.Aggregate

60 Rel8.Aggregate

@@ -60,6 +66,7 @@ library

60 Rel8.Column.List

66 Rel8.Column.List

61 Rel8.Column.Maybe

67 Rel8.Column.Maybe

62 Rel8.Column.NonEmpty

68 Rel8.Column.NonEmpty

69+ Rel8.Column.Null

63 Rel8.Column.These

70 Rel8.Column.These

65 Rel8.Expr

72 Rel8.Expr

@@ -75,6 +82,7 @@ library

75 Rel8.Expr.Order

82 Rel8.Expr.Order

76 Rel8.Expr.Sequence

83 Rel8.Expr.Sequence

77 Rel8.Expr.Serialize

84 Rel8.Expr.Serialize

85+ Rel8.Expr.Window

79 Rel8.FCF

87 Rel8.FCF

@@ -86,7 +94,6 @@ library

86 Rel8.Generic.Construction.Record

94 Rel8.Generic.Construction.Record

87 Rel8.Generic.Map

95 Rel8.Generic.Map

88 Rel8.Generic.Record

96 Rel8.Generic.Record

89− Rel8.Generic.Reify

90 Rel8.Generic.Rel8able

97 Rel8.Generic.Rel8able

91 Rel8.Generic.Table

98 Rel8.Generic.Table

92 Rel8.Generic.Table.ADT

99 Rel8.Generic.Table.ADT

@@ -102,20 +109,23 @@ library

102 Rel8.Query.Evaluate

109 Rel8.Query.Evaluate

103 Rel8.Query.Exists

110 Rel8.Query.Exists

104 Rel8.Query.Filter

111 Rel8.Query.Filter

112+ Rel8.Query.Indexed

105 Rel8.Query.Limit

113 Rel8.Query.Limit

106 Rel8.Query.List

114 Rel8.Query.List

107 Rel8.Query.Maybe

115 Rel8.Query.Maybe

108 Rel8.Query.Null

116 Rel8.Query.Null

109 Rel8.Query.Opaleye

117 Rel8.Query.Opaleye

110 Rel8.Query.Order

118 Rel8.Query.Order

119+ Rel8.Query.Rebind

111 Rel8.Query.Set

120 Rel8.Query.Set

112 Rel8.Query.SQL

121 Rel8.Query.SQL

113 Rel8.Query.These

122 Rel8.Query.These

114 Rel8.Query.Values

123 Rel8.Query.Values

124+ Rel8.Query.Window

115

125

116− Rel8.Schema.Context

117 Rel8.Schema.Context.Nullify

126 Rel8.Schema.Context.Nullify

118 Rel8.Schema.Dict

127 Rel8.Schema.Dict

128+ Rel8.Schema.Field

119 Rel8.Schema.HTable

129 Rel8.Schema.HTable

120 Rel8.Schema.HTable.Either

130 Rel8.Schema.HTable.Either

121 Rel8.Schema.HTable.Identity

131 Rel8.Schema.HTable.Identity

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

131 Rel8.Schema.Kind

141 Rel8.Schema.Kind

132 Rel8.Schema.Name

142 Rel8.Schema.Name

133 Rel8.Schema.Null

143 Rel8.Schema.Null

134− Rel8.Schema.Reify

135 Rel8.Schema.Result

144 Rel8.Schema.Result

136 Rel8.Schema.Spec

145 Rel8.Schema.Spec

137− Rel8.Schema.Spec.Constrain

138 Rel8.Schema.Table

146 Rel8.Schema.Table

139

147

140 Rel8.Statement.Delete

148 Rel8.Statement.Delete

141 Rel8.Statement.Insert

149 Rel8.Statement.Insert

150+ Rel8.Statement.OnConflict

142 Rel8.Statement.Returning

151 Rel8.Statement.Returning

143 Rel8.Statement.Select

152 Rel8.Statement.Select

153+ Rel8.Statement.Set

154+ Rel8.Statement.SQL

144 Rel8.Statement.Update

155 Rel8.Statement.Update

156+ Rel8.Statement.Using

145 Rel8.Statement.View

157 Rel8.Statement.View

158+ Rel8.Statement.Where

146

159

147 Rel8.Table

160 Rel8.Table

148 Rel8.Table.ADT

161 Rel8.Table.ADT

149 Rel8.Table.Aggregate

162 Rel8.Table.Aggregate

150 Rel8.Table.Alternative

163 Rel8.Table.Alternative

151 Rel8.Table.Bool

164 Rel8.Table.Bool

165+ Rel8.Table.Cols

152 Rel8.Table.Either

166 Rel8.Table.Either

153 Rel8.Table.Eq

167 Rel8.Table.Eq

154 Rel8.Table.HKD

168 Rel8.Table.HKD

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

156 Rel8.Table.Maybe

170 Rel8.Table.Maybe

157 Rel8.Table.Name

171 Rel8.Table.Name

158 Rel8.Table.NonEmpty

172 Rel8.Table.NonEmpty

173+ Rel8.Table.Null

174+ Rel8.Table.Nullify

159 Rel8.Table.Opaleye

175 Rel8.Table.Opaleye

160 Rel8.Table.Ord

176 Rel8.Table.Ord

161 Rel8.Table.Order

177 Rel8.Table.Order

162− Rel8.Table.Recontextualize

178+ Rel8.Table.Projection

163 Rel8.Table.Rel8able

179 Rel8.Table.Rel8able

164 Rel8.Table.Serialize

180 Rel8.Table.Serialize

165− Rel8.Table.Tag

166 Rel8.Table.These

181 Rel8.Table.These

182+ Rel8.Table.Transpose

167 Rel8.Table.Undefined

183 Rel8.Table.Undefined

168− Rel8.Table.Unreify

184+ Rel8.Table.Window

169

185

170 Rel8.Type

186 Rel8.Type

171 Rel8.Type.Array

187 Rel8.Type.Array

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

184 Rel8.Type.Sum

200 Rel8.Type.Sum

185 Rel8.Type.Tag

201 Rel8.Type.Tag

186

202

203+ Rel8.Window

204+

205+

187test-suite tests

206test-suite tests

188 type: exitcode-stdio-1.0

207 type: exitcode-stdio-1.0

189 build-depends:

208 build-depends:

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

192 , case-insensitive

211 , case-insensitive

193 , containers

212 , containers

194 , hasql

213 , hasql

214+ , hasql-transaction

195− , hedgehog ^>=1.0.2

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

196− , lifted-base ^>=0.2.3.12

216+ , mmorph

197− , monad-control ^>=1.0.2.3

198 , rel8

217 , rel8

199 , scientific

218 , scientific

200 , tasty

219 , tasty

@@ -202,6 +221,7 @@ test-suite tests

202 , text

221 , text

203 , time

222 , time

204 , tmp-postgres ^>=1.34.1.0

223 , tmp-postgres ^>=1.34.1.0

224+ , transformers

205 , uuid

225 , uuid

206

226

207 other-modules:

227 other-modules:

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+301−15

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

38 , HMaybe

39 , HList

40 , HNonEmpty

41+ , HNull

41 , HThese

42 , HThese

42 , Lift

43 , Lift

44 , Table(..)

45 , Table(..)

45 , HTable

46 , HTable

46− , Recontextualize

47+ , Transposes

47 , AltTable((<|>:))

48 , AltTable((<|>:))

48 , AlternativeTable( emptyTable )

49 , AlternativeTable( emptyTable )

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

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

50− , OrdTable, ascTable, descTable

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

51 , lit

52 , lit

52 , bool

53 , bool

53 , case_

54 , case_

55+ , castTable

55 -- ** @MaybeTable@

57 -- ** @MaybeTable@

56 , MaybeTable

58 , MaybeTable

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

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

58 , isNothingTable, isJustTable

60 , isNothingTable, isJustTable

61+ , fromMaybeTable

59 , optional

62 , optional

60 , catMaybeTable

63 , catMaybeTable

61 , traverseMaybeTable

64 , traverseMaybeTable

65+ , aggregateMaybeTable

62 , nameMaybeTable

66 , nameMaybeTable

64 -- ** @EitherTable@

68 -- ** @EitherTable@

@@ -68,6 +72,7 @@ module Rel8

68 , keepLeftTable

72 , keepLeftTable

69 , keepRightTable

73 , keepRightTable

70 , bitraverseEitherTable

74 , bitraverseEitherTable

75+ , aggregateEitherTable

71 , nameEitherTable

76 , nameEitherTable

73 -- ** @TheseTable@

78 -- ** @TheseTable@

@@ -76,6 +81,7 @@ 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

@@ -83,11 +89,12 @@ module Rel8

83 , keepThatTable, loseThatTable

89 , keepThatTable, loseThatTable

84 , keepThoseTable, loseThoseTable

90 , keepThoseTable, loseThoseTable

85 , bitraverseTheseTable

91 , bitraverseTheseTable

92+ , aggregateTheseTable

86 , nameTheseTable

93 , nameTheseTable

88 -- ** @ListTable@

95 -- ** @ListTable@

89 , ListTable

96 , ListTable

90− , listTable

97+ , listTable, ($*)

91 , nameListTable

98 , nameListTable

92 , many

99 , many

93 , manyExpr

100 , manyExpr

@@ -96,21 +103,44 @@ module Rel8

103

97 -- ** @NonEmptyTable@

104 -- ** @NonEmptyTable@

98 , NonEmptyTable

105 , NonEmptyTable

99− , nonEmptyTable

106+ , nonEmptyTable, ($+)

100 , nameNonEmptyTable

107 , nameNonEmptyTable

101 , some

108 , some

102 , someExpr

109 , someExpr

103 , catNonEmptyTable

110 , catNonEmptyTable

104 , catNonEmpty

111 , catNonEmpty

105

112

106− -- ** @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

107 , ADT, ADTable

127 , ADT, ADTable

128+

129+ -- *** Deconstruction of ADTs

130+ -- $deconstruction

131+ , DeconstructADT, deconstructADT

132+

133+ -- *** Construction of ADTs

134+ -- $construction

108 , BuildADT, buildADT

135 , BuildADT, buildADT

109 , ConstructADT, constructADT

136 , ConstructADT, constructADT

110− , DeconstructADT, deconstructADT

137+

111− , NameADT, nameADT

138+ -- *** Other ADT operations

112 , AggregateADT, aggregateADT

139 , AggregateADT, aggregateADT

113

140

141+ -- *** Miscellaneous notes

142+ -- $misc-notes

143+

114 -- ** @HKD@

144 -- ** @HKD@

115 , HKD, HKDable

145 , HKD, HKDable

116 , BuildHKD, buildHKD

146 , BuildHKD, buildHKD

@@ -135,6 +165,7 @@ module Rel8

135 -- ** @null@

165 -- ** @null@

136 , NotNull

166 , NotNull

137 , Nullable

167 , Nullable

168+ , Homonullable

138 , null

169 , null

139 , nullify

170 , nullify

140 , nullable

171 , nullable

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

153 , (==.), (/=.), (==?), (/=?)

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

154 , in_

185 , in_

155 , boolExpr, caseExpr

186 , boolExpr, caseExpr

187+ , like, ilike

156

188

157 -- ** Ordering

189 -- ** Ordering

158 , DBOrd

190 , DBOrd

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

170 , Query

202 , Query

171 , showQuery

203 , showQuery

172

204

205+ -- ** Projection

206+ , Projection

207+ , Projectable( project )

208+ , Biprojectable( biproject )

209+ , Projecting

210+ , Field

211+

173 -- ** Selecting rows

212 -- ** Selecting rows

174 , Selects

213 , Selects

175 , each

214 , each

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

214 , countRows

253 , countRows

215 , groupBy

254 , groupBy

216 , listAgg, listAggExpr

255 , listAgg, listAggExpr

256+ , mode

217 , nonEmptyAgg, nonEmptyAggExpr

257 , nonEmptyAgg, nonEmptyAggExpr

218 , DBMax, max

258 , DBMax, max

219 , DBMin, min

259 , DBMin, min

220− , DBSum, sum, sumWhere

260+ , DBSum, sum, sumWhere, avg

221 , DBString, stringAgg

261 , DBString, stringAgg

222 , count

262 , count

223 , countStar

263 , countStar

@@ -234,10 +274,35 @@ module Rel8

234 , nullsFirst

274 , nullsFirst

235 , nullsLast

275 , nullsLast

236

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+

237 -- * IO

303 -- * IO

238 , Serializable

304 , Serializable

239− , ToExprs(..)

305+ , ToExprs

240− , FromExprs

241 , Result

306 , Result

242

307

243 -- * Running statements

308 -- * Running statements

@@ -249,29 +314,31 @@ module Rel8

249 -- ** @INSERT@

314 -- ** @INSERT@

250 , Insert(..)

315 , Insert(..)

251 , OnConflict(..)

316 , OnConflict(..)

317+ , Upsert(..)

252 , insert

318 , insert

253 , unsafeDefault

319 , unsafeDefault

320+ , showInsert

254

321

255 -- ** @DELETE@

322 -- ** @DELETE@

256 , Delete(..)

323 , Delete(..)

257 , delete

324 , delete

325+ , showDelete

258

326

259 -- ** @UPDATE@

327 -- ** @UPDATE@

260 , Update(..)

328 , Update(..)

261 , update

329 , update

330+ , showUpdate

262

331

263 -- ** @.. RETURNING@

332 -- ** @.. RETURNING@

264 , Returning(..)

333 , Returning(..)

265

334

266 -- ** @CREATE VIEW@

335 -- ** @CREATE VIEW@

267 , createView

336 , createView

337+ , createOrReplaceView

268

338

269 -- ** Sequences

339 -- ** Sequences

270 , nextval

340 , nextval

271 , evaluate

341 , evaluate

272−

273− -- * Implementation details

274− , HKDT(..)

275 ) where

342 ) where

276

343

277-- base

344-- base

@@ -286,6 +353,7 @@ import Rel8.Column.Lift

286import Rel8.Column.List

353import Rel8.Column.List

287import Rel8.Column.Maybe

354import Rel8.Column.Maybe

288import Rel8.Column.NonEmpty

355import Rel8.Column.NonEmpty

356+import Rel8.Column.Null

289import Rel8.Column.These

357import Rel8.Column.These

290import Rel8.Expr

358import Rel8.Expr

291import Rel8.Expr.Aggregate

359import Rel8.Expr.Aggregate

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

299import Rel8.Expr.Order

367import Rel8.Expr.Order

300import Rel8.Expr.Serialize

368import Rel8.Expr.Serialize

301import Rel8.Expr.Sequence

369import Rel8.Expr.Sequence

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

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

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

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

303import Rel8.Order

373import Rel8.Order

304import Rel8.Query

374import Rel8.Query

@@ -309,15 +379,19 @@ import Rel8.Query.Either

309import Rel8.Query.Evaluate

379import Rel8.Query.Evaluate

310import Rel8.Query.Exists

380import Rel8.Query.Exists

311import Rel8.Query.Filter

381import Rel8.Query.Filter

382+import Rel8.Query.Indexed

312import Rel8.Query.Limit

383import Rel8.Query.Limit

313import Rel8.Query.List

384import Rel8.Query.List

314import Rel8.Query.Maybe

385import Rel8.Query.Maybe

315import Rel8.Query.Null

386import Rel8.Query.Null

316import Rel8.Query.Order

387import Rel8.Query.Order

388+import Rel8.Query.Rebind

317import Rel8.Query.SQL (showQuery)

389import Rel8.Query.SQL (showQuery)

318import Rel8.Query.Set

390import Rel8.Query.Set

319import Rel8.Query.These

391import Rel8.Query.These

320import Rel8.Query.Values

392import Rel8.Query.Values

393+import Rel8.Query.Window

394+import Rel8.Schema.Field

321import Rel8.Schema.HTable

395import Rel8.Schema.HTable

322import Rel8.Schema.Name

396import Rel8.Schema.Name

323import Rel8.Schema.Null hiding ( nullable )

397import Rel8.Schema.Null hiding ( nullable )

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

325import Rel8.Schema.Table

399import Rel8.Schema.Table

326import Rel8.Statement.Delete

400import Rel8.Statement.Delete

327import Rel8.Statement.Insert

401import Rel8.Statement.Insert

402+import Rel8.Statement.OnConflict

328import Rel8.Statement.Returning

403import Rel8.Statement.Returning

329import Rel8.Statement.Select

404import Rel8.Statement.Select

405+import Rel8.Statement.SQL

330import Rel8.Statement.Update

406import Rel8.Statement.Update

331import Rel8.Statement.View

407import Rel8.Statement.View

332import Rel8.Table

408import Rel8.Table

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

341import Rel8.Table.Maybe

417import Rel8.Table.Maybe

342import Rel8.Table.Name

418import Rel8.Table.Name

343import Rel8.Table.NonEmpty

419import Rel8.Table.NonEmpty

420+import Rel8.Table.Null

421+import Rel8.Table.Opaleye ( castTable )

344import Rel8.Table.Ord

422import Rel8.Table.Ord

345import Rel8.Table.Order

423import Rel8.Table.Order

346−import Rel8.Table.Recontextualize

424+import Rel8.Table.Projection

347import Rel8.Table.Rel8able ()

425import Rel8.Table.Rel8able ()

348import Rel8.Table.Serialize

426import Rel8.Table.Serialize

349import Rel8.Table.These

427import Rel8.Table.These

428+import Rel8.Table.Transpose

429+import Rel8.Table.Window

350import Rel8.Type

430import Rel8.Type

351import Rel8.Type.Composite

431import Rel8.Type.Composite

352import Rel8.Type.Eq

432import Rel8.Type.Eq

@@ -361,6 +441,7 @@ import Rel8.Type.ReadShow

361import Rel8.Type.Semigroup

441import Rel8.Type.Semigroup

362import Rel8.Type.String

442import Rel8.Type.String

363import Rel8.Type.Sum

443import Rel8.Type.Sum

444+import Rel8.Window

364

445

365

446

366-- $running

447-- $running

@@ -368,3 +449,208 @@ import Rel8.Type.Sum

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

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

369-- 'insert', 'update' and 'delete' will generally need the

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

370-- `DuplicateRecordFields` language extension enabled.

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

@@ -1,149 +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.HTable.Identity ( HIdentity(..), HType )

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

37−import Rel8.Schema.Name ( Name )

34+import qualified Rel8.Schema.Kind as K

38import Rel8.Schema.Null ( Sql )

35import Rel8.Schema.Null ( Sql )

39−import Rel8.Schema.Reify ( notReify )

40−import Rel8.Schema.Result ( Result )

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

42import Rel8.Table

36import Rel8.Table

43 ( Table, Columns, Context, fromColumns, toColumns

37 ( Table, Columns, Context, fromColumns, toColumns

44− , reify, unreify

38+ , FromExprs, fromResult, toResult

39+ , Transpose

45 )

40 )

46−import Rel8.Table.Recontextualize ( Recontextualize )

41+import Rel8.Table.Transpose ( Transposes )

47import Rel8.Type ( DBType )

42import Rel8.Type ( DBType )

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

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

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

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

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

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

55−type Aggregate :: k -> Type

46+type Aggregate :: K.Context

56−data Aggregate a where

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

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

58−

59−

60−instance Interpretation Aggregate where

61− data Col Aggregate _spec where

62− A :: ()

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

64− -> Col Aggregate ('Spec a)

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

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

68− type Columns (Aggregate a) = HType a

51+ type Columns (Aggregate a) = HIdentity a

69 type Context (Aggregate a) = Aggregate

52 type Context (Aggregate a) = Aggregate

53+ type FromExprs (Aggregate a) = a

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

71− toColumns = HIdentity . A

56+ toColumns = HIdentity

57+ fromColumns (HIdentity a) = a

58+ toResult = HIdentity . Identity

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

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

73−

74− reify = notReify

75− unreify = notReify

76−

77−

78−instance Sql DBType a =>

79− Recontextualize Aggregate Aggregate (Aggregate a) (Aggregate a)

80−

81−

82−instance Sql DBType a =>

83− Recontextualize Aggregate Expr (Aggregate a) (Expr a)

84−

85−

86−instance Sql DBType a =>

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

88−

90−instance Sql DBType a =>

91− Recontextualize Aggregate Name (Aggregate a) (Name a)

93−

94−instance Sql DBType a =>

95− Recontextualize Expr Aggregate (Expr a) (Aggregate a)

96−

97−

98−instance Sql DBType a =>

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

100−

101−

102−instance Sql DBType a =>

103− Recontextualize Name Aggregate (Name a) (Aggregate a)

104−

105−

106−-- | @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

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

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

108type Aggregates :: Type -> Type -> Constraint

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

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

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

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

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

111−

112−

113−foldInputs :: Monoid b

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

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

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

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

118− where

119− detuplize (operation, ordering, distinction) =

120− Aggregator {operation, ordering, distinction}

121−

122−

123−mapInputs :: ()

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

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

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

127− f (fmap transform input)

128

129

130−type Aggregator :: Type

69+zipOutputs :: ()

131−data Aggregator = Aggregator

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

132− { operation :: Opaleye.AggrOp

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

133− , ordering :: [Opaleye.OrderExpr]

134− , distinction :: Opaleye.AggrDistinct

135− }

136

137

138−unsafeMakeAggregate :: ()

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

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

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

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

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

141− -> Maybe Aggregator

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

142 -> Expr input

78 -> Expr input

143 -> Aggregate output

79 -> Aggregate output

144unsafeMakeAggregate input output aggregator expr =

80unsafeMakeAggregate input output aggregator expr =

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

81+ Aggregate $ dimap in_ out aggregator

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

82+ where out = output . Opaleye.unColumn

147− where

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

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

149− (operation, ordering, distinction)

src/Rel8/Column.hs+5−77

@@ -1,38 +1,21 @@

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(..), HType )

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 )

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

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

@@ -40,63 +23,8 @@ import Rel8.Type ( DBType )

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

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

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

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

42type family Column context a where

25type family Column context a where

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

44− Column Aggregate a = Aggregate a

45− Column Expr a = Expr a

46− Column Name a = Name a

47− Column Result a = a

26+ Column Result a = a

48−

49−

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

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

52−

53−

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

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

56− where

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

58− type Columns (AColumn context a) = HType a

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

27+ Column context a = context a

60−

61− fromColumns (HType (Reify a)) = sfromColumn contextSing a

62− toColumns = HType . Reify . stoColumn contextSing

63− reify _ = AColumn

64− unreify _ (AColumn a) = a

65−

66−

67−instance

68− ( Reifiable context, Reifiable context'

69− , Sql DBType a

70− ) =>

71− Recontextualize

72− (Reify context)

73− (Reify context')

74− (AColumn context a)

75− (AColumn context' a)

76−

77−

78−sfromColumn :: ()

79− => SContext context

80− -> Col context ('Spec a)

81− -> AColumn context a

82−sfromColumn = \case

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

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

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

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

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

88−

89−

90−stoColumn :: ()

91− => SContext context

92− -> AColumn context a

93− -> Col context ('Spec a)

94−stoColumn = \case

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

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

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

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

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

100

101

102data 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+4−140

@@ -1,162 +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 )

38-- | Nest an 'Either' value within a 'Rel8able'. @HEither f a b@ will produce a

20-- | Nest an 'Either' value within a 'Rel8able'. @HEither f a b@ will produce a

39-- 'EitherTable' @a b@ in the 'Expr' context, and a 'Either' @a b@ in the

21-- 'EitherTable' @a b@ in the 'Expr' context, and a 'Either' @a b@ in the

40-- 'Result' context.

22-- 'Result' context.

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

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

42−type family HEither context where

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

43− HEither (Reify context) = AHEither context

44− HEither Aggregate = EitherTable

45− HEither Expr = EitherTable

46− HEither Name = EitherTable

47 HEither Result = Either

25 HEither Result = Either

48−

26+ HEither context = EitherTable context

49−

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

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

52−

53−

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

55− bimap = sbimapEither contextSing

56−

57−

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

59− fmap = bimap id

60−

61−

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

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

64− where

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

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

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

68−

69− fromColumns = sfromColumnsEither contextSing

70− toColumns = stoColumnsEither contextSing

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

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

73−

74−

75−instance

76− ( Reifiable context, Reifiable context'

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

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

79− ) =>

80− Recontextualize

81− (Reify context)

82− (Reify context')

83− (AHEither context a b)

84− (AHEither context' a' b')

85−

86−

87−sbimapEither :: ()

88− => SContext context

89− -> (a -> c)

90− -> (b -> d)

91− -> AHEither context a b

92− -> AHEither context c d

93−sbimapEither = \case

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

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

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

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

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

99−

100−

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

102− => SContext context

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

104− -> AHEither context a b

105−sfromColumnsEither = \case

106− SAggregate ->

107− AHEither .

108− bimap (fromColumns . hreify) (fromColumns . hreify) .

109− fromColumns .

110− hunreify

111− SExpr ->

112− AHEither .

113− bimap (fromColumns . hreify) (fromColumns . hreify) .

114− fromColumns .

115− hunreify

116− SResult ->

117− AHEither .

118− bimap (fromColumns . hreify) (fromColumns . hreify) .

119− fromColumns .

120− hunreify

121− SName ->

122− AHEither .

123− bimap (fromColumns . hreify) (fromColumns . hreify) .

124− fromColumns .

125− hunreify

126− SReify context ->

127− AHEither .

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

129− sfromColumnsEither context .

130− hunreify

131−

132−

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

134− => SContext context

135− -> AHEither context a b

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

137−stoColumnsEither = \case

138− SAggregate ->

139− hreify .

140− toColumns .

141− bimap (hunreify . toColumns) (hunreify . toColumns) .

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

143− SExpr ->

144− hreify .

145− toColumns .

146− bimap (hunreify . toColumns) (hunreify . toColumns) .

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

148− SResult ->

149− hreify .

150− toColumns .

151− bimap (hunreify . toColumns) (hunreify . toColumns) .

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

153− SName ->

154− hreify .

155− toColumns .

156− bimap (hunreify . toColumns) (hunreify . toColumns) .

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

158− SReify context ->

159− hreify .

160− stoColumnsEither context .

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

162− (\(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+6−126

@@ -1,145 +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 )

38-- | Nest a list within a 'Rel8able'. @HList f a@ will produce a 'ListTable'

20-- | Nest a list within a 'Rel8able'. @HList f a@ will produce a 'ListTable'

39-- @a@ in the 'Expr' context, and a @[a]@ in the 'Result' context.

21-- @a@ in the 'Expr' context, and a @[a]@ in the 'Result' context.

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

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

41−type family HList context where

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

42− HList (Reify context) = AHList context

43− HList Aggregate = ListTable

44− HList Expr = ListTable

45− HList Name = ListTable

46 HList Result = []

24 HList Result = []

47−

25+ HList context = ListTable context

48−

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

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

51−

52−

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

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

55− where

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

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

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

59−

60− fromColumns = sfromColumnsList contextSing

61− toColumns = stoColumnsList contextSing

62−

63− reify _ = sreifyList (unreifiability contextSing)

64− unreify _ = sunreifyList (unreifiability contextSing)

65−

66−

67−instance

68− ( Reifiable context, Reifiable context'

69− , Unreifiable a, Unreifiable a'

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

71− )

72− => Recontextualize

73− (Reify context)

74− (Reify context')

75− (AHList context a)

76− (AHList context' a')

77−

78−

79−smapList :: Congruent a b

80− => SContext context

81− -> (a -> b)

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

83− -> AHList context a

84− -> AHList context b

85−smapList = \case

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

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

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

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

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

91−

92−

93−sfromColumnsList :: Table (Reify context) a

94− => SContext context

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

96− -> AHList context a

97−sfromColumnsList = \case

98− SAggregate -> AHList . ListTable

99− SExpr -> AHList . ListTable

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

101− SName -> AHList . ListTable

102− SReify context ->

103− AHList .

104− smapList context (fromColumns . hreify) hreify .

105− sfromColumnsList context .

106− hunreify

107−

108−

109−stoColumnsList :: Table (Reify context) a

110− => SContext context

111− -> AHList context a

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

113−stoColumnsList = \case

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

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

116− SResult ->

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

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

119− SReify context ->

120− hreify .

121− stoColumnsList context .

122− smapList context (hunreify . toColumns) hunreify .

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

124−

125−

126−sreifyList :: Table (Reify context) a

127− => Unreifiability context a

128− -> HList context (Unreify a)

129− -> AHList context a

130−sreifyList = \case

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

132− Unreifiability context ->

133− smapList context (reify Refl) hreify .

134− AHList

135−

136−

137−sunreifyList :: Table (Reify context) a

138− => Unreifiability context a

139− -> AHList context a

140− -> HList context (Unreify a)

141−sunreifyList = \case

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

143− Unreifiability context ->

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

145− smapList context (unreify Refl) hunreify

src/Rel8/Column/Maybe.hs+4−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,111 +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 )

37-- | Nest a 'Maybe' value within a 'Rel8able'. @HMaybe f a@ will produce a

20-- | Nest a 'Maybe' value within a 'Rel8able'. @HMaybe f a@ will produce a

38-- 'MaybeTable' @a@ in the 'Expr' context, and a 'Maybe' @a@ in the 'Result'

21-- 'MaybeTable' @a@ in the 'Expr' context, and a 'Maybe' @a@ in the 'Result'

39-- context.

22-- context.

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

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

41−type family HMaybe context where

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

42− HMaybe (Reify context) = AHMaybe context

43− HMaybe Aggregate = MaybeTable

44− HMaybe Expr = MaybeTable

45− HMaybe Name = MaybeTable

46 HMaybe Result = Maybe

25 HMaybe Result = Maybe

47−

26+ HMaybe context = MaybeTable context

48−

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

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

51−

52−

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

54− fmap = smapMaybe contextSing

55−

56−

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

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

59− where

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

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

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

63−

64− fromColumns = sfromColumnsMaybe contextSing

65− toColumns = stoColumnsMaybe contextSing

66− reify proof = fmap fmap reify proof . AHMaybe

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

68−

69−

70−instance

71− ( Reifiable context, Reifiable context'

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

73− ) =>

74− Recontextualize

75− (Reify context)

76− (Reify context')

77− (AHMaybe context a)

78− (AHMaybe context' a')

79−

80−

81−smapMaybe :: ()

82− => SContext context

83− -> (a -> b)

84− -> AHMaybe context a

85− -> AHMaybe context b

86−smapMaybe = \case

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

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

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

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

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

92−

93−

94−sfromColumnsMaybe :: Table (Reify context) a

95− => SContext context

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

97− -> AHMaybe context a

98−sfromColumnsMaybe = \case

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

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

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

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

103− SReify context ->

104− AHMaybe .

105− smapMaybe context (fromColumns . hreify) .

106− sfromColumnsMaybe context .

107− hunreify

108−

109−

110−stoColumnsMaybe :: Table (Reify context) a

111− => SContext context

112− -> AHMaybe context a

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

114−stoColumnsMaybe = \case

115− SAggregate ->

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

117− SExpr ->

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

119− SResult ->

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

121− SName ->

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

123− SReify context ->

124− hreify .

125− stoColumnsMaybe context .

126− smapMaybe context (hunreify . toColumns) .

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

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

@@ -1,148 +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 )

39-- | Nest a 'NonEmpty' list within a 'Rel8able'. @HNonEmpty f a@ will produce a

21-- | Nest a 'NonEmpty' list within a 'Rel8able'. @HNonEmpty f a@ will produce a

40-- 'NonEmptyTable' @a@ in the 'Expr' context, and a 'NonEmpty' @a@ in the

22-- 'NonEmptyTable' @a@ in the 'Expr' context, and a 'NonEmpty' @a@ in the

41-- 'Result' context.

23-- 'Result' context.

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

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

43−type family HNonEmpty context where

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

44− HNonEmpty (Reify context) = AHNonEmpty context

45− HNonEmpty Aggregate = NonEmptyTable

46− HNonEmpty Expr = NonEmptyTable

47− HNonEmpty Name = NonEmptyTable

48 HNonEmpty Result = NonEmpty

26 HNonEmpty Result = NonEmpty

49−

27+ HNonEmpty context = NonEmptyTable context

50−

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

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

53−

54−

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

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

57− where

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

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

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

61−

62− fromColumns = sfromColumnsNonEmpty contextSing

63− toColumns = stoColumnsNonEmpty contextSing

64−

65− reify _ = sreifyNonEmpty (unreifiability contextSing)

66− unreify _ = sunreifyNonEmpty (unreifiability contextSing)

67−

68−

69−instance

70− ( Reifiable context, Reifiable context'

71− , Unreifiable a, Unreifiable a'

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

73− )

74− => Recontextualize

75− (Reify context)

76− (Reify context')

77− (AHNonEmpty context a)

78− (AHNonEmpty context' a')

79−

80−

81−smapNonEmpty :: Congruent a b

82− => SContext context

83− -> (a -> b)

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

85− -> AHNonEmpty context a

86− -> AHNonEmpty context b

87−smapNonEmpty = \case

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

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

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

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

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

93−

94−

95−sfromColumnsNonEmpty :: Table (Reify context) a

96− => SContext context

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

98− -> AHNonEmpty context a

99−sfromColumnsNonEmpty = \case

100− SAggregate -> AHNonEmpty . NonEmptyTable

101− SExpr -> AHNonEmpty . NonEmptyTable

102− SResult ->

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

104− SName -> AHNonEmpty . NonEmptyTable

105− SReify context ->

106− AHNonEmpty .

107− smapNonEmpty context (fromColumns . hreify) hreify .

108− sfromColumnsNonEmpty context .

109− hunreify

110−

111−

112−stoColumnsNonEmpty :: Table (Reify context) a

113− => SContext context

114− -> AHNonEmpty context a

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

116−stoColumnsNonEmpty = \case

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

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

119− SResult ->

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

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

122− SReify context ->

123− hreify .

124− stoColumnsNonEmpty context .

125− smapNonEmpty context (hunreify . toColumns) hunreify .

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

127−

128−

129−sreifyNonEmpty :: Table (Reify context) a

130− => Unreifiability context a

131− -> HNonEmpty context (Unreify a)

132− -> AHNonEmpty context a

133−sreifyNonEmpty = \case

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

135− Unreifiability context ->

136− smapNonEmpty context (reify Refl) hreify .

137− AHNonEmpty

138−

139−

140−sunreifyNonEmpty :: Table (Reify context) a

141− => Unreifiability context a

142− -> AHNonEmpty context a

143− -> HNonEmpty context (Unreify a)

144−sunreifyNonEmpty = \case

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

146− Unreifiability context ->

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

148− 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+5−142

@@ -1,38 +1,19 @@

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

@@ -43,124 +24,6 @@ import Data.These ( These )

43-- 'TheseTable' @a b@ in the 'Expr' context, and a 'These' @a b@ in the

24-- 'TheseTable' @a b@ in the 'Expr' context, and a 'These' @a b@ in the

44-- 'Result' context.

25-- 'Result' context.

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

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

46−type family HThese context where

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

47− HThese (Reify context) = AHThese context

48− HThese Aggregate = TheseTable

49− HThese Expr = TheseTable

50− HThese Name = TheseTable

51 HThese Result = These

28 HThese Result = These

52−

29+ HThese context = TheseTable context

53−

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

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

56−

57−

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

59− bimap = sbimapThese contextSing

60−

61−

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

63− fmap = bimap id

64−

65−

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

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

68− where

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

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

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

72−

73− fromColumns = sfromColumnsThese contextSing

74− toColumns = stoColumnsThese contextSing

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

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

77−

78−

79−instance

80− ( Reifiable context, Reifiable context'

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

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

83− ) =>

84− Recontextualize

85− (Reify context)

86− (Reify context')

87− (AHThese context a b)

88− (AHThese context' a' b')

89−

90−

91−sbimapThese :: ()

92− => SContext context

93− -> (a -> c)

94− -> (b -> d)

95− -> AHThese context a b

96− -> AHThese context c d

97−sbimapThese = \case

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

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

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

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

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

103−

104−

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

106− => SContext context

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

108− -> AHThese context a b

109−sfromColumnsThese = \case

110− SAggregate ->

111− AHThese .

112− bimap (fromColumns . hreify) (fromColumns . hreify) .

113− fromColumns .

114− hunreify

115− SExpr ->

116− AHThese .

117− bimap (fromColumns . hreify) (fromColumns . hreify) .

118− fromColumns .

119− hunreify

120− SResult ->

121− AHThese .

122− bimap (fromColumns . hreify) (fromColumns . hreify) .

123− fromColumns .

124− hunreify

125− SName ->

126− AHThese .

127− bimap (fromColumns . hreify) (fromColumns . hreify) .

128− fromColumns .

129− hunreify

130− SReify context ->

131− AHThese .

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

133− sfromColumnsThese context .

134− hunreify

135−

136−

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

138− => SContext context

139− -> AHThese context a b

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

141−stoColumnsThese = \case

142− SAggregate ->

143− hreify .

144− toColumns .

145− bimap (hunreify . toColumns) (hunreify . toColumns) .

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

147− SExpr ->

148− hreify .

149− toColumns .

150− bimap (hunreify . toColumns) (hunreify . toColumns) .

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

152− SResult ->

153− hreify .

154− toColumns .

155− bimap (hunreify . toColumns) (hunreify . toColumns) .

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

157− SName ->

158− hreify .

159− toColumns .

160− bimap (hunreify . toColumns) (hunreify . toColumns) .

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

162− SReify context ->

163− hreify .

164− stoColumnsThese context .

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

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

src/Rel8/Expr.hs+17−41

@@ -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,16 +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.HTable.Identity ( HIdentity( HType ), HType )

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

36+import qualified Rel8.Schema.Kind as K

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

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

44−import Rel8.Schema.Reify ( notReify )

45−import Rel8.Schema.Result ( Result )

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

47import Rel8.Table

38import Rel8.Table

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

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

40+ , FromExprs, fromResult, toResult

41+ , Transpose

49 )

42 )

50−import Rel8.Table.Recontextualize ( Recontextualize )

51import Rel8.Type ( DBType )

43import Rel8.Type ( DBType )

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

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

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

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

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

57-- | Typed SQL expressions.

49-- | Typed SQL expressions.

58−type role Expr representational

50+type Expr :: K.Context

59−type Expr :: k -> Type

60−data Expr a where

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

51+newtype Expr a = Expr Opaleye.PrimExpr

62−

63−

64−deriving stock instance Show (Expr a)

52+ deriving stock Show

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

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

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

125 atanh = function "atanh"

113 atanh = function "atanh"

126

114

127

115

128−instance Interpretation Expr where

129− data Col Expr _spec where

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

131−

132−

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

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

134− type Columns (Expr a) = HType a

117+ type Columns (Expr a) = HIdentity a

135 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

136

121

137− toColumns a = HType (E a)

122+ toColumns a = HIdentity a

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

123+ fromColumns (HIdentity a) = a

139− reify = notReify

124+ toResult a = HIdentity (Identity a)

140− unreify = notReify

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

141−

142−

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

144−

145−

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

147−

148−

149−instance Sql DBType a => Recontextualize Result Expr (Identity a) (Expr 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/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+12−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

@@ -80,9 +83,15 @@ traversePrimExpr :: Functor f

80traversePrimExpr 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+

83−toColumn :: Opaleye.PrimExpr -> Opaleye.Column b

92+toColumn :: Opaleye.PrimExpr -> Opaleye.Field_ n b

84toColumn = Opaleye.Column

93toColumn = Opaleye.Column

87−fromColumn :: Opaleye.Column b -> Opaleye.PrimExpr

96+fromColumn :: Opaleye.Field_ n b -> Opaleye.PrimExpr

88fromColumn (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+20−27

@@ -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 #-}

@@ -49,12 +50,12 @@ import Rel8.Generic.Construction.Record

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 )

51import Rel8.Schema.HTable ( HTable )

52import Rel8.Schema.HTable ( HTable )

52−import Rel8.Schema.HTable.Identity ( HType )

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

53import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )

54import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )

54import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify )

55import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify )

55import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )

56import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )

56import Rel8.Schema.Null ( Nullify )

57import Rel8.Schema.Null ( Nullify )

57−import Rel8.Schema.Spec ( Spec( Spec ), SSpec )

58+import Rel8.Schema.Spec ( Spec )

58import qualified Rel8.Schema.Kind as K

59import qualified Rel8.Schema.Kind as K

59import Rel8.Type.Tag ( Tag( Tag ) )

60import Rel8.Type.Tag ( Tag( Tag ) )

@@ -62,24 +63,16 @@ import Rel8.Type.Tag ( Tag( Tag ) )

62import Data.Text ( pack )

63import Data.Text ( pack )

65−type Null :: K.HContext -> Type

66+type Null :: K.Context -> Type

66−type Null context = forall a. ()

67+type Null context = forall a. Spec a -> context (Nullify a)

67− => SSpec ('Spec a)

68− -> context ('Spec (Nullify a))

71−type Nullifier :: K.HContext -> Type

70+type Nullifier :: K.Context -> Type

72−type Nullifier context = forall a. ()

71+type Nullifier context = forall a. Spec a -> context a -> context (Nullify a)

73− => SSpec ('Spec a)

74− -> context ('Spec a)

75− -> context ('Spec (Nullify a))

78−type Unnullifier :: K.HContext -> Type

74+type Unnullifier :: K.Context -> Type

79−type Unnullifier context = forall a. ()

75+type Unnullifier context = forall a. Spec a -> context (Nullify a) -> context a

80− => SSpec ('Spec a)

81− -> context ('Spec (Nullify a))

82− -> context ('Spec a)

85type NoConstructor :: Symbol -> Symbol -> ErrorMessage

78type NoConstructor :: Symbol -> Symbol -> ErrorMessage

@@ -188,12 +181,12 @@ type GConstructableADT

188 :: (Type -> Exp Constraint)

181 :: (Type -> Exp Constraint)

189 -> (Type -> Exp K.HTable)

182 -> (Type -> Exp K.HTable)

190 -> (Type -> Exp Type)

183 -> (Type -> Exp Type)

191− -> K.HContext -> (Type -> Type) -> Constraint

184+ -> K.Context -> (Type -> Type) -> Constraint

192class GConstructableADT _Table _Columns f context rep where

185class GConstructableADT _Table _Columns f context rep where

193 gbuildADT :: ()

186 gbuildADT :: ()

194 => ToColumns _Table _Columns f context

187 => ToColumns _Table _Columns f context

195 -> (Tag -> Nullifier context)

188 -> (Tag -> Nullifier context)

196− -> HType Tag context

189+ -> HIdentity Tag context

197 -> GFieldsADT f rep

190 -> GFieldsADT f rep

198 -> GColumnsADT _Columns rep context

191 -> GColumnsADT _Columns rep context

199

192

@@ -201,13 +194,13 @@ class GConstructableADT _Table _Columns f context rep where

201 => FromColumns _Table _Columns f context

194 => FromColumns _Table _Columns f context

202 -> Unnullifier context

195 -> Unnullifier context

203 -> GColumnsADT _Columns rep context

196 -> GColumnsADT _Columns rep context

204− -> (HType Tag context, GFieldsADT f rep)

197+ -> (HIdentity Tag context, GFieldsADT f rep)

205

198

206 gconstructADT :: ()

199 gconstructADT :: ()

207 => ToColumns _Table _Columns f context

200 => ToColumns _Table _Columns f context

208 -> Null context

201 -> Null context

209 -> Nullifier context

202 -> Nullifier context

210− -> (Tag -> HType Tag context)

203+ -> (Tag -> HIdentity Tag context)

211 -> GConstructors f rep (GColumnsADT _Columns rep context)

204 -> GConstructors f rep (GColumnsADT _Columns rep context)

212

205

213 gdeconstructADT :: ()

206 gdeconstructADT :: ()

@@ -215,11 +208,11 @@ class GConstructableADT _Table _Columns f context rep where

215 -> Unnullifier context

208 -> Unnullifier context

216 -> GConstructors f rep r

209 -> GConstructors f rep r

217 -> GColumnsADT _Columns rep context

210 -> GColumnsADT _Columns rep context

218− -> (HType Tag context, NonEmpty (Tag, r))

211+ -> (HIdentity Tag context, NonEmpty (Tag, r))

219

212

220

213

221instance

214instance

222− ( htable ~ HLabel "tag" (HType Tag)

215+ ( htable ~ HLabel "tag" (HIdentity Tag)

223 , GConstructableADT' _Table _Columns f context htable rep

216 , GConstructableADT' _Table _Columns f context htable rep

224 )

217 )

225 => GConstructableADT _Table _Columns f context (M1 D meta rep)

218 => GConstructableADT _Table _Columns f context (M1 D meta rep)

@@ -245,7 +238,7 @@ type GConstructableADT'

245 :: (Type -> Exp Constraint)

238 :: (Type -> Exp Constraint)

246 -> (Type -> Exp K.HTable)

239 -> (Type -> Exp K.HTable)

247 -> (Type -> Exp Type)

240 -> (Type -> Exp Type)

248− -> K.HContext -> K.HTable -> (Type -> Type) -> Constraint

241+ -> K.Context -> K.HTable -> (Type -> Type) -> Constraint

249class GConstructableADT' _Table _Columns f context htable rep where

242class GConstructableADT' _Table _Columns f context htable rep where

250 gbuildADT' :: ()

243 gbuildADT' :: ()

251 => ToColumns _Table _Columns f context

244 => ToColumns _Table _Columns f context

@@ -383,19 +376,19 @@ type GMakeableADT

383 :: (Type -> Exp Constraint)

376 :: (Type -> Exp Constraint)

384 -> (Type -> Exp K.HTable)

377 -> (Type -> Exp K.HTable)

385 -> (Type -> Exp Type)

378 -> (Type -> Exp Type)

386− -> K.HContext -> Symbol -> (Type -> Type) -> Constraint

379+ -> K.Context -> Symbol -> (Type -> Type) -> Constraint

387class GMakeableADT _Table _Columns f context name rep where

380class GMakeableADT _Table _Columns f context name rep where

388 gmakeADT :: ()

381 gmakeADT :: ()

389 => ToColumns _Table _Columns f context

382 => ToColumns _Table _Columns f context

390 -> Null context

383 -> Null context

391 -> Nullifier context

384 -> Nullifier context

392− -> (Tag -> HType Tag context)

385+ -> (Tag -> HIdentity Tag context)

393 -> GFields f (GConstructorADT name rep)

386 -> GFields f (GConstructorADT name rep)

394 -> GColumnsADT _Columns rep context

387 -> GColumnsADT _Columns rep context

395

388

396

389

397instance

390instance

398− ( htable ~ HLabel "tag" (HType Tag)

391+ ( htable ~ HLabel "tag" (HIdentity Tag)

399 , meta ~ 'MetaData datatype _module _package _newtype

392 , meta ~ 'MetaData datatype _module _package _newtype

400 , fallback ~ TypeError (NoConstructor datatype name)

393 , fallback ~ TypeError (NoConstructor datatype name)

401 , fields ~ GFields f (GConstructorADT' name rep fallback)

394 , fields ~ GFields f (GConstructorADT' name rep fallback)

@@ -417,7 +410,7 @@ type GMakeableADT'

417 :: (Type -> Exp Constraint)

410 :: (Type -> Exp Constraint)

418 -> (Type -> Exp K.HTable)

411 -> (Type -> Exp K.HTable)

419 -> (Type -> Exp Type)

412 -> (Type -> Exp Type)

420− -> K.HContext -> K.HTable -> Symbol -> (Type -> Type) -> Type -> Constraint

413+ -> K.Context -> K.HTable -> Symbol -> (Type -> Type) -> Type -> Constraint

421class GMakeableADT' _Table _Columns f context htable name rep fields where

414class GMakeableADT' _Table _Columns f context htable name rep fields where

422 gmakeADT' :: ()

415 gmakeADT' :: ()

423 => ToColumns _Table _Columns f context

416 => ToColumns _Table _Columns f context

src/Rel8/Generic/Construction/Record.hs+3−3

@@ -43,7 +43,7 @@ type FromColumns

43 :: (Type -> Exp Constraint)

44 -> (Type -> Exp K.HTable)

45 -> (Type -> Exp Type)

46− -> K.HContext

46+ -> K.Context

47 -> Type

48type FromColumns _Table _Columns f context = forall proxy x.

49 Eval (_Table x) => proxy x -> Eval (_Columns x) context -> Eval (f x)

@@ -53,7 +53,7 @@ type ToColumns

53 :: (Type -> Exp Constraint)

54 -> (Type -> Exp K.HTable)

55 -> (Type -> Exp Type)

56− -> K.HContext

56+ -> K.Context

57 -> Type

58type ToColumns _Table _Columns f context = forall proxy x.

59 Eval (_Table x) => proxy x -> Eval (f x) -> Eval (_Columns x) context

@@ -117,7 +117,7 @@ type GConstructable

117 :: (Type -> Exp Constraint)

118 -> (Type -> Exp K.HTable)

119 -> (Type -> Exp Type)

120− -> K.HContext -> (Type -> Type) -> Constraint

120+ -> K.Context -> (Type -> Type) -> Constraint

121class GConstructable _Table _Columns f context rep where

122 gconstruct :: ()

123 => ToColumns _Table _Columns f context

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+178−71

@@ -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,35 +20,39 @@ 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(..) )

44+import Rel8.Schema.Field ( Field )

39import Rel8.Schema.HTable ( HTable )

45import Rel8.Schema.HTable ( HTable )

40import qualified Rel8.Schema.Kind as K

46import qualified Rel8.Schema.Kind as K

41−import Rel8.Schema.Reify ( Reify, UnwrapReify )

47+import Rel8.Schema.Name ( Name )

42import Rel8.Schema.Result ( Result )

48import Rel8.Schema.Result ( Result )

43import Rel8.Table

49import Rel8.Table

44− ( fromColumns, toColumns, reify, unreify

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

51+ , FromExprs, fromResult, toResult

52+ , Transpose

45− , TTable, TColumns, TContext, TUnreify

53+ , TTable, TColumns

46 )

54 )

55+import Rel8.Table.Transpose ( Transposes )

49-- | The kind of 'Rel8able' types

58-- | The kind of 'Rel8able' types

@@ -51,6 +60,59 @@ type 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--

@@ -84,7 +146,7 @@ type KRel8able = K.Rel8able

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-- @

@@ -96,79 +158,124 @@ type KRel8able = K.Rel8able

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 :: Reifiable context

101− => GColumns t (Col (Reify context)) -> t (Reify context)

163+ gfromColumns :: SContext context -> GColumns t context -> t context

102−

103− gtoColumns :: Reifiable context

104− => t (Reify context) -> GColumns t (Col (Reify context))

164+ gtoColumns :: SContext context -> t context -> GColumns t context

105

165

106− greify :: Reifiable context

166+ gfromResult :: GColumns t Result -> GFromExprs t

107− => t context -> t (Reify context)

167+ gtoResult :: GFromExprs t -> GColumns t Result

108

168

109− gunreify :: Reifiable context

110− => t (Reify context) -> t context

111−

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 )

193 )

142− => t context -> t (Reify context)

194+ => SContext context -> t context -> GColumns t context

143− greify =

195+ gtoColumns = \case

144− unrecord .

196+ SAggregate -> stoColumns

145− to .

197+ SExpr -> stoColumns

146− gunmap @(TTable (Reify context)) (Proxy @TUnreify) (reify Refl) .

198+ SField -> stoColumns

147− from .

199+ SName -> stoColumns

148− Record

200+ SResult -> stoResult

149−

201+

150− default gunreify :: forall context.

202+ default gfromResult :: (SSerialize t, GFromExprs t ~ t Result)

151− ( Generic (Record (t context))

203+ => GColumns t Result -> GFromExprs t

152− , Generic (Record (t (Reify context)))

204+ gfromResult = sfromResult

153− , GMappable (TTable (Reify context)) (GRep t (Reify context))

205+

154− , GRep t context ~ GMap TUnreify (GRep t (Reify context))

206+ default gtoResult :: (SSerialize t, GFromExprs t ~ t Result)

155− )

207+ => GFromExprs t -> GColumns t Result

156− => t (Reify context) -> t context

208+ gtoResult = stoResult

157− gunreify =

158− unrecord .

159− to .

160− gmap @(TTable (Reify context)) (Proxy @TUnreify) (unreify Refl) .

161− from .

162− Record

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+22−107

@@ -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 f g h x = case algebraSing @algebra of

128− SProduct -> gfromColumns @_Table @_Columns h x

129− SSum -> gfromColumnsADT @_Table @_Columns f g h x

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 f g h x = case algebraSing @algebra of

142− SProduct -> gtoColumns @_Table @_Columns h x

143− SSum -> gtoColumnsADT @_Table @_Columns f g h x

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. ()

152− => SSpec ('Spec a)

153− -> context ('Spec a)

154− -> context ('Spec (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

171ggfromResult f x = case algebraSing @algebra of

88ggfromResult f x = case algebraSing @algebra of

172− SProduct -> gfromResult @_ToExprs @_Columns @exprs f x

89+ SProduct -> gfromResult @_Serialize @_Columns @exprs @rep f x

173− SSum -> gfromResultADT @_ToExprs @_Columns @exprs f x

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

186ggtoResult f x = case algebraSing @algebra of

101ggtoResult f x = case algebraSing @algebra of

187− SProduct -> gtoResult @_ToExprs @_Columns @exprs f x

102+ SProduct -> gtoResult @_Serialize @_Columns @exprs @rep f x

188− SSum -> gtoResultADT @_ToExprs @_Columns @exprs f x

103+ SSum -> gtoResultADT @_Serialize @_Columns @exprs @rep f x

src/Rel8/Generic/Table/ADT.hs+58−197

@@ -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,22 +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.HTable ( HTable, hmap )

36+import Rel8.Schema.HTable ( HTable )

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

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

42import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )

38import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )

43import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify )

39import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify )

44import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )

40import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )

45import qualified Rel8.Schema.Kind as K

41import qualified Rel8.Schema.Kind as K

46−import Rel8.Schema.Null ( Nullify )

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

48−import Rel8.Schema.Result

49− ( Col( R ), Result

50− , null, nullifier, unnullifier

42+import Rel8.Schema.Result ( Result, null, nullifier, unnullifier )

51− )

52import Rel8.Type.Tag ( Tag( Tag ) )

43import Rel8.Type.Tag ( Tag( Tag ) )

54-- text

45-- text

@@ -60,7 +51,7 @@ type GColumnsADT

60 -> (Type -> Type) -> K.HTable

51 -> (Type -> Type) -> K.HTable

61type family GColumnsADT _Columns rep where

52type family GColumnsADT _Columns rep where

62 GColumnsADT _Columns (M1 D _ rep) =

53 GColumnsADT _Columns (M1 D _ rep) =

63− GColumnsADT' _Columns (HLabel "tag" (HType Tag)) rep

54+ GColumnsADT' _Columns (HLabel "tag" (HIdentity Tag)) rep

66type GColumnsADT'

57type GColumnsADT'

@@ -74,244 +65,118 @@ type family GColumnsADT' _Columns htable rep where

74 HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))

65 HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))

77−type GTableADT

68+type GSerializeADT

78− :: (Type -> Exp Constraint)

79− -> (Type -> Exp K.HTable)

80− -> K.HContext -> (Type -> Type) -> Constraint

81−class GTableADT _Table _Columns context rep where

82− gfromColumnsADT :: ()

83− => (forall spec. context spec -> Col Result spec)

84− -> (forall spec. Col Result spec -> context spec)

85− -> (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)

86− -> GColumnsADT _Columns rep context

87− -> rep x

88−

89− gtoColumnsADT :: ()

90− => (forall spec. context spec -> Col Result spec)

91− -> (forall spec. Col Result spec -> context spec)

92− -> (forall a. Eval (_Table a) => a -> Eval (_Columns a) context)

93− -> rep x

94− -> GColumnsADT _Columns rep context

95−

96− gtableADT :: ()

97− => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)

98− -> (forall a. ()

99− => SSpec ('Spec a)

100− -> context ('Spec a)

101− -> context ('Spec (Nullify a)))

102− -> GColumnsADT _Columns rep context

103−

104−

105−instance

106− ( htable ~ HLabel "tag" (HType Tag)

107− , HTable (GColumnsADT _Columns (M1 D meta rep))

108− , Eval (_Table (htable context))

109− , Eval (_Columns (htable context)) ~ htable

110− , GTableADT' _Table _Columns htable context rep

111− , GToExprsADT' (Const _Table) _Columns htable rep rep

112− )

113− => GTableADT _Table _Columns context (M1 D meta rep)

114− where

115− gfromColumnsADT fromContext toContext fromColumns =

116− gfromResultADT @(Const _Table) @_Columns @(M1 D meta rep) @(M1 D meta rep)

117− (const (fromColumns . hmap toContext)) .

118− hmap fromContext

119−

120− gtoColumnsADT fromContext toContext toColumns =

121− hmap toContext .

122− gtoResultADT @(Const _Table) @_Columns @(M1 D meta rep) @(M1 D meta rep)

123− (const (hmap fromContext . toColumns))

124−

125− gtableADT table hnullifier =

126− gtableADT' @_Table @_Columns @htable @context @rep table hnullifier htable

127− where

128− htable = table (Proxy @(htable context))

129−

130−

131−type GTableADT'

132− :: (Type -> Exp Constraint)

133− -> (Type -> Exp K.HTable)

134− -> K.HTable -> K.HContext -> (Type -> Type) -> Constraint

135−class GTableADT' _Table _Columns htable context rep where

136− gtableADT' :: ()

137− => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)

138− -> (forall a. ()

139− => SSpec ('Spec a)

140− -> context ('Spec a)

141− -> context ('Spec (Nullify a)))

142− -> htable context

143− -> GColumnsADT' _Columns htable rep context

144−

145−

146−instance

147− ( htable' ~ GColumnsADT' _Columns htable a

148− , GTableADT' _Table _Columns htable context a

149− , GTableADT' _Table _Columns htable' context b

150− )

151− => GTableADT' _Table _Columns htable context (a :+: b)

152− where

153− gtableADT' table hnullifier =

154− gtableADT' @_Table @_Columns @_ @_ @b table hnullifier .

155− gtableADT' @_Table @_Columns @_ @_ @a table hnullifier

156−

157−

158−instance meta ~ 'MetaCons label _fixity _isRecord =>

159− GTableADT' _Table _Columns htable context (M1 C meta U1)

160− where

161− gtableADT' _ _ = id

162−

163−

164−instance {-# OVERLAPPABLE #-}

165− ( HTable (GColumns _Columns rep)

166− , GTable _Table _Columns context rep

167− , meta ~ 'MetaCons label _fixity _isRecord

168− , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) rep) ~

169− HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))

170− )

171− => GTableADT' _Table _Columns htable context (M1 C meta rep)

172− where

173− gtableADT' table hnullifier htable =

174− HProduct htable $

175− hlabel $

176− hnullify hnullifier $

177− gtable @_Table @_Columns @_ @rep table

178−

179−

180−type GToExprsADT

181 :: (Type -> Type -> Exp Constraint)

69 :: (Type -> Type -> Exp Constraint)

182 -> (Type -> Exp K.HTable)

70 -> (Type -> Exp K.HTable)

183 -> (Type -> Type) -> (Type -> Type) -> Constraint

71 -> (Type -> Type) -> (Type -> Type) -> Constraint

184−class GToExprsADT _ToExprs _Columns exprs rep where

72+class GSerializeADT _Serialize _Columns exprs rep where

185 gfromResultADT :: ()

73 gfromResultADT :: ()

186− => (forall expr a proxy.

74+ => (forall expr a proxy. Eval (_Serialize expr a)

187− ( Eval (_ToExprs expr a)

188− , HTable (Eval (_Columns expr))

189− )

190− => proxy expr

191− -> Eval (_Columns expr) (Col Result)

75+ => proxy expr -> Eval (_Columns expr) Result -> a)

192− -> a)

193− -> GColumnsADT _Columns exprs (Col Result)

76+ -> GColumnsADT _Columns exprs Result

194 -> rep x

77 -> rep x

195

196 gtoResultADT :: ()

79 gtoResultADT :: ()

197− => (forall expr a proxy.

80+ => (forall expr a proxy. Eval (_Serialize expr a)

198− ( Eval (_ToExprs expr a)

199− , HTable (Eval (_Columns expr))

200− )

201− => proxy expr

202− -> a

203− -> Eval (_Columns expr) (Col Result))

81+ => proxy expr -> a -> Eval (_Columns expr) Result)

204 -> rep x

82 -> rep x

205− -> GColumnsADT _Columns exprs (Col Result)

83+ -> GColumnsADT _Columns exprs Result

206

207

208instance

86instance

209− ( htable ~ HLabel "tag" (HType Tag)

87+ ( htable ~ HLabel "tag" (HIdentity Tag)

210− , GToExprsADT' _ToExprs _Columns htable exprs rep

88+ , GSerializeADT' _Serialize _Columns htable exprs rep

211 )

89 )

212− => GToExprsADT _ToExprs _Columns (M1 D meta exprs) (M1 D meta rep)

90+ => GSerializeADT _Serialize _Columns (M1 D meta exprs) (M1 D meta rep)

213 where

91 where

214 gfromResultADT fromResult columns =

92 gfromResultADT fromResult columns =

215− case gfromResultADT' @_ToExprs @_Columns @_ @exprs fromResult tag columns of

93+ case gfromResultADT' @_Serialize @_Columns @htable @exprs @rep fromResult tag columns of

216 Just rep -> M1 rep

94 Just rep -> M1 rep

217 _ -> error "ADT.fromColumns: mismatch between tag and data"

95 _ -> error "ADT.fromColumns: mismatch between tag and data"

218 where

96 where

219− tag = (\(HType (R a)) -> a) . hunlabel @"tag"

97+ tag = (\(HIdentity (Identity a)) -> a) . hunlabel @"tag"

220

221 gtoResultADT toResult (M1 rep) =

99 gtoResultADT toResult (M1 rep) =

222− gtoResultADT' @_ToExprs @_Columns @_ @exprs toResult tag (Just rep)

100+ gtoResultADT' @_Serialize @_Columns @htable @exprs @rep toResult tag (Just rep)

223 where

101 where

224− tag = hlabel @"tag" . HType . R

102+ tag = hlabel @"tag" . HIdentity . Identity

225

103

226

104

227−type GToExprsADT'

105+type GSerializeADT'

228 :: (Type -> Type -> Exp Constraint)

106 :: (Type -> Type -> Exp Constraint)

229 -> (Type -> Exp K.HTable)

107 -> (Type -> Exp K.HTable)

230 -> K.HTable -> (Type -> Type) -> (Type -> Type) -> Constraint

108 -> K.HTable -> (Type -> Type) -> (Type -> Type) -> Constraint

231−class GToExprsADT' _ToExprs _Columns htable exprs rep where

109+class GSerializeADT' _Serialize _Columns htable exprs rep where

232− gfromResultADT' :: ()

110+ gfromResultADT' :: context ~ Result

233− => (forall expr a proxy.

111+ => (forall expr a proxy. Eval (_Serialize expr a)

234− ( Eval (_ToExprs expr a)

235− , HTable (Eval (_Columns expr))

236− )

237− => proxy expr

238− -> Eval (_Columns expr) (Col Result)

112+ => proxy expr -> Eval (_Columns expr) context -> a)

239− -> a)

240− -> (htable (Col Result) -> Tag)

113+ -> (htable Result -> Tag)

241− -> GColumnsADT' _Columns htable exprs (Col Result)

114+ -> GColumnsADT' _Columns htable exprs context

242 -> Maybe (rep x)

115 -> Maybe (rep x)

243

116

244− gtoResultADT' :: ()

117+ gtoResultADT' :: context ~ Result

245− => (forall expr a proxy.

118+ => (forall expr a proxy. Eval (_Serialize expr a)

246− ( Eval (_ToExprs expr a)

247− , HTable (Eval (_Columns expr))

248− )

249− => proxy expr

250− -> a

251− -> Eval (_Columns expr) (Col Result))

119+ => proxy expr -> a -> Eval (_Columns expr) context)

252− -> (Tag -> htable (Col Result))

120+ -> (Tag -> htable Result)

253 -> Maybe (rep x)

121 -> Maybe (rep x)

254− -> GColumnsADT' _Columns htable exprs (Col Result)

122+ -> GColumnsADT' _Columns htable exprs context

255

123

256 extract :: GColumnsADT' _Columns htable exprs context -> htable context

124 extract :: GColumnsADT' _Columns htable exprs context -> htable context

257

125

258

126

259instance

127instance

260− ( htable' ~ GColumnsADT' _Columns htable a

128+ ( htable' ~ GColumnsADT' _Columns htable exprs1

261− , GToExprsADT' _ToExprs _Columns htable a rep1

129+ , GSerializeADT' _Serialize _Columns htable exprs1 a

262− , GToExprsADT' _ToExprs _Columns htable' b rep2

130+ , GSerializeADT' _Serialize _Columns htable' exprs2 b

263 )

131 )

264− => GToExprsADT' _ToExprs _Columns htable (a :+: b) (rep1 :+: rep2)

132+ => GSerializeADT' _Serialize _Columns htable (exprs1 :+: exprs2) (a :+: b)

265 where

133 where

266 gfromResultADT' fromResult f columns =

134 gfromResultADT' fromResult f columns =

267 case ma of

135 case ma of

268 Just a -> Just (L1 a)

136 Just a -> Just (L1 a)

269 Nothing -> R1 <$>

137 Nothing -> R1 <$>

270− gfromResultADT' @_ToExprs @_Columns @_ @b @rep2

138+ gfromResultADT' @_Serialize @_Columns @_ @exprs2 @b

271 fromResult

139 fromResult

272− (f . extract @_ToExprs @_Columns @_ @a @rep1)

140+ (f . extract @_Serialize @_Columns @_ @exprs1 @a)

273 columns

141 columns

274 where

142 where

275 ma =

143 ma =

276− gfromResultADT' @_ToExprs @_Columns @_ @a @rep1

144+ gfromResultADT' @_Serialize @_Columns @_ @exprs1 @a

277 fromResult

145 fromResult

278 f

146 f

279− (extract @_ToExprs @_Columns @_ @b @rep2 columns)

147+ (extract @_Serialize @_Columns @_ @exprs2 @b columns)

280

148

281 gtoResultADT' toResult tag = \case

149 gtoResultADT' toResult tag = \case

282 Just (L1 a) ->

150 Just (L1 a) ->

283− gtoResultADT' @_ToExprs @_Columns @_ @b @rep2

151+ gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b

284 toResult

152 toResult

285− (\_ -> gtoResultADT' @_ToExprs @_Columns @_ @a @rep1

153+ (\_ -> gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a

286 toResult

154 toResult

287 tag

155 tag

288 (Just a))

156 (Just a))

289 Nothing

157 Nothing

290 Just (R1 b) ->

158 Just (R1 b) ->

291− gtoResultADT' @_ToExprs @_Columns @_ @b @rep2

159+ gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b

292 toResult

160 toResult

293 (\tag' ->

161 (\tag' ->

294− gtoResultADT' @_ToExprs @_Columns @_ @a @rep1

162+ gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a

295 toResult

163 toResult

296 (\_ -> tag tag')

164 (\_ -> tag tag')

297 Nothing)

165 Nothing)

298 (Just b)

166 (Just b)

299 Nothing ->

167 Nothing ->

300− gtoResultADT' @_ToExprs @_Columns @_ @b @rep2

168+ gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b

301 toResult

169 toResult

302− (\_ -> gtoResultADT' @_ToExprs @_Columns @_ @a @rep1 toResult tag Nothing)

170+ (\_ -> gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a toResult tag Nothing)

303 Nothing

171 Nothing

304

172

305 extract =

173 extract =

306− extract @_ToExprs @_Columns @_ @a @rep1 .

174+ extract @_Serialize @_Columns @_ @exprs1 @a .

307− extract @_ToExprs @_Columns @_ @b @rep2

175+ extract @_Serialize @_Columns @_ @exprs2 @b

308

176

309

177

310−instance

311− ( meta ~ 'MetaCons label _fixity _isRecord

178+instance (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) =>

312− , KnownSymbol label

313− )

314− => 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)

315 where

180 where

316 gfromResultADT' _ tag columns

181 gfromResultADT' _ tag columns

317 | tag columns == tag' = Just (M1 U1)

182 | tag columns == tag' = Just (M1 U1)

@@ -328,17 +193,17 @@ instance

328

193

329instance {-# OVERLAPPABLE #-}

194instance {-# OVERLAPPABLE #-}

330 ( HTable (GColumns _Columns exprs)

195 ( HTable (GColumns _Columns exprs)

331− , GToExprs _ToExprs _Columns exprs rep

196+ , GSerialize _Serialize _Columns exprs rep

332 , meta ~ 'MetaCons label _fixity _isRecord

197 , meta ~ 'MetaCons label _fixity _isRecord

333 , KnownSymbol label

198 , KnownSymbol label

334− , GColumnsADT' _Columns htable (M1 C meta exprs) ~

199+ , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) exprs) ~

335 HProduct htable (HLabel label (HNullify (GColumns _Columns exprs)))

200 HProduct htable (HLabel label (HNullify (GColumns _Columns exprs)))

336 )

201 )

337− => 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)

338 where

203 where

339 gfromResultADT' fromResult tag (HProduct a b)

204 gfromResultADT' fromResult tag (HProduct a b)

340 | tag a == tag' =

205 | tag a == tag' =

341− M1 . gfromResult @_ToExprs @_Columns @exprs fromResult <$>

206+ M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult <$>

342 hunnullify unnullifier (hunlabel b)

207 hunnullify unnullifier (hunlabel b)

343 | otherwise = Nothing

208 | otherwise = Nothing

344 where

209 where

@@ -349,12 +214,8 @@ instance {-# OVERLAPPABLE #-}

349 Just (M1 rep) -> HProduct (tag tag') $

214 Just (M1 rep) -> HProduct (tag tag') $

350 hlabel $

215 hlabel $

351 hnullify nullifier $

216 hnullify nullifier $

352− gtoResult @_ToExprs @_Columns @exprs toResult rep

217+ gtoResult @_Serialize @_Columns @exprs @rep toResult rep

353 where

218 where

354 tag' = Tag $ pack $ symbolVal (Proxy @label)

219 tag' = Tag $ pack $ symbolVal (Proxy @label)

355

220

356 extract (HProduct a _) = a

221 extract (HProduct a _) = a

357−

358−

359−data Const :: (a -> Exp Constraint) -> a -> a -> Exp Constraint

360−type instance Eval (Const f x a) = (Eval (f a), x ~ a)

src/Rel8/Generic/Table/Record.hs+74−93

@@ -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

@@ -30,12 +30,9 @@ import Prelude hiding ( null )

31-- rel8

32import Rel8.FCF ( Eval, Exp )

33−import Rel8.Schema.Context ( Col )

34−import Rel8.Schema.HTable ( HTable )

35import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )

33import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )

36import Rel8.Schema.HTable.Product ( HProduct(..) )

34import Rel8.Schema.HTable.Product ( HProduct(..) )

37import qualified Rel8.Schema.Kind as K

35import qualified Rel8.Schema.Kind as K

38−import Rel8.Schema.Result ( Result )

41type GColumns :: (Type -> Exp K.HTable) -> (Type -> Type) -> K.HTable

38type GColumns :: (Type -> Exp K.HTable) -> (Type -> Type) -> K.HTable

@@ -58,8 +55,8 @@ type family GContext _Context rep where

58type GTable

55type GTable

59 :: (Type -> Exp Constraint)

56 :: (Type -> Exp Constraint)

60 -> (Type -> Exp K.HTable)

57 -> (Type -> Exp K.HTable)

61− -> K.HContext -> (Type -> Type) -> Constraint

58+ -> (Type -> Type) -> Constraint

62−class GTable _Table _Columns context rep

59+class GTable _Table _Columns rep

63 where

60 where

64 gfromColumns :: ()

61 gfromColumns :: ()

65 => (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)

62 => (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)

@@ -76,125 +73,109 @@ class GTable _Table _Columns context rep

76 -> GColumns _Columns rep context

73 -> GColumns _Columns rep context

79−instance GTable _Table _Columns context rep =>

76+type GSerialize

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

81 where

82− gfromColumns fromColumns =

82+ gfromResult :: ()

83− M1 . gfromColumns @_Table @_Columns @context @rep fromColumns

83+ => (forall expr a proxy. Eval (_Serialize expr a)

84− gtoColumns toColumns (M1 a) =

85− gtoColumns @_Table @_Columns @context @rep toColumns a

84+ => proxy expr -> Eval (_Columns expr) context -> a)

86− gtable = gtable @_Table @_Columns @context @rep

85+ -> GColumns _Columns exprs context

86+ -> rep x

88+ gtoResult :: ()

89+ => (forall expr a proxy. Eval (_Serialize expr a)

90+ => proxy expr -> a -> Eval (_Columns expr) context)

91+ -> rep x

92+ -> GColumns _Columns exprs context

94+

89−instance GTable _Table _Columns context rep =>

95+instance GTable _Table _Columns rep => GTable _Table _Columns (M1 D c rep)

90− GTable _Table _Columns context (M1 C c rep)

91 where

96 where

92 gfromColumns fromColumns =

97 gfromColumns fromColumns =

93− M1 . gfromColumns @_Table @_Columns @context @rep fromColumns

98+ M1 . gfromColumns @_Table @_Columns @rep fromColumns

94 gtoColumns toColumns (M1 a) =

99 gtoColumns toColumns (M1 a) =

95− gtoColumns @_Table @_Columns @context @rep toColumns a

100+ gtoColumns @_Table @_Columns @rep toColumns a

96− gtable = gtable @_Table @_Columns @context @rep

101+ gtable = gtable @_Table @_Columns @rep

102

103

99−instance

104+instance GSerialize _Serialize _Columns exprs rep =>

100− ( GTable _Table _Columns context rep1

105+ GSerialize _Serialize _Columns (M1 D c exprs) (M1 D c rep)

101− , GTable _Table _Columns context rep2

102− )

103− => GTable _Table _Columns context (rep1 :*: rep2)

104 where

106 where

105− gfromColumns fromColumns (HProduct a b) =

107+ gfromResult fromResult =

106− gfromColumns @_Table @_Columns @context @rep1 fromColumns a :*:

108+ M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult

107− gfromColumns @_Table @_Columns @context @rep2 fromColumns b

109+ gtoResult toResult (M1 a) =

108− gtoColumns toColumns (a :*: b) = HProduct

110+ gtoResult @_Serialize @_Columns @exprs @rep toResult a

109− (gtoColumns @_Table @_Columns @context @rep1 toColumns a)

110− (gtoColumns @_Table @_Columns @context @rep2 toColumns b)

111− gtable table = HProduct

112− (gtable @_Table @_Columns @context @rep1 table)

113− (gtable @_Table @_Columns @context @rep2 table)

114

111

115

112

116−instance

117− ( Eval (_Table a)

118− , meta ~ 'MetaSel ('Just label) _su _ss _ds

119− , k1 ~ K1 i a

120− )

121− => GTable _Table _Columns context (M1 S meta k1)

113+instance GTable _Table _Columns rep => GTable _Table _Columns (M1 C c rep)

122 where

114 where

123− gfromColumns fromColumns = M1 . K1 . fromColumns . hunlabel

115+ gfromColumns fromColumns =

116+ M1 . gfromColumns @_Table @_Columns @rep fromColumns

124− gtoColumns toColumns (M1 (K1 a)) = hlabel (toColumns a)

117+ gtoColumns toColumns (M1 a) =

125− gtable table = hlabel (table (Proxy @a))

118+ gtoColumns @_Table @_Columns @rep toColumns a

126−

119+ gtable = gtable @_Table @_Columns @rep

127−

128−type GToExprs

129− :: (Type -> Type -> Exp Constraint)

130− -> (Type -> Exp K.HTable)

131− -> (Type -> Type) -> (Type -> Type) -> Constraint

132−class GToExprs _ToExprs _Columns exprs rep where

133− gfromResult :: ()

134− => (forall expr a proxy.

135− ( Eval (_ToExprs expr a)

136− , HTable (Eval (_Columns expr))

137− )

138− => proxy expr

139− -> Eval (_Columns expr) (Col Result)

140− -> a)

141− -> GColumns _Columns exprs (Col Result)

142− -> rep x

143− gtoResult :: ()

144− => (forall expr a proxy.

145− ( Eval (_ToExprs expr a)

146− , HTable (Eval (_Columns expr))

147− )

148− => proxy expr

149− -> a

150− -> Eval (_Columns expr) (Col Result))

151− -> rep x

152− -> GColumns _Columns exprs (Col Result)

153

120

154

121

155−instance GToExprs _ToExprs _Columns exprs rep =>

122+instance GSerialize _Serialize _Columns exprs rep =>

156− GToExprs _ToExprs _Columns (M1 D c exprs) (M1 D c rep)

123+ GSerialize _Serialize _Columns (M1 C c exprs) (M1 C c rep)

157 where

124 where

158 gfromResult fromResult =

125 gfromResult fromResult =

159− M1 . gfromResult @_ToExprs @_Columns @exprs fromResult

126+ M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult

160 gtoResult toResult (M1 a) =

127 gtoResult toResult (M1 a) =

161− gtoResult @_ToExprs @_Columns @exprs toResult a

128+ gtoResult @_Serialize @_Columns @exprs @rep toResult a

162

129

163

130

164−instance GToExprs _ToExprs _Columns exprs rep =>

131+instance (GTable _Table _Columns rep1, GTable _Table _Columns rep2) =>

165− GToExprs _ToExprs _Columns (M1 C c exprs) (M1 C c rep)

132+ GTable _Table _Columns (rep1 :*: rep2)

166 where

133 where

167− gfromResult fromResult =

134+ gfromColumns fromColumns (HProduct a b) =

168− M1 . gfromResult @_ToExprs @_Columns @exprs fromResult

135+ gfromColumns @_Table @_Columns @rep1 fromColumns a :*:

169− gtoResult toResult (M1 a) =

136+ gfromColumns @_Table @_Columns @rep2 fromColumns b

170− 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)

171

143

172

144

173instance

145instance

174− ( GToExprs _ToExprs _Columns exprs1 rep1

146+ ( GSerialize _Serialize _Columns expr1 rep1

175− , GToExprs _ToExprs _Columns exprs2 rep2

147+ , GSerialize _Serialize _Columns expr2 rep2

176 )

148 )

177− => GToExprs _ToExprs _Columns (exprs1 :*: exprs2) (rep1 :*: rep2)

149+ => GSerialize _Serialize _Columns (expr1 :*: expr2) (rep1 :*: rep2)

178 where

150 where

179 gfromResult fromResult (HProduct a b) =

151 gfromResult fromResult (HProduct a b) =

180− gfromResult @_ToExprs @_Columns @exprs1 fromResult a :*:

152+ gfromResult @_Serialize @_Columns @expr1 @rep1 fromResult a :*:

181− gfromResult @_ToExprs @_Columns @exprs2 fromResult b

153+ gfromResult @_Serialize @_Columns @expr2 @rep2 fromResult b

182 gtoResult toResult (a :*: b) =

154 gtoResult toResult (a :*: b) =

183 HProduct

155 HProduct

184− (gtoResult @_ToExprs @_Columns @exprs1 toResult a)

156+ (gtoResult @_Serialize @_Columns @expr1 @rep1 toResult a)

185− (gtoResult @_ToExprs @_Columns @exprs2 toResult b)

157+ (gtoResult @_Serialize @_Columns @expr2 @rep2 toResult b)

186

158

187

159

188instance

160instance

189− ( Eval (_ToExprs exprs a)

161+ ( Eval (_Table a)

190− , HTable (Eval (_Columns exprs))

191 , meta ~ 'MetaSel ('Just label) _su _ss _ds

162 , meta ~ 'MetaSel ('Just label) _su _ss _ds

192− , 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

193 , k1' ~ K1 i a

176 , k1' ~ K1 i a

194 )

177 )

195− => GToExprs _ToExprs _Columns (M1 S meta k1) (M1 S meta k1')

178+ => GSerialize _Serialize _Columns (M1 S meta k1) (M1 S meta k1')

196 where

179 where

197− gfromResult fromResult =

198− M1 . K1 . fromResult (Proxy @exprs) . hunlabel

180+ gfromResult fromResult = M1 . K1 . fromResult (Proxy @expr) . hunlabel

199− gtoResult toResult (M1 (K1 a)) =

181+ gtoResult toResult (M1 (K1 a)) = hlabel (toResult (Proxy @expr) a)

200− hlabel (toResult (Proxy @exprs) a)

src/Rel8/Kind/Context.hs+8−21

@@ -1,12 +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 )

9 )

11where

10where

@@ -17,11 +16,9 @@ import Prelude ()

17-- rel8

16-- rel8

18import Rel8.Aggregate ( Aggregate )

17import Rel8.Aggregate ( Aggregate )

19import Rel8.Expr ( Expr )

18import Rel8.Expr ( Expr )

20−import Rel8.Schema.Dict ( Dict( Dict ) )

19+import Rel8.Schema.Field ( Field )

21−import Rel8.Schema.Context ( Interpretation )

22import Rel8.Schema.Kind ( Context )

20import Rel8.Schema.Kind ( Context )

23import Rel8.Schema.Name ( Name )

21import Rel8.Schema.Name ( Name )

24−import Rel8.Schema.Reify ( Reify )

25import Rel8.Schema.Result ( Result )

22import Rel8.Schema.Result ( Result )

@@ -29,13 +26,13 @@ type SContext :: Context -> Type

29data SContext context where

26data SContext context where

30 SAggregate :: SContext Aggregate

27 SAggregate :: SContext Aggregate

31 SExpr :: SContext Expr

28 SExpr :: SContext Expr

29+ SField :: SContext (Field table)

32 SName :: SContext Name

30 SName :: SContext Name

33 SResult :: SContext Result

31 SResult :: SContext Result

34− SReify :: SContext context -> SContext (Reify context)

37type Reifiable :: Context -> Constraint

34type Reifiable :: Context -> Constraint

38−class Interpretation context => Reifiable context where

35+class Reifiable context where

39 contextSing :: SContext context

36 contextSing :: SContext context

@@ -47,23 +44,13 @@ instance Reifiable Expr where

47 contextSing = SExpr

44 contextSing = SExpr

47+instance Reifiable (Field table) where

48+ contextSing = SField

49+

50+

50instance Reifiable Result where

51instance Reifiable Result where

51 contextSing = SResult

52 contextSing = SResult

54instance Reifiable Name where

55instance Reifiable Name where

55 contextSing = SName

56 contextSing = SName

56−

57−

58−instance Reifiable context => Reifiable (Reify context) where

59− contextSing = SReify contextSing

60−

61−

62−sReifiable :: SContext context -> Dict Reifiable context

63−sReifiable = \case

64− SAggregate -> Dict

65− SExpr -> Dict

66− SName -> Dict

67− SResult -> Dict

68− SReify context -> case sReifiable context of

69− Dict -> Dict

src/Rel8/Order.hs+1−8

@@ -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

@@ -30,8 +28,3 @@ import qualified Opaleye.Internal.Order as Opaleye

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+28−9

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

1+{-# language FlexibleContexts #-}

1{-# language StandaloneKindSignatures #-}

2{-# language StandaloneKindSignatures #-}

3+{-# language UndecidableInstances #-}

3module Rel8.Query

5module Rel8.Query

4 ( Query( Query )

6 ( Query( Query )

@@ -15,18 +17,21 @@ import Prelude

15-- opaleye

17-- opaleye

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

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

17import qualified Opaleye.Internal.PackMap as Opaleye

19import qualified Opaleye.Internal.PackMap as Opaleye

18−import qualified Opaleye.Internal.PrimQuery as Opaleye

20+import qualified Opaleye.Internal.PrimQuery as Opaleye hiding (lateral)

19import qualified Opaleye.Internal.QueryArr as Opaleye

21import qualified Opaleye.Internal.QueryArr as Opaleye

20import qualified Opaleye.Internal.Tag as Opaleye

22import qualified Opaleye.Internal.Tag as Opaleye

22-- rel8

24-- rel8

25+import Rel8.Expr ( Expr )

23import Rel8.Query.Set ( unionAll )

26import Rel8.Query.Set ( unionAll )

24import Rel8.Query.Opaleye ( fromOpaleye )

27import Rel8.Query.Opaleye ( fromOpaleye )

25import Rel8.Query.Values ( values )

28import Rel8.Query.Values ( values )

29+import Rel8.Table ( Table, fromColumns, toColumns )

26import Rel8.Table.Alternative

30import Rel8.Table.Alternative

27 ( AltTable, (<|>:)

31 ( AltTable, (<|>:)

28 , AlternativeTable, emptyTable

32 , AlternativeTable, emptyTable

29 )

33 )

34+import Rel8.Table.Projection ( Projectable, apply, project )

31-- semigroupoids

36-- semigroupoids

32import Data.Functor.Apply ( Apply, (<.>) )

37import Data.Functor.Apply ( Apply, (<.>) )

@@ -151,6 +156,10 @@ newtype Query a =

151 )

156 )

152

157

153

158

159+instance Projectable Query where

160+ project f = fmap (fromColumns . apply f . toColumns)

161+

162+

154instance Functor Query where

163instance Functor Query where

155 fmap f (Query a) = Query (fmap (fmap (fmap f)) a)

164 fmap f (Query a) = Query (fmap (fmap (fmap f)) a)

156

165

@@ -169,14 +178,14 @@ instance Bind Query where

169

178

170

179

171instance Monad Query where

180instance Monad Query where

172− Query q >>= f = Query $ \dummies -> Opaleye.QueryArr $ \(_, tag) ->

181+ Query q >>= f = Query $ \dummies -> Opaleye.stateQueryArr $ \_ tag ->

173 let

182 let

174− Opaleye.QueryArr qa = q dummies

183+ qa = q dummies

175− ((m, a), query, tag') = qa ((), tag)

184+ ((m, a), query, tag') = Opaleye.runStateQueryArr qa () tag

176 Query q' = f a

185 Query q' = f a

177 (dummies', query', tag'') =

186 (dummies', query', tag'') =

178 ( dummy : dummies

187 ( dummy : dummies

179− , \lateral -> Opaleye.Rebind True bindings . query lateral

188+ , query <> Opaleye.aRebind bindings

180 , Opaleye.next tag'

189 , Opaleye.next tag'

181 )

190 )

182 where

191 where

@@ -184,11 +193,11 @@ instance Monad Query where

184 where

193 where

185 random = Opaleye.FunExpr "random" []

194 random = Opaleye.FunExpr "random" []

186 name = Opaleye.extractAttr "dummy" tag'

195 name = Opaleye.extractAttr "dummy" tag'

187− Opaleye.QueryArr qa' = Opaleye.lateral $ \_ -> q' dummies'

196+ qa' = Opaleye.lateral $ \_ -> q' dummies'

188− ((m'@(Any needsDummies), b), query'', tag''') = qa' ((), tag'')

197+ ((m'@(Any needsDummies), b), query'', tag''') = Opaleye.runStateQueryArr qa' () tag''

189 query'''

198 query'''

190− | needsDummies = \lateral -> query'' lateral . query' lateral

199+ | needsDummies = query' <> query''

191− | otherwise = \lateral -> query'' lateral . query lateral

200+ | otherwise = query <> query''

192 m'' = m <> m'

201 m'' = m <> m'

193 in

202 in

194 ((m'', b), query''', tag''')

203 ((m'', b), query''', tag''')

@@ -202,3 +211,13 @@ instance AltTable Query where

202-- | 'emptyTable' = 'values' @[]@.

211-- | 'emptyTable' = 'values' @[]@.

203instance AlternativeTable Query where

212instance AlternativeTable Query where

204 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/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+10−6

@@ -10,7 +10,11 @@ where

10-- base

11import Prelude

13+-- comonad

14+import Control.Comonad ( extract )

15+

13-- rel8

16-- rel8

17+import Rel8.Expr ( Expr )

14import Rel8.Expr.Eq ( (==.) )

18import Rel8.Expr.Eq ( (==.) )

15import Rel8.Query ( Query )

19import Rel8.Query ( Query )

16import Rel8.Query.Filter ( where_ )

20import Rel8.Query.Filter ( where_ )

@@ -23,17 +27,17 @@ import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )

25-- | Filter 'EitherTable's, keeping only 'leftTable's.

29-- | Filter 'EitherTable's, keeping only 'leftTable's.

26−keepLeftTable :: EitherTable a b -> Query a

30+keepLeftTable :: EitherTable Expr a b -> Query a

27keepLeftTable e@(EitherTable _ a _) = do

31keepLeftTable e@(EitherTable _ a _) = do

28 where_ $ isLeftTable e

32 where_ $ isLeftTable e

29− pure a

33+ pure (extract a)

32-- | Filter 'EitherTable's, keeping only 'rightTable's.

36-- | Filter 'EitherTable's, keeping only 'rightTable's.

33−keepRightTable :: EitherTable a b -> Query b

37+keepRightTable :: EitherTable Expr a b -> Query b

34keepRightTable e@(EitherTable _ _ b) = do

38keepRightTable e@(EitherTable _ _ b) = do

35 where_ $ isRightTable e

39 where_ $ isRightTable e

36− pure b

40+ pure (extract b)

39-- | @bitraverseEitherTable f g x@ will pass all @leftTable@s through @f@ and

43-- | @bitraverseEitherTable f g x@ will pass all @leftTable@s through @f@ and

@@ -55,8 +59,8 @@ keepRightTable e@(EitherTable _ _ b) = do

55bitraverseEitherTable :: ()

59bitraverseEitherTable :: ()

56 => (a -> Query c)

60 => (a -> Query c)

57 -> (b -> Query d)

61 -> (b -> Query d)

58− -> EitherTable a b

62+ -> EitherTable Expr a b

59− -> Query (EitherTable c d)

63+ -> Query (EitherTable Expr c d)

60bitraverseEitherTable f g e@(EitherTable tag _ _) = do

64bitraverseEitherTable f g e@(EitherTable tag _ _) = do

61 mc@(MaybeTable _ c) <- optional (f =<< keepLeftTable e)

65 mc@(MaybeTable _ c) <- optional (f =<< keepLeftTable e)

62 md@(MaybeTable _ d) <- optional (g =<< keepRightTable e)

66 md@(MaybeTable _ d) <- optional (g =<< keepRightTable e)

src/Rel8/Query/Evaluate.hs+3−22

@@ -3,7 +3,6 @@

4module Rel8.Query.Evaluate

5 ( evaluate

6− , rebind

7 )

6 )

8where

7where

@@ -16,28 +15,23 @@ import Prelude hiding ( undefined )

17-- opaleye

16-- opaleye

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

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

19−import qualified Opaleye.Internal.PackMap as Opaleye

20−import qualified Opaleye.Internal.PrimQuery as Opaleye

21−import qualified Opaleye.Internal.QueryArr as Opaleye

22−import qualified Opaleye.Internal.Tag as Opaleye

23−import qualified Opaleye.Internal.Unpackspec as Opaleye

25-- rel8

19-- rel8

26import Rel8.Expr ( Expr )

20import Rel8.Expr ( Expr )

27import Rel8.Expr.Bool ( (&&.) )

21import Rel8.Expr.Bool ( (&&.) )

28import Rel8.Expr.Opaleye ( fromPrimExpr )

22import Rel8.Expr.Opaleye ( fromPrimExpr )

29import Rel8.Query ( Query( Query ) )

23import Rel8.Query ( Query( Query ) )

24+import Rel8.Query.Rebind ( rebind )

30import Rel8.Table ( Table )

25import Rel8.Table ( Table )

31import Rel8.Table.Bool ( case_ )

26import Rel8.Table.Bool ( case_ )

32−import Rel8.Table.Opaleye ( unpackspec )

27+import Rel8.Table.Undefined ( undefined )

33−import Rel8.Table.Undefined

36-- | 'evaluate' takes expressions that could potentially have side effects and

30-- | 'evaluate' takes expressions that could potentially have side effects and

37-- \"runs\" them in the 'Query' monad. The returned expressions have no side

31-- \"runs\" them in the 'Query' monad. The returned expressions have no side

38-- effects and can safely be reused.

32-- effects and can safely be reused.

39evaluate :: Table Expr a => a -> Query a

33evaluate :: Table Expr a => a -> Query a

40−evaluate = laterally >=> rebind

34+evaluate = laterally >=> rebind "eval"

43laterally :: Table Expr a => a -> Query a

37laterally :: Table Expr a => a -> Query a

@@ -51,18 +45,5 @@ laterally a = Query $ \bindings -> pure $ (Any True,) $

51 go = fromPrimExpr . Opaleye.UnExpr Opaleye.OpIsNotNull

45 go = fromPrimExpr . Opaleye.UnExpr Opaleye.OpIsNotNull

54−-- | 'rebind' takes some expressions, and binds each of them to a new

55−-- variable in the SQL. The @a@ returned consists only of these

56−-- variables. It's essentially a @let@ binding for Postgres expressions.

57−rebind :: Table Expr a => a -> Query a

58−rebind a = Query $ \_ -> Opaleye.QueryArr $ \(_, tag) ->

59− let

60− tag' = Opaleye.next tag

61− (a', bindings) = Opaleye.run $

62− Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr "eval" tag') a

63− in

64− ((mempty, a'), \_ -> Opaleye.Rebind True bindings, tag')

65−

66−

67foldl1' :: (a -> a -> a) -> NonEmpty a -> a

48foldl1' :: (a -> a -> a) -> NonEmpty a -> a

68foldl1' f (a :| as) = foldl' f a as

49foldl1' f (a :| as) = foldl' f a as

src/Rel8/Query/Exists.hs+1−1

@@ -12,7 +12,7 @@ import Prelude hiding ( filter )

13-- opaleye

14import qualified Opaleye.Exists as Opaleye

15−import qualified Opaleye.Operators as Opaleye hiding ( exists )

15+import qualified Opaleye.Operators as Opaleye

17-- rel8

18import Rel8.Expr ( Expr )

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+19−16

@@ -19,17 +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 )

27−import Rel8.Query.Evaluate ( rebind )

28import Rel8.Query.Maybe ( optional )

27import Rel8.Query.Maybe ( optional )

28+import Rel8.Query.Rebind ( rebind )

29import Rel8.Schema.HTable.Vectorize ( hunvectorize )

30import Rel8.Schema.Null ( Sql, Unnullify )

31−import Rel8.Schema.Spec ( SSpec( SSpec, info ) )

31+import Rel8.Schema.Spec ( Spec( Spec, info ) )

32−import Rel8.Table ( Table, fromColumns, toColumns )

32+import Rel8.Table ( Table, fromColumns )

33+import Rel8.Table.Cols ( toCols )

33import Rel8.Table.Aggregate ( listAgg, nonEmptyAgg )

34import Rel8.Table.Aggregate ( listAgg, nonEmptyAgg )

34import Rel8.Table.List ( ListTable( ListTable ) )

35import Rel8.Table.List ( ListTable( ListTable ) )

35import Rel8.Table.Maybe ( maybeTable )

36import Rel8.Table.Maybe ( maybeTable )

@@ -46,12 +47,12 @@ import Rel8.Type.Information ( TypeInformation )

46--

47--

47-- @many@ is analogous to 'Control.Applicative.many' from

48-- @many@ is analogous to 'Control.Applicative.many' from

48-- @Control.Applicative@.

49-- @Control.Applicative@.

49−many :: Table Expr a => Query a -> Query (ListTable a)

50+many :: Table Expr a => Query a -> Query (ListTable Expr a)

50many =

51many =

51 fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .

52 fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .

52 optional .

53 optional .

53 aggregate .

54 aggregate .

54− fmap (listAgg . toColumns)

55+ fmap (listAgg . toCols)

57-- | Aggregate a 'Query' into a 'NonEmptyTable'. If the supplied query returns

58-- | Aggregate a 'Query' into a 'NonEmptyTable'. If the supplied query returns

@@ -62,11 +63,11 @@ many =

62--

63--

63-- @some@ is analogous to 'Control.Applicative.some' from

64-- @some@ is analogous to 'Control.Applicative.some' from

64-- @Control.Applicative@.

65-- @Control.Applicative@.

65−some :: Table Expr a => Query a -> Query (NonEmptyTable a)

66+some :: Table Expr a => Query a -> Query (NonEmptyTable Expr a)

66some =

67some =

67 fmap (\(NonEmptyTable a) -> NonEmptyTable a) .

68 fmap (\(NonEmptyTable a) -> NonEmptyTable a) .

68 aggregate .

69 aggregate .

69− fmap (nonEmptyAgg . toColumns)

70+ fmap (nonEmptyAgg . toCols)

72-- | A version of 'many' specialised to single expressions.

73-- | A version of 'many' specialised to single expressions.

@@ -83,18 +84,20 @@ someExpr = aggregate . fmap nonEmptyAggExpr

83-- element of the given @ListTable@.

84-- element of the given @ListTable@.

84--

85--

85-- @catListTable@ is an inverse to 'many'.

86-- @catListTable@ is an inverse to 'many'.

86−catListTable :: Table Expr a => ListTable a -> Query a

87+catListTable :: Table Expr a => ListTable Expr a -> Query a

88+catListTable (ListTable as) =

87−catListTable (ListTable as) = rebind $ fromColumns $ runIdentity $

89+ rebind "unnest" $ fromColumns $ runIdentity $

88− hunvectorize (\SSpec {info} -> pure . E . sunnest info . unE) as

90+ hunvectorize (\Spec {info} -> pure . sunnest info) as

91-- | Expand a 'NonEmptyTable' into a 'Query', where each row in the query is an

93-- | Expand a 'NonEmptyTable' into a 'Query', where each row in the query is an

92-- element of the given @NonEmptyTable@.

94-- element of the given @NonEmptyTable@.

93--

95--

94-- @catNonEmptyTable@ is an inverse to 'some'.

96-- @catNonEmptyTable@ is an inverse to 'some'.

95−catNonEmptyTable :: Table Expr a => NonEmptyTable a -> Query a

97+catNonEmptyTable :: Table Expr a => NonEmptyTable Expr a -> Query a

96−catNonEmptyTable (NonEmptyTable as) = rebind $ fromColumns $ runIdentity $

98+catNonEmptyTable (NonEmptyTable as) =

99+ rebind "unnest" $ fromColumns $ runIdentity $

97− hunvectorize (\SSpec {info} -> pure . E . sunnest info . unE) as

100+ hunvectorize (\Spec {info} -> pure . sunnest info) as

101

102

100-- | Expand an expression that contains a list into a 'Query', where each row

103-- | Expand an expression that contains a list into a 'Query', where each row

@@ -102,7 +105,7 @@ catNonEmptyTable (NonEmptyTable as) = rebind $ fromColumns $ runIdentity $

102--

105--

103-- @catList@ is an inverse to 'manyExpr'.

106-- @catList@ is an inverse to 'manyExpr'.

104catList :: Sql DBType a => Expr [a] -> Query (Expr a)

107catList :: Sql DBType a => Expr [a] -> Query (Expr a)

105−catList = rebind . sunnest typeInformation

108+catList = rebind "unnest" . sunnest typeInformation

106

109

107

110

108-- | Expand an expression that contains a non-empty list into a 'Query', where

111-- | Expand an expression that contains a non-empty list into a 'Query', where

@@ -110,7 +113,7 @@ catList = rebind . sunnest typeInformation

110--

113--

111-- @catNonEmpty@ is an inverse to 'someExpr'.

114-- @catNonEmpty@ is an inverse to 'someExpr'.

112catNonEmpty :: Sql DBType a => Expr (NonEmpty a) -> Query (Expr a)

115catNonEmpty :: Sql DBType a => Expr (NonEmpty a) -> Query (Expr a)

113−catNonEmpty = rebind . sunnest typeInformation

116+catNonEmpty = rebind "unnest" . sunnest typeInformation

114

117

115

118

116sunnest :: TypeInformation (Unnullify a) -> Expr (list a) -> Expr a

119sunnest :: TypeInformation (Unnullify a) -> Expr (list a) -> Expr a

src/Rel8/Query/Maybe.hs+22−14

@@ -1,3 +1,7 @@

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

@@ -8,17 +12,20 @@ where

8-- base

12-- base

9import Prelude

13import Prelude

15+-- comonad

16+import Control.Comonad ( extract )

17+

11-- opaleye

18-- opaleye

12import qualified Opaleye.Internal.MaybeFields as Opaleye

19import qualified Opaleye.Internal.MaybeFields as Opaleye

14-- rel8

21-- rel8

22+import Rel8.Expr ( Expr )

15import Rel8.Expr.Eq ( (==.) )

23import Rel8.Expr.Eq ( (==.) )

16import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )

24import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )

17import Rel8.Query ( Query )

25import Rel8.Query ( Query )

18import Rel8.Query.Filter ( where_ )

26import Rel8.Query.Filter ( where_ )

19import Rel8.Query.Opaleye ( mapOpaleye )

27import Rel8.Query.Opaleye ( mapOpaleye )

20−import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )

28+import Rel8.Table.Maybe ( MaybeTable(..), isJustTable )

21−import Rel8.Table.Tag ( Tag(..), fromExpr )

24-- | Convert a query that might return zero rows to a query that always returns

31-- | Convert a query that might return zero rows to a query that always returns

@@ -26,11 +33,11 @@ import Rel8.Table.Tag ( Tag(..), fromExpr )

26--

33--

27-- To speak in more concrete terms, 'optional' is most useful to write @LEFT

34-- To speak in more concrete terms, 'optional' is most useful to write @LEFT

28-- JOIN@s.

35-- JOIN@s.

29−optional :: Query a -> Query (MaybeTable a)

36+optional :: Query a -> Query (MaybeTable Expr a)

30−optional =

31− mapOpaleye $

32− Opaleye.optionalInternal $

37+optional = mapOpaleye $ Opaleye.optionalInternal $ \tag a -> MaybeTable

33− MaybeTable . fromExpr . fromPrimExpr . fromColumn

38+ { tag = fromPrimExpr $ fromColumn tag

39+ , just = pure a

40+ }

36-- | 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.

@@ -38,23 +45,24 @@ optional =

38-- 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

39-- 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

40-- can think of this as analogous to 'Data.Maybe.catMaybes'.

47-- can think of this as analogous to 'Data.Maybe.catMaybes'.

41−catMaybeTable :: MaybeTable a -> Query a

48+catMaybeTable :: MaybeTable Expr a -> Query a

42catMaybeTable ma@(MaybeTable _ a) = do

49catMaybeTable ma@(MaybeTable _ a) = do

43 where_ $ isJustTable ma

50 where_ $ isJustTable ma

44− pure a

51+ pure (extract a)

47-- | 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

48-- to step through multiple @LEFT JOINs@.

55-- to step through multiple @LEFT JOINs@.

49--

56--

50-- Note that @traverseMaybeTable@ takes a @a -> Query b@ function, which means

57-- Note that @traverseMaybeTable@ takes a @a -> Query b@ function, which means

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

52-- @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

53-- 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

54-- the input is @nothingTable@, you will always get exactly one @nothingTable@

61-- the input is @nothingTable@, you will always get exactly one @nothingTable@

55-- back.

62-- back.

56−traverseMaybeTable :: (a -> Query b) -> MaybeTable a -> Query (MaybeTable b)

63+traverseMaybeTable :: (a -> Query b) -> MaybeTable Expr a -> Query (MaybeTable Expr b)

57traverseMaybeTable query ma@(MaybeTable input _) = do

64traverseMaybeTable query ma@(MaybeTable input _) = do

58− MaybeTable output b <- optional (query =<< catMaybeTable ma)

65+ optional (query =<< catMaybeTable ma) >>= \case

66+ MaybeTable output b -> do

59− where_ $ expr output ==. expr input

67+ where_ $ output ==. input

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

@@ -5,6 +5,7 @@ module Rel8.Query.Opaleye

5 , toOpaleye

6 , mapOpaleye

7 , zipOpaleyeWith

8+ , unsafePeekQuery

8 )

9 )

9where

10where

@@ -14,6 +15,7 @@ import Prelude

15-- opaleye

16-- opaleye

16import qualified Opaleye.Internal.QueryArr as Opaleye

17import qualified Opaleye.Internal.QueryArr as Opaleye

18+import qualified Opaleye.Internal.Tag as Opaleye

18-- rel8

20-- rel8

19import {-# SOURCE #-} Rel8.Query ( Query( Query ) )

21import {-# SOURCE #-} Rel8.Query ( Query( Query ) )

@@ -37,26 +39,32 @@ zipOpaleyeWith :: ()

37zipOpaleyeWith f (Query a) (Query b) = Query $ liftA2 (zipping f) a b

39zipOpaleyeWith f (Query a) (Query b) = Query $ liftA2 (zipping f) a b

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+

40mapping :: ()

48mapping :: ()

41 => (Opaleye.Select a -> Opaleye.Select b)

49 => (Opaleye.Select a -> Opaleye.Select b)

42 -> Opaleye.Select (m, a) -> Opaleye.Select (m, b)

50 -> Opaleye.Select (m, a) -> Opaleye.Select (m, b)

43−mapping f q@(Opaleye.QueryArr qa) = Opaleye.QueryArr $ \(_, tag) ->

51+mapping f q = Opaleye.stateQueryArr $ \_ tag ->

44 let

52 let

45− ((m, _), _, _) = qa ((), tag)

53+ ((m, _), _, _) = Opaleye.runStateQueryArr q () tag

46− Opaleye.QueryArr qa' = (m,) <$> f (snd <$> q)

54+ q' = (m,) <$> f (snd <$> q)

47 in

55 in

48− qa' ((), tag)

56+ Opaleye.runStateQueryArr q' () tag

51zipping :: Semigroup m

59zipping :: Semigroup m

52 => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)

60 => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)

53 -> Opaleye.Select (m, a) -> Opaleye.Select (m, b) -> Opaleye.Select (m, c)

61 -> Opaleye.Select (m, a) -> Opaleye.Select (m, b) -> Opaleye.Select (m, c)

54−zipping f q@(Opaleye.QueryArr qa) q'@(Opaleye.QueryArr qa') =

62+zipping f q q' =

55− Opaleye.QueryArr $ \(_, tag) ->

63+ Opaleye.stateQueryArr $ \_ tag ->

56 let

64 let

57− ((m, _), _, _) = qa ((), tag)

65+ ((m, _), _, _) = Opaleye.runStateQueryArr q () tag

58− ((m', _), _, _) = qa' ((), tag)

66+ ((m', _), _, _) = Opaleye.runStateQueryArr q' () tag

59 m'' = m <> m'

67 m'' = m <> m'

60− Opaleye.QueryArr qa'' = (m'',) <$> f (snd <$> q) (snd <$> q')

68+ q'' = (m'',) <$> f (snd <$> q) (snd <$> q')

61 in

69 in

62− qa'' ((), tag)

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

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

1{-# language FlexibleContexts #-}

2+{-# language GADTs #-}

3module Rel8.Query.These

4module Rel8.Query.These

4 ( alignBy

5 ( alignBy

@@ -14,6 +15,9 @@ where

14-- base

15-- base

15import Prelude

16import Prelude

18+-- comonad

19+import Control.Comonad ( extract )

20+

17-- opaleye

21-- opaleye

18import qualified Opaleye.Internal.PackMap as Opaleye

22import qualified Opaleye.Internal.PackMap as Opaleye

19import qualified Opaleye.Internal.PrimQuery as Opaleye

23import qualified Opaleye.Internal.PrimQuery as Opaleye

@@ -32,7 +36,6 @@ import Rel8.Query.Maybe ( optional )

32import Rel8.Query.Opaleye ( zipOpaleyeWith )

36import Rel8.Query.Opaleye ( zipOpaleyeWith )

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.Tag ( Tag(..), fromExpr )

36import Rel8.Table.These

39import Rel8.Table.These

37 ( TheseTable( TheseTable, here, there )

40 ( TheseTable( TheseTable, here, there )

38 , hasHereTable, hasThereTable

41 , hasHereTable, hasThereTable

@@ -44,92 +47,89 @@ import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) )

44-- | Corresponds to a @FULL OUTER JOIN@ between two queries.

47-- | Corresponds to a @FULL OUTER JOIN@ between two queries.

45alignBy :: ()

48alignBy :: ()

46 => (a -> b -> Expr Bool)

49 => (a -> b -> Expr Bool)

47− -> Query a -> Query b -> Query (TheseTable a b)

50+ -> Query a -> Query b -> Query (TheseTable Expr a b)

48−alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.QueryArr $ \i -> case i of

51+alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.stateQueryArr $ \_ t -> case t of

49− (_, tag) -> (tab, join', tag''')

52+ tag -> (tab, join', tag''')

50 where

53 where

51− (ma, left', tag') = Opaleye.runSimpleQueryArr (pure <$> left) ((), tag)

54+ (ma, left', tag') = Opaleye.runStateQueryArr (pure <$> left) () tag

52− (mb, right', tag'') = Opaleye.runSimpleQueryArr (pure <$> right) ((), tag')

55+ (mb, right', tag'') = Opaleye.runStateQueryArr (pure <$> right) () tag'

53− MaybeTable Tag {expr = hasHere} a = ma

56+ MaybeTable hasHere a = ma

54− MaybeTable Tag {expr = hasThere} b = mb

57+ MaybeTable hasThere b = mb

55 (hasHere', lbindings) = Opaleye.run $ do

58 (hasHere', lbindings) = Opaleye.run $ do

56 traversePrimExpr (Opaleye.extractAttr "hasHere" tag'') hasHere

59 traversePrimExpr (Opaleye.extractAttr "hasHere" tag'') hasHere

57 (hasThere', rbindings) = Opaleye.run $ do

60 (hasThere', rbindings) = Opaleye.run $ do

58 traversePrimExpr (Opaleye.extractAttr "hasThere" tag'') hasThere

61 traversePrimExpr (Opaleye.extractAttr "hasThere" tag'') hasThere

59 tag''' = Opaleye.next tag''

62 tag''' = Opaleye.next tag''

60− join lateral = Opaleye.Join Opaleye.FullJoin on left'' right''

63+ join = Opaleye.Join Opaleye.FullJoin on left'' right''

61 where

64 where

62− on = toPrimExpr $ condition a b

65+ on = toPrimExpr $ condition (extract a) (extract b)

63− left'' = (lateral, Opaleye.Rebind True lbindings left')

66+ left'' = (Opaleye.NonLateral, Opaleye.toPrimQuery (left' <> Opaleye.aRebind lbindings))

64− right'' = (lateral, Opaleye.Rebind True rbindings right')

67+ right'' = (Opaleye.NonLateral, Opaleye.toPrimQuery (right' <> Opaleye.aRebind rbindings))

65− ma' = MaybeTable (fromExpr hasHere') a

68+ ma' = MaybeTable hasHere' a

66− mb' = MaybeTable (fromExpr hasThere') b

69+ mb' = MaybeTable hasThere' b

67 tab = TheseTable {here = ma', there = mb'}

70 tab = TheseTable {here = ma', there = mb'}

68− join' lateral input = Opaleye.times lateral input (join lateral)

71+ join' = Opaleye.aProduct join

71−-- | Filter 'TheseTable's, keeping only 'thisTable's and 'thoseTable's.

72−keepHereTable :: TheseTable a b -> Query (a, MaybeTable b)

74+keepHereTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)

73keepHereTable = loseThatTable

75keepHereTable = loseThatTable

76−-- | Filter 'TheseTable's, keeping on

77−loseHereTable :: TheseTable a b -> Query b

78+loseHereTable :: TheseTable Expr a b -> Query b

78loseHereTable = keepThatTable

79loseHereTable = keepThatTable

81−keepThereTable :: TheseTable a b -> Query (MaybeTable a, b)

82+keepThereTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)

82keepThereTable = loseThisTable

83keepThereTable = loseThisTable

85−loseThereTable :: TheseTable a b -> Query a

86+loseThereTable :: TheseTable Expr a b -> Query a

86loseThereTable = keepThisTable

87loseThereTable = keepThisTable

89−keepThisTable :: TheseTable a b -> Query a

90+keepThisTable :: TheseTable Expr a b -> Query a

90keepThisTable t@(TheseTable (MaybeTable _ a) _) = do

91keepThisTable t@(TheseTable (MaybeTable _ a) _) = do

91 where_ $ isThisTable t

92 where_ $ isThisTable t

92− pure a

93+ pure (extract a)

95−loseThisTable :: TheseTable a b -> Query (MaybeTable a, b)

96+loseThisTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)

96loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do

97loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do

97 where_ $ not_ $ isThisTable t

98 where_ $ not_ $ isThisTable t

98− pure (ma, b)

99+ pure (ma, extract b)

100

101

101−keepThatTable :: TheseTable a b -> Query b

102+keepThatTable :: TheseTable Expr a b -> Query b

102keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do

103keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do

103 where_ $ isThatTable t

104 where_ $ isThatTable t

104− pure b

105+ pure (extract b)

105

106

107

107−loseThatTable :: TheseTable a b -> Query (a, MaybeTable b)

108+loseThatTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)

108loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do

109loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do

109 where_ $ not_ $ isThatTable t

110 where_ $ not_ $ isThatTable t

110− pure (a, mb)

111+ pure (extract a, mb)

111

112

113

113−keepThoseTable :: TheseTable a b -> Query (a, b)

114+keepThoseTable :: TheseTable Expr a b -> Query (a, b)

114keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do

115keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do

115 where_ $ isThoseTable t

116 where_ $ isThoseTable t

116− pure (a, b)

117+ pure (extract a, extract b)

117

118

119

119−loseThoseTable :: TheseTable a b -> Query (EitherTable a b)

120+loseThoseTable :: TheseTable Expr a b -> Query (EitherTable Expr a b)

120loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do

121loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do

121 where_ $ not_ $ isThoseTable t

122 where_ $ not_ $ isThoseTable t

122− pure $ EitherTable result a b

123+ pure $ EitherTable tag a b

123 where

124 where

124 tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)

125 tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)

125− result = (mempty `asTypeOf` result) {expr = tag}

126

127

128bitraverseTheseTable :: ()

129 => (a -> Query c)

130 -> (b -> Query d)

131− -> TheseTable a b

131+ -> TheseTable Expr a b

132− -> Query (TheseTable c d)

132+ -> Query (TheseTable Expr c d)

133bitraverseTheseTable f g t = do

134 mc <- optional (f . fst =<< keepHereTable 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/Nullify.hs+105−86

@@ -1,125 +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

12− ( Nullifiable( encodeTag, decodeTag, nullifier, unnullifier )

10+ ( Nullifiability(..), NonNullifiability(..), nullifiableOrNot, absurd

13− , runTag, unnull

11+ , Nullifiable, nullifiability

12+ , guarder, nullifier, unnullifier

13+ , sguard, snullify

14 )

15where

17-- base

18−import Data.Kind ( Constraint )

18+import Data.Bool ( bool )

19−import GHC.TypeLits ( KnownSymbol )

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

20+import Data.Kind ( Constraint, Type )

20import Prelude hiding ( null )

21import Prelude hiding ( null )

22-- opaleye

23-- opaleye

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

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

25-- rel8

26-- rel8

26−import Rel8.Aggregate

27+import Rel8.Aggregate ( Aggregate(..), zipOutputs )

27− ( Aggregate( Aggregate ), Col( A )

28+import Rel8.Expr ( Expr )

28− , mapInputs

29− , unsafeMakeAggregate

30− )

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

32import Rel8.Expr.Bool ( boolExpr )

29import Rel8.Expr.Bool ( boolExpr )

33import Rel8.Expr.Null ( nullify, unsafeUnnullify )

30import Rel8.Expr.Null ( nullify, unsafeUnnullify )

34−import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )

31+import Rel8.Expr.Opaleye ( fromPrimExpr )

35−import Rel8.Schema.Context ( Interpretation )

32+import Rel8.Kind.Context ( SContext(..) )

33+import Rel8.Schema.Field ( Field )

36import qualified Rel8.Schema.Kind as K

34import qualified Rel8.Schema.Kind as K

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

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

38import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )

36import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )

39−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

37+import Rel8.Schema.Result ( Result )

40−import Rel8.Table.Tag ( Tag(..), Taggable, fromAggregate, fromExpr, fromName )

38+import Rel8.Schema.Spec ( Spec(..) )

41−

43−type Nullifiable :: K.Context -> Constraint

44−class Interpretation context => Nullifiable context where

45− encodeTag :: Taggable a

46− => Tag label a

47− -> Col context ('Spec a)

49− decodeTag :: (KnownSymbol label, Taggable a)

41+type Nullifiability :: K.Context -> Type

50− => Col context ('Spec a)

42+data Nullifiability context where

51− -> Tag label a

43+ NAggregate :: Nullifiability Aggregate

44+ NExpr :: Nullifiability Expr

45+ NName :: Nullifiability Name

53− nullifier :: ()

54− => Tag label a

55− -> (Expr a -> Expr Bool)

56− -> SSpec ('Spec x)

57− -> Col context ('Spec x)

58− -> Col context ('Spec (Nullify x))

60− unnullifier :: ()

48+type Nullifiable :: K.Context -> Constraint

61− => SSpec ('Spec x)

49+class Nullifiable context where

62− -> Col context ('Spec (Nullify x))

50+ nullifiability :: Nullifiability context

63− -> Col context ('Spec x)

66instance Nullifiable Aggregate where

53instance Nullifiable Aggregate where

67− encodeTag Tag {aggregator, expr} =

54+ nullifiability = NAggregate

68− A $ unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr

69−

70− decodeTag (A aggregate) = fromAggregate aggregate

71−

72− nullifier Tag {expr} test SSpec {nullity} (A (Aggregate a)) =

73− A $

74− mapInputs (toPrimExpr . runTag nullity condition . fromPrimExpr) $

75− Aggregate $

76− runTag nullity condition <$> a

77− where

78− condition = test expr

79−

80− unnullifier SSpec {nullity} (A (Aggregate a)) =

81− A (Aggregate (unnull nullity <$> a))

82−

83− {-# INLINABLE encodeTag #-}

84− {-# INLINABLE decodeTag #-}

85− {-# INLINABLE nullifier #-}

86− {-# INLINABLE unnullifier #-}

89instance Nullifiable Expr where

57instance Nullifiable Expr where

90− encodeTag Tag {expr} = E expr

58+ nullifiability = NExpr

91− decodeTag (E a) = fromExpr a

92− nullifier Tag {expr} test SSpec {nullity} (E a) =

93− E $ runTag nullity (test expr) a

94− unnullifier SSpec {nullity} (E a) = E $ unnull nullity a

95−

96− {-# INLINABLE encodeTag #-}

97− {-# INLINABLE decodeTag #-}

98− {-# INLINABLE nullifier #-}

99− {-# INLINABLE unnullifier #-}

100

101

102instance Nullifiable Name where

61instance Nullifiable Name where

103− encodeTag Tag {name} = N name

62+ nullifiability = NName

104− decodeTag (N name) = fromName name

63+

105− nullifier _ _ _ (N (Name name)) = N (Name name)

64+

106− unnullifier _ (N (Name name)) = N (Name name)

65+type NonNullifiability :: K.Context -> Type

107−

66+data NonNullifiability context where

108− {-# INLINABLE encodeTag #-}

67+ NField :: NonNullifiability (Field table)

109− {-# INLINABLE decodeTag #-}

68+ NResult :: NonNullifiability Result

110− {-# INLINABLE nullifier #-}

69+

111− {-# INLINABLE unnullifier #-}

70+

112−

71+nullifiableOrNot :: ()

113−

72+ => SContext context

114−runTag :: Nullity a -> Expr Bool -> Expr a -> Expr (Nullify a)

73+ -> Either (NonNullifiability context) (Nullifiability context)

115−runTag nullity tag a = case nullity of

74+nullifiableOrNot = \case

116− Null -> boolExpr null a tag

75+ SAggregate -> Right NAggregate

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

118 where

131 where

119 null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit

132 null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit

120

133

121

134

122−unnull :: Nullity a -> Expr (Nullify a) -> Expr a

135+snullify :: Nullity a -> Expr a -> Expr (Nullify a)

123−unnull nullity a = case nullity of

136+snullify nullity a = case nullity of

137+ Null -> a

138+ NotNull -> nullify a

139+

140+

141+sunnullify :: Nullity a -> Expr (Nullify a) -> Expr a

142+sunnullify nullity a = case nullity of

124 Null -> a

143 Null -> a

125 NotNull -> unsafeUnnullify a

144 NotNull -> unsafeUnnullify 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−2

@@ -15,7 +15,7 @@ import Prelude ()

16-- rel8

17import Rel8.Schema.HTable ( HTable )

18−import Rel8.Schema.HTable.Identity ( HType )

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

@@ -24,7 +24,7 @@ import Rel8.Type.Tag ( EitherTag )

25type HEitherTable :: K.HTable -> K.HTable -> K.HTable

26data HEitherTable left right context = HEitherTable

27− { htag :: HLabel "isRight" (HType EitherTag) context

27+ { htag :: HLabel "isRight" (HIdentity EitherTag) context

28 , hleft :: HLabel "Left" (HNullify left) context

29 , hright :: HLabel "Right" (HNullify right) context

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)

30+newtype HIdentity a context = HIdentity

29−

31+ { unHIdentity :: context a

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

38− { unHIdentity :: context spec

39 }

32 }

42−type HIdentityField :: Spec -> Spec -> Type

35+instance Sql DBType a => HTable (HIdentity a) where

43−data HIdentityField _spec spec where

36+ type HConstrainTable (HIdentity a) constraint = constraint a

44− HIdentityField :: HIdentityField spec spec

37+ type HField (HIdentity a) = (:~:) a

45−

46−

47−instance KnownSpec spec => HTable (HIdentity spec) where

48− type HConstrainTable (HIdentity spec) c = c spec

49− type HField (HIdentity spec) = HIdentityField spec

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+16−4

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

1{-# language DataKinds #-}

2+{-# language RankNTypes #-}

2{-# language RecordWildCards #-}

3{-# language RecordWildCards #-}

3{-# language ScopedTypeVariables #-}

4{-# language ScopedTypeVariables #-}

4{-# language StandaloneKindSignatures #-}

5{-# language StandaloneKindSignatures #-}

@@ -7,6 +8,7 @@

8module Rel8.Schema.HTable.Label

9module Rel8.Schema.HTable.Label

9 ( HLabel, hlabel, hrelabel, hunlabel

10 ( HLabel, hlabel, hrelabel, hunlabel

11+ , hproject

10 )

12 )

11where

13where

@@ -18,16 +20,19 @@ import Prelude

19-- rel8

21-- rel8

20import Rel8.Schema.HTable

22import Rel8.Schema.HTable

23+ ( HTable, HConstrainTable, HField

24+ , htabulate, hfield, htraverse, hdicts, hspecs

25+ )

21import qualified Rel8.Schema.Kind as K

26import qualified Rel8.Schema.Kind as K

22−import Rel8.Schema.Spec ( Spec, SSpec(..) )

27+import Rel8.Schema.Spec ( Spec(..) )

25type HLabel :: Symbol -> K.HTable -> K.HTable

30type HLabel :: Symbol -> K.HTable -> K.HTable

26newtype HLabel label table context = HLabel (table context)

31newtype HLabel label table context = HLabel (table context)

29−type HLabelField :: Symbol -> K.HTable -> Spec -> Type

34+type HLabelField :: Symbol -> K.HTable -> Type -> Type

30−newtype HLabelField label table spec = HLabelField (HField table spec)

35+newtype HLabelField label table a = HLabelField (HField table a)

33instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where

38instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where

@@ -40,7 +45,8 @@ instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where

40 htraverse f (HLabel a) = HLabel <$> htraverse f a

45 htraverse f (HLabel a) = HLabel <$> htraverse f a

41 hdicts = HLabel (hdicts @table)

46 hdicts = HLabel (hdicts @table)

42 hspecs = HLabel $ htabulate $ \field -> case hfield (hspecs @table) field of

47 hspecs = HLabel $ htabulate $ \field -> case hfield (hspecs @table) field of

43− SSpec {..} -> SSpec {labels = symbolVal (Proxy @label) : labels, ..}

48+ Spec {..} -> Spec {labels = symbolVal (Proxy @label) : labels, ..}

49+ {-# INLINABLE hspecs #-}

46hlabel :: forall label t context. t context -> HLabel label t context

52hlabel :: forall label t context. t context -> HLabel label t context

@@ -56,3 +62,9 @@ hrelabel = hlabel . hunlabel

56hunlabel :: forall label t context. HLabel label t context -> t context

62hunlabel :: forall label t context. HLabel label t context -> t context

57hunlabel (HLabel a) = a

63hunlabel (HLabel a) = a

58{-# 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

32−import Rel8.Schema.Spec ( Spec, SSpec )

33+ ( HTable, HConstrainTable, HField

34+ , hfield, htabulate, htraverse, hdicts, hspecs

35+ )

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

@@ -15,7 +15,7 @@ import Prelude

16-- rel8

17import Rel8.Schema.HTable ( HTable )

18−import Rel8.Schema.HTable.Identity ( HType )

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

@@ -24,7 +24,7 @@ import Rel8.Type.Tag ( MaybeTag )

25type HMaybeTable :: K.HTable -> K.HTable

26data HMaybeTable table context = HMaybeTable

27− { htag :: HLabel "isJust" (HType (Maybe MaybeTag)) context

27+ { htag :: HLabel "isJust" (HIdentity (Maybe MaybeTag)) context

28 , hjust :: HLabel "Just" (HNullify table) context

29 }

30 deriving stock Generic

src/Rel8/Schema/HTable/Nullify.hs+44−29

@@ -19,25 +19,34 @@

19module Rel8.Schema.HTable.Nullify

20 ( HNullify( HNullify )

21 , Nullify

22− , hnulls, hnullify, hunnullify

22+ , hguard

23+ , hnulls

24+ , hnullify

25+ , hunnullify

26+ , hproject

23 )

27 )

24where

28where

26-- base

30-- base

31+import Data.Kind ( Type )

32+import GHC.Generics ( Generic )

27import Prelude hiding ( null )

33import Prelude hiding ( null )

29-- rel8

35-- rel8

36+import Rel8.FCF ( Eval, Exp )

30import 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 )

31import qualified Rel8.Schema.Kind as K

43import qualified Rel8.Schema.Kind as K

32import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

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

33import qualified Rel8.Schema.Null as Type ( Nullify )

45import qualified Rel8.Schema.Null as Type ( Nullify )

34−import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

46+import Rel8.Schema.Spec ( Spec(..) )

36-- semigroupoids

48-- semigroupoids

37import Data.Functor.Apply ( Apply )

49import Data.Functor.Apply ( Apply )

38−import Rel8.Schema.HTable.MapTable

39−import Rel8.FCF

40−import GHC.Generics (Generic)

43type HNullify :: K.HTable -> K.HTable

52type HNullify :: K.HTable -> K.HTable

@@ -46,57 +55,63 @@ newtype HNullify table context = HNullify (HMapTable Nullify table context)

46 deriving anyclass HTable

55 deriving anyclass HTable

49−

58+-- | Transform a 'Type' by allowing it to be @null@.

50−-- | Transform a 'Spec' by allowing it to be @null@.

59+data Nullify :: Type -> Exp Type

51−data Nullify :: Spec -> Exp Spec

60+type instance Eval (Nullify a) = Type.Nullify a

52−

53−

54−type instance Eval (Nullify ('Spec a)) =

55− 'Spec (Type.Nullify a)

58instance MapSpec Nullify where

63instance MapSpec Nullify where

59 mapInfo = \case

64 mapInfo = \case

60− SSpec {nullity, ..} -> SSpec

65+ Spec {nullity, ..} -> Spec

61 { nullity = case nullity of

66 { nullity = case nullity of

62 Null -> Null

67 Null -> Null

63 NotNull -> Null

68 NotNull -> Null

64 , ..

69 , ..

65− }

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 a. ()

85+ => (forall a. Spec a -> context (Type.Nullify a))

70− => SSpec ('Spec a)

71− -> context ('Spec (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) ->

74− spec@SSpec {} -> null spec

88+ case hfield hspecs field of

89+ spec@Spec {} -> null spec

75{-# INLINABLE hnulls #-}

90{-# INLINABLE hnulls #-}

78hnullify :: HTable t

93hnullify :: HTable t

79− => (forall a. ()

94+ => (forall a. Spec a -> context a -> context (Type.Nullify a))

80− => SSpec ('Spec a)

81− -> context ('Spec a)

82− -> context ('Spec (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 a. ()

104+ => (forall a. Spec a -> context (Type.Nullify a) -> m (context a))

93− => SSpec ('Spec a)

94− -> context ('Spec (Type.Nullify a))

95− -> m (context ('Spec 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+3−3

@@ -15,7 +15,7 @@ import Prelude

16-- rel8

17import Rel8.Schema.HTable ( HTable )

18−import Rel8.Schema.HTable.Identity ( HType )

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

@@ -24,9 +24,9 @@ import Rel8.Type.Tag ( MaybeTag )

25type HTheseTable :: K.HTable -> K.HTable -> K.HTable

26data HTheseTable here there context = HTheseTable

27− { hhereTag :: HLabel "hereTag" (HType (Maybe MaybeTag)) context

27+ { hhereTag :: HLabel "hereTag" (HIdentity (Maybe MaybeTag)) context

28 , hhere :: HLabel "Here" (HNullify here) context

29− , hthereTag :: HLabel "thereTag" (HType (Maybe MaybeTag)) context

29+ , hthereTag :: HLabel "thereTag" (HIdentity (Maybe MaybeTag)) context

30 , hthere :: HLabel "There" (HNullify there) context

31 }

32 deriving stock Generic

src/Rel8/Schema/HTable/Vectorize.hs+39−41

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

36+import Rel8.FCF ( Eval, Exp )

35import Rel8.Schema.Dict ( Dict( Dict ) )

37import Rel8.Schema.Dict ( Dict( Dict ) )

36import qualified Rel8.Schema.Kind as K

38import qualified Rel8.Schema.Kind as K

37−import Rel8.Schema.HTable

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

38− ( HTable

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

39− , hfield, htabulate, htabulateA, hspecs

41+import Rel8.Schema.HTable.MapTable

42+ ( HMapTable( HMapTable ), HMapTableField( HMapTableField )

43+ , MapSpec, mapInfo

44+ , Precompose( Precompose )

40 )

45 )

46+import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )

41import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )

47import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )

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

48+import Rel8.Schema.Spec ( Spec(..) )

43import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )

49import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )

44import Rel8.Type.Information ( TypeInformation )

50import Rel8.Type.Information ( TypeInformation )

46-- semialign

52-- semialign

47import Data.Zip ( Unzip, Zip, Zippy(..) )

53import Data.Zip ( Unzip, Zip, Zippy(..) )

48−import Rel8.FCF

49−import Rel8.Schema.HTable.MapTable

50−import GHC.Generics (Generic)

56+type Vector :: (Type -> Type) -> Constraint

53class Vector list where

57class Vector list where

54 listNotNull :: proxy a -> Dict NotNull (list a)

58 listNotNull :: proxy a -> Dict NotNull (list a)

55 vectorTypeInformation :: ()

59 vectorTypeInformation :: ()

@@ -74,16 +78,16 @@ newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) t

74 deriving anyclass HTable

78 deriving anyclass HTable

77−data Vectorize :: (Type -> Type) -> Spec -> Exp Spec

81+data Vectorize :: (Type -> Type) -> Type -> Exp Type

80−type instance Eval (Vectorize list ('Spec a)) = 'Spec (list a)

84+type instance Eval (Vectorize list a) = list a

83instance Vector list => MapSpec (Vectorize list) where

87instance Vector list => MapSpec (Vectorize list) where

84 mapInfo = \case

88 mapInfo = \case

85− SSpec {..} -> case listNotNull @list nullity of

89+ Spec {..} -> case listNotNull @list nullity of

86− Dict -> SSpec

90+ Dict -> Spec

87 { nullity = NotNull

91 { nullity = NotNull

88 , info = vectorTypeInformation nullity info

92 , info = vectorTypeInformation nullity info

89 , ..

93 , ..

@@ -91,55 +95,49 @@ instance Vector list => MapSpec (Vectorize list) where

93hvectorize :: (HTable t, Unzip f, Vector list)

97hvectorize :: (HTable t, Unzip f, Vector list)

94− => (forall a. ()

98+ => (forall a. Spec a -> f (context a) -> context' (list a))

95− => SSpec ('Spec a)

96− -> f (context ('Spec a))

97− -> context' ('Spec (list a)))

98 -> f (t context)

99 -> f (t context)

99 -> HVectorize list t context'

100 -> HVectorize list t context'

100hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->

101hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->

101 case hfield hspecs field of

102 case hfield hspecs field of

102− spec@SSpec {} -> vectorizer spec (fmap (`hfield` field) as)

103+ spec -> vectorizer spec (fmap (`hfield` field) as)

103{-# INLINABLE hvectorize #-}

104{-# INLINABLE hvectorize #-}

104

105

106

106hunvectorize :: (HTable t, Zip f, Vector list)

107hunvectorize :: (HTable t, Zip f, Vector list)

107− => (forall a. ()

108+ => (forall a. Spec a -> context (list a) -> f (context' a))

108− => SSpec ('Spec a)

109− -> context ('Spec (list a))

110− -> f (context' ('Spec a)))

111 -> HVectorize list t context

109 -> HVectorize list t context

112 -> f (t context')

110 -> f (t context')

113hunvectorize unvectorizer (HVectorize table) =

111hunvectorize unvectorizer (HVectorize table) =

114 getZippy $ htabulateA $ \field -> case hfield hspecs field of

112 getZippy $ htabulateA $ \field -> case hfield hspecs field of

115− spec@SSpec{} -> case hfield table (HMapTableField field) of

113+ spec -> case hfield table (HMapTableField field) of

116 a -> Zippy (unvectorizer spec a)

114 a -> Zippy (unvectorizer spec a)

117{-# INLINABLE hunvectorize #-}

115{-# INLINABLE hunvectorize #-}

118

116

119

117

120−happend :: (HTable t, Vector list) =>

118+happend :: (HTable t, Vector list)

121− ( forall a. ()

119+ => (forall a. Spec a -> context (list a) -> context (list a) -> context (list a))

122− => Nullity a

123− -> TypeInformation (Unnullify a)

124− -> context ('Spec (list a))

125− -> context ('Spec (list a))

126− -> context ('Spec (list a))

127− )

128 -> HVectorize list t context

120 -> HVectorize list t context

129 -> HVectorize list t context

121 -> HVectorize list t context

130 -> HVectorize list t context

122 -> HVectorize list t context

131happend append (HVectorize as) (HVectorize bs) = HVectorize $

123happend append (HVectorize as) (HVectorize bs) = HVectorize $

132 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

133 (a, b) -> case hfield hspecs j of

125 (a, b) -> case hfield hspecs j of

134− SSpec {nullity, info} -> append nullity info a b

126+ spec -> append spec a b

135

127

136

128

137−hempty :: HTable t =>

129+hempty :: HTable t

138− ( forall a. ()

130+ => (forall a. Spec a -> context [a])

139− => Nullity a

140− -> TypeInformation (Unnullify a)

141− -> context ('Spec [a])

142− )

143 -> HVectorize [] t context

131 -> HVectorize [] t context

144−hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of

132+hempty empty = HVectorize $ htabulate $ \(HMapTableField field) ->

145− 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)

140+

141+

142+hcolumn :: HVectorize list (HIdentity a) context -> context (list a)

143+hcolumn (HVectorize (HMapTable (HIdentity (Precompose a)))) = a

src/Rel8/Schema/Kind.hs+6−15

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

1{-# language StandaloneKindSignatures #-}

3module Rel8.Schema.Kind

4− ( Context, Rel8able

4+ ( Rel8able

5− , HContext, HTable

5+ , Context

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−

15+type Context :: Type

17−type HContext :: Type

16+type Context = Type -> Type

18−type HContext = Spec -> Type

21type HTable :: Type

19type HTable :: Type

22−type HTable = HContext -> Type

20+type HTable = Context -> Type

23−

24−

25−data X

26−

27−

28−type Context :: Type

29−type Context = X -> Type

32type Rel8able :: Type

23type Rel8able :: Type

src/Rel8/Schema/Name.hs+34−50

@@ -3,40 +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.HTable.Identity ( HIdentity( HType ), HType )

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

32import Rel8.Schema.Null ( Sql )

37import Rel8.Schema.Null ( Sql )

33−import Rel8.Schema.Reify ( notReify )

34−import Rel8.Schema.Result ( Result )

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

36import Rel8.Table

38import Rel8.Table

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

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

40+ , FromExprs, fromResult, toResult

41+ , Transpose

38 )

42 )

39−import Rel8.Table.Recontextualize ( Recontextualize )

43+import Rel8.Table.Transpose ( Transposes )

40import Rel8.Type ( DBType )

44import Rel8.Type ( DBType )

@@ -44,50 +48,30 @@ import Rel8.Type ( DBType )

44-- schema definition. You can construct names by using the @OverloadedStrings@

48-- schema definition. You can construct names by using the @OverloadedStrings@

45-- extension and writing string literals. This is typically done when providing

49-- extension and writing string literals. This is typically done when providing

46-- a 'TableSchema' value.

50-- a 'TableSchema' value.

47−type Name :: k -> Type

51+type Name :: K.Context

48−data Name a where

52+newtype Name a = Name String

49− Name :: k ~ Type => !String -> Name (a :: k)

53+ deriving stock Show

50−

54+ deriving newtype IsString

51−

52−deriving stock instance Show (Name a)

53−

54−

55−instance k ~ Type => IsString (Name (a :: k)) where

56− fromString = Name

59instance Sql DBType a => Table Name (Name a) where

57instance Sql DBType a => Table Name (Name a) where

60− type Columns (Name a) = HType a

58+ type Columns (Name a) = HIdentity a

61 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

63− toColumns a = HType (N a)

63+ toColumns a = HIdentity a

64− fromColumns (HType (N a)) = a

64+ fromColumns (HIdentity a) = a

65− reify = notReify

65+ toResult a = HIdentity (Identity a)

66− unreify = notReify

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

67−

68−

69−instance Sql DBType a => Recontextualize Expr Name (Expr a) (Name a)

70−

71−

72−instance Sql DBType a => Recontextualize Result Name (Identity a) (Name a)

73−

74−

75−instance Sql DBType a => Recontextualize Name Expr (Name a) (Expr a)

76−

77−

78−instance Sql DBType a => Recontextualize Name Result (Name a) (Identity a)

79−

80−

81−instance Sql DBType a => Recontextualize Name Name (Name a) (Name a)

82−

83−

84−instance Interpretation Name where

85− data Col Name _spec where

86− N :: {unN :: !(Name a)} -> Col Name ('Spec a)

89-- | @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

90-- the 'Expr' columns in @b@.

70-- the 'Expr' columns in @b@.

91type Selects :: Type -> Type -> Constraint

71type Selects :: Type -> Type -> Constraint

92−class Recontextualize Name Expr names exprs => Selects names exprs

72+class Transposes Name Expr names exprs => Selects names exprs

93−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−68

@@ -1,68 +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.HTable ( HTable, hmap )

27−import Rel8.Schema.Kind ( Context )

28−

29−

30−type Reify :: Context -> Context

31−data Reify context a

32−

33−

34−instance Interpretation (Reify context) where

35− newtype Col (Reify context) spec = Reify (Col context spec)

36−

37−

38−hreify :: HTable t => t (Col context) -> t (Col (Reify context))

39−hreify = hmap Reify

40−

41−

42−hunreify :: HTable t => t (Col (Reify context)) -> t (Col context)

43−hunreify = hmap (\(Reify a) -> a)

44−

45−

46−type UnwrapReify :: Context -> Context

47−type family UnwrapReify context where

48− UnwrapReify (Reify context) = context

49−

50−

51−type IsReify :: Context -> Bool

52−type family IsReify context where

53− IsReify (Reify _) = 'True

54− IsReify _ = 'False

55−

56−

57−type NotReify :: Context -> Constraint

58−class IsReify context ~ 'False => NotReify context

59−instance IsReify context ~ 'False => NotReify context

60−

61−

62−notReify :: forall context ctx a. NotReify context => context :~: Reify ctx -> a

63−notReify refl = case lemma @context of

64− Refl -> case refl of

65−

66−

67−lemma :: NotReify context => IsReify context :~: 'False

68−lemma = Refl

src/Rel8/Schema/Result.hs+16−33

@@ -5,20 +5,20 @@

5{-# language TypeFamilies #-}

7module Rel8.Schema.Result

8− ( Col( R, unR ), Result

8+ ( Result

9 , null, nullifier, unnullifier

10 , vectorizer, unvectorizer

11 )

12where

14-- base

15+import Data.Functor.Identity ( Identity( Identity), runIdentity )

15import Prelude hiding ( null )

16import Prelude hiding ( null )

17-- rel8

18-- rel8

18−import Rel8.Schema.Context ( Interpretation( Col ) )

19import Rel8.Schema.Kind ( Context )

20import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )

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

@@ -26,46 +26,29 @@ import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )

26-- When a query is executed against a PostgreSQL database, Rel8 parses the

27-- returned rows, decoding each row into the @Result@ context.

28type Result :: Context

29−data Result a

29+type Result = Identity

32−instance Interpretation Result where

32+null :: Result (Maybe a)

33− data Col Result _spec where

33+null = Identity Nothing

34− R :: {unR :: !a} -> Col Result ('Spec a)

37−null :: Col Result ('Spec (Maybe a))

36+nullifier :: Spec a -> Result a -> Result (Nullify a)

38−null = R Nothing

37+nullifier Spec {nullity} (Identity a) = Identity $ case nullity of

39−

40−

41−nullifier :: ()

42− => SSpec ('Spec a)

43− -> Col Result ('Spec a)

44− -> Col Result ('Spec (Nullify a))

45−nullifier SSpec {nullity} (R a) = R $ case nullity of

46 Null -> a

38 Null -> a

47 NotNull -> Just a

39 NotNull -> Just a

50−unnullifier :: ()

42+unnullifier :: Spec a -> Result (Nullify a) -> Maybe (Result a)

51− => SSpec ('Spec a)

43+unnullifier Spec {nullity} (Identity a) =

52− -> Col Result ('Spec (Nullify a))

53− -> Maybe (Col Result ('Spec a))

54−unnullifier SSpec {nullity} (R a) =

55 case nullity of

44 case nullity of

56− Null -> pure $ R a

45+ Null -> pure $ Identity a

57− NotNull -> R <$> a

46+ NotNull -> Identity <$> a

60−vectorizer :: Functor f

49+vectorizer :: Functor f => Spec a -> f (Result a) -> Result (f a)

61− => SSpec ('Spec a)

50+vectorizer _ = Identity . fmap runIdentity

62− -> f (Col Result ('Spec a))

63− -> Col Result ('Spec (f a))

64−vectorizer _ = R . fmap unR

67−unvectorizer :: Functor f

53+unvectorizer :: Functor f => Spec a -> Result (f a) -> f (Result a)

68− => SSpec ('Spec a)

54+unvectorizer _ (Identity results) = Identity <$> results

69− -> Col Result ('Spec (f a))

70− -> f (Col Result ('Spec a))

71−unvectorizer _ (R results) = R <$> results

src/Rel8/Schema/Spec.hs+16−30

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

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 )

6+ ( Spec( Spec, labels, info, nullity )

9− , SSpec( SSpec, labels, info, nullity )

7+ , specification

10− , KnownSpec( specSing )

11 )

8 )

12where

9where

14-- base

11-- base

15−import Data.Kind ( Constraint, Type )

12+import Data.Kind ( Type )

16import Prelude

13import Prelude

18-- rel8

15-- rel8

@@ -21,28 +18,17 @@ import Rel8.Type ( DBType, typeInformation )

21import Rel8.Type.Information ( TypeInformation )

18import Rel8.Type.Information ( TypeInformation )

24−type Spec :: Type

21+type Spec :: Type -> Type

25−newtype Spec = Spec Type

22+data Spec a = Spec

23+ { labels :: [String]

24+ , info :: TypeInformation (Unnullify a)

25+ , nullity :: Nullity a

26+ }

28−type SSpec :: Spec -> Type

29+specification :: Sql DBType a => Spec a

29−data SSpec spec where

30+specification = Spec

30− SSpec ::

31+ { labels = []

31− { labels :: [String]

32+ , info = typeInformation

32− , info :: TypeInformation (Unnullify a)

33+ , nullity = nullable

33− , nullity :: Nullity a

34+ }

34− }

35− -> SSpec ('Spec a)

36−

37−

38−type KnownSpec :: Spec -> Constraint

39−class KnownSpec spec where

40− specSing :: SSpec spec

41−

42−

43−instance Sql DBType a => KnownSpec ('Spec a) where

44− specSing = SSpec

45− { labels = []

46− , info = typeInformation

47− , nullity = nullable

48− }

src/Rel8/Schema/Spec/Constrain.hsdeleted−32

@@ -1,32 +0,0 @@

1−{-# language ConstraintKinds #-}

2−{-# language DataKinds #-}

3−{-# language FlexibleInstances #-}

4−{-# language MultiParamTypeClasses #-}

5−{-# language StandaloneKindSignatures #-}

6−{-# language TypeFamilies #-}

7−{-# language UndecidableInstances #-}

8−{-# language UndecidableSuperClasses #-}

9−

10−module Rel8.Schema.Spec.Constrain

11− ( ConstrainSpec

12− )

13−where

14−

15−-- base

16−import Data.Kind ( Constraint, Type )

17−import Prelude ()

18−

19−-- rel8

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

21−

22−

23−type Unspec :: Spec -> Type

24−type family Unspec spec where

25− Unspec ('Spec a) = a

26−

27−

28−type ConstrainSpec :: (Type -> Constraint) -> Spec -> Constraint

29−class (spec ~ 'Spec (Unspec spec), constraint (Unspec spec)) =>

30− ConstrainSpec constraint spec

31−instance (spec ~ 'Spec (Unspec spec), constraint (Unspec spec)) =>

32− ConstrainSpec constraint spec

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.

50− , deleteWhere :: exprs -> Expr Bool

47+ , using :: Query using

48+ -- ^ @USING@ clause — this can be used to join against other tables,

49+ -- and its results can be referenced in the @WHERE@ clause

50+ , deleteWhere :: using -> exprs -> Expr Bool

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.Schema.Name ( Selects )

33+import Rel8.Query ( Query )

34−import Rel8.Schema.Table ( TableSchema )

34+import Rel8.Schema.Name ( Name, Selects, ppColumn )

35−import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) )

35+import Rel8.Schema.Table ( TableSchema(..), ppTable )

36−import Rel8.Table ( fromColumns, toColumns )

36+import Rel8.Statement.OnConflict ( OnConflict, ppOnConflict )

37−import Rel8.Table.Opaleye ( castTable, table, unpackspec )

37+import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )

38−import Rel8.Table.Serialize ( Serializable, parse )

38+import Rel8.Statement.Select ( ppRows )

39+import Rel8.Table ( Table )

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

61− , onConflict :: OnConflict

55+ -- 'Rel8.values' insert a static list of rows.

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 )

12−import Prelude ()

22+import Data.List.NonEmpty ( NonEmpty )

23+import Prelude

24+

25+-- hasql

26+import qualified Hasql.Decoders as Hasql

27+

28+-- opaleye

29+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

30+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye

31+import qualified Opaleye.Internal.Sql as Opaleye

32+

33+-- pretty

34+import Text.PrettyPrint ( Doc, (<+>), text )

14-- rel8

36-- rel8

15import Rel8.Schema.Name ( Selects )

37import Rel8.Schema.Name ( Selects )

16−import Rel8.Table.Serialize ( Serializable )

38+import Rel8.Schema.Table ( TableSchema(..) )

39+import Rel8.Table.Opaleye ( castTable, exprs, view )

40+import Rel8.Table.Serialize ( Serializable, parse )

42+-- semigropuoids

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

19−-- | @INSERT@, @UPDATE@ and @DELETE@ all support returning either the number of

45+

20−-- rows affected, or the actual rows modified. 'Projection' allows you to

46+-- | 'Rel8.Insert', 'Rel8.Update' and 'Rel8.Delete' all support returning either

21−-- project out of these returned rows, which can be useful if you want to log

47+-- the number of rows affected, or the actual rows modified.

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

27− Projection :: (Selects names exprs, Serializable projection a)

55+

28− => (exprs -> projection)

56+ -- | 'Projection' allows you to project out of the affected rows, which can

57+ -- be useful if you want to log exactly which rows were deleted, or to view

58+ -- a generated id (for example, if using a column with an autoincrementing

59+ -- counter via 'Rel8.nextval').

60+ Projection :: (Selects names exprs, Serializable returning a)

61+ => (exprs -> returning)

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 )

13−import Prelude

21+import Data.Kind ( Type )

22+import Data.Void ( Void )

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'

49− ( Selects names exprs

80+ where

50− , Serializable exprs a

81+ names = namesFromLabels

51− )

82+ (exprs, primQuery, _) =

52− => Connection -> names -> Query exprs -> IO [a]

83+ Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

53−selectWithNames c names query = case sqlForQueryWithNames names query of

84+ (exprs', primQuery') = case optimize primQuery of

54− Nothing -> pure []

85+ Empty -> (undefined, Opaleye.Product (pure (pure Opaleye.Unit)) never)

55− Just sql -> Hasql.run session c >>= either throwIO pure

86+ Unit -> (exprs, Opaleye.Unit)

56− where

87+ Optimized pq -> (exprs, pq)

57− session = Hasql.statement () statement

88+ never = pure (toPrimExpr false)

58− statement = Hasql.Statement bytes params decode prepare

89+

59− bytes = encodeUtf8 (Text.pack sql)

90+

60− params = Hasql.noParams

91+ppRows :: Table Expr a => Query a -> Doc

61− decode = Hasql.rowList (parse @exprs @a)

92+ppRows query = case optimize primQuery of

62− prepare = False

93+ -- Special case VALUES because we can't use DEFAULT inside a SELECT

94+ Optimized (Opaleye.Values symbols rows)

95+ | eqSymbols symbols (toList (T.exprs a)) ->

96+ Opaleye.ppValues_ (map Opaleye.sqlExpr <$> toList rows)

97+ _ -> ppSelect query

98+ where

99+ (a, primQuery, _) = Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

100+

101+ eqSymbols (symbol : symbols) (Opaleye.AttrExpr symbol' : exprs)

102+ | eqSymbol symbol symbol' = eqSymbols symbols exprs

103+ | otherwise = False

104+ eqSymbols [] [] = True

105+ eqSymbols _ _ = False

106+

107+ eqSymbol

108+ (Opaleye.Symbol name (Opaleye.UnsafeTag tag))

109+ (Opaleye.Symbol name' (Opaleye.UnsafeTag tag'))

110+ = name == name' && tag == tag'

111+

112+

113+ppPrimSelect :: Query a -> (Optimized Doc, a)

114+ppPrimSelect query =

115+ (Opaleye.ppSql . primSelect <$> optimize primQuery, a)

116+ where

117+ (a, primQuery, _) = Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

118+

119+

120+type Optimized :: Type -> Type

121+data Optimized a = Empty | Unit | Optimized a

122+ deriving stock (Functor, Foldable, Traversable, Show)

123+

124+

125+optimize :: Opaleye.PrimQuery' a -> Optimized (Opaleye.PrimQuery' Void)

126+optimize query = case Opaleye.removeEmpty (Opaleye.optimize query) of

127+ Nothing -> Empty

128+ Just Opaleye.Unit -> Unit

129+ Just query' -> Optimized query'

130+

131+

132+primSelect :: Opaleye.PrimQuery' Void -> Opaleye.Select

133+primSelect = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator

134+

135+

136+primSelectWith :: Selects names exprs

137+ => names -> exprs -> Opaleye.PrimQuery' Void -> Opaleye.Select

138+primSelectWith names exprs query =

139+ Opaleye.SelectFrom $ Opaleye.newSelect

140+ { Opaleye.attrs = Opaleye.SelectAttrs attrs

141+ , Opaleye.tables = Opaleye.oneTable (primSelect query)

142+ }

143+ where

144+ attrs = makeAttr <$> exprsWithNames names (castTable exprs)

145+ where

146+ makeAttr (label, expr) =

147+ (Opaleye.sqlExpr expr, Just (Opaleye.SqlColumn label))

src/Rel8/Statement/Set.hsnew file+33

@@ -0,0 +1,33 @@

1+{-# language MonoLocalBinds #-}

2+{-# language NamedFieldPuns #-}

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.

49− , set :: exprs -> exprs

47+ , from :: Query from

48+ -- ^ @FROM@ clause — this can be used to join against other tables,

49+ -- and its results can be referenced in the @SET@ and @WHERE@ clauses.

50+ , set :: from -> exprs -> exprs

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

@@ -1,75 +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

18− ( Table (Columns, Context, Unreify, toColumns, fromColumns, reify, unreify)

14+ ( Table

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 )

34+import Rel8.Generic.Table.Record

38−import Rel8.Generic.Table

35+ ( GTable, GColumns, GContext, gfromColumns, gtoColumns

39− ( GGTable, GGColumns, GGContext, ggfromColumns, ggtoColumns

36+ , GSerialize, gfromResult, gtoResult

40− , GAlgebra

41 )

37 )

42import Rel8.Generic.Record ( Record(..) )

38import Rel8.Generic.Record ( Record(..) )

43−import Rel8.Generic.Reify ( ARep )

44import Rel8.Schema.HTable ( HTable )

39import Rel8.Schema.HTable ( HTable )

45−import Rel8.Schema.HTable.Either ( HEitherTable(..) )

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

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

47−import Rel8.Schema.HTable.Label ( hlabel, hrelabel, hunlabel )

48−import Rel8.Schema.HTable.List ( HListTable )

49−import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )

50−import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )

51−import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify )

52−import Rel8.Schema.HTable.These ( HTheseTable(..) )

53−import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )

54import qualified Rel8.Schema.Kind as K

41import qualified Rel8.Schema.Kind as K

55import Rel8.Schema.Null ( Sql )

42import Rel8.Schema.Null ( Sql )

56−import Rel8.Schema.Reify

43+import Rel8.Schema.Result ( Result )

57− ( Reify, Col( Reify ), hreify, hunreify

58− , UnwrapReify

59− , notReify

60− )

61−import Rel8.Schema.Result

62− ( Col( R ), Result

63− , null, nullifier, unnullifier

64− , vectorizer, unvectorizer

65− )

66−import Rel8.Schema.Spec ( KnownSpec )

67import Rel8.Type ( DBType )

44import Rel8.Type ( DBType )

68−import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )

69−

70−-- these

71−import Data.These ( These( This, That, These ) )

72−import Data.These.Combinators ( justHere, justThere )

75-- | @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

@@ -84,90 +56,102 @@ import Data.These.Combinators ( justHere, justThere )

84-- 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

85-- 'Table'.

57-- 'Table'.

86type Table :: K.Context -> Type -> Constraint

58type Table :: K.Context -> Type -> Constraint

87−class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where

59+class

60+ ( HTable (Columns a)

61+ , context ~ Context a

62+ , a ~ Transpose context a

63+ )

64+ => Table context a | a -> context

65+ where

88 -- | The 'HTable' functor that describes the schema of this table.

66 -- | The 'HTable' functor that describes the schema of this table.

89 type Columns a :: K.HTable

67 type Columns a :: K.HTable

91 -- | The common context that all columns use as an interpretation.

69 -- | The common context that all columns use as an interpretation.

92 type Context a :: K.Context

70 type Context a :: K.Context

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

96− toColumns :: a -> Columns a (Col context)

97− fromColumns :: Columns a (Col context) -> a

99− reify :: context :~: Reify ctx -> Unreify a -> a

79+ toColumns :: a -> Columns a context

100− unreify :: context :~: Reify ctx -> a -> Unreify a

80+ fromColumns :: Columns a context -> a

101

102− type Columns a = Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))

82+ fromResult :: Columns a Result -> FromExprs a

103− type Context a = Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))

83+ toResult :: FromExprs a -> Columns a Result

104− type Unreify a = DefaultUnreify a

84+

85+ type Columns a = GColumns TColumns (Rep (Record a))

86+ type Context a = GContext TContext (Rep (Record a))

87+ type FromExprs a = Map TFromExprs a

88+ type Transpose context a = Map (TTranspose context) a

105

106 default toColumns ::

90 default toColumns ::

107 ( Generic (Record a)

91 ( Generic (Record a)

108− , KnownAlgebra (GAlgebra (Rep (Record a)))

92+ , GTable (TTable context) TColumns (Rep (Record a))

109− , Eval (GGTable (GAlgebra (Rep (Record a))) (TTable context) TColumns (Col context) (Rep (Record a)))

93+ , Columns a ~ GColumns TColumns (Rep (Record a))

110− , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))

111− , Context a ~ Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))

112 )

94 )

113− => a -> Columns a (Col context)

95+ => a -> Columns a context

114 toColumns =

96 toColumns =

115− ggtoColumns

97+ gtoColumns @(TTable context) @TColumns toColumns .

116− @(GAlgebra (Rep (Record a)))

117− @(TTable context)

118− @TColumns

119− id

120− id

121− toColumns .

122 from .

98 from .

123 Record

99 Record

124

100

125 default fromColumns ::

101 default fromColumns ::

126 ( Generic (Record a)

102 ( Generic (Record a)

127− , KnownAlgebra (GAlgebra (Rep (Record a)))

103+ , GTable (TTable context) TColumns (Rep (Record a))

128− , Eval (GGTable (GAlgebra (Rep (Record a))) (TTable context) TColumns (Col context) (Rep (Record a)))

104+ , Columns a ~ GColumns TColumns (Rep (Record a))

129− , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))

130− , Context a ~ Eval (GGContext (GAlgebra (Rep (Record a))) TContext (Rep (Record a)))

131 )

105 )

132− => Columns a (Col context) -> a

106+ => Columns a context -> a

133 fromColumns =

107 fromColumns =

134 unrecord .

108 unrecord .

135 to .

109 to .

136− ggfromColumns

110+ gfromColumns @(TTable context) @TColumns fromColumns

137− @(GAlgebra (Rep (Record a)))

138− @(TTable context)

139− @TColumns

140− id

141− id

142− fromColumns

143

111

144− default reify ::

112+ default toResult ::

145− ( Generic (Record a)

113+ ( Generic (Record (FromExprs a))

146− , Generic (Record (Unreify a))

114+ , GSerialize TSerialize TColumns (Rep (Record a)) (Rep (Record (FromExprs a)))

147− , GMappable (TTable context) (Rep (Record a))

115+ , Columns a ~ GColumns TColumns (Rep (Record a))

148− , Rep (Record (Unreify a)) ~ GMap TUnreify (Rep (Record a))

149 )

116 )

150− => context :~: Reify ctx -> Unreify a -> a

117+ => FromExprs a -> Columns a Result

151− reify Refl =

118+ toResult =

152− unrecord .

119+ gtoResult

153− to .

120+ @TSerialize

154− 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) .

155 from .

125 from .

156 Record

126 Record

157

127

158− default unreify ::

128+ default fromResult ::

159− ( Generic (Record a)

129+ ( Generic (Record (FromExprs a))

160− , Generic (Record (Unreify a))

130+ , GSerialize TSerialize TColumns (Rep (Record a)) (Rep (Record (FromExprs a)))

161− , GMappable (TTable context) (Rep (Record a))

131+ , Columns a ~ GColumns TColumns (Rep (Record a))

162− , Rep (Record (Unreify a)) ~ GMap TUnreify (Rep (Record a))

163 )

132 )

164− => context :~: Reify ctx -> a -> Unreify a

133+ => Columns a Result -> FromExprs a

165− unreify Refl =

134+ fromResult =

166 unrecord .

135 unrecord .

167 to .

136 to .

168− gmap @(TTable context) (Proxy @TUnreify) (unreify Refl) .

137+ gfromResult

169− from .

138+ @TSerialize

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

171

155

172

156

173data TTable :: K.Context -> Type -> Exp Constraint

157data TTable :: K.Context -> Type -> Exp Constraint

@@ -182,163 +166,22 @@ data TContext :: Type -> Exp K.Context

182type instance Eval (TContext a) = Context a

166type instance Eval (TContext a) = Context a

183

167

184

168

185−data TUnreify :: Type -> Exp Type

169+data TFromExprs :: Type -> Exp Type

186−type instance Eval (TUnreify a) = Unreify a

170+type instance Eval (TFromExprs a) = FromExprs a

187−

188−

189−type DefaultUnreify :: Type -> Type

190−type family DefaultUnreify a where

191− DefaultUnreify (t a b c d e f g) =

192− t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e) (Unreify f) (Unreify g)

193− DefaultUnreify (t a b c d e f) =

194− t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e) (Unreify f)

195− DefaultUnreify (t a b c d e) =

196− t (Unreify a) (Unreify b) (Unreify c) (Unreify d) (Unreify e)

197− DefaultUnreify (t a b c d) =

198− t (Unreify a) (Unreify b) (Unreify c) (Unreify d)

199− DefaultUnreify (t a b c) = t (Unreify a) (Unreify b) (Unreify c)

200− DefaultUnreify (t a b) = t (Unreify a) (Unreify b)

201− DefaultUnreify (t a) = t (Unreify a)

202− DefaultUnreify a = ARep (GMap TUnreify (Rep a))

203−

204

171

205−-- | Any 'HTable' is also a 'Table'.

206−instance HTable t => Table context (t (Col context)) where

207− type Columns (t (Col context)) = t

208− type Context (t (Col context)) = context

209− type Unreify (t (Col context)) = t (Col (UnwrapReify context))

210

172

211− toColumns = id

173+data TTranspose :: K.Context -> Type -> Exp Type

212− fromColumns = id

174+type instance Eval (TTranspose context a) = Transpose context a

213

175

214− reify Refl = hreify

215− unreify Refl = hunreify

216−

217−

218−-- | Any context is trivially a table.

219−instance KnownSpec spec => Table context (Col context spec) where

220− type Columns (Col context spec) = HIdentity spec

221− type Context (Col context spec) = context

222− type Unreify (Col context spec) = Col (UnwrapReify context) spec

223−

224− toColumns = HIdentity

225− fromColumns = unHIdentity

226−

227− reify Refl = Reify

228− unreify Refl (Reify a) = a

229

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

230

182

231−instance Sql DBType a => Table Result (Identity a) where

232− type Columns (Identity a) = HType a

233− type Context (Identity a) = Result

234

183

235− toColumns (Identity a) = HType (R a)

184+instance (Table context a, Table context b) => Table context (a, b)

236− fromColumns (HType (R a)) = Identity a

237−

238− reify = notReify

239− unreify = notReify

240−

241−

242−instance (Table Result a, Table Result b) => Table Result (Either a b) where

243− type Columns (Either a b) = HEitherTable (Columns a) (Columns b)

244− type Context (Either a b) = Result

245−

246− toColumns = \case

247− Left table -> HEitherTable

248− { htag = hlabel (HType (R IsLeft))

249− , hleft = hlabel (hnullify nullifier (toColumns table))

250− , hright = hlabel (hnulls (const null))

251− }

252− Right table -> HEitherTable

253− { htag = hlabel (HType (R IsRight))

254− , hleft = hlabel (hnulls (const null))

255− , hright = hlabel (hnullify nullifier (toColumns table))

256− }

257−

258− fromColumns HEitherTable {htag, hleft, hright} = case hunlabel htag of

259− HType (R tag) -> case tag of

260− IsLeft -> maybe err (Left . fromColumns) $ hunnullify unnullifier (hunlabel hleft)

261− IsRight -> maybe err (Right . fromColumns) $ hunnullify unnullifier (hunlabel hright)

262− where

263− err = error "Either.fromColumns: mismatch between tag and data"

264−

265−

266−instance Table Result a => Table Result [a] where

267− type Columns [a] = HListTable (Columns a)

268− type Context [a] = Result

269−

270− toColumns = hvectorize vectorizer . fmap toColumns

271− fromColumns = fmap fromColumns . hunvectorize unvectorizer

272−

273−

274−instance Table Result a => Table Result (Maybe a) where

275− type Columns (Maybe a) = HMaybeTable (Columns a)

276− type Context (Maybe a) = Result

277−

278− toColumns = \case

279− Nothing -> HMaybeTable

280− { htag = hlabel (HIdentity (R Nothing))

281− , hjust = hlabel (hnulls (const null))

282− }

283− Just table -> HMaybeTable

284− { htag = hlabel (HIdentity (R (Just IsJust)))

285− , hjust = hlabel (hnullify nullifier (toColumns table))

286− }

287−

288− fromColumns HMaybeTable {htag, hjust} = case hunlabel htag of

289− HType (R tag) -> tag $>

290− case hunnullify unnullifier (hunlabel hjust) of

291− Nothing -> error "Maybe.fromColumns: mismatch between tag and data"

292− Just just -> fromColumns just

293−

294−

295−instance Table Result a => Table Result (NonEmpty a) where

296− type Columns (NonEmpty a) = HNonEmptyTable (Columns a)

297− type Context (NonEmpty a) = Result

298−

299− toColumns = hvectorize vectorizer . fmap toColumns

300− fromColumns = fmap fromColumns . hunvectorize unvectorizer

301−

302−

303−instance (Table Result a, Table Result b) => Table Result (These a b) where

304− type Columns (These a b) = HTheseTable (Columns a) (Columns b)

305− type Context (These a b) = Result

306−

307− toColumns tables = HTheseTable

308− { hhereTag = hrelabel hhereTag

309− , hhere = hrelabel (toColumns hhere)

310− , hthereTag = hrelabel hthereTag

311− , hthere = hrelabel (toColumns hthere)

312− }

313− where

314− HMaybeTable

315− { htag = hhereTag

316− , hjust = hhere

317− } = toColumns (justHere tables)

318− HMaybeTable

319− { htag = hthereTag

320− , hjust = hthere

321− } = toColumns (justThere tables)

322−

323− fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} =

324− case (fromColumns mhere, fromColumns mthere) of

325− (Just a, Nothing) -> This (fromColumns a)

326− (Nothing, Just b) -> That (fromColumns b)

327− (Just a, Just b) -> These (fromColumns a) (fromColumns b)

328− _ -> error "These.fromColumns: mismatch between tags and data"

329− where

330− mhere = HMaybeTable

331− { htag = hrelabel hhereTag

332− , hjust = hrelabel hhere

333− }

334− mthere = HMaybeTable

335− { htag = hrelabel hthereTag

336− , hjust = hrelabel hthere

337− }

338−

339−

340−instance (Table context a, Table context b)

341− => Table context (a, b)

342

185

343

186

344instance

187instance

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

30+import GHC.Generics ( Generic, from, to )

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

32−import GHC.Generics ( Generic, Rep, 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−

76+ to .

88− from =

77+ G.gfromResultADT

89− gmap @(TTable (Reify Result)) (Proxy @TUnreify) (unreify Refl) .

78+ @TSerialize

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 =

101− ADT .

102− hunreify .

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

@@ -27,8 +27,7 @@ import Rel8.Schema.Dict ( Dict( Dict ) )

27import Rel8.Schema.HTable ( HTable, hfield, htabulate )

28import Rel8.Schema.HTable.Vectorize ( hvectorize )

29import Rel8.Schema.Null ( Sql )

30−import Rel8.Schema.Spec ( SSpec( SSpec, info ) )

30+import Rel8.Schema.Spec ( Spec( Spec, info ) )

31−import Rel8.Schema.Spec.Constrain ( ConstrainSpec )

32import Rel8.Table ( toColumns, fromColumns )

31import Rel8.Table ( toColumns, fromColumns )

33import Rel8.Table.Eq ( EqTable, eqTable )

32import Rel8.Table.Eq ( EqTable, eqTable )

34import Rel8.Table.List ( ListTable )

33import Rel8.Table.List ( ListTable )

@@ -38,17 +37,28 @@ import Rel8.Type.Eq ( DBEq )

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

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

40-- given table with 'groupByExpr'.

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

41groupBy :: forall exprs aggregates. (EqTable exprs, Aggregates aggregates exprs)

52groupBy :: forall exprs aggregates. (EqTable exprs, Aggregates aggregates exprs)

42 => exprs -> aggregates

53 => exprs -> aggregates

43groupBy = fromColumns . hgroupBy (eqTable @exprs) . toColumns

54groupBy = fromColumns . hgroupBy (eqTable @exprs) . toColumns

46−hgroupBy :: HTable t

57+hgroupBy :: HTable t => t (Dict (Sql DBEq)) -> t Expr -> t Aggregate

47− => t (Dict (ConstrainSpec (Sql DBEq))) -> t (Col Expr) -> t (Col Aggregate)

58+hgroupBy eqs exprs = htabulate $ \field ->

48−hgroupBy eqs exprs = fromColumns $ htabulate $ \field ->

49 case hfield eqs field of

59 case hfield eqs field of

50 Dict -> case hfield exprs field of

60 Dict -> case hfield exprs field of

51− E expr -> A $ groupByExpr expr

61+ expr -> groupByExpr expr

54-- | 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

@@ -61,22 +71,22 @@ hgroupBy eqs exprs = fromColumns $ htabulate $ \field ->

61-- items:

71-- items:

62--

72--

63-- @

73-- @

64−-- ordersWithItems :: Query (Order Expr, ListTable (Item Expr))

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

65-- ordersWithItems = do

75-- ordersWithItems = do

66-- order <- each orderSchema

76-- order <- each orderSchema

67-- items <- aggregate $ listAgg <$> itemsFromOrder order

77-- items <- aggregate $ listAgg <$> itemsFromOrder order

68-- return (order, items)

78-- return (order, items)

69-- @

79-- @

70−listAgg :: Aggregates aggregates exprs => exprs -> ListTable aggregates

80+listAgg :: Aggregates aggregates exprs => exprs -> ListTable Aggregate aggregates

71listAgg (toColumns -> exprs) = fromColumns $

81listAgg (toColumns -> exprs) = fromColumns $

72 hvectorize

82 hvectorize

73− (\SSpec {info} (Identity (E a)) -> A $ slistAggExpr info a)

83+ (\Spec {info} (Identity a) -> slistAggExpr info a)

74 (pure exprs)

84 (pure exprs)

77-- | 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.

78−nonEmptyAgg :: Aggregates aggregates exprs => exprs -> NonEmptyTable aggregates

88+nonEmptyAgg :: Aggregates aggregates exprs => exprs -> NonEmptyTable Aggregate aggregates

79nonEmptyAgg (toColumns -> exprs) = fromColumns $

89nonEmptyAgg (toColumns -> exprs) = fromColumns $

80 hvectorize

90 hvectorize

81− (\SSpec {info} (Identity (E a)) -> A $ snonEmptyAggExpr info a)

91+ (\Spec {info} (Identity a) -> snonEmptyAggExpr info a)

82 (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) ->

31+ (falseExpr, trueExpr) -> boolExpr falseExpr trueExpr condition

32− E (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+111−96

@@ -18,41 +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.Nullify

40+import Rel8.Kind.Context ( Reifiable )

36− ( Nullifiable

41+import Rel8.Schema.Context.Nullify ( Nullifiable )

37− , encodeTag, decodeTag

38− , nullifier, unnullifier

39− )

40import Rel8.Schema.Dict ( Dict( Dict ) )

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

41import Rel8.Schema.HTable.Either ( HEitherTable(..) )

43import Rel8.Schema.HTable.Either ( HEitherTable(..) )

42import Rel8.Schema.HTable.Identity ( HIdentity(..) )

44import Rel8.Schema.HTable.Identity ( HIdentity(..) )

43import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

45import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

44−import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )

46+import qualified Rel8.Schema.Kind as K

45import Rel8.Schema.Name ( Name )

47import Rel8.Schema.Name ( Name )

46import Rel8.Table

48import Rel8.Table

47 ( Table, Columns, Context, fromColumns, toColumns

49 ( Table, Columns, Context, fromColumns, toColumns

48− , reify, unreify

50+ , FromExprs, fromResult, toResult

51+ , Transpose

49 )

52 )

50import Rel8.Table.Bool ( bool )

53import Rel8.Table.Bool ( bool )

51import Rel8.Table.Eq ( EqTable, eqTable )

54import Rel8.Table.Eq ( EqTable, eqTable )

55+import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )

52import Rel8.Table.Ord ( OrdTable, ordTable )

56import Rel8.Table.Ord ( OrdTable, ordTable )

53−import Rel8.Table.Recontextualize ( Recontextualize )

57+import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )

54−import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )

58+import Rel8.Table.Serialize ( ToExprs )

55−import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )

56import Rel8.Table.Undefined ( undefined )

59import Rel8.Table.Undefined ( undefined )

57import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )

60import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )

@@ -67,150 +70,162 @@ import Data.Functor.Bind ( Bind, (>>-) )

67--

70--

68-- An @EitherTable@ is operationally the same as Haskell's 'Either' type, but

71-- An @EitherTable@ is operationally the same as Haskell's 'Either' type, but

69-- adapted to work with Rel8.

72-- adapted to work with Rel8.

70−type EitherTable :: Type -> Type -> Type

73+type EitherTable :: K.Context -> Type -> Type -> Type

71−data EitherTable a b = EitherTable

74+data EitherTable context a b = EitherTable

72− { tag :: Tag "isRight" EitherTag

75+ { tag :: context EitherTag

73− , left :: a

76+ , left :: Nullify context a

74− , right :: b

77+ , right :: Nullify context b

75 }

78 }

76 deriving stock Functor

79 deriving stock Functor

79−instance Bifunctor EitherTable where

82+instance Biprojectable (EitherTable context) where

80− bimap f g (EitherTable tag a b) = EitherTable tag (f a) (g b)

83+ biproject f g (EitherTable tag a b) =

84+ EitherTable tag (project f a) (project g b)

85+

86+

87+instance Nullifiable context => Bifunctor (EitherTable context) where

88+ bimap f g (EitherTable tag a b) = EitherTable tag (fmap f a) (fmap g b)

89+

90+

91+instance Projectable (EitherTable context a) where

92+ project f (EitherTable tag a b) = EitherTable tag a (project f b)

83−instance Table Expr a => Apply (EitherTable a) where

95+instance (context ~ Expr, Table Expr a) => Apply (EitherTable context a) where

84 EitherTable tag l1 f <.> EitherTable tag' l2 a =

96 EitherTable tag l1 f <.> EitherTable tag' l2 a =

85− EitherTable (tag <> tag') (bool l1 l2 (isLeft (expr tag))) (f a)

97+ EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f <.> a)

88−instance Table Expr a => Applicative (EitherTable a) where

100+instance (context ~ Expr, Table Expr a) => Applicative (EitherTable context a) where

89 pure = rightTable

101 pure = rightTable

90 (<*>) = (<.>)

102 (<*>) = (<.>)

103

104

93−instance Table Expr a => Bind (EitherTable a) where

105+instance (context ~ Expr, Table Expr a) => Bind (EitherTable context a) where

94− EitherTable tag l1 a >>- f = case f a of

106+ EitherTable tag l1 a >>- f = case f (extract a) of

95 EitherTable tag' l2 b ->

107 EitherTable tag' l2 b ->

96− EitherTable (tag <> tag') (bool l1 l2 (isRight (expr tag))) b

108+ EitherTable (tag <> tag') (bool l1 l2 (isRight tag)) b

109

110

99−instance Table Expr a => Monad (EitherTable a) where

111+instance (context ~ Expr, Table Expr a) => Monad (EitherTable context a) where

100 (>>=) = (>>-)

112 (>>=) = (>>-)

101

113

102

114

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

104 a <> b = bool a b (isRightTable a)

118 a <> b = bool a b (isRightTable a)

105

119

106

120

107instance

121instance

108 ( Table context a, Table context b

122 ( Table context a, Table context b

109− , Nullifiable context

123+ , Reifiable context, context ~ context'

110 )

124 )

111− => Table context (EitherTable a b)

125+ => Table context' (EitherTable context a b)

112 where

126 where

113− type Columns (EitherTable a b) = HEitherTable (Columns a) (Columns b)

127+ type Columns (EitherTable context a b) = HEitherTable (Columns a) (Columns b)

114− type Context (EitherTable a b) = Context a

128+ type Context (EitherTable context a b) = Context a

129+ type FromExprs (EitherTable context a b) = Either (FromExprs a) (FromExprs b)

130+ type Transpose to (EitherTable context a b) =

131+ EitherTable to (Transpose to a) (Transpose to b)

115

132

116 toColumns EitherTable {tag, left, right} = HEitherTable

133 toColumns EitherTable {tag, left, right} = HEitherTable

117− { htag

134+ { htag = hlabel $ HIdentity tag

118− , hleft = hlabel $ hnullify (nullifier tag isLeft) $ toColumns left

135+ , hleft = hlabel $ guard tag (== IsLeft) isLeft $ toColumns left

119− , hright = hlabel $ hnullify (nullifier tag isRight) $ toColumns right

136+ , hright = hlabel $ guard tag (== IsRight) isRight $ toColumns right

120 }

137 }

121− where

122− htag = hlabel $ HType $ encodeTag tag

123

138

124 fromColumns HEitherTable {htag, hleft, hright} = EitherTable

139 fromColumns HEitherTable {htag, hleft, hright} = EitherTable

125− { tag

140+ { tag = unHIdentity $ hunlabel htag

126− , left =

141+ , left = fromColumns $ hunlabel hleft

127− fromColumns $

142+ , right = fromColumns $ hunlabel hright

128− runIdentity $

129− hunnullify (\a -> pure . unnullifier a) $

130− hunlabel

131− hleft

132− , right =

133− fromColumns $

134− runIdentity $

135− hunnullify (\a -> pure . unnullifier a) $

136− hunlabel

137− hright

138 }

143 }

139− where

140− tag = decodeTag $ unHIdentity $ hunlabel htag

141−

142− reify = liftA2 bimap reify reify

143− unreify = liftA2 bimap unreify unreify

144−

145

144

146−instance

145+ toResult = \case

147− ( Nullifiable from, Nullifiable to

146+ Left table -> HEitherTable

148− , Recontextualize from to a1 b1

147+ { htag = hlabel (HIdentity (Identity IsLeft))

149− , Recontextualize from to a2 b2

148+ , hleft = hlabel (toResult @_ @(Nullify context a) (Just table))

150− )

149+ , hright = hlabel (toResult @_ @(Nullify context b) Nothing)

151− => Recontextualize from to (EitherTable a1 a2) (EitherTable b1 b2)

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"

152

163

153

164

154−instance (EqTable a, EqTable b) => EqTable (EitherTable a b) where

165+instance (EqTable a, EqTable b, context ~ Expr) =>

166+ EqTable (EitherTable context a b)

167+ where

155 eqTable = HEitherTable

168 eqTable = HEitherTable

156− { htag = hlabel (HType Dict)

169+ { htag = hlabel (HIdentity Dict)

157− , hleft = hlabel (hnullify (\_ Dict -> Dict) (eqTable @a))

170+ , hleft = hlabel (eqTable @(Nullify context a))

158− , hright = hlabel (hnullify (\_ Dict -> Dict) (eqTable @b))

171+ , hright = hlabel (eqTable @(Nullify context b))

159 }

172 }

160

173

161

174

162−instance (OrdTable a, OrdTable b) => OrdTable (EitherTable a b) where

175+instance (OrdTable a, OrdTable b, context ~ Expr) =>

176+ OrdTable (EitherTable context a b)

177+ where

163 ordTable = HEitherTable

178 ordTable = HEitherTable

164− { htag = hlabel (HType Dict)

179+ { htag = hlabel (HIdentity Dict)

165− , hleft = hlabel (hnullify (\_ Dict -> Dict) (ordTable @a))

180+ , hleft = hlabel (ordTable @(Nullify context a))

166− , hright = hlabel (hnullify (\_ Dict -> Dict) (ordTable @b))

181+ , hright = hlabel (ordTable @(Nullify context b))

167 }

182 }

168

183

169

184

170−type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)

185+instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable Expr exprs1 exprs2) =>

171−

172−

173−instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable exprs1 exprs2) =>

174 ToExprs x (Either a b)

186 ToExprs x (Either a b)

175− where

176− fromResult =

177− bimap (fromResult @exprs1) (fromResult @exprs2) .

178− fromColumns

179− toResult =

180− toColumns .

181− bimap (toResult @exprs1) (toResult @exprs2)

182

187

183

188

184-- | Test if an 'EitherTable' is a 'leftTable'.

189-- | Test if an 'EitherTable' is a 'leftTable'.

185−isLeftTable :: EitherTable a b -> Expr Bool

190+isLeftTable :: EitherTable Expr a b -> Expr Bool

186−isLeftTable = isLeft . expr . tag

191+isLeftTable EitherTable {tag} = isLeft tag

187

192

188

193

189-- | Test if an 'EitherTable' is a 'rightTable'.

194-- | Test if an 'EitherTable' is a 'rightTable'.

190−isRightTable :: EitherTable a b -> Expr Bool

195+isRightTable :: EitherTable Expr a b -> Expr Bool

191−isRightTable = isRight . expr . tag

196+isRightTable EitherTable {tag} = isRight tag

192

197

193

198

194-- | Pattern match/eliminate an 'EitherTable', by providing mappings from a

199-- | Pattern match/eliminate an 'EitherTable', by providing mappings from a

195-- 'leftTable' and 'rightTable'.

200-- 'leftTable' and 'rightTable'.

196eitherTable :: Table Expr c

201eitherTable :: Table Expr c

197− => (a -> c) -> (b -> c) -> EitherTable a b -> c

202+ => (a -> c) -> (b -> c) -> EitherTable Expr a b -> c

198eitherTable f g EitherTable {tag, left, right} =

203eitherTable f g EitherTable {tag, left, right} =

199− bool (f left) (g right) (isRight (expr tag))

204+ bool (f (extract left)) (g (extract right)) (isRight tag)

200

205

201

206

202-- | Construct a left 'EitherTable'. Like 'Left'.

207-- | Construct a left 'EitherTable'. Like 'Left'.

203−leftTable :: Table Expr b => a -> EitherTable a b

208+leftTable :: Table Expr b => a -> EitherTable Expr a b

204−leftTable a = EitherTable (fromExpr (litExpr IsLeft)) a undefined

209+leftTable a = EitherTable (litExpr IsLeft) (pure a) undefined

205

210

206

211

207-- | Construct a right 'EitherTable'. Like 'Right'.

212-- | Construct a right 'EitherTable'. Like 'Right'.

208−rightTable :: Table Expr a => b -> EitherTable a b

213+rightTable :: Table Expr a => b -> EitherTable Expr a b

209−rightTable = rightTableWith undefined

214+rightTable = EitherTable (litExpr IsRight) undefined . pure

210−

215+

211−

216+

212−rightTableWith :: a -> b -> EitherTable a b

217+-- | Lift a pair of aggregating functions to operate on an 'EitherTable'.

213−rightTableWith = EitherTable (fromExpr (litExpr IsRight))

218+-- @leftTable@s and @rightTable@s are grouped separately.

219+aggregateEitherTable :: ()

220+ => (exprs -> aggregates)

221+ -> (exprs' -> aggregates')

222+ -> EitherTable Expr exprs exprs'

223+ -> EitherTable Aggregate aggregates aggregates'

224+aggregateEitherTable f g (EitherTable tag a b) = EitherTable

225+ { tag = groupByExpr tag

226+ , left = aggregateNullify f a

227+ , right = aggregateNullify g b

228+ }

214

229

215

230

216-- | Construct a 'EitherTable' in the 'Name' context. This can be useful if you

231-- | Construct a 'EitherTable' in the 'Name' context. This can be useful if you

@@ -224,5 +239,5 @@ nameEitherTable

224 -- ^ Names of the columns in the @a@ table.

239 -- ^ Names of the columns in the @a@ table.

225 -> b

240 -> b

226 -- ^ Names of the columns in the @b@ table.

241 -- ^ Names of the columns in the @b@ table.

227− -> EitherTable a b

242+ -> EitherTable Name a b

228−nameEitherTable = EitherTable . fromName

243+nameEitherTable tag left right = EitherTable tag (pure left) (pure right)

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

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

44− , htabulateA, hfield, hdicts

45− )

46−import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )

47import Rel8.Schema.Null ( Sql )

39import Rel8.Schema.Null ( Sql )

48−import Rel8.Schema.Spec.Constrain ( ConstrainSpec )

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 (ConstrainSpec (Sql DBEq)))

49+ eqTable :: Columns a (Dict (Sql DBEq))

60 default eqTable ::

51 default eqTable ::

61− ( KnownAlgebra (GAlgebra (Rep (Record a)))

52+ ( GTable TEqTable TColumns (Rep (Record a))

62− , Eval (GGTable (GAlgebra (Rep (Record a))) TEqTable TColumns (Dict (ConstrainSpec (Sql DBEq))) (Rep (Record a)))

53+ , Columns a ~ GColumns TColumns (Rep (Record a))

63− , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))

64 )

54 )

65− => Columns a (Dict (ConstrainSpec (Sql 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− (\_ Dict -> Dict)

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 (ConstrainSpec (Sql DBEq))

86− )

87− => EqTable (t f)

88− where

89− eqTable = hdicts @(Columns (t f)) @(ConstrainSpec (Sql 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 )

53−import Rel8.Generic.Record ( GRecord, GRecordable, grecord, gunrecord )

50+import Rel8.Generic.Record

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

69+ ( Table, fromColumns, toColumns, fromResult, toResult

72− , fromColumns, toColumns, reify, unreify

70+ , TTable, TColumns, TContext

73− , TTable, TColumns, TUnreify

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

115+ ( GTable (TTable f) TColumns (GRecord (GMap (TColumn f) (Rep a)))

99− , HTable (GColumnsHKD a)

116+ , G.GColumns TColumns (GRecord (GMap (TColumn f) (Rep a))) ~ GColumnsHKD a

100− , Eval (GGTable (GAlgebra (Rep a)) (TTable (Reify f)) TColumns (Col (Reify f)) (GRecord (GMap (TColumn (Reify f)) (Rep a))))

117+ , GContext TContext (GRecord (GMap (TColumn f) (Rep a))) ~ f

101− , Eval (GGColumns (GAlgebra (Rep a)) TColumns (GRecord (GMap (TColumn (Reify f)) (Rep a)))) ~ GColumnsHKD a

118+ , GRecordable (GMap (TColumn f) (Rep a))

102− , Eval (GGContext (GAlgebra (Rep a)) TUnreifyContext (GRecord (GMap (TColumn (Reify f)) (Rep a)))) ~ f

103− , GRecordable (GMap (TColumn (Reify 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) .

125+ gunrecord @(GMap (TColumn f) (Rep a)) .

113− gunrecord @(GMap (TColumn (Reify f)) (Rep a)) .

126+ G.gfromColumns

114− ggfromColumns

127+ @(TTable f)

115− @(GAlgebra (Rep a))

116− @(TTable (Reify 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

135+ @(TTable f)

128− @(GAlgebra (Rep a))

129− @(TTable (Reify 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

147+ , GRecord (GMap (TColumn Result) (Rep a)) ~ Rep (Record a)

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)

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

155+ , GRecord (GMap (TColumn Result) (Rep a)) ~ Rep (Record a)

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)

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+61−48

@@ -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,29 +11,36 @@

11module Rel8.Table.List

12module Rel8.Table.List

12 ( ListTable(..)

13 ( ListTable(..)

13− , listTable, nameListTable

14+ , ($*)

15+ , listTable

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

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

31+ ( hvectorize, hunvectorize

32+ , happend, hempty

33+ , hproject, hcolumn

34+ )

35+import qualified Rel8.Schema.Kind as K

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

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.Reify ( hreify, hunreify )

39+import Rel8.Schema.Spec ( Spec(..) )

33import Rel8.Table

40import Rel8.Table

34 ( Table, Context, Columns, fromColumns, toColumns

41 ( Table, Context, Columns, fromColumns, toColumns

35− , reify, unreify

42+ , FromExprs, fromResult, toResult

43+ , Transpose

36 )

44 )

37import Rel8.Table.Alternative

45import Rel8.Table.Alternative

38 ( AltTable, (<|>:)

46 ( AltTable, (<|>:)

@@ -40,85 +48,90 @@ import Rel8.Table.Alternative

40 )

48 )

41import Rel8.Table.Eq ( EqTable, eqTable )

49import Rel8.Table.Eq ( EqTable, eqTable )

42import Rel8.Table.Ord ( OrdTable, ordTable )

50import Rel8.Table.Ord ( OrdTable, ordTable )

43−import Rel8.Table.Recontextualize ( Recontextualize )

51+import Rel8.Table.Projection

44−import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )

52+ ( Projectable, Projecting, Projection, project, apply

45−import Rel8.Table.Unreify ( Unreifies )

53+ )

54+import Rel8.Table.Serialize ( ToExprs )

48-- | 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

49-- @ListTable@s with 'Rel8.many' or 'Rel8.listAgg'.

58-- @ListTable@s with 'Rel8.many' or 'Rel8.listAgg'.

50−type ListTable :: Type -> Type

59+type ListTable :: K.Context -> Type -> Type

51−newtype ListTable a = ListTable (HListTable (Columns a) (Col (Context a)))

60+newtype ListTable 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)

54−instance (Table context a, Unreifies context a) =>

68+instance (Table context a, context ~ context') =>

55− Table context (ListTable a)

69+ Table context' (ListTable context a)

56 where

70 where

57− type Columns (ListTable a) = HListTable (Columns a)

71+ type Columns (ListTable context a) = HListTable (Columns a)

58− 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)

60 fromColumns = ListTable

76 fromColumns = ListTable

61 toColumns (ListTable a) = a

77 toColumns (ListTable a) = a

62−

78+ fromResult = fmap (fromResult @_ @a) . hunvectorize unvectorizer

63− reify Refl (ListTable a) = ListTable (hreify a)

79+ toResult = hvectorize vectorizer . fmap (toResult @_ @a)

64− unreify Refl (ListTable a) = ListTable (hunreify a)

65−

66−

67−instance

68− ( Unreifies from a, Unreifies to b

69− , Recontextualize from to a b

70− )

71− => Recontextualize from to (ListTable a) (ListTable b)

74−instance EqTable a => EqTable (ListTable a) where

82+instance (EqTable a, context ~ Expr) => EqTable (ListTable context a) where

75 eqTable =

83 eqTable =

76 hvectorize

84 hvectorize

77− (\SSpec {nullity} (Identity Dict) -> case nullity of

85+ (\Spec {nullity} (Identity Dict) -> case nullity of

78 Null -> Dict

86 Null -> Dict

79 NotNull -> Dict)

87 NotNull -> Dict)

80 (Identity (eqTable @a))

88 (Identity (eqTable @a))

83−instance OrdTable a => OrdTable (ListTable a) where

91+instance (OrdTable a, context ~ Expr) => OrdTable (ListTable context a) where

84 ordTable =

92 ordTable =

85 hvectorize

93 hvectorize

86− (\SSpec {nullity} (Identity Dict) -> case nullity of

94+ (\Spec {nullity} (Identity Dict) -> case nullity of

87 Null -> Dict

95 Null -> Dict

88 NotNull -> Dict)

96 NotNull -> Dict)

89 (Identity (ordTable @a))

97 (Identity (ordTable @a))

92−type instance FromExprs (ListTable a) = [FromExprs a]

100+instance (ToExprs exprs a, context ~ Expr) =>

93−

101+ ToExprs (ListTable context exprs) [a]

102

95−instance ToExprs exprs a => ToExprs (ListTable exprs) [a] where

96− fromResult = fmap (fromResult @exprs) . fromColumns

97− toResult = toColumns . fmap (toResult @exprs)

103

99−

104+instance context ~ Expr => AltTable (ListTable context) where

100−instance AltTable ListTable where

101 (<|>:) = (<>)

105 (<|>:) = (<>)

102

106

103

107

104−instance AlternativeTable ListTable where

108+instance context ~ Expr => AlternativeTable (ListTable context) where

105 emptyTable = mempty

109 emptyTable = mempty

106

110

107

111

108−instance Table Expr a => Semigroup (ListTable a) where

112+instance (context ~ Expr, Table Expr a) => Semigroup (ListTable context a)

109− ListTable as <> ListTable bs = ListTable $

113+ where

110− happend (\_ _ (E a) (E b) -> E (sappend a b)) as bs

114+ ListTable as <> ListTable bs = ListTable $ happend (const sappend) as bs

115+

116+

117+instance (context ~ Expr, Table Expr a) =>

118+ Monoid (ListTable context a)

119+ where

120+ mempty = ListTable $ hempty $ \Spec {info} -> sempty info

111

121

112

122

113−instance Table Expr a => Monoid (ListTable a) where

123+-- | Project a single expression out of a 'ListTable'.

114− 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 $*

115

128

116

129

117-- | Construct a @ListTable@ from a list of expressions.

130-- | Construct a @ListTable@ from a list of expressions.

118−listTable :: Table Expr a => [a] -> ListTable a

131+listTable :: Table Expr a => [a] -> ListTable Expr a

119listTable =

132listTable =

120 ListTable .

133 ListTable .

121− hvectorize (\SSpec {info} -> E . slistOf info . fmap unE) .

134+ hvectorize (\Spec {info} -> slistOf info) .

122 fmap toColumns

135 fmap toColumns

123

136

124

137

@@ -128,9 +141,9 @@ listTable =

128nameListTable

141nameListTable

129 :: Table Name a

142 :: Table Name a

130 => a -- ^ The names of the columns of elements of the list.

143 => a -- ^ The names of the columns of elements of the list.

131− -> ListTable a

144+ -> ListTable Name a

132nameListTable =

145nameListTable =

133 ListTable .

146 ListTable .

134− hvectorize (\_ (Identity (N (Name a))) -> N (Name a)) .

147+ hvectorize (\_ (Identity (Name a)) -> Name a) .

135 pure .

148 pure .

136 toColumns

149 toColumns

src/Rel8/Table/Maybe.hs+100−88

@@ -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,35 +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.Nullify

41+import Rel8.Kind.Context ( Reifiable )

34− ( Nullifiable

35− , encodeTag, decodeTag

36− , nullifier, unnullifier

37− )

38import Rel8.Schema.Dict ( Dict( Dict ) )

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

43+import qualified Rel8.Schema.Kind as K

39import Rel8.Schema.HTable.Identity ( HIdentity(..) )

44import Rel8.Schema.HTable.Identity ( HIdentity(..) )

40import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

45import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

41import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )

46import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )

42−import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )

43import Rel8.Schema.Name ( Name )

47import Rel8.Schema.Name ( Name )

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

45import Rel8.Table

50import Rel8.Table

46 ( Table, Columns, Context, fromColumns, toColumns

51 ( Table, Columns, Context, fromColumns, toColumns

47− , reify, unreify

52+ , FromExprs, fromResult, toResult

53+ , Transpose

48 )

54 )

49import Rel8.Table.Alternative

55import Rel8.Table.Alternative

50 ( AltTable, (<|>:)

56 ( AltTable, (<|>:)

@@ -53,12 +59,12 @@ import Rel8.Table.Alternative

53import Rel8.Table.Bool ( bool )

59import Rel8.Table.Bool ( bool )

54import Rel8.Table.Eq ( EqTable, eqTable )

60import Rel8.Table.Eq ( EqTable, eqTable )

55import Rel8.Table.Ord ( OrdTable, ordTable )

61import Rel8.Table.Ord ( OrdTable, ordTable )

56−import Rel8.Table.Recontextualize ( Recontextualize )

62+import Rel8.Table.Projection ( Projectable, project )

57−import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )

63+import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )

58−import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )

64+import Rel8.Table.Serialize ( ToExprs )

59import Rel8.Table.Undefined ( undefined )

65import Rel8.Table.Undefined ( undefined )

60import Rel8.Type ( DBType )

66import Rel8.Type ( DBType )

61−import Rel8.Type.Tag ( MaybeTag )

67+import Rel8.Type.Tag ( MaybeTag( IsJust ) )

63-- semigroupoids

69-- semigroupoids

64import Data.Functor.Apply ( Apply, (<.>) )

70import Data.Functor.Apply ( Apply, (<.>) )

@@ -73,154 +79,160 @@ import Data.Functor.Bind ( Bind, (>>-) )

73-- 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

74-- 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 -

75-- 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.

76−type MaybeTable :: Type -> Type

82+type MaybeTable :: K.Context -> Type -> Type

77−data MaybeTable a = MaybeTable

83+data MaybeTable context a = MaybeTable

78− { tag :: Tag "isJust" (Maybe MaybeTag)

84+ { tag :: context (Maybe MaybeTag)

79− , just :: a

85+ , just :: Nullify context a

80 }

86 }

81 deriving stock Functor

87 deriving stock Functor

84−instance Apply MaybeTable where

90+instance Projectable (MaybeTable context) where

85− MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f a)

91+ project f (MaybeTable tag a) = MaybeTable tag (project f a)

92+

93+

94+instance context ~ Expr => Apply (MaybeTable context) where

95+ MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f <.> a)

88-- | 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:

89-- 'Rel8.traverseMaybeTable'.

99-- 'Rel8.traverseMaybeTable'.

90−instance Applicative MaybeTable where

100+instance context ~ Expr => Applicative (MaybeTable context) where

91 (<*>) = (<.>)

101 (<*>) = (<.>)

92 pure = justTable

102 pure = justTable

103

104

95−instance Bind MaybeTable where

105+instance context ~ Expr => Bind (MaybeTable context) where

96− MaybeTable tag a >>- f = case f a of

106+ MaybeTable tag a >>- f = case f (extract a) of

97 MaybeTable tag' b -> MaybeTable (tag <> tag') b

107 MaybeTable tag' b -> MaybeTable (tag <> tag') b

108

109

100-- | Has the same behavior as the @Monad@ instance for @Maybe@.

110-- | Has the same behavior as the @Monad@ instance for @Maybe@.

101−instance Monad MaybeTable where

111+instance context ~ Expr => Monad (MaybeTable context) where

102 (>>=) = (>>-)

112 (>>=) = (>>-)

103

113

104

114

105−instance AltTable MaybeTable where

115+instance context ~ Expr => AltTable (MaybeTable context) where

106− ma@(MaybeTable tag a) <|>: MaybeTable tag' b = MaybeTable

116+ ma <|>: mb = bool ma mb (isNothingTable ma)

107− { tag = (tag <> tag')

108− { expr = boolExpr (expr tag) (expr tag') condition

109− }

110− , just = bool a b condition

111− }

112− where

113− condition = isNothingTable ma

114

117

115

118

116−instance AlternativeTable MaybeTable where

119+instance context ~ Expr => AlternativeTable (MaybeTable context) where

117 emptyTable = nothingTable

120 emptyTable = nothingTable

118

121

119

122

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

121 ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma

126 ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma

122

127

123

128

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

125 mempty = nothingTable

132 mempty = nothingTable

126

133

127

134

128−instance

135+instance (Table context a, Reifiable context, context ~ context') =>

129− ( Table context a

136+ Table context' (MaybeTable context a)

130− , Nullifiable context

131− )

132− => Table context (MaybeTable a)

133 where

137 where

134− type Columns (MaybeTable a) = HMaybeTable (Columns a)

138+ type Columns (MaybeTable context a) = HMaybeTable (Columns a)

135− type Context (MaybeTable a) = Context a

139+ type Context (MaybeTable context a) = Context a

140+ type FromExprs (MaybeTable context a) = Maybe (FromExprs a)

141+ type Transpose to (MaybeTable context a) = MaybeTable to (Transpose to a)

136

142

137 toColumns MaybeTable {tag, just} = HMaybeTable

143 toColumns MaybeTable {tag, just} = HMaybeTable

138− { htag

144+ { htag = hlabel $ HIdentity tag

139− , hjust = hlabel $ hnullify (nullifier tag isNonNull) $ toColumns just

145+ , hjust = hlabel $ guard tag isJust isNonNull $ toColumns just

140 }

146 }

141− where

142− htag = hlabel (HType (encodeTag tag))

143

147

144 fromColumns HMaybeTable {htag, hjust} = MaybeTable

148 fromColumns HMaybeTable {htag, hjust} = MaybeTable

145− { tag

149+ { tag = unHIdentity $ hunlabel htag

146− , just = fromColumns $ runIdentity $

150+ , just = fromColumns $ hunlabel hjust

147− hunnullify (\a -> pure . unnullifier a) (hunlabel hjust)

148 }

151 }

149− where

150− tag = decodeTag (unHIdentity (hunlabel htag))

151−

152− reify = fmap fmap reify

153− unreify = fmap fmap unreify

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

158+ fromResult HMaybeTable {htag, hjust} = case hunlabel htag of

157− ( Nullifiable from

159+ HIdentity (Identity tag) -> tag $>

158− , Nullifiable to

160+ fromMaybe err (fromResult @_ @(Nullify context a) (hunlabel hjust))

159− , Recontextualize from to a b

161+ where

160− )

162+ err = error "Maybe.fromColumns: mismatch between tag and data"

161− => Recontextualize from to (MaybeTable a) (MaybeTable b)

162

163

164

164−instance EqTable a => EqTable (MaybeTable a) where

165+instance (EqTable a, context ~ Expr) => EqTable (MaybeTable context a) where

165 eqTable = HMaybeTable

166 eqTable = HMaybeTable

166− { htag = hlabel (HType Dict)

167+ { htag = hlabel (HIdentity Dict)

167− , hjust = hlabel (hnullify (\_ Dict -> Dict) (eqTable @a))

168+ , hjust = hlabel (eqTable @(Nullify context a))

168 }

169 }

169

170

171

171−instance OrdTable a => OrdTable (MaybeTable a) where

172+instance (OrdTable a, context ~ Expr) => OrdTable (MaybeTable context a) where

172 ordTable = HMaybeTable

173 ordTable = HMaybeTable

173− { htag = hlabel (HType Dict)

174+ { htag = hlabel (HIdentity Dict)

174− , hjust = hlabel (hnullify (\_ Dict -> Dict) (ordTable @a))

175+ , hjust = hlabel (ordTable @(Nullify context a))

175 }

176 }

176

177

178

178−type instance FromExprs (MaybeTable a) = Maybe (FromExprs a)

179+instance (ToExprs exprs a, context ~ Expr) =>

179−

180+ ToExprs (MaybeTable context exprs) (Maybe a)

180−

181−instance ToExprs exprs a => ToExprs (MaybeTable exprs) (Maybe a) where

182− fromResult = fmap (fromResult @exprs) . fromColumns

183− toResult = toColumns . fmap (toResult @exprs)

184

181

185

182

186-- | 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'.

187−isNothingTable :: MaybeTable a -> Expr Bool

184+isNothingTable :: MaybeTable Expr a -> Expr Bool

188−isNothingTable (MaybeTable tag _) = isNull (expr tag)

185+isNothingTable (MaybeTable tag _) = isNull tag

189

186

190

187

191-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.

188-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.

192−isJustTable :: MaybeTable a -> Expr Bool

189+isJustTable :: MaybeTable Expr a -> Expr Bool

193−isJustTable (MaybeTable tag _) = isNonNull (expr tag)

190+isJustTable (MaybeTable tag _) = isNonNull tag

194

191

195

192

196-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.

193-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.

197−maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable a -> b

194+maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable Expr a -> b

198−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)

199{-# INLINABLE maybeTable #-}

196{-# INLINABLE maybeTable #-}

200

197

201

198

202-- | The null table. Like 'Nothing'.

199-- | The null table. Like 'Nothing'.

203−nothingTable :: Table Expr a => MaybeTable a

200+nothingTable :: Table Expr a => MaybeTable Expr a

204−nothingTable = MaybeTable (fromExpr null) undefined

201+nothingTable = MaybeTable null (pure undefined)

205

202

206

203

207-- | 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

208-- 'pure'.

205-- 'pure'.

209−justTable :: a -> MaybeTable a

206+justTable :: a -> MaybeTable Expr a

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

211

213

212

214

213-- | 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

214-- 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

215-- @null@.

217-- @null@.

216($?) :: forall a b. Sql DBType b

218($?) :: forall a b. Sql DBType b

217− => (a -> Expr b) -> MaybeTable a -> Expr (Nullify b)

219+ => (a -> Expr b) -> MaybeTable Expr a -> Expr (N.Nullify b)

218f $? ma@(MaybeTable _ a) = case nullable @b of

220f $? ma@(MaybeTable _ a) = case nullable @b of

219− Null -> boolExpr (f a) null (isNothingTable ma)

221+ Null -> boolExpr (f (extract a)) null (isNothingTable ma)

220− NotNull -> boolExpr (nullify (f a)) null (isNothingTable ma)

222+ NotNull -> boolExpr (nullify (f (extract a))) null (isNothingTable ma)

221infixl 4 $?

223infixl 4 $?

222

224

223

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+

224-- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you

236-- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you

225-- have a 'MaybeTable' that you are storing in a table and need to construct a

237-- have a 'MaybeTable' that you are storing in a table and need to construct a

226-- 'TableSchema'.

238-- 'TableSchema'.

@@ -230,5 +242,5 @@ nameMaybeTable

230 -- 'nothingTable'.

242 -- 'nothingTable'.

231 -> a

243 -> a

232 -- ^ Names of the columns in @a@.

244 -- ^ Names of the columns in @a@.

233− -> MaybeTable a

245+ -> MaybeTable Name a

234−nameMaybeTable = MaybeTable . fromName

246+nameMaybeTable tag = MaybeTable tag . pure

src/Rel8/Table/Name.hs+11−20

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

@@ -21,16 +24,11 @@ import Data.List.NonEmpty ( NonEmpty, intersperse, nonEmpty )

21import Data.Maybe ( fromMaybe )

24import Data.Maybe ( fromMaybe )

22import Prelude

25import Prelude

24−-- opaleye

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

26−

27-- rel8

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

29−import Rel8.Expr.Opaleye ( toPrimExpr )

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(..) )

36-- | Construct a table in the 'Name' context containing the names of all

34-- | Construct a table in the 'Name' context containing the names of all

@@ -62,26 +60,19 @@ namesFromLabelsWith :: Table Name a

62 => (NonEmpty String -> String) -> a

60 => (NonEmpty String -> String) -> a

63namesFromLabelsWith f = fromColumns $ htabulate $ \field ->

61namesFromLabelsWith f = fromColumns $ htabulate $ \field ->

64 case hfield hspecs field of

62 case hfield hspecs field of

65− SSpec {labels} -> N (Name (f (renderLabels labels)))

63+ Spec {labels} -> Name (f (renderLabels labels))

66−

67−

68−showExprs :: Table Expr a => a -> [(String, Opaleye.PrimExpr)]

69−showExprs as = case (namesFromLabels, toColumns as) of

70− (names, exprs) -> getConst $ htabulateA $ \field ->

71− case (hfield names field, hfield exprs field) of

72− (N (Name name), E expr) -> Const [(name, toPrimExpr expr)]

75showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]

66showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]

76showLabels _ = getConst $

67showLabels _ = getConst $

77 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

68 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

78− SSpec {labels} -> Const [renderLabels labels]

69+ Spec {labels} -> Const (pure (renderLabels labels))

81−showNames :: forall a. Table Name a => a -> [String]

72+showNames :: forall a. Table Name a => a -> NonEmpty String

82showNames (toColumns -> names) = getConst $

73showNames (toColumns -> names) = getConst $

83 htabulateA @(Columns a) $ \field -> case hfield names field of

74 htabulateA @(Columns a) $ \field -> case hfield names field of

84− N (Name name) -> Const [name]

75+ Name name -> Const (pure name)

87renderLabels :: [String] -> NonEmpty String

78renderLabels :: [String] -> NonEmpty String

src/Rel8/Table/NonEmpty.hs+62−47

@@ -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(..)

13− , nonEmptyTable, nameNonEmptyTable

14+ , ($+)

15+ , nonEmptyTable

16+ , nameNonEmptyTable

14 )

17 )

15where

18where

@@ -18,99 +21,111 @@ 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 ) )

24+import Prelude hiding ( id )

22−import Prelude

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

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

32+ ( hvectorize, hunvectorize

33+ , happend

34+ , hproject, hcolumn

35+ )

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(..) )

34import Rel8.Table

41import Rel8.Table

35 ( Table, Context, Columns, fromColumns, toColumns

42 ( Table, Context, Columns, fromColumns, toColumns

36− , reify, unreify

43+ , FromExprs, fromResult, toResult

44+ , Transpose

37 )

45 )

38import Rel8.Table.Alternative ( AltTable, (<|>:) )

46import Rel8.Table.Alternative ( AltTable, (<|>:) )

39import Rel8.Table.Eq ( EqTable, eqTable )

47import Rel8.Table.Eq ( EqTable, eqTable )

40import Rel8.Table.Ord ( OrdTable, ordTable )

48import Rel8.Table.Ord ( OrdTable, ordTable )

41−import Rel8.Table.Recontextualize ( Recontextualize )

49+import Rel8.Table.Projection

42−import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )

50+ ( Projectable, Projecting, Projection, project, apply

43−import Rel8.Table.Unreify ( Unreifies )

51+ )

52+import Rel8.Table.Serialize ( ToExprs )

46-- | A @NonEmptyTable@ value contains one or more instances of @a@. You

55-- | A @NonEmptyTable@ value contains one or more instances of @a@. You

47-- construct @NonEmptyTable@s with 'Rel8.some' or 'nonEmptyAgg'.

56-- construct @NonEmptyTable@s with 'Rel8.some' or 'nonEmptyAgg'.

48−type NonEmptyTable :: Type -> Type

57+type NonEmptyTable :: K.Context -> Type -> Type

49−newtype NonEmptyTable a =

58+newtype NonEmptyTable context a =

50− 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)

53−instance (Table context a, Unreifies context a) =>

66+instance (Table context a, context ~ context') =>

54− Table context (NonEmptyTable a)

67+ Table context' (NonEmptyTable context a)

55 where

68 where

56− type Columns (NonEmptyTable a) = HNonEmptyTable (Columns a)

69+ type Columns (NonEmptyTable context a) = HNonEmptyTable (Columns a)

57− 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)

59 fromColumns = NonEmptyTable

75 fromColumns = NonEmptyTable

60 toColumns (NonEmptyTable a) = a

76 toColumns (NonEmptyTable a) = a

61−

77+ fromResult = fmap (fromResult @_ @a) . hunvectorize unvectorizer

62− reify Refl (NonEmptyTable a) = NonEmptyTable (hreify a)

78+ toResult = hvectorize vectorizer . fmap (toResult @_ @a)

63− unreify Refl (NonEmptyTable a) = NonEmptyTable (hunreify a)

64−

65−

66−instance

67− ( Unreifies from a, Unreifies to b

68− , Recontextualize from to a b

69− )

70− => Recontextualize from to (NonEmptyTable a) (NonEmptyTable b)

73−instance EqTable a => EqTable (NonEmptyTable a) where

81+instance (EqTable a, context ~ Expr) =>

82+ EqTable (NonEmptyTable context a)

83+ where

74 eqTable =

84 eqTable =

75 hvectorize

85 hvectorize

76− (\SSpec {nullity} (Identity Dict) -> case nullity of

86+ (\Spec {nullity} (Identity Dict) -> case nullity of

77 Null -> Dict

87 Null -> Dict

78 NotNull -> Dict)

88 NotNull -> Dict)

79 (Identity (eqTable @a))

89 (Identity (eqTable @a))

82−instance OrdTable a => OrdTable (NonEmptyTable a) where

92+instance (OrdTable a, context ~ Expr) =>

93+ OrdTable (NonEmptyTable context a)

94+ where

83 ordTable =

95 ordTable =

84 hvectorize

96 hvectorize

85− (\SSpec {nullity} (Identity Dict) -> case nullity of

97+ (\Spec {nullity} (Identity Dict) -> case nullity of

86 Null -> Dict

98 Null -> Dict

87 NotNull -> Dict)

99 NotNull -> Dict)

88 (Identity (ordTable @a))

100 (Identity (ordTable @a))

101

102

91−type instance FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)

103+instance (ToExprs exprs a, context ~ Expr) =>

92−

104+ ToExprs (NonEmptyTable context exprs) (NonEmpty a)

93−

94−instance ToExprs exprs a => ToExprs (NonEmptyTable exprs) (NonEmpty a)

95− where

96− fromResult = fmap (fromResult @exprs) . fromColumns

97− toResult = toColumns . fmap (toResult @exprs)

105

106

100−instance AltTable NonEmptyTable where

107+instance context ~ Expr => AltTable (NonEmptyTable context) where

101 (<|>:) = (<>)

108 (<|>:) = (<>)

102

109

103

110

104−instance Table Expr a => Semigroup (NonEmptyTable a) where

111+instance (Table Expr a, context ~ Expr) => Semigroup (NonEmptyTable context a)

112+ where

105 NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $

113 NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $

106− 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 $+

107

122

108

123

109-- | Construct a @NonEmptyTable@ from a non-empty list of expressions.

124-- | Construct a @NonEmptyTable@ from a non-empty list of expressions.

110−nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable a

125+nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable Expr a

111nonEmptyTable =

126nonEmptyTable =

112 NonEmptyTable .

127 NonEmptyTable .

113− hvectorize (\SSpec {info} -> E . snonEmptyOf info . fmap unE) .

128+ hvectorize (\Spec {info} -> snonEmptyOf info) .

114 fmap toColumns

129 fmap toColumns

115

130

116

131

@@ -120,9 +135,9 @@ nonEmptyTable =

120nameNonEmptyTable

135nameNonEmptyTable

121 :: Table Name a

136 :: Table Name a

122 => a -- ^ The names of the columns of elements of the list.

137 => a -- ^ The names of the columns of elements of the list.

123− -> NonEmptyTable a

138+ -> NonEmptyTable Name a

124nameNonEmptyTable =

139nameNonEmptyTable =

125 NonEmptyTable .

140 NonEmptyTable .

126− hvectorize (\_ (Identity (N (Name a))) -> N (Name a)) .

141+ hvectorize (\_ (Identity (Name a)) -> Name a) .

127 pure .

142 pure .

128 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

49+ , scastExpr, traverseFieldP

43− , fromColumn, toColumn

44− , scastExpr

45 )

50 )

46−import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs, htabulate )

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

47−import Rel8.Schema.Name ( Col( N ), Name( Name ), Selects )

52+ htraverseP, htraversePWithField )

48−import Rel8.Schema.Spec ( SSpec(..) )

53+import Rel8.Schema.Name ( Name( Name ), Selects, ppColumn )

49−import Rel8.Schema.Table ( TableSchema(..) )

54+import Rel8.Schema.Spec ( Spec(..) )

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 $

60− WrapApplicative $ case hfield (toColumns aggregates) field of

67+ lmap (\(Aggregate a) -> (a, ())) Opaleye.aggregatorApply

61− A (Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner))) ->

68+

62− E <$> inner f ()

69+

70+attributes :: Selects names exprs => TableSchema names -> exprs

71+attributes schema@TableSchema {columns} = fromColumns $ htabulate $ \field ->

72+ case hfield (toColumns columns) field of

73+ Name column -> fromPrimExpr $ Opaleye.ConstExpr $

74+ Opaleye.OtherLit $

75+ show (ppTable schema) <> "." <> show (ppColumn column)

76+

77+

78+fromOpaleyespec :: (ProductProfunctor p, Table Expr a)

79+ => p (Opaleye.Field_ n x) (Opaleye.Field_ n x)

80+ -> p a a

81+fromOpaleyespec x =

82+ dimap toColumns fromColumns (htraverseP (traverseFieldP x))

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 <$>

123+ Opaleye.requiredTableField name

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

138+view columns = fromColumns $ htabulate $ \field ->

120−toPackMap as = Opaleye.PackMap $ \f () ->

139+ case hfield (toColumns columns) field of

121− fmap fromColumns $

140+ Name column -> fromPrimExpr $ Opaleye.BaseTableAttrExpr column

122− unwrapApplicative .

123− htraverse (\(E a) -> WrapApplicative $ E <$> traversePrimExpr f a) $

124− toColumns as

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} ->

149+ Spec {info} -> case hfield as field of

134− case hfield as i of

150+ expr -> scastExpr info expr

135− E expr ->

136− E (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

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

42− , htabulateA, hfield, hdicts

43− )

44−import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )

45import Rel8.Schema.Null (Sql)

37import Rel8.Schema.Null (Sql)

46−import Rel8.Schema.Spec.Constrain ( ConstrainSpec )

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 (ConstrainSpec (Sql DBOrd)))

49+ ordTable :: Columns a (Dict (Sql DBOrd))

61 default ordTable ::

51 default ordTable ::

62− ( KnownAlgebra (GAlgebra (Rep (Record a)))

52+ ( GTable TOrdTable TColumns (Rep (Record a))

63− , Eval (GGTable (GAlgebra (Rep (Record a))) TOrdTable TColumns (Dict (ConstrainSpec (Sql DBOrd))) (Rep (Record a)))

53+ , Columns a ~ GColumns TColumns (Rep (Record a))

64− , Columns a ~ Eval (GGColumns (GAlgebra (Rep (Record a))) TColumns (Rep (Record a)))

65 )

54 )

66− => Columns a (Dict (ConstrainSpec (Sql 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− (\_ Dict -> Dict)

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 (ConstrainSpec (Sql DBEq))

87− , HConstrainTable t (ConstrainSpec (Sql DBOrd))

88− )

89− => OrdTable (t f)

90− where

91− ordTable = hdicts @(Columns (t f)) @(ConstrainSpec (Sql 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+5−6

@@ -16,13 +16,12 @@ import Data.Functor.Contravariant ( (>$<), contramap )

16import Prelude

18-- rel8

19−import Rel8.Expr ( unE )

20import Rel8.Expr.Order ( asc, desc, nullsFirst, nullsLast )

19import Rel8.Expr.Order ( asc, desc, nullsFirst, nullsLast )

21import Rel8.Order ( Order )

20import Rel8.Order ( Order )

22import Rel8.Schema.Dict ( Dict( Dict ) )

21import Rel8.Schema.Dict ( Dict( Dict ) )

23import Rel8.Schema.HTable (htabulateA, hfield, hspecs)

22import Rel8.Schema.HTable (htabulateA, hfield, hspecs)

24import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

23import Rel8.Schema.Null ( Nullity( Null, NotNull ) )

25−import Rel8.Schema.Spec ( SSpec( SSpec, nullity ) )

24+import Rel8.Schema.Spec ( Spec( Spec, nullity ) )

26import Rel8.Table ( Columns, toColumns )

25import Rel8.Table ( Columns, toColumns )

27import Rel8.Table.Ord ( OrdTable, ordTable )

26import Rel8.Table.Ord ( OrdTable, ordTable )

@@ -32,8 +31,8 @@ import Rel8.Table.Ord ( OrdTable, ordTable )

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 {nullity} -> case hfield (ordTable @a) field of

34+ Spec {nullity} -> case hfield (ordTable @a) field of

36− Dict -> Const $ unE . (`hfield` field) >$<

35+ Dict -> Const $ (`hfield` field) >$<

37 case nullity of

36 case nullity of

38 Null -> nullsFirst asc

37 Null -> nullsFirst asc

39 NotNull -> asc

38 NotNull -> asc

@@ -44,8 +43,8 @@ ascTable = contramap toColumns $ getConst $

44descTable :: forall a. OrdTable a => Order a

43descTable :: forall a. OrdTable a => Order a

45descTable = contramap toColumns $ getConst $

44descTable = contramap toColumns $ getConst $

46 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

45 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

47− SSpec {nullity} -> case hfield (ordTable @a) field of

46+ Spec {nullity} -> case hfield (ordTable @a) field of

48− Dict -> Const $ unE . (`hfield` field) >$<

47+ Dict -> Const $ (`hfield` field) >$<

49 case nullity of

48 case nullity of

50 Null -> nullsLast desc

49 Null -> nullsLast desc

51 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−111

@@ -1,111 +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.HTable ( HTable )

22−import qualified Rel8.Schema.Kind as K

23−import Rel8.Schema.Null ( Sql )

24−import Rel8.Schema.Result ( Result )

25−import Rel8.Schema.Spec ( KnownSpec )

26−import Rel8.Table ( Table, Congruent )

27−import Rel8.Type ( DBType )

28−

29−

30−-- | @Recontextualize from to a b@ is evidence that the types @a@ and @b@ are

31−-- related, and that @b@ is the same type as @a@, but after changing the

32−-- context from the initial context @from@, to the new context @to@.

33−type Recontextualize :: K.Context -> K.Context -> Type -> Type -> Constraint

34−class

35− ( Table from a

36− , Table to b

37− , Congruent a b

38− , Recontextualize from from a a

39− , Recontextualize to to b b

40− , Recontextualize to from b a

41− ) => Recontextualize from to a b

42− | a -> from

43− , b -> to

44− , a to -> b

45− , b from -> a

46−

47−

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

49−

50−

51−instance KnownSpec spec => Recontextualize from to (Col from spec) (Col to spec)

52−

53−

54−instance HTable t => Recontextualize from to (t (Col from)) (t (Col to))

55−

56−

57−instance

58− ( Recontextualize from to a1 b1

59− , Recontextualize from to a2 b2

60− )

61− => Recontextualize from to (a1, a2) (b1, b2)

62−

63−

64−instance

65− ( Recontextualize from to a1 b1

66− , Recontextualize from to a2 b2

67− , Recontextualize from to a3 b3

68− )

69− => Recontextualize from to (a1, a2, a3) (b1, b2, b3)

70−

71−

72−instance

73− ( Recontextualize from to a1 b1

74− , Recontextualize from to a2 b2

75− , Recontextualize from to a3 b3

76− , Recontextualize from to a4 b4

77− )

78− => Recontextualize from to (a1, a2, a3, a4) (b1, b2, b3, b4)

79−

80−

81−instance

82− ( Recontextualize from to a1 b1

83− , Recontextualize from to a2 b2

84− , Recontextualize from to a3 b3

85− , Recontextualize from to a4 b4

86− , Recontextualize from to a5 b5

87− )

88− => Recontextualize from to (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5)

89−

90−

91−instance

92− ( Recontextualize from to a1 b1

93− , Recontextualize from to a2 b2

94− , Recontextualize from to a3 b3

95− , Recontextualize from to a4 b4

96− , Recontextualize from to a5 b5

97− , Recontextualize from to a6 b6

98− )

99− => Recontextualize from to (a1, a2, a3, a4, a5, a6) (b1, b2, b3, b4, b5, b6)

100−

101−

102−instance

103− ( Recontextualize from to a1 b1

104− , Recontextualize from to a2 b2

105− , Recontextualize from to a3 b3

106− , Recontextualize from to a4 b4

107− , Recontextualize from to a5 b5

108− , Recontextualize from to a6 b6

109− , Recontextualize from to a7 b7

110− )

111− => Recontextualize from to (a1, a2, a3, a4, a5, a6, a7) (b1, b2, b3, b4, b5, b6, b7)

src/Rel8/Table/Rel8able.hs+28−82

@@ -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,132 +15,78 @@ module Rel8.Table.Rel8able

15where

17-- base

18−import Data.Kind ( Constraint, Type )

18+import Prelude ()

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

20−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− , 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.Dict ( Dict( Dict ) )

37import qualified Rel8.Schema.Kind as K

29import qualified Rel8.Schema.Kind as K

38import Rel8.Schema.HTable ( HConstrainTable, hdicts )

30import Rel8.Schema.HTable ( HConstrainTable, hdicts )

39import Rel8.Schema.Null ( Sql )

31import Rel8.Schema.Null ( Sql )

40−import Rel8.Schema.Reify ( hreify, hunreify, UnwrapReify )

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.Constrain ( ConstrainSpec )

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, 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 sReifiable context of

69− Dict -> greify

70−

71− unreify Refl = case contextSing @context of

72− SReify context -> case sReifiable context of

73− Dict -> gunreify

74−

76−instance

54+ fromColumns = gfromColumns contextSing

77− ( Rel8able t

55+ toColumns = gtoColumns contextSing

78− , Reifiable from

56+ fromResult = gfromResult @t

79− , Reifiable to

57+ toResult = gtoResult @t

80− , Congruent (t from) (t to)

81− )

82− => Recontextualize from to (t from) (t to)

85instance

60instance

86 ( context ~ Expr

61 ( context ~ Expr

87 , Rel8able t

62 , Rel8able t

88− , HConstrainTable (Columns (t context)) (ConstrainSpec (Sql DBEq))

63+ , HConstrainTable (Columns (t context)) (Sql DBEq)

89 )

64 )

90 => EqTable (t context)

65 => EqTable (t context)

91 where

66 where

92− eqTable = hdicts @(Columns (t context)) @(ConstrainSpec (Sql DBEq))

67+ eqTable = hdicts @(Columns (t context)) @(Sql DBEq)

95instance

70instance

96 ( context ~ Expr

71 ( context ~ Expr

97 , Rel8able t

72 , Rel8able t

98− , HConstrainTable (Columns (t context)) (ConstrainSpec (Sql DBEq))

73+ , HConstrainTable (Columns (t context)) (Sql DBEq)

99− , HConstrainTable (Columns (t context)) (ConstrainSpec (Sql DBOrd))

74+ , HConstrainTable (Columns (t context)) (Sql DBOrd)

100 )

75 )

101 => OrdTable (t context)

76 => OrdTable (t context)

102 where

77 where

103− ordTable = hdicts @(Columns (t context)) @(ConstrainSpec (Sql DBOrd))

78+ ordTable = hdicts @(Columns (t context)) @(Sql DBOrd)

104−

105−

106−type instance FromExprs (t Expr) = FromExprs' t

107

108

109instance

81instance

110− ( x ~ t' Expr

82+ ( Rel8able t', t' ~ Choose (Algebra t) t

83+ , x ~ t' Expr

111 , result ~ Result

84 , result ~ Result

112− , ToExprs' (Algebra t) t' t

113 )

85 )

114 => ToExprs x (t result)

86 => ToExprs x (t result)

115− where

116− fromResult = fromResult' @(Algebra t) @t'

117− toResult = toResult' @(Algebra t) @t'

118

119

120−type FromExprs' :: K.Rel8able -> Type

89+type Choose :: K.Algebra -> K.Rel8able -> K.Rel8able

121−type family FromExprs' t where

90+type family Choose algebra t where

122− FromExprs' (ADT t) = t Result

91+ Choose 'K.Sum t = ADT t

123− FromExprs' (HKD a) = a

92+ Choose 'K.Product t = t

124− FromExprs' t = t Result

125−

126−

127−type ToExprs' :: K.Algebra -> K.Rel8able -> K.Rel8able -> Constraint

128−class (algebra ~ Algebra t, Rel8able t') =>

129− ToExprs' algebra t' t | algebra t -> t'

130− where

131− fromResult' :: GColumns t' (Col Result) -> t Result

132− toResult' :: t Result -> GColumns t' (Col Result)

133−

134−

135−instance (Algebra t ~ 'K.Product, Rel8able t, t ~ t') =>

136− ToExprs' 'K.Product t' t

137− where

138− fromResult' = fromColumns

139− toResult' = toColumns

140−

141−

142−instance (Algebra t ~ 'K.Sum, ADTable t, t' ~ ADT t) =>

143− ToExprs' 'K.Sum t' t

144− where

145− fromResult' = fromADT . ADT

146− toResult' = (\(ADT a) -> a) . toADT

src/Rel8/Table/Serialize.hs+22−122

@@ -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,41 +7,31 @@

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

@@ -53,71 +40,21 @@ import Data.Functor.Apply ( WrappedApplicative(..) )

54-- | @ToExprs exprs a@ is evidence that the types @exprs@ and @a@ describe

41-- | @ToExprs exprs a@ is evidence that the types @exprs@ and @a@ describe

55-- essentially the same type, but @exprs@ is in the 'Expr' context, and @a@ is

42-- essentially the same type, but @exprs@ is in the 'Expr' context, and @a@ is

56−-- in the 'Result' context.

43+-- a normal Haskell type.

57type ToExprs :: Type -> Type -> Constraint

44type ToExprs :: Type -> Type -> Constraint

58−class Table Expr exprs => ToExprs exprs a where

45+class Table Expr exprs => ToExprs exprs a

59− fromResult :: Columns exprs (Col Result) -> a

46+

60− toResult :: a -> Columns exprs (Col Result)

47+

61−

48+instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a

62− default fromResult ::

49+

63− ( Generic (Record a)

50+

64− , KnownAlgebra (GAlgebra (Rep (Record exprs)))

51+instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a]

65− , Eval (GGToExprs (GAlgebra (Rep (Record exprs))) TToExprs TColumns (Rep (Record exprs)) (Rep (Record a)))

66− , Columns exprs ~ Eval (GGColumns (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs)))

67− )

68− => Columns exprs (Col Result) -> a

69− fromResult =

70− unrecord .

71− to .

72− ggfromResult

73− @(GAlgebra (Rep (Record exprs)))

74− @TToExprs

75− @TColumns

76− @(Rep (Record exprs))

77− (\(_ :: proxy expr) -> fromResult @expr)

78−

79− default toResult ::

80− ( Generic (Record a)

81− , KnownAlgebra (GAlgebra (Rep (Record exprs)))

82− , Eval (GGToExprs (GAlgebra (Rep (Record exprs))) TToExprs TColumns (Rep (Record exprs)) (Rep (Record a)))

83− , Columns exprs ~ Eval (GGColumns (GAlgebra (Rep (Record exprs))) TColumns (Rep (Record exprs)))

84− )

85− => a -> Columns exprs (Col Result)

86− toResult =

87− ggtoResult

88− @(GAlgebra (Rep (Record exprs)))

89− @TToExprs

90− @TColumns

91− @(Rep (Record exprs))

92− (\(_ :: proxy expr) -> toResult @expr) .

93− from .

94− Record

95−

96−

97−data TToExprs :: Type -> Type -> Exp Constraint

98−type instance Eval (TToExprs exprs a) = ToExprs exprs a

99−

100−

101−instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a where

102− fromResult (HType (R a)) = a

103− toResult = HType . R

104−

105−

106−instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a] where

107− fromResult (HType (R a)) = a

108− toResult = HType . R

109

110

111instance (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)

112− where

113− fromResult (HType (R a)) = a

114− toResult = HType . R

115

116

117instance (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)

118− where

119− fromResult (HType (R a)) = a

120− toResult = HType . R

121

122

123instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>

60instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>

@@ -179,43 +116,6 @@ instance

179 => ToExprs x (a, b, c, d, e, f, g)

116 => ToExprs x (a, b, c, d, e, f, g)

180

117

181

118

182−instance (HTable t, result ~ Col Result, x ~ t (Col Expr)) =>

183− ToExprs x (t result)

184− where

185− fromResult = id

186− toResult = id

187−

188−

189−instance (KnownSpec spec, x ~ Col Expr spec) =>

190− ToExprs x (Col Result spec)

191− where

192− fromResult = fromColumns

193− toResult = toColumns

194−

195−

196−-- | The @FromExprs@ type function maps a type in the @Expr@ context to the

197−-- corresponding type in the @Result@ context.

198−type FromExprs :: Type -> Type

199−type family FromExprs a

200−type instance FromExprs (Expr a) = a

201−type instance FromExprs (Col Expr spec) = Col Result spec

202−type instance FromExprs (a, b) = (FromExprs a, FromExprs b)

203−type instance FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)

204−type instance FromExprs (a, b, c, d) =

205− (FromExprs a, FromExprs b, FromExprs c, FromExprs d)

206−type instance FromExprs (a, b, c, d, e) =

207− (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)

208−type instance FromExprs (a, b, c, d, e, f) =

209− ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e

210− , FromExprs f

211− )

212−type instance FromExprs (a, b, c, d, e, f, g) =

213− ( FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e

214− , FromExprs f, FromExprs g

215− )

216−type instance FromExprs (t (Col Expr)) = t (Col Result)

217−

218−

219-- | @Serializable@ witnesses the one-to-one correspondence between the type

119-- | @Serializable@ witnesses the one-to-one correspondence between the type

220-- @sql@, which contains SQL expressions, and the type @haskell@, which

120-- @sql@, which contains SQL expressions, and the type @haskell@, which

221-- contains the Haskell decoding of rows containing @sql@ SQL expressions.

121-- contains the Haskell decoding of rows containing @sql@ SQL expressions.

@@ -228,21 +128,21 @@ instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a

228-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is

128-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is

229-- capable of lifting single @Expr@s to full tables.

129-- capable of lifting single @Expr@s to full tables.

230lit :: forall exprs a. Serializable exprs a => a -> exprs

130lit :: forall exprs a. Serializable exprs a => a -> exprs

231−lit = fromColumns . litHTable . toResult @exprs

131+lit = fromColumns . litHTable . toResult @_ @exprs

232

132

233

133

234parse :: forall exprs a. Serializable exprs a => Hasql.Row a

134parse :: forall exprs a. Serializable exprs a => Hasql.Row a

235−parse = fromResult @exprs <$> parseHTable

135+parse = fromResult @_ @exprs <$> parseHTable

236

136

237

137

238−litHTable :: HTable t => t (Col Result) -> t (Col Expr)

138+litHTable :: HTable t => t Result -> t Expr

239litHTable as = htabulate $ \field ->

139litHTable as = htabulate $ \field ->

240 case hfield hspecs field of

140 case hfield hspecs field of

241− SSpec {nullity, info} -> case hfield as field of

141+ Spec {nullity, info} -> case hfield as field of

242− R value -> E (slitExpr nullity info value)

142+ Identity value -> slitExpr nullity info value

243

143

244

144

245−parseHTable :: HTable t => Hasql.Row (t (Col Result))

145+parseHTable :: HTable t => Hasql.Row (t Result)

246parseHTable = unwrapApplicative $ htabulateA $ \field ->

146parseHTable = unwrapApplicative $ htabulateA $ \field ->

247 WrapApplicative $ case hfield hspecs field of

147 WrapApplicative $ case hfield hspecs field of

248− 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+151−119

@@ -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,47 +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 )

33−import Prelude hiding ( undefined )

32+import Data.Maybe ( isJust )

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.Nullify

40+import Rel8.Kind.Context ( Reifiable )

40− ( Nullifiable

41+import Rel8.Schema.Context.Nullify ( Nullifiable )

41− , encodeTag, decodeTag

42− , nullifier, unnullifier

43− )

44import Rel8.Schema.Dict ( Dict( Dict ) )

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

45−import Rel8.Schema.HTable.Label ( hlabel, hunlabel )

43+import Rel8.Schema.HTable.Label ( hlabel, hrelabel, hunlabel )

46import Rel8.Schema.HTable.Identity ( HIdentity(..) )

44import Rel8.Schema.HTable.Identity ( HIdentity(..) )

47−import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )

45+import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )

48import Rel8.Schema.HTable.These ( HTheseTable(..) )

46import Rel8.Schema.HTable.These ( HTheseTable(..) )

47+import qualified Rel8.Schema.Kind as K

49import Rel8.Schema.Name ( Name )

48import Rel8.Schema.Name ( Name )

50import Rel8.Table

49import Rel8.Table

51 ( Table, Columns, Context, fromColumns, toColumns

50 ( Table, Columns, Context, fromColumns, toColumns

52− , reify, unreify

51+ , FromExprs, fromResult, toResult

52+ , Transpose

53 )

54import Rel8.Table.Eq ( EqTable, eqTable )

55import Rel8.Table.Maybe

56 ( MaybeTable(..)

57 , maybeTable, justTable, nothingTable

58 , isJustTable

59+ , aggregateMaybeTable

59 , nameMaybeTable

60 , nameMaybeTable

60 )

61 )

62+import Rel8.Table.Nullify ( Nullify, guard )

61import Rel8.Table.Ord ( OrdTable, ordTable )

63import Rel8.Table.Ord ( OrdTable, ordTable )

62−import Rel8.Table.Recontextualize ( Recontextualize )

64+import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )

63−import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )

65+import Rel8.Table.Serialize ( ToExprs )

64−import Rel8.Table.Tag ( Tag(..) )

65import Rel8.Table.Undefined ( undefined )

66import Rel8.Table.Undefined ( undefined )

66import Rel8.Type.Tag ( MaybeTag )

67import Rel8.Type.Tag ( MaybeTag )

@@ -70,7 +71,8 @@ import Data.Functor.Apply ( Apply, (<.>) )

70import Data.Functor.Bind ( Bind, (>>-) )

71import Data.Functor.Bind ( Bind, (>>-) )

72-- these

73-- these

73−import Data.These ( These )

74+import Data.These ( These( This, That, These ) )

75+import Data.These.Combinators ( justHere, justThere )

76-- | @TheseTable a b@ is a Rel8 table that contains either the table @a@, the

78-- | @TheseTable a b@ is a Rel8 table that contains either the table @a@, the

@@ -80,32 +82,45 @@ import Data.These ( These )

80--

82--

81-- @TheseTable@ is operationally the same as Haskell's 'These' type, but

83-- @TheseTable@ is operationally the same as Haskell's 'These' type, but

82-- adapted to work with Rel8.

84-- adapted to work with Rel8.

83−type TheseTable :: Type -> Type -> Type

85+type TheseTable :: K.Context -> Type -> Type -> Type

84−data TheseTable a b = TheseTable

86+data TheseTable context a b = TheseTable

85− { here :: MaybeTable a

87+ { here :: MaybeTable context a

86− , there :: MaybeTable b

88+ , there :: MaybeTable context b

87 }

89 }

88 deriving stock Functor

90 deriving stock Functor

91−instance Bifunctor TheseTable where

93+instance Biprojectable (TheseTable context) where

94+ biproject f g (TheseTable a b) = TheseTable (project f a) (project g b)

95+

96+

97+instance Nullifiable context => Bifunctor (TheseTable context) where

92 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

95−instance (Table Expr a, Semigroup a) => Apply (TheseTable a) where

101+instance Projectable (TheseTable context a) where

102+ project f (TheseTable a b) = TheseTable a (project f b)

103+

104+

105+instance (context ~ Expr, Table Expr a, Semigroup a) =>

106+ Apply (TheseTable context a)

107+ where

96 fs <.> as = TheseTable

108 fs <.> as = TheseTable

97 { here = here fs <> here as

109 { here = here fs <> here as

98 , there = there fs <.> there as

110 , there = there fs <.> there as

99 }

111 }

100

112

101

113

102−instance (Table Expr a, Semigroup a) => Applicative (TheseTable a)

114+instance (context ~ Expr, Table Expr a, Semigroup a) =>

115+ Applicative (TheseTable context a)

103 where

116 where

104 pure = thatTable

117 pure = thatTable

105 (<*>) = (<.>)

118 (<*>) = (<.>)

106

119

107

120

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

109 TheseTable here1 ma >>- f = case ma >>- f' of

124 TheseTable here1 ma >>- f = case ma >>- f' of

110 mtb -> TheseTable

125 mtb -> TheseTable

111 { here = maybeTable here1 ((here1 <>) . fst) mtb

126 { here = maybeTable here1 ((here1 <>) . fst) mtb

@@ -116,12 +131,14 @@ instance (Table Expr a, Semigroup a) => Bind (TheseTable a) where

116 TheseTable here2 mb -> (here2,) <$> mb

131 TheseTable here2 mb -> (here2,) <$> mb

117

132

118

133

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

120 (>>=) = (>>-)

137 (>>=) = (>>-)

121

138

122

139

123−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) =>

124− Semigroup (TheseTable a b)

141+ Semigroup (TheseTable context a b)

125 where

142 where

126 a <> b = TheseTable

143 a <> b = TheseTable

127 { here = here a <> here b

144 { here = here a <> here b

@@ -131,173 +148,175 @@ instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>

131

148

132instance

149instance

133 ( Table context a, Table context b

150 ( Table context a, Table context b

134− , Nullifiable context

151+ , Reifiable context, context ~ context'

135 )

152 )

136− => Table context (TheseTable a b)

153+ => Table context' (TheseTable context a b)

137 where

154 where

138− type Columns (TheseTable a b) = HTheseTable (Columns a) (Columns b)

155+ type Columns (TheseTable context a b) = HTheseTable (Columns a) (Columns b)

139− type Context (TheseTable a b) = Context a

156+ type Context (TheseTable context a b) = Context a

157+ type FromExprs (TheseTable context a b) =

158+ These (FromExprs a) (FromExprs b)

159+ type Transpose to (TheseTable context a b) =

160+ TheseTable to (Transpose to a) (Transpose to b)

140

161

141 toColumns TheseTable {here, there} = HTheseTable

162 toColumns TheseTable {here, there} = HTheseTable

142− { hhereTag = hlabel $ HType $ encodeTag (toHereTag (tag here))

163+ { hhereTag = hlabel $ HIdentity $ tag here

143 , hhere =

164 , hhere =

144− hlabel $ hnullify (nullifier (tag here) isNonNull) $ toColumns $

165+ hlabel $ guard (tag here) isJust isNonNull $ toColumns $ just here

145− just here

166+ , hthereTag = hlabel $ HIdentity $ tag there

146− , hthereTag = hlabel $ HType $ encodeTag (toThereTag (tag there))

147 , hthere =

167 , hthere =

148− hlabel $ hnullify (nullifier (tag there) isNonNull) $ toColumns $

168+ hlabel $ guard (tag there) isJust isNonNull $ toColumns $ just there

149− just there

150 }

169 }

151

170

152 fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable

171 fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable

153− { here =

172+ { here = MaybeTable

154− let

173+ { tag = unHIdentity $ hunlabel hhereTag

155− tag = decodeTag $ unHIdentity $ hunlabel hhereTag

174+ , just = fromColumns $ hunlabel hhere

156− in

175+ }

157− MaybeTable

176+ , there = MaybeTable

158− { tag

177+ { tag = unHIdentity $ hunlabel hthereTag

159− , just =

178+ , just = fromColumns $ hunlabel hthere

160− fromColumns $

179+ }

161− runIdentity $

162− hunnullify (\a -> pure . unnullifier a) $

163− hunlabel

164− hhere

165− }

166− , there =

167− let

168− tag = decodeTag $ unHIdentity $ hunlabel hthereTag

169− in

170− MaybeTable

171− { tag

172− , just =

173− fromColumns $

174− runIdentity $

175− hunnullify (\a -> pure . unnullifier a) $

176− hunlabel

177− hthere

178− }

179 }

180 }

180

181

181−

182+ toResult tables = HTheseTable

182− reify = liftA2 bimap reify reify

183+ { hhereTag = hrelabel hhereTag

183− unreify = liftA2 bimap unreify unreify

184+ , hhere = hrelabel hhere

184−

185+ , hthereTag = hrelabel hthereTag

185−

186+ , hthere = hrelabel hthere

186−instance

187+ }

187− ( Nullifiable from, Nullifiable to

188+ where

188− , Recontextualize from to a1 b1

189+ HMaybeTable

189− , Recontextualize from to a2 b2

190+ { htag = hhereTag

190− )

191+ , hjust = hhere

191− => Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2)

192+ } = toResult @_ @(MaybeTable context a) (justHere tables)

192−

193+ HMaybeTable

193−

194+ { htag = hthereTag

194−instance (EqTable a, EqTable b) => EqTable (TheseTable a b) where

195+ , hjust = hthere

196+ } = toResult @_ @(MaybeTable context b) (justThere tables)

197+

198+ fromResult HTheseTable {hhereTag, hhere, hthereTag, hthere} =

199+ case (here, there) of

200+ (Just a, Nothing) -> This a

201+ (Nothing, Just b) -> That b

202+ (Just a, Just b) -> These a b

203+ _ -> error "These.fromColumns: mismatch between tags and data"

204+ where

205+ here = fromResult @_ @(MaybeTable context a) mhere

206+ there = fromResult @_ @(MaybeTable context b) mthere

207+ mhere = HMaybeTable

208+ { htag = hrelabel hhereTag

209+ , hjust = hrelabel hhere

210+ }

211+ mthere = HMaybeTable

212+ { htag = hrelabel hthereTag

213+ , hjust = hrelabel hthere

214+ }

215+

216+

217+instance (EqTable a, EqTable b, context ~ Expr) =>

218+ EqTable (TheseTable context a b)

219+ where

195 eqTable = HTheseTable

220 eqTable = HTheseTable

196− { hhereTag = hlabel (HType Dict)

221+ { hhereTag = hlabel (HIdentity Dict)

197− , hhere = hlabel (hnullify (\_ Dict -> Dict) (eqTable @a))

222+ , hhere = hlabel (eqTable @(Nullify context a))

198− , hthereTag = hlabel (HType Dict)

223+ , hthereTag = hlabel (HIdentity Dict)

199− , hthere = hlabel (hnullify (\_ Dict -> Dict) (eqTable @b))

224+ , hthere = hlabel (eqTable @(Nullify context b))

200 }

225 }

201

226

202

227

203−instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where

228+instance (OrdTable a, OrdTable b, context ~ Expr) =>

229+ OrdTable (TheseTable context a b)

230+ where

204 ordTable = HTheseTable

231 ordTable = HTheseTable

205− { hhereTag = hlabel (HType Dict)

232+ { hhereTag = hlabel (HIdentity Dict)

206− , hhere = hlabel (hnullify (\_ Dict -> Dict) (ordTable @a))

233+ , hhere = hlabel (ordTable @(Nullify context a))

207− , hthereTag = hlabel (HType Dict)

234+ , hthereTag = hlabel (HIdentity Dict)

208− , hthere = hlabel (hnullify (\_ Dict -> Dict) (ordTable @b))

235+ , hthere = hlabel (ordTable @(Nullify context b))

209 }

236 }

210

237

211

238

212−type instance FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)

239+instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable Expr exprs1 exprs2) =>

213−

214−

215−instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable exprs1 exprs2) =>

216 ToExprs x (These a b)

240 ToExprs x (These a b)

217− where

218− fromResult =

219− bimap (fromResult @exprs1) (fromResult @exprs2) .

220− fromColumns

221− toResult =

222− toColumns .

223− bimap (toResult @exprs1) (toResult @exprs2)

224−

225−

226−toHereTag :: Tag "isJust" a -> Tag "hasHere" a

227−toHereTag Tag {..} = Tag {..}

228−

229−

230−toThereTag :: Tag "isJust" a -> Tag "hasThere" a

231−toThereTag Tag {..} = Tag {..}

232

241

233

242

234-- | Test if a 'TheseTable' was constructed with 'thisTable'.

243-- | Test if a 'TheseTable' was constructed with 'thisTable'.

235--

244--

236-- Corresponds to 'Data.These.Combinators.isThis'.

245-- Corresponds to 'Data.These.Combinators.isThis'.

237−isThisTable :: TheseTable a b -> Expr Bool

246+isThisTable :: TheseTable Expr a b -> Expr Bool

238isThisTable a = hasHereTable a &&. not_ (hasThereTable a)

247isThisTable a = hasHereTable a &&. not_ (hasThereTable a)

239

248

240

249

241-- | Test if a 'TheseTable' was constructed with 'thatTable'.

250-- | Test if a 'TheseTable' was constructed with 'thatTable'.

242--

251--

243-- Corresponds to 'Data.These.Combinators.isThat'.

252-- Corresponds to 'Data.These.Combinators.isThat'.

244−isThatTable :: TheseTable a b -> Expr Bool

253+isThatTable :: TheseTable Expr a b -> Expr Bool

245isThatTable a = not_ (hasHereTable a) &&. hasThereTable a

254isThatTable a = not_ (hasHereTable a) &&. hasThereTable a

246

255

247

256

248-- | Test if a 'TheseTable' was constructed with 'thoseTable'.

257-- | Test if a 'TheseTable' was constructed with 'thoseTable'.

249--

258--

250-- Corresponds to 'Data.These.Combinators.isThese'.

259-- Corresponds to 'Data.These.Combinators.isThese'.

251−isThoseTable :: TheseTable a b -> Expr Bool

260+isThoseTable :: TheseTable Expr a b -> Expr Bool

252isThoseTable a = hasHereTable a &&. hasThereTable a

261isThoseTable a = hasHereTable a &&. hasThereTable a

253

262

254

263

255-- | Test if the @a@ side of @TheseTable a b@ is present.

264-- | Test if the @a@ side of @TheseTable a b@ is present.

256--

265--

257-- Corresponds to 'Data.These.Combinators.hasHere'.

266-- Corresponds to 'Data.These.Combinators.hasHere'.

258−hasHereTable :: TheseTable a b -> Expr Bool

267+hasHereTable :: TheseTable Expr a b -> Expr Bool

259hasHereTable TheseTable {here} = isJustTable here

268hasHereTable TheseTable {here} = isJustTable here

260

269

261

270

262-- | Test if the @b@ table of @TheseTable a b@ is present.

271-- | Test if the @b@ table of @TheseTable a b@ is present.

263--

272--

264-- Corresponds to 'Data.These.Combinators.hasThere'.

273-- Corresponds to 'Data.These.Combinators.hasThere'.

265−hasThereTable :: TheseTable a b -> Expr Bool

274+hasThereTable :: TheseTable Expr a b -> Expr Bool

266hasThereTable TheseTable {there} = isJustTable there

275hasThereTable TheseTable {there} = isJustTable there

267

276

268

277

269-- | Attempt to project out the @a@ table of a @TheseTable a b@.

278-- | Attempt to project out the @a@ table of a @TheseTable a b@.

270--

279--

271-- Corresponds to 'Data.These.Combinators.justHere'.

280-- Corresponds to 'Data.These.Combinators.justHere'.

272−justHereTable :: TheseTable a b -> MaybeTable a

281+justHereTable :: TheseTable context a b -> MaybeTable context a

273justHereTable = here

282justHereTable = here

274

283

275

284

276-- | Attempt to project out the @b@ table of a @TheseTable a b@.

285-- | Attempt to project out the @b@ table of a @TheseTable a b@.

277--

286--

278-- Corresponds to 'Data.These.Combinators.justThere'.

287-- Corresponds to 'Data.These.Combinators.justThere'.

279−justThereTable :: TheseTable a b -> MaybeTable b

288+justThereTable :: TheseTable context a b -> MaybeTable context b

280justThereTable = there

289justThereTable = there

281

290

282

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+

283-- | Construct a @TheseTable@. Corresponds to 'This'.

302-- | Construct a @TheseTable@. Corresponds to 'This'.

284−thisTable :: Table Expr b => a -> TheseTable a b

303+thisTable :: Table Expr b => a -> TheseTable Expr a b

285thisTable a = TheseTable (justTable a) nothingTable

304thisTable a = TheseTable (justTable a) nothingTable

286

305

287

306

288-- | Construct a @TheseTable@. Corresponds to 'That'.

307-- | Construct a @TheseTable@. Corresponds to 'That'.

289−thatTable :: Table Expr a => b -> TheseTable a b

308+thatTable :: Table Expr a => b -> TheseTable Expr a b

290thatTable b = TheseTable nothingTable (justTable b)

309thatTable b = TheseTable nothingTable (justTable b)

291

310

292

311

293-- | Construct a @TheseTable@. Corresponds to 'These'.

312-- | Construct a @TheseTable@. Corresponds to 'These'.

294−thoseTable :: a -> b -> TheseTable a b

313+thoseTable :: a -> b -> TheseTable Expr a b

295thoseTable a b = TheseTable (justTable a) (justTable b)

314thoseTable a b = TheseTable (justTable a) (justTable b)

296

315

297

316

298-- | Pattern match on a 'TheseTable'. Corresponds to 'these'.

317-- | Pattern match on a 'TheseTable'. Corresponds to 'these'.

299theseTable :: Table Expr c

318theseTable :: Table Expr c

300− => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable a b -> c

319+ => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable Expr a b -> c

301theseTable f g h TheseTable {here, there} =

320theseTable f g h TheseTable {here, there} =

302 maybeTable

321 maybeTable

303 (maybeTable undefined f here)

322 (maybeTable undefined f here)

@@ -305,6 +324,19 @@ theseTable f g h TheseTable {here, there} =

305 there

324 there

306

325

307

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+

308-- | Construct a 'TheseTable' in the 'Name' context. This can be useful if you

340-- | Construct a 'TheseTable' in the 'Name' context. This can be useful if you

309-- have a 'TheseTable' that you are storing in a table and need to construct a

341-- have a 'TheseTable' that you are storing in a table and need to construct a

310-- 'TableSchema'.

342-- 'TableSchema'.

@@ -317,7 +349,7 @@ nameTheseTable :: ()

317 -- ^ Names of the columns in the @a@ table.

349 -- ^ Names of the columns in the @a@ table.

318 -> b

350 -> b

319 -- ^ Names of the columns in the @b@ table.

351 -- ^ Names of the columns in the @b@ table.

320− -> TheseTable a b

352+ -> TheseTable Name a b

321nameTheseTable here there a b =

353nameTheseTable here there a b =

322 TheseTable

354 TheseTable

323 { here = nameMaybeTable here a

355 { here = nameMaybeTable here a

src/Rel8/Table/Transpose.hsnew file+46

@@ -0,0 +1,46 @@

1+{-# language DataKinds #-}

2+{-# language FlexibleInstances #-}

3+{-# language FunctionalDependencies #-}

4+{-# language StandaloneKindSignatures #-}

5+{-# language TypeFamilies #-}

6+{-# language UndecidableInstances #-}

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.hsnew file+640

@@ -0,0 +1,640 @@

1+{-# language FlexibleContexts #-}

2+{-# language MonoLocalBinds #-}

3+{-# language ScopedTypeVariables #-}

4+{-# language StandaloneKindSignatures #-}

5+{-# language TypeApplications #-}

6+{-# language TupleSections #-}

7+{-# language UndecidableInstances #-}

9+-- | "Rel8.Tabulate" provides an alternative API ('Tabulation') for writing

10+-- queries that complements the main "Rel8" API ('Query').

11+

12+module Rel8.Tabulate

13+ (

14+ Tabulation

15+

16+ -- * Interfacing with 'Query's

17+ , fromQuery

18+ , toQuery

19+ , liftQuery

20+ , through

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

39+ , align

40+ , alignWith

41+ , leftAlign

42+ , leftAlignWith

43+ , rightAlign

44+ , rightAlignWith

45+ , zip

46+ , zipWith

47+ , similarity

48+ , difference

49+ )

50+where

51+

52+-- base

53+import Control.Applicative ( (<|>), empty, liftA2 )

54+import Control.Monad ( liftM2 )

55+import Data.Bifunctor ( Bifunctor, bimap, first, second )

56+import Data.Foldable ( traverse_ )

57+import Data.Function ( on )

58+import Data.Functor.Contravariant ( Contravariant, (>$<), contramap )

59+import Data.Int ( Int64 )

60+import Data.Kind ( Type )

61+import Data.Maybe ( fromJust, fromMaybe )

62+import Prelude hiding ( lookup, zip, zipWith )

63+

64+-- bifunctors

65+import Data.Bifunctor.Clown ( Clown( Clown ), runClown )

66+

67+-- comonad

68+import Control.Comonad ( extract )

69+

70+-- opaleye

71+import qualified Opaleye.Aggregate as Opaleye

72+import qualified Opaleye.Order as Opaleye ( orderBy, distinctOnExplicit )

73+

74+-- profunctors

75+import Data.Profunctor ( dimap, lmap )

76+

77+-- product-profunctors

78+import Data.Profunctor.Product

79+ ( ProductProfunctor, (***!)

80+ , SumProfunctor, (+++!)

81+ )

82+import qualified Data.Profunctor.Product as PP

83+

84+-- rel8

85+import Rel8.Aggregate ( Aggregates )

86+import Rel8.Expr ( Expr )

87+import Rel8.Expr.Aggregate ( countStar )

88+import Rel8.Expr.Bool ( true )

89+import Rel8.Order ( Order( Order ) )

90+import Rel8.Query ( Query )

91+import qualified Rel8.Query.Exists as Q ( exists, present, absent )

92+import Rel8.Query.Filter ( where_ )

93+import Rel8.Query.List ( catNonEmptyTable )

94+import qualified Rel8.Query.Maybe as Q ( optional )

95+import Rel8.Query.Opaleye ( mapOpaleye, unsafePeekQuery )

96+import Rel8.Query.Rebind ( rebind )

97+import Rel8.Query.These ( alignBy )

98+import Rel8.Table ( Table, fromColumns, toColumns )

99+import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )

100+import Rel8.Table.Alternative

101+ ( AltTable, (<|>:)

102+ , AlternativeTable, emptyTable

103+ )

104+import Rel8.Table.Cols ( fromCols, toCols )

105+import Rel8.Table.Eq ( EqTable, (==:), eqTable )

106+import Rel8.Table.List ( ListTable( ListTable ) )

107+import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), maybeTable )

108+import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )

109+import Rel8.Table.Opaleye ( aggregator, unpackspec )

110+import Rel8.Table.Ord ( OrdTable )

111+import Rel8.Table.Order ( ascTable )

112+import Rel8.Table.Projection

113+ ( Biprojectable, biproject

114+ , Projectable, project

115+ , apply

116+ )

117+import Rel8.Table.These ( TheseTable( TheseTable ), theseTable )

118+

119+-- semigroupoids

120+import Data.Functor.Apply ( Apply, liftF2 )

121+import Data.Functor.Bind ( Bind, (>>-) )

122+

123+

124+type Key :: Type -> Type

125+type Key = Maybe

126+

127+

128+cat :: Table Expr k => Key k -> Query k

129+cat = maybe emptyTable pure

130+

131+

132+key :: (ProductProfunctor p, SumProfunctor p)

133+ => p a b -> p (Key a) (Key b)

134+key a = dimap from to (PP.empty +++! a)

135+ where

136+ from = maybe (Left ()) Right

137+ to = either (const Nothing) Just

138+

139+

140+keyed :: (ProductProfunctor p, SumProfunctor p)

141+ => p k l -> p a b -> p (Key k, a) (Key l, b)

142+keyed k a = key k ***! a

143+

144+

145+type Predicate :: Type -> Type

146+newtype Predicate a = Predicate (Maybe (a -> Expr Bool))

147+

148+

149+instance Contravariant Predicate where

150+ contramap f (Predicate a) = Predicate (lmap f <$> a)

151+

152+

153+instance Semigroup (Predicate k) where

154+ Predicate ma <> Predicate mb = Predicate $ ma <|> mb

155+

156+

157+instance Monoid (Predicate k) where

158+ mempty = Predicate Nothing

159+

160+

161+match :: EqTable k => Key k -> Predicate k

162+match = Predicate . fmap (==:)

163+

164+

165+ensure :: Predicate k -> Key k -> Query ()

166+ensure (Predicate mp) = traverse_ (\k -> traverse_ (\p -> where_ (p k)) mp)

167+

168+

169+-- | A @'Tabulation' k a@ is like a @'Query' a@, except that each row also

170+-- has a key @k@ in addition to the value @a@. 'Tabulation's can be composed

171+-- monadically just like 'Query's, but the resulting join is more like a

172+-- @NATURAL JOIN@ (based on the common key column(s) @k@) than the

173+-- @CROSS JOIN@ given by 'Query'.

174+--

175+-- Another way to think of @'Tabulation' k a@ is as analogous to @Map k a@ in

176+-- the same way @'Query' a@ is analogous to @[a]@. However, there's nothing

177+-- stopping a 'Tabulation' from containing multiple rows with the same key, so

178+-- technically @Map k (NonEmpty a)@ is more accurate.

179+--

180+-- 'Tabulation's can be created from 'Query's with 'fromQuery' and 'liftQuery'

181+-- and converted back to 'Query's with 'lookup' and 'toQuery' (though note the

182+-- caveats that come with the latter).

183+type Tabulation :: Type -> Type -> Type

184+newtype Tabulation k a = Tabulation (Predicate k -> Query (Key k, a))

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 (<*>))@

209+instance EqTable k => Apply (Tabulation k) where

210+ liftF2 = liftA2

211+

212+

213+-- | @pure = 'liftQuery' . pure@

214+instance EqTable k => Applicative (Tabulation k) where

215+ pure = liftQuery . pure

216+ liftA2 = liftM2

217+

218+

219+instance EqTable k => Bind (Tabulation k) where

220+ Tabulation as >>- f = Tabulation $ \p -> do

221+ (k, a) <- as p

222+ case f a of

223+ Tabulation bs -> do

224+ let p' = match k

225+ (k', b) <- bs (p' <> p)

226+ ensure p' k'

227+ pure (k' <|> k, b)

228+

229+

230+instance EqTable k => Monad (Tabulation k) where

231+ (>>=) = (>>-)

232+

233+

234+-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<|>:)@ is

235+-- @unionWith (<>)@.

236+instance EqTable k => AltTable (Tabulation k) where

237+ tas <|>: tbs = do

238+ eas <- peek tas

239+ ebs <- peek tbs

240+ case (eas, ebs) of

241+ (Left as, Left bs) -> liftQuery $ as <|>: bs

242+ (Right as, Right bs) -> fromQuery $ as <|>: bs

243+ _ -> catNonEmptyTable `through` ((<>) `on` some) tas tbs

244+

245+

246+instance EqTable k => AlternativeTable (Tabulation k) where

247+ emptyTable = Tabulation $ const $ fmap (empty,) emptyTable

248+

249+

250+-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<>)@ is

251+-- @unionWith (liftA2 (<>))@.

252+instance (EqTable k, Table Expr a, Semigroup a) => Semigroup (Tabulation k a)

253+ where

254+ (<>) = alignWith (theseTable id id (<>))

255+

256+

257+instance (EqTable k, Table Expr a, Semigroup a) => Monoid (Tabulation k a)

258+ where

259+ mempty = emptyTable

260+

261+

262+-- | Any 'Query' of key-value pairs @(k, a)@ can be a @'Tabulation' k a@.

263+fromQuery :: Query (k, a) -> Tabulation k a

264+fromQuery = Tabulation . const . fmap (first pure)

265+

266+

267+-- | Convert a @'Tabulation' k a@ back into a 'Query' of key-value pairs.

268+--

269+-- Note that the result of a 'toQuery' is undefined (will always return zero

270+-- rows) on 'Tabulation's constructed with 'liftQuery' or 'pure'. So while

271+-- @toQuery . fromQuery@ is always @id@, @fromQuery . toQuery@ is not.

272+--

273+-- A safer, more predictable alternative to 'toQuery' is to use 'lookup' with

274+-- an explicit set of keys:

275+--

276+-- @

277+-- do

278+-- k <- keys

279+-- a <- lookup k tabulation

280+-- pure (k, a)

281+-- @

282+--

283+-- Having said that, in practice, most legitimate uses of 'Tabulation' will

284+-- have a well-defined 'toQuery'. It would be possible in theory to encode

285+-- the necessary invariants at the type level using an indexed monad, but we

286+-- would lose the ability to use @do@-notation, which is the main benefit

287+-- of having 'Tabulation' as a monad in the first place.

288+--

289+-- In particular, @'toQuery' t@ is well-defined for any 'Tabulation' @t@

290+-- defined as @t = fromQuery _@. @'toQuery' t@ is also well-defined for any

291+-- 'Tabulation' @t@ defined as @t = t' >>= _@ or @t = t' *> _@ where

292+-- @'toQuery' t'@ is well-defined. There are other valid permutations too.

293+-- Generally, anything that uses 'fromQuery' at some point, unless wrapped in

294+-- a top-level 'present' or 'absent', will have a well-defined 'toQuery'.

295+toQuery :: Table Expr k => Tabulation k a -> Query (k, a)

296+toQuery (Tabulation f) = do

297+ (mk, a) <- f mempty

298+ k <- cat mk

299+ pure (k, a)

300+

301+

302+-- | A @'Query' a@ can be treated as a @'Tabulation' k a@ where the given @a@

303+-- values exist at every possible key @k@.

304+liftQuery :: Query a -> Tabulation k a

305+liftQuery = Tabulation . const . fmap (empty,)

306+

307+

308+-- | Run a Kleisli arrow in the the 'Query' monad \"through\" a 'Tabulation'.

309+-- Useful for 'Rel8.filter'ing a 'Tabulation'.

310+--

311+-- @

312+-- 'Rel8.filter' ((>=. 30) . userAge) `'through'` usersById

313+-- @

314+through :: (a -> Query b) -> Tabulation k a -> Tabulation k b

315+through f (Tabulation as) = Tabulation $ \p -> do

316+ (k, a) <- as p

317+ b <- f a

318+ pure (k, b)

319+infixr 1 `through`

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

368+--

369+-- Some of the following combinators produce \"magic\" 'Tabulation's. Let's

370+-- use 'count' as an example to demonstrate this concept. Consider

371+-- the following:

372+--

373+-- @

374+-- count $ fromQuery $ values

375+-- [ (lit 'a', lit True)

376+-- , (lit 'a', lit False)

377+-- , (lit 'b', lit True)

378+-- ]

379+-- @

380+--

381+-- You might expect this to be equivalent to the following 'Tabulation':

382+--

383+-- @

384+-- fromQuery $ values

385+-- [ (lit 'a', 2)

386+-- , (lit 'b', 1)

387+-- ]

388+-- @

389+--

390+-- However, it isn't quite. While the resulting 'Tabulation' does effectively

391+-- contain the above entries, it also behaves as though it contained the value

392+-- @0@ at every other possible key.

393+--

394+-- This means you can do:

395+--

396+-- @

397+-- do

398+-- user <- usersById

399+-- orderCount <- count ordersByUserId

400+-- @

401+--

402+-- To see how many orders a user has (getting @0@ if they have no orders).

403+

404+

405+-- | 'count' returns a count of how many entries are in the given

406+-- 'Tabulation' at each key.

407+--

408+-- The resulting 'Tabulation' is \"magic\" in that the value @0@ exists at

409+-- every possible key that wasn't in the given 'Tabulation'.

410+count :: EqTable k => Tabulation k a -> Tabulation k (Expr Int64)

411+count =

412+ fmap (maybeTable 0 id) .

413+ optional .

414+ aggregate .

415+ fmap (const countStar)

416+

417+

418+-- | 'optional' produces a \"magic\" 'Tabulation' whereby each

419+-- entry in the given 'Tabulation' is wrapped in 'Rel8.justTable', and every

420+-- other possible key contains a single 'Rel8.nothingTable'.

421+--

422+-- This is used to implement 'leftAlignWith'.

423+optional :: Tabulation k a -> Tabulation k (MaybeTable Expr a)

424+optional (Tabulation f) = Tabulation $ \p -> case p of

425+ Predicate Nothing -> fmap pure <$> f p

426+ _ -> fmap (\m -> (empty, snd <$> m)) $ Q.optional $ do

427+ (k, a) <- f p

428+ ensure p k

429+ pure (k, a)

430+

431+

432+-- | 'many' aggregates each entry with a particular key into a

433+-- single entry with all of the values contained in a 'ListTable'.

434+--

435+-- 'order' can be used to give this 'ListTable' a defined order.

436+--

437+-- The resulting 'Tabulation' is \"magic\" in that the value

438+-- @'Rel8.listTable []'@ exists at every possible key that wasn't in the given

439+-- 'Tabulation'.

440+many :: (EqTable k, Table Expr a)

441+ => Tabulation k a -> Tabulation k (ListTable Expr a)

442+many =

443+ fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .

444+ optional .

445+ aggregate .

446+ fmap (listAgg . toCols)

447+

448+

449+-- | 'some' aggregates each entry with a particular key into a

450+-- single entry with all of the values contained in a 'NonEmptyTable'.

451+--

452+-- 'order' can be used to give this 'NonEmptyTable' a defined order.

453+some :: (EqTable k, Table Expr a)

454+ => Tabulation k a -> Tabulation k (NonEmptyTable Expr a)

455+some =

456+ fmap (\(NonEmptyTable a) -> NonEmptyTable a) .

457+ aggregate .

458+ fmap (nonEmptyAgg . toCols)

459+

460+

461+-- | 'exists' produces a \"magic\" 'Tabulation' which contains the

462+-- value 'Rel8.true' at each key in the given 'Tabulation', and the value

463+-- 'Rel8.false' at every other possible key.

464+exists :: Tabulation k a -> Tabulation k (Expr Bool)

465+exists (Tabulation f) = Tabulation $ \p -> case p of

466+ Predicate Nothing -> (true <$) <$> f p

467+ _ -> fmap (empty,) $ Q.exists $ do

468+ (k, _) <- f p

469+ ensure p k

470+

471+

472+-- | 'present' produces a 'Tabulation' where a single @()@ row

473+-- exists for every key that was present in the given 'Tabulation'.

474+--

475+-- This is used to implement 'similarity'.

476+present :: Tabulation k a -> Tabulation k ()

477+present (Tabulation f) = Tabulation $ \p -> do

478+ Q.present $ do

479+ (k, _) <- f p

480+ ensure p k

481+ pure (empty, ())

482+

483+

484+-- | 'absent' produces a 'Tabulation' where a single @()@ row exists

485+-- at every possible key that absent from the given 'Tabulation'.

486+--

487+-- This is used to implement 'difference'.

488+absent :: Tabulation k a -> Tabulation k ()

489+absent (Tabulation f) = Tabulation $ \p -> do

490+ Q.absent $ do

491+ (k, _) <- f p

492+ ensure p k

493+ pure (empty, ())

494+

495+

496+-- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns.

497+--

498+-- Analogous to 'Data.Semialign.align'.

499+align :: EqTable k

500+ => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable Expr a b)

501+align = alignWith id

502+

503+

504+-- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns.

505+--

506+-- Analogous to 'Data.Semialign.alignWith'.

507+alignWith :: EqTable k

508+ => (TheseTable Expr a b -> c)

509+ -> Tabulation k a -> Tabulation k b -> Tabulation k c

510+alignWith f (Tabulation as) (Tabulation bs) = Tabulation $ \p -> do

511+ tkab <- liftF2 (alignBy condition) as bs p

512+ k <- traverse (rebind "key") $ recover $ bimap fst fst tkab

513+ let

514+ tab = bimap snd snd tkab

515+ pure (k, f tab)

516+ where

517+ condition (k, _) (k', _) = fromMaybe true (liftA2 (==:) k k')

518+ recover (TheseTable mma@(MaybeTable _ ma) mmb@(MaybeTable _ mb)) =

519+ case extract ma of

520+ Nothing -> extract mb

521+ Just a -> case extract mb of

522+ Nothing -> extract ma

523+ Just b -> case a <$ mma <|>: b <$ mmb of

524+ MaybeTable _ c -> pure (extract c)

525+

526+

527+-- | Performs a @NATURAL LEFT OUTER JOIN@ based on the common key columns.

528+--

529+-- Analogous to 'Data.Semialign.rpadZip'.

530+--

531+-- Note that you can achieve the same effect with 'optional' and the

532+-- 'Applicative' instance for 'Tabulation', i.e., this is just

533+-- @\left right -> liftA2 (,) left (optional right). You can also

534+-- use @do@-notation.

535+leftAlign :: EqTable k

536+ => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable Expr b)

537+leftAlign = leftAlignWith (,)

538+

539+

540+-- | Performs a @NATURAL LEFT OUTER JOIN@ based on the common key columns.

541+--

542+-- Analogous to 'Data.Semialign.rpadZipWith'.

543+--

544+-- Note that you can achieve the same effect with 'optional' and the

545+-- 'Applicative' instance for 'Tabulation', i.e., this is just

546+-- @\f left right -> liftA2 f left (optional right). You can also

547+-- use @do@-notation.

548+leftAlignWith :: EqTable k

549+ => (a -> MaybeTable Expr b -> c)

550+ -> Tabulation k a -> Tabulation k b -> Tabulation k c

551+leftAlignWith f left right = liftA2 f left (optional right)

552+

553+

554+-- | Performs a @NATURAL RIGHT OUTER JOIN@ based on the common key columns.

555+--

556+-- Analogous to 'Data.Semialign.lpadZip'.

557+--

558+-- Note that you can achieve the same effect with 'optional' and the

559+-- 'Applicative' instance for 'Tabulation', i.e., this is just

560+-- @\left right -> liftA2 (flip (,)) right (optional left). You can

561+-- also use @do@-notation.

562+rightAlign :: EqTable k

563+ => Tabulation k a -> Tabulation k b -> Tabulation k (MaybeTable Expr a, b)

564+rightAlign = rightAlignWith (,)

565+

566+

567+-- | Performs a @NATURAL RIGHT OUTER JOIN@ based on the common key columns.

568+--

569+-- Analogous to 'Data.Semialign.lpadZipWith'.

570+--

571+-- Note that you can achieve the same effect with 'optional' and the

572+-- 'Applicative' instance for 'Tabulation', i.e., this is just

573+-- @\f left right -> liftA2 (flip f) right (optional left). You can

574+-- also use @do@-notation.

575+rightAlignWith :: EqTable k

576+ => (MaybeTable Expr a -> b -> c)

577+ -> Tabulation k a -> Tabulation k b -> Tabulation k c

578+rightAlignWith f left right = liftA2 (flip f) right (optional left)

579+

580+

581+-- | Performs a @NATURAL INNER JOIN@ based on the common key columns.

582+--

583+-- Analagous to 'Data.Semialign.zip'.

584+--

585+-- Note that you can achieve the same effect with the 'Applicative' instance

586+-- of 'Tabulation', i.e., this is just @'liftA2 (,)'@. You can also use

587+-- @do@-notation.

588+zip :: EqTable k

589+ => Tabulation k a -> Tabulation k b -> Tabulation k (a, b)

590+zip = zipWith (,)

591+

592+

593+-- | Performs a @NATURAL INNER JOIN@ based on the common key columns.

594+--

595+-- Analagous to 'Data.Semialign.zipWith'.

596+--

597+-- Note that you can achieve the same effect with the 'Applicative' instance

598+-- of 'Tabulation', i.e., this is just @'liftA2'@. You can also use

599+-- @do@-notation.

600+zipWith :: EqTable k

601+ => (a -> b -> c) -> Tabulation k a -> Tabulation k b -> Tabulation k c

602+zipWith = liftA2

603+

604+

605+-- | Performs a [@NATURAL SEMI JOIN@](https://en.wikipedia.org/wiki/Relational_algebra#Semijoin_%28%E2%8B%89%29%28%E2%8B%8A%29)

606+-- based on the common key columns.

607+--

608+-- The result is a subset of the left tabulation where only entries which have

609+-- a corresponding entry in the right tabulation are kept.

610+--

611+-- Note that you can achieve a similar effect with 'present' and the

612+-- 'Applicative' instance of 'Tabulation', i.e., this is just

613+-- @\left right -> left <* present right@. You can also use

614+-- @do@-notation.

615+similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a

616+similarity a b = a <* present b

617+

618+

619+-- | Performs a [@NATURAL ANTI JOIN@](https://en.wikipedia.org/wiki/Relational_algebra#Antijoin_%28%E2%96%B7%29)

620+-- based on the common key columns.

621+--

622+-- The result is a subset of the left tabulation where only entries which do

623+-- not have a corresponding entry in the right tabulation are kept.

624+--

625+-- Note that you can achieve a similar effect with 'absent' and the

626+-- 'Applicative' instance of 'Tabulation', i.e., this is just

627+-- @\left right -> left <* absent right@. You can also use

628+-- @do@-notation.

629+difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a

630+difference a b = a <* absent b

631+

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.

636+peek :: Tabulation k a -> Tabulation k (Either (Query a) (Query (k, a)))

637+peek (Tabulation f) = Tabulation $ \p ->

638+ pure $ (empty,) $ case unsafePeekQuery (f p) of

639+ (Nothing, _) -> Left $ fmap snd (f p)

640+ (Just _, _) -> Right $ fmap (first fromJust) (f p)

src/Rel8/Type.hs+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+20−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 }

@@ -103,7 +104,7 @@ class (DBType a, HKDable a) => DBComposite a where

103-- single column expression, by combining them into a PostgreSQL composite

104-- single column expression, by combining them into a PostgreSQL composite

104-- type.

105-- type.

105compose :: DBComposite a => HKD a Expr -> Expr a

106compose :: DBComposite a => HKD a Expr -> Expr a

106−compose = castExpr . fromPrimExpr . encoder

107+compose = castExpr . fromPrimExpr . encoder . toColumns

107

108

109

109-- | Expand a composite type into a 'HKD'.

110-- | Expand a composite type into a 'HKD'.

@@ -112,23 +113,23 @@ compose = castExpr . fromPrimExpr . encoder

112decompose :: forall a. DBComposite a => Expr a -> HKD a Expr

113decompose :: forall a. DBComposite a => Expr a -> HKD a Expr

113decompose (toPrimExpr -> a) = fromColumns $ htabulate \field ->

114decompose (toPrimExpr -> a) = fromColumns $ htabulate \field ->

114 case hfield names field of

115 case hfield names field of

115− N (Name name) -> case hfield hspecs field of

116+ Name name -> case hfield hspecs field of

116− SSpec {} -> E $ fromPrimExpr $ Opaleye.CompositeExpr a name

117+ Spec {} -> fromPrimExpr $ Opaleye.CompositeExpr a name

117 where

118 where

118 names = toColumns (compositeFields @a)

119 names = toColumns (compositeFields @a)

119

120

121

121−decoder :: Table Result a => Hasql.Composite a

122+decoder :: HTable t => Hasql.Composite (t Result)

122−decoder = fmap fromColumns $ unwrapApplicative $ htabulateA \field ->

123+decoder = unwrapApplicative $ htabulateA \field ->

123 case hfield hspecs field of

124 case hfield hspecs field of

124− SSpec {nullity, info} -> WrapApplicative $ R <$>

125+ Spec {nullity, info} -> WrapApplicative $ Identity <$>

125 case nullity of

126 case nullity of

126 Null -> Hasql.field $ Hasql.nullable $ decode info

127 Null -> Hasql.field $ Hasql.nullable $ decode info

127 NotNull -> Hasql.field $ Hasql.nonNullable $ decode info

128 NotNull -> Hasql.field $ Hasql.nonNullable $ decode info

128

129

130

130−encoder :: Table Expr a => a -> Opaleye.PrimExpr

131+encoder :: HTable t => t Expr -> Opaleye.PrimExpr

131−encoder (toColumns -> a) = Opaleye.FunExpr "ROW" exprs

132+encoder a = Opaleye.FunExpr "ROW" exprs

132 where

133 where

133 exprs = getConst $ htabulateA \field -> case hfield a field of

134 exprs = getConst $ htabulateA \field -> case hfield a field of

134− E (toPrimExpr -> expr) -> Const [expr]

135+ expr -> Const [toPrimExpr expr]

src/Rel8/Type/Enum.hs+1

@@ -106,6 +106,7 @@ class (DBType a, Enumable a) => DBEnum a where

106

107-- | Types that are sum types, where each constructor is unary (that is, has no

108-- fields).

109+type Enumable :: Type -> Constraint

109class (Generic a, GEnumable (Rep a)) => Enumable a

110class (Generic a, GEnumable (Rep a)) => Enumable a

110instance (Generic a, GEnumable (Rep a)) => Enumable a

111instance (Generic a, GEnumable (Rep a)) => Enumable a

111

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+288−178

@@ -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_ )

58+import Control.Monad.Morph ( hoist )

57−

58−-- monad-control

59−import Control.Monad.Trans.Control ( MonadBaseControl )

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,11 +116,13 @@ 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

@@ -133,6 +138,7 @@ tests =

133 flip run conn do

138 flip run conn do

134 sql "CREATE EXTENSION citext"

139 sql "CREATE EXTENSION citext"

135 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 )"

136 sql "CREATE SEQUENCE test_seq"

142 sql "CREATE SEQUENCE test_seq"

137

143

138 return db

144 return db

@@ -140,19 +146,21 @@ tests =

140 stopTestDatabase = TmpPostgres.stop

146 stopTestDatabase = TmpPostgres.stop

141

147

142

148

149+connect :: TmpPostgres.DB -> IO Connection

150+connect = acquire . TmpPostgres.toConnectionString >=> either (maybe empty (fail . unpack . decodeUtf8)) pure

151+

152+

143databasePropertyTest

153databasePropertyTest

144 :: TestName

154 :: TestName

145− -> (((Connection -> TestT IO ()) -> PropertyT IO ()) -> PropertyT IO ())

155+ -> ((TestT Transaction () -> PropertyT IO ()) -> PropertyT IO ())

146 -> IO TmpPostgres.DB -> TestTree

156 -> IO TmpPostgres.DB -> TestTree

147databasePropertyTest testName f getTestDatabase =

157databasePropertyTest testName f getTestDatabase =

148− withResource connect release $ \c ->

158+ withResource (connect =<< getTestDatabase) release $ \c ->

149 testProperty testName $ property do

159 testProperty testName $ property do

150− connection <- liftIO c

160+ connection <- lift c

151− f \g -> test $ rollingBack connection $ g connection

161+ f $ test . hoist \m -> do

152−

162+ e <- run (Hasql.transaction Hasql.Serializable Hasql.Write (m <* condemn)) connection

153− where

163+ either throwIO pure e

154−

155− connect = either (error . show) return =<< acquire . TmpPostgres.toConnectionString =<< getTestDatabase

156

164

157

165

158data TestTable f = TestTable

166data TestTable f = TestTable

@@ -184,18 +192,17 @@ testSelectTestTable :: IO TmpPostgres.DB -> TestTree

184testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do

192testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do

185 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

193 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

186

194

187− transaction \connection -> do

195+ transaction do

188− void do

196+ selected <- lift do

189− liftIO $ Rel8.insert connection

197+ statement () $ Rel8.insert Rel8.Insert

190− Rel8.Insert

198+ { into = testTableSchema

191− { into = testTableSchema

199+ , rows = Rel8.values $ map Rel8.lit rows

192− , rows = map Rel8.lit rows

200+ , onConflict = Rel8.DoNothing

193− , onConflict = Rel8.DoNothing

201+ , returning = pure ()

194− , returning = Rel8.NumberOfRowsAffected

202+ }

195− }

196

203

197− selected <- liftIO $ Rel8.select connection do

204+ statement () $ Rel8.select do

198− Rel8.each testTableSchema

205+ Rel8.each testTableSchema

199

206

200 sort selected === sort rows

207 sort selected === sort rows

201

208

@@ -212,11 +219,12 @@ testWhere_ = databasePropertyTest "WHERE (Rel8.where_)" \transaction -> do

212

219

213 let expected = filter (\t -> testTableColumn2 t == magicBool) rows

220 let expected = filter (\t -> testTableColumn2 t == magicBool) rows

214

221

215− transaction \connection -> do

222+ transaction do

216− selected <- liftIO $ Rel8.select connection do

223+ selected <- lift do

217− t <- Rel8.values $ Rel8.lit <$> rows

224+ statement () $ Rel8.select do

218− Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool

225+ t <- Rel8.values $ Rel8.lit <$> rows

219− return t

226+ Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool

227+ return t

220

228

221 sort selected === sort expected

229 sort selected === sort expected

222

230

@@ -229,11 +237,12 @@ testFilter :: IO TmpPostgres.DB -> TestTree

229testFilter = databasePropertyTest "filter" \transaction -> do

237testFilter = databasePropertyTest "filter" \transaction -> do

230 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable

238 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable

231

239

232− transaction \connection -> do

240+ transaction do

233 let expected = filter testTableColumn2 rows

241 let expected = filter testTableColumn2 rows

234

242

235− selected <- liftIO $ Rel8.select connection

243+ selected <- lift do

236− $ Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)

244+ statement () $ Rel8.select do

245+ Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)

237

246

238 sort selected === sort expected

247 sort selected === sort expected

239

248

@@ -248,9 +257,10 @@ testLimit = databasePropertyTest "LIMIT (Rel8.limit)" \transaction -> do

248

257

249 n <- forAll $ Gen.integral (Range.linear 0 10)

258 n <- forAll $ Gen.integral (Range.linear 0 10)

250

259

251− transaction \connection -> do

260+ transaction do

252− selected <- liftIO $ Rel8.select connection do

261+ selected <- lift do

253− Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)

262+ statement () $ Rel8.select do

263+ Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)

254

264

255 diff (length selected) (<=) (fromIntegral n)

265 diff (length selected) (<=) (fromIntegral n)

256

266

@@ -268,9 +278,10 @@ testUnion = databasePropertyTest "UNION (Rel8.union)" \transaction -> evalM do

268 left <- forAll $ Gen.list (Range.linear 0 10) genTestTable

278 left <- forAll $ Gen.list (Range.linear 0 10) genTestTable

269 right <- forAll $ Gen.list (Range.linear 0 10) genTestTable

279 right <- forAll $ Gen.list (Range.linear 0 10) genTestTable

270

280

271− transaction \connection -> do

281+ transaction do

272− selected <- liftIO $ Rel8.select connection do

282+ selected <- lift do

273− Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)

283+ statement () $ Rel8.select do

284+ Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)

274

285

275 sort selected === sort (nub (left ++ right))

286 sort selected === sort (nub (left ++ right))

276

287

@@ -279,9 +290,11 @@ testDistinct :: IO TmpPostgres.DB -> TestTree

279testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do

290testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do

280 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

291 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

281

292

282− transaction \connection -> do

293+ transaction do

283− selected <- liftIO $ Rel8.select connection $ Rel8.distinct do

294+ selected <- lift do

284− Rel8.values (Rel8.lit <$> rows)

295+ statement () $ Rel8.select do

296+ Rel8.distinct do

297+ Rel8.values (Rel8.lit <$> rows)

285

298

286 sort selected === nub (sort rows)

299 sort selected === nub (sort rows)

287

300

@@ -294,8 +307,10 @@ testExists :: IO TmpPostgres.DB -> TestTree

294testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do

307testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do

295 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

308 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

296

309

297− transaction \connection -> do

310+ transaction do

298− exists <- liftIO $ Rel8.select connection $ Rel8.exists $ Rel8.values $ Rel8.lit <$> rows

311+ exists <- lift do

312+ statement () $ Rel8.select do

313+ Rel8.exists $ Rel8.values $ Rel8.lit <$> rows

299

314

300 case rows of

315 case rows of

301 [] -> exists === [False]

316 [] -> exists === [False]

@@ -306,9 +321,10 @@ testOptional :: IO TmpPostgres.DB -> TestTree

306testOptional = databasePropertyTest "Rel8.optional" \transaction -> do

321testOptional = databasePropertyTest "Rel8.optional" \transaction -> do

307 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

322 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

308

323

309− transaction \connection -> do

324+ transaction do

310− selected <- liftIO $ Rel8.select connection do

325+ selected <- lift do

311− Rel8.optional $ Rel8.values (Rel8.lit <$> rows)

326+ statement () $ Rel8.select do

327+ Rel8.optional $ Rel8.values (Rel8.lit <$> rows)

312

328

313 case rows of

329 case rows of

314 [] -> selected === [Nothing]

330 [] -> selected === [Nothing]

@@ -319,9 +335,10 @@ testAnd :: IO TmpPostgres.DB -> TestTree

319testAnd = databasePropertyTest "AND (&&.)" \transaction -> do

335testAnd = databasePropertyTest "AND (&&.)" \transaction -> do

320 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool

336 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool

321

337

322− transaction \connection -> do

338+ transaction do

323− [result] <- liftIO $ Rel8.select connection $ pure $

339+ [result] <- lift do

324− Rel8.lit x Rel8.&&. Rel8.lit y

340+ statement () $ Rel8.select do

341+ pure $ Rel8.lit x Rel8.&&. Rel8.lit y

325

342

326 result === (x && y)

343 result === (x && y)

327

344

@@ -330,9 +347,10 @@ testOr :: IO TmpPostgres.DB -> TestTree

330testOr = databasePropertyTest "OR (||.)" \transaction -> do

347testOr = databasePropertyTest "OR (||.)" \transaction -> do

331 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool

348 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool

332

349

333− transaction \connection -> do

350+ transaction do

334− [result] <- liftIO $ Rel8.select connection $ pure $

351+ [result] <- lift do

335− Rel8.lit x Rel8.||. Rel8.lit y

352+ statement () $ Rel8.select $ pure $

353+ Rel8.lit x Rel8.||. Rel8.lit y

336

354

337 result === (x || y)

355 result === (x || y)

338

356

@@ -341,9 +359,10 @@ testLogicalFixities :: IO TmpPostgres.DB -> TestTree

341testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do

359testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do

342 (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

343

361

344− transaction \connection -> do

362+ transaction do

345− [result] <- liftIO $ Rel8.select connection $ pure $

363+ [result] <- lift do

346− Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x

364+ statement () $ Rel8.select do

365+ pure $ Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x

347

366

348 result === (u || v && w == x)

367 result === (u || v && w == x)

349

368

@@ -352,9 +371,10 @@ testNot :: IO TmpPostgres.DB -> TestTree

352testNot = databasePropertyTest "NOT (not_)" \transaction -> do

371testNot = databasePropertyTest "NOT (not_)" \transaction -> do

353 x <- forAll Gen.bool

372 x <- forAll Gen.bool

354

373

355− transaction \connection -> do

374+ transaction do

356− [result] <- liftIO $ Rel8.select connection $ pure $

375+ [result] <- lift do

357− Rel8.not_ $ Rel8.lit x

376+ statement () $ Rel8.select do

377+ pure $ Rel8.not_ $ Rel8.lit x

358

378

359 result === not x

379 result === not x

360

380

@@ -363,9 +383,10 @@ testBool :: IO TmpPostgres.DB -> TestTree

363testBool = databasePropertyTest "ifThenElse_" \transaction -> do

383testBool = databasePropertyTest "ifThenElse_" \transaction -> do

364 (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool

384 (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool

365

385

366− transaction \connection -> do

386+ transaction do

367− [result] <- liftIO $ Rel8.select connection $ pure $

387+ [result] <- lift do

368− Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)

388+ statement () $ Rel8.select do

389+ pure $ Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)

369

390

370 result === if x then y else z

391 result === if x then y else z

371

392

@@ -377,9 +398,10 @@ testAp = databasePropertyTest "Cartesian product (<*>)" \transaction -> do

377 (Gen.list (Range.linear 1 10) genTestTable)

398 (Gen.list (Range.linear 1 10) genTestTable)

378 (Gen.list (Range.linear 1 10) genTestTable)

399 (Gen.list (Range.linear 1 10) genTestTable)

379

400

380− transaction \connection -> do

401+ transaction do

381− result <- liftIO $ Rel8.select connection $ do

402+ result <- lift do

382− liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))

403+ statement () $ Rel8.select do

404+ liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))

383

405

384 sort result === sort (liftA2 (,) rows1 rows2)

406 sort result === sort (liftA2 (,) rows1 rows2)

385

407

@@ -408,21 +430,22 @@ testDBType getTestDatabase = testGroup "DBType instances"

408 where

430 where

409 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

410 dbTypeTest name generator = testGroup name

432 dbTypeTest name generator = testGroup name

411− [ databasePropertyTest name (t (==) generator) getTestDatabase

433+ [ databasePropertyTest name (t generator) getTestDatabase

412− , databasePropertyTest ("Maybe " <> name) (t (==) (Gen.maybe generator)) getTestDatabase

434+ , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase

413 ]

435 ]

414

436

415− 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)

416− => (a -> a -> Bool)

438+ => Gen a

417− -> Gen a

439+ -> (TestT Transaction () -> PropertyT IO b)

418− -> ((Connection -> TestT IO ()) -> PropertyT IO b)

419 -> PropertyT IO b

440 -> PropertyT IO b

420− t eq generator transaction = do

441+ t generator transaction = do

421 x <- forAll generator

442 x <- forAll generator

422

443

423− transaction \connection -> do

444+ transaction do

424− [res] <- liftIO $ Rel8.select connection $ pure (Rel8.litExpr x)

445+ [res] <- lift do

425− diff res eq x

446+ statement () $ Rel8.select do

447+ pure (Rel8.litExpr x)

448+ diff res (==) x

426

449

427 genDay :: Gen Day

450 genDay :: Gen Day

428 genDay = do

451 genDay = do

@@ -464,13 +487,15 @@ testDBEq getTestDatabase = testGroup "DBEq instances"

464

487

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

466 => Gen a

489 => Gen a

467− -> ((Connection -> TestT IO ()) -> PropertyT IO ())

490+ -> (TestT Transaction () -> PropertyT IO ())

468 -> PropertyT IO ()

491 -> PropertyT IO ()

469 t generator transaction = do

492 t generator transaction = do

470 (x, y) <- forAll (liftA2 (,) generator generator)

493 (x, y) <- forAll (liftA2 (,) generator generator)

471

494

472− transaction \connection -> do

495+ transaction do

473− [res] <- liftIO $ Rel8.select connection $ pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y

496+ [res] <- lift do

497+ statement () $ Rel8.select do

498+ pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y

474 res === (x == y)

499 res === (x == y)

475

500

476

501

@@ -478,9 +503,10 @@ testTableEquality :: IO TmpPostgres.DB -> TestTree

478testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do

503testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do

479 (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable

504 (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable

480

505

481− transaction \connection -> do

506+ transaction do

482− [eq] <- liftIO $ Rel8.select connection do

507+ [eq] <- lift do

483− pure $ Rel8.lit x Rel8.==: Rel8.lit y

508+ statement () $ Rel8.select do

509+ pure $ Rel8.lit x Rel8.==: Rel8.lit y

484

510

485 eq === (x == y)

511 eq === (x == y)

486

512

@@ -489,8 +515,10 @@ testFromString :: IO TmpPostgres.DB -> TestTree

489testFromString = databasePropertyTest "FromString" \transaction -> do

515testFromString = databasePropertyTest "FromString" \transaction -> do

490 str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode

516 str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode

491

517

492− transaction \connection -> do

518+ transaction do

493− [result] <- liftIO $ Rel8.select connection $ pure $ fromString str

519+ [result] <- lift do

520+ statement () $ Rel8.select do

521+ pure $ fromString str

494 result === pack str

522 result === pack str

495

523

496

524

@@ -498,10 +526,11 @@ testCatMaybeTable :: IO TmpPostgres.DB -> TestTree

498testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do

526testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do

499 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

527 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable

500

528

501− transaction \connection -> do

529+ transaction do

502− selected <- liftIO $ Rel8.select connection do

530+ selected <- lift do

503− testTable <- Rel8.values $ Rel8.lit <$> rows

531+ statement () $ Rel8.select do

504− Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)

532+ testTable <- Rel8.values $ Rel8.lit <$> rows

533+ Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)

505

534

506 sort selected === sort (filter testTableColumn2 rows)

535 sort selected === sort (filter testTableColumn2 rows)

507

536

@@ -510,9 +539,10 @@ testCatMaybe :: IO TmpPostgres.DB -> TestTree

510testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do

539testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do

511 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

512

541

513− transaction \connection -> do

542+ transaction do

514− selected <- evalM $ liftIO $ Rel8.select connection do

543+ selected <- lift do

515− Rel8.catNull =<< Rel8.values (map Rel8.lit rows)

544+ statement () $ Rel8.select do

545+ Rel8.catNull =<< Rel8.values (map Rel8.lit rows)

516

546

517 sort selected === sort (catMaybes rows)

547 sort selected === sort (catMaybes rows)

518

548

@@ -521,15 +551,38 @@ testMaybeTable :: IO TmpPostgres.DB -> TestTree

521testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do

551testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do

522 (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

523

553

524− transaction \connection -> do

554+ transaction do

525− selected <- liftIO $ Rel8.select connection $

555+ selected <- lift do

526− Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))

556+ statement () $ Rel8.select do

557+ Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))

527

558

528 case rows of

559 case rows of

529 [] -> selected === [def]

560 [] -> selected === [def]

530 _ -> sort selected === sort rows

561 _ -> sort selected === sort rows

531

562

532

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+

533data TwoTestTables f =

586data TwoTestTables f =

534 TwoTestTables

587 TwoTestTables

535 { testTable1 :: TestTable f

588 { testTable1 :: TestTable f

@@ -550,9 +603,10 @@ testNestedTables = databasePropertyTest "Nested TestTables" \transaction -> eval

550 Gen.list (Range.linear 0 10) $

603 Gen.list (Range.linear 0 10) $

551 liftA2 TwoTestTables genTestTable genTestTable

604 liftA2 TwoTestTables genTestTable genTestTable

552

605

553− transaction \connection -> do

606+ transaction do

554− selected <- liftIO $ Rel8.select connection do

607+ selected <- lift do

555− Rel8.values (Rel8.lit <$> rows)

608+ statement () $ Rel8.select do

609+ Rel8.values (Rel8.lit <$> rows)

556

610

557 sort selected === sort rows

611 sort selected === sort rows

558

612

@@ -562,11 +616,12 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction

562 rows1 <- genRows

616 rows1 <- genRows

563 rows2 <- genRows

617 rows2 <- genRows

564

618

565− transaction \connection -> do

619+ transaction do

566− selected <- liftIO $ Rel8.select connection do

620+ selected <- lift do

567− as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))

621+ statement () $ Rel8.select do

568− bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))

622+ as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))

569− pure $ liftA2 (,) as bs

623+ bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))

624+ pure $ liftA2 (,) as bs

570

625

571 case (rows1, rows2) of

626 case (rows1, rows2) of

572 ([], []) -> selected === [Nothing]

627 ([], []) -> selected === [Nothing]

@@ -578,14 +633,6 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction

578 genRows = forAll do

633 genRows = forAll do

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

580

635

581−rollingBack

582− :: (MonadBaseControl IO m, MonadIO m)

583− => Connection -> m a -> m a

584−rollingBack connection =

585− bracket_

586− (liftIO (run (sql "BEGIN") connection))

587− (liftIO (run (sql "ROLLBACK") connection))

588−

589

636

590genTestTable :: Gen (TestTable Result)

637genTestTable :: Gen (TestTable Result)

591genTestTable = do

638genTestTable = do

@@ -598,19 +645,19 @@ testUpdate :: IO TmpPostgres.DB -> TestTree

598testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do

645testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do

599 rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable

646 rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable

600

647

601− transaction \connection -> do

648+ transaction do

602− void $ liftIO $ Rel8.insert connection

649+ selected <- lift do

603− Rel8.Insert

650+ statement () $ Rel8.insert Rel8.Insert

604 { into = testTableSchema

651 { into = testTableSchema

605− , rows = map Rel8.lit $ Map.keys rows

652+ , rows = Rel8.values $ map Rel8.lit $ Map.keys rows

606 , onConflict = Rel8.DoNothing

653 , onConflict = Rel8.DoNothing

607− , returning = Rel8.NumberOfRowsAffected

654+ , returning = pure ()

608 }

655 }

609

656

610− void $ liftIO $ Rel8.update connection

657+ statement () $ Rel8.update Rel8.Update

611− Rel8.Update

612 { target = testTableSchema

658 { target = testTableSchema

613− , set = \r ->

659+ , from = pure ()

660+ , set = \_ r ->

614 let updates = map (bimap Rel8.lit Rel8.lit) $ Map.toList rows

661 let updates = map (bimap Rel8.lit Rel8.lit) $ Map.toList rows

615 in

662 in

616 foldl

663 foldl

@@ -624,12 +671,12 @@ testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do

624 )

671 )

625 r

672 r

626 updates

673 updates

627− , updateWhere = \_ -> Rel8.lit True

674+ , updateWhere = \_ _ -> Rel8.lit True

628− , returning = Rel8.NumberOfRowsAffected

675+ , returning = pure ()

629 }

676 }

630

677

631− selected <- liftIO $ Rel8.select connection do

678+ statement () $ Rel8.select do

632− Rel8.each testTableSchema

679+ Rel8.each testTableSchema

633

680

634 sort selected === sort (Map.elems rows)

681 sort selected === sort (Map.elems rows)

635

682

@@ -642,29 +689,96 @@ testDelete :: IO TmpPostgres.DB -> TestTree

642testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do

689testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do

643 rows <- forAll $ Gen.list (Range.linear 0 5) genTestTable

690 rows <- forAll $ Gen.list (Range.linear 0 5) genTestTable

644

691

645− transaction \connection -> do

692+ transaction do

646− void $ liftIO $ Rel8.insert connection

693+ (deleted, selected) <- lift do

647− Rel8.Insert

694+ statement () $ Rel8.insert Rel8.Insert

648 { into = testTableSchema

695 { into = testTableSchema

649− , rows = map Rel8.lit rows

696+ , rows = Rel8.values $ map Rel8.lit rows

650 , onConflict = Rel8.DoNothing

697 , onConflict = Rel8.DoNothing

651− , returning = Rel8.NumberOfRowsAffected

698+ , returning = pure ()

652 }

699 }

653

700

654− deleted <-

701+ deleted <- statement () $ Rel8.delete Rel8.Delete

655− liftIO $ Rel8.delete connection

656− Rel8.Delete

657 { from = testTableSchema

702 { from = testTableSchema

658− , deleteWhere = testTableColumn2

703+ , using = pure ()

704+ , deleteWhere = const testTableColumn2

659 , returning = Rel8.Projection id

705 , returning = Rel8.Projection id

660 }

706 }

661

707

662− selected <- liftIO $ Rel8.select connection do

708+ selected <- statement () $ Rel8.select do

663− Rel8.each testTableSchema

709+ Rel8.each testTableSchema

710+

711+ pure (deleted, selected)

664

712

665 sort (deleted <> selected) === sort rows

713 sort (deleted <> selected) === sort rows

666

714

667

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+

668newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }

782newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }

669 deriving stock Generic

783 deriving stock Generic

670 deriving anyclass Rel8.Rel8able

784 deriving anyclass Rel8.Rel8able

@@ -678,9 +792,10 @@ testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree

678testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do

792testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do

679 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

680

794

681− transaction \connection -> do

795+ transaction do

682− selected <- liftIO $ Rel8.select connection do

796+ selected <- lift do

683− Rel8.values $ map Rel8.lit rows

797+ statement () $ Rel8.select do

798+ Rel8.values $ map Rel8.lit rows

684

799

685 sort selected === sort rows

800 sort selected === sort rows

686

801

@@ -689,18 +804,20 @@ testSelectArray :: IO TmpPostgres.DB -> TestTree

689testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do

804testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do

690 rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool

805 rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool

691

806

692− transaction \connection -> do

807+ transaction do

693− selected <- liftIO $ Rel8.select connection do

808+ selected <- lift do

694− Rel8.many $ Rel8.values (map Rel8.lit rows)

809+ statement () $ Rel8.select do

810+ Rel8.many $ Rel8.values (map Rel8.lit rows)

695

811

696 selected === [foldMap pure rows]

812 selected === [foldMap pure rows]

697

813

698− selected' <- liftIO $ Rel8.select connection $ do

814+ selected' <- lift do

699− a <- Rel8.catListTable =<< do

815+ statement () $ Rel8.select do

700− Rel8.many $ Rel8.values (map Rel8.lit rows)

816+ a <- Rel8.catListTable =<< do

701− b <- Rel8.catListTable =<< do

817+ Rel8.many $ Rel8.values (map Rel8.lit rows)

702− Rel8.many $ Rel8.values (map Rel8.lit rows)

818+ b <- Rel8.catListTable =<< do

703− pure (a, b)

819+ Rel8.many $ Rel8.values (map Rel8.lit rows)

820+ pure (a, b)

704

821

705 selected' === liftA2 (,) rows rows

822 selected' === liftA2 (,) rows rows

706

823

@@ -722,10 +839,11 @@ 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

726− selected <- liftIO $ Rel8.select connection do

843+ selected <- lift do

727− x <- Rel8.values [Rel8.lit example]

844+ statement () $ Rel8.select do

728− pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)

845+ x <- Rel8.values [Rel8.lit example]

846+ pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)

729

847

730 selected === [True]

848 selected === [True]

731

849

@@ -733,11 +851,12 @@ testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other ta

733testEvaluate :: IO TmpPostgres.DB -> TestTree

851testEvaluate :: IO TmpPostgres.DB -> TestTree

734testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect" \transaction -> do

852testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect" \transaction -> do

735

853

736− transaction \connection -> do

854+ transaction do

737− selected <- liftIO $ Rel8.select connection do

855+ selected <- lift do

738− x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])

856+ statement () $ Rel8.select do

739− y <- Rel8.evaluate (Rel8.nextval "test_seq")

857+ x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])

740− pure (x, (y, y))

858+ y <- Rel8.evaluate (Rel8.nextval "test_seq")

859+ pure (x, (y, y))

741

860

742 normalize selected ===

861 normalize selected ===

743 [ ('a', (0, 0))

862 [ ('a', (0, 0))

@@ -745,11 +864,12 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect

745 , ('c', (2, 2))

864 , ('c', (2, 2))

746 ]

865 ]

747

866

748− selected' <- liftIO $ Rel8.select connection do

867+ selected' <- lift do

749− x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])

868+ statement () $ Rel8.select do

750− y <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])

869+ x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])

751− z <- Rel8.evaluate (Rel8.nextval "test_seq")

870+ y <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])

752− pure ((x, y), (z, z))

871+ z <- Rel8.evaluate (Rel8.nextval "test_seq")

872+ pure ((x, y), (z, z))

753

873

754 normalize selected' ===

874 normalize selected' ===

755 [ (('a', 'd'), (0, 0))

875 [ (('a', 'd'), (0, 0))

@@ -767,13 +887,3 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect

767 normalize :: [(x, (Int64, Int64))] -> [(x, (Int64, Int64))]

887 normalize :: [(x, (Int64, Int64))] -> [(x, (Int64, Int64))]

768 normalize [] = []

888 normalize [] = []

769 normalize xs@((_, (i, _)) : _) = map (fmap (\(a, b) -> (a - i, b - i))) xs

889 normalize xs@((_, (i, _)) : _) = map (fmap (\(a, b) -> (a - i, b - i))) xs

770−

771−{-

772− selected <- liftIO $ Rel8.select connection do

773− x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])

774− x <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])

775− y <- Rel8.evaluate (Rel8.nextval "test_seq")

776− pure (x, y, y)

777−

778− selected === [('a', 1, 1), ('b', 2, 2), ('c', 3, 3)]

779−-}

tests/Rel8/Generic/Rel8able/Test.hs+46−15

@@ -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,24 +98,14 @@ data S3Object = S3Object

98 deriving stock Generic

100

101−deriving via HKDT S3Object

101+instance x ~ HKD S3Object Expr => ToExprs x S3Object

102− instance Table Result S3Object

103−

104−

105−deriving via HKDT S3Object

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

108+instance x ~ HKD HKDSum Expr => ToExprs x HKDSum

114− instance Table Result HKDSum

115−

116−

117−deriving via HKDT HKDSum

118− instance x ~ HKD HKDSum Expr => ToExprs x HKDSum

119

109

120

110

121data HKDTest f = HKDTest

111data HKDTest f = HKDTest

@@ -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