packages feed

rel8 1.2.2.0 → 1.8.0.0

raw patch · 146 files changed

Files

Changelog.md view
@@ -1,3 +1,327 @@++<a id='changelog-1.8.0.0'></a>+# 1.8.0.0 — 2026-09-16++## Added++- Added `Rel8.TH.deriveRel8able` and `Rel8.TH.deriveRel8ables` for deriving `Rel8able` instances using `TemplateHaskell`. +  This can be significantly faster than using `Generics`. In testing, we have seen 80% reductions in build time!+  +- Expose all `rel8` internal modules from the `rel8-internal` package.++- Added new `Conflict` and `Index` types. `Conflict` represents a [`conflict_target`](https://www.postgresql.org/docs/current/sql-insert.html#SQL-ON-CONFLICT) in an `ON CONFLICT`. It can be either a named constraint (`ON CONSTRAINT`) or a an `Index`.++- Added `Index`. `Index` is a description of a unique index which PostgreSQL can use for *unique index inference*. This is an alternative to specifying an explicit named constraint in a `conflict_target`.++- Add `notElem` and `notElem1` to `Rel8.Array`++- Added preliminary support for PostgreSQL ranges.++- Support GHC-9.14 and `semialign >= 1.4`.++- Added `notElem` and `notElem1` to `Rel8.Array`.++- Added `DBType Aeson.Object` instance.++- Bumped a variety of bounds.++## Changed++- The `Upsert` type was changed. Previously it had the columns (`index`, `predicate`) of what is now the `Index` type baked into its record. It now instead has a single `conflict` column (of type `Conflict`, which can be either an `Index` or a named constraint).+- The `DoNothing` constructor of `OnConflict` was changed to also take an optional `Conflict` value. Even though `ON CONFLICT DO NOTHING` does not generally require a `conflict_target`, there are cases where it can be necessary, e.g., if you have table that has both deferrable and non-deferrable constraints.++- `rel8` now requires at least version `0.10.8.0` of `opaleye`++## Fixed++- `elem` and `elem1` now use `IS NOT DISTINCT FROM` semantics (matching `(==.)`) when the element type is nullable, so `null` is found in an array containing `null`. Previously they were implemented with the array containment operator `<@`, which never matches `null`.++- Fixed some issues around the truncation of long column names.++- Improved documentation.++<a id='changelog-1.7.0.0'></a>+# 1.7.0.0 — 2025-07-31++## Removed++- Removed support for `network-ip`. We still support `iproute`.++## Added++- Add support for prepared statements. To use prepared statements, simply use `prepare run` instead of `run` with a function that passes the parameters to your statement.++- Added new `Encoder` type with three members: `binary`, which is the Hasql binary encoder, `text` which encodes a type in PostgreSQL's text format (needed for nested arrays) and `quote`, which is the does the thing that the function we previously called `encode` does (i.e., `a -> Opaleye.PrimExpr`).++- Add `elem` and `elem1` to `Rel8.Array` for testing if an element is contained in `[]` and `NonEmpty` `Expr`s.++- Support hasql-1.9++- Support GHC-9.12++## Changed++- Several changes to `TypeInformation`:++  * Changed the `encode` field of `TypeInformation` to be `Encoder a` instead of `a -> Opaleye.PrimExpr`.++  * Moved the `delimiter` field of `Decoder` into the top level of `TypeInformation`, as it's not "decoding" specific, it's also used when "encoding".++  * Renamed the `parser` field of `Decoder` to `text`, to mirror the `text` field of the new `Encoder` type.++  All of this will break any downstream code that uses a completely custom `DBType` implementation, but anything that uses `ReadShow`, `Enum`, `Composite`, `JSONBEncoded` or `parseTypeInformation` will continue working as before (which should cover all common cases).++- Stop exporting `Decoder` and `Encoder` from the `Rel8` module. These can now be found in `Rel8.Decoder` and `Rel8.Encoder`.++- Some changes were made to the `DBEnum` type class:++  * `Enumable` was removed as a superclass constraint. It is still used to provide the default implementation of the `DBEnum` class.+  * A new method, `enumerate`, was added to the `DBEnum` class (with the default implementation provided by `Enumable`).++  This is unlikely to break any existing `DBEnum` instances, it just allows some instances that weren't possible before (e.g., for types that are not `Generic`).++<a id='changelog-1.6.0.0'></a>+# 1.6.0.0 — 2024-12-13++## Removed++- Remove `Table Expr b` constraint from `materialize`. ([#334](https://github.com/circuithub/rel8/pull/334))++## Added++- Support GHC-9.10. ([#340](https://github.com/circuithub/rel8/pull/340))++- Support hasql-1.8 ([#345](https://github.com/circuithub/rel8/pull/345))++- Add `aggregateJustTable`, `aggregateJustTable` aggregator functions. These provide another way to do aggregation of `MaybeTable`s than the existing `aggregateMaybeTable` function. ([#333](https://github.com/circuithub/rel8/pull/333))++- Add `aggregateLeftTable`, `aggregateLeftTable1`, `aggregateRightTable` and `aggregateRightTable1` aggregator functions. These provide another way to do aggregation of `EitherTable`s than the existing `aggregateEitherTable` function. ([#333](https://github.com/circuithub/rel8/pull/333))++- Add `aggregateThisTable`, `aggregateThisTable1`, `aggregateThatTable`, `aggregateThatTable1`, `aggregateThoseTable`, `aggregateThoseTable1`, `aggregateHereTable`, `aggregateHereTable1`, `aggregateThereTable` and `aggregateThereTable1` aggregation functions. These provide another way to do aggregation of `TheseTable`s than the existing `aggregateTheseTable` function. ([#333](https://github.com/circuithub/rel8/pull/333))++- Add `rawFunction`, `rawBinaryOperator`, `rawAggregateFunction`, `unsafeCoerceExpr`, `unsafePrimExpr`, `unsafeSubscript`, `unsafeSubscripts` — these give more options for generating SQL expressions that Rel8 does not support natively. ([#331](https://github.com/circuithub/rel8/pull/331))++- Expose `unsafeUnnullify` and `unsafeUnnullifyTable` from `Rel8`. ([#343](https://github.com/circuithub/rel8/pull/343))++- Expose `listOf` and `nonEmptyOf`. ([#330](https://github.com/circuithub/rel8/pull/330))++- Add `NOINLINE` pragmas to `Generic` derived default methods of `Rel8able`. This should speed up+  compilation times. If users wish for these methods to be `INLINE`d, they can override with a+  pragma in their own code. ([#346](https://github.com/circuithub/rel8/pull/346))++## Fixed++- `JSONEncoded` should be encoded as `json` not `jsonb`. ([#347](https://github.com/circuithub/rel8/pull/347))++- Disallow NULL characters in Hedgehog generated text values. ([#339](https://github.com/circuithub/rel8/pull/339))++- Fix fromRational bug. ([#338](https://github.com/circuithub/rel8/pull/338))++- Fix regex match operator. ([#336](https://github.com/circuithub/rel8/pull/336))++- Fix some documentation formatting issues. ([#332](https://github.com/circuithub/rel8/pull/332)), ([#329](https://github.com/circuithub/rel8/pull/329)), ([#327](https://github.com/circuithub/rel8/pull/327)), and ([#318](https://github.com/circuithub/rel8/pull/318))+++<a id='changelog-1.5.0.0'></a>+# 1.5.0.0 — 2024-03-19++## Removed++- Removed `nullaryFunction`. Instead `function` can be called with `()`. ([#258](https://github.com/circuithub/rel8/pull/258))++## Added++- Support PostgreSQL's `inet` type (which maps to the Haskell `NetAddr IP` type). ([#227](https://github.com/circuithub/rel8/pull/227))++- `Rel8.materialize` and `Rel8.Tabulate.materialize`, which add a materialization/optimisation fence to `SELECT` statements by binding a query to a `WITH` subquery. Note that explicitly materialized common table expressions are only supported in PostgreSQL 12 an higher. ([#180](https://github.com/circuithub/rel8/pull/180)) ([#284](https://github.com/circuithub/rel8/pull/284))++- `Rel8.head`, `Rel8.headExpr`, `Rel8.last`, `Rel8.lastExpr` for accessing the first/last elements of `ListTable`s and arrays. We have also added variants for `NonEmptyTable`s/non-empty arrays with the `1` suffix (e.g., `head1`). ([#245](https://github.com/circuithub/rel8/pull/245))++- Rel8 now has extensive support for `WITH` statements and data-modifying statements (https://www.postgresql.org/docs/current/queries-with.html#QUERIES-WITH-MODIFYING).++  This work offers a lot of new power to Rel8. One new possibility is "moving" rows between tables, for example to archive rows in one table into a log table:++  ```haskell+  import Rel8++  archive :: Statement ()+  archive = do+    deleted <-+      delete Delete+        { from = mainTable+        , using = pure ()+        , deleteWhere = \foo -> fooId foo ==. lit 123+        , returning = Returning id+        }++    insert Insert+      { into = archiveTable+      , rows = deleted+      , onConflict = DoNothing+      , returning = NoReturninvg+      }+  ```++  This `Statement` will compile to a single SQL statement - essentially:++  ```sql+  WITH deleted_rows (DELETE FROM main_table WHERE id = 123 RETURNING *)+  INSERT INTO archive_table SELECT * FROM deleted_rows+  ```++  This feature is a significant performant improvement, as it avoids an entire roundtrip.++  This change has necessitated a change to how a `SELECT` statement is ran: `select` now will now produce a `Rel8.Statement`, which you have to `run` to turn it into a Hasql `Statement`. Rel8 offers a variety of `run` functions depending on how many rows need to be returned - see the various family of `run` functions in Rel8's documentation for more.++  [#250](https://github.com/circuithub/rel8/pull/250)++- `Rel8.loop` and `Rel8.loopDistinct`, which allow writing `WITH .. RECURSIVE` queries. ([#180](https://github.com/circuithub/rel8/pull/180))++- Added the `QualifiedName` type for named PostgreSQL objects (tables, views, functions, operators, sequences, etc.) that can optionally be qualified by a schema, including an `IsString` instance. ([#257](https://github.com/circuithub/rel8/pull/257)) ([#263](https://github.com/circuithub/rel8/pull/263))++- Added `queryFunction` for `SELECT`ing from table-returning functions such as `jsonb_to_recordset`. ([#241](https://github.com/circuithub/rel8/pull/241))++- `TypeName` record, which gives a richer representation of the components of a PostgreSQL type name (name, schema, modifiers, scalar/array). ([#263](https://github.com/circuithub/rel8/pull/263))++- `Rel8.length` and `Rel8.lengthExpr` for getting the length `ListTable`s and arrays. We have also added variants for `NonEmptyTable`s/non-empty arrays with the `1` suffix (e.g., `length1`). ([#268](https://github.com/circuithub/rel8/pull/268))++- Added aggregators `listCat` and `nonEmptyCat` for folding a collection of lists into a single list by concatenation. ([#270](https://github.com/circuithub/rel8/pull/270))++- `DBType` instance for `Fixed` that would map (e.g.) `Micro` to `numeric(1000, 6)` and `Pico` to `numeric(1000, 12)`. ([#280](https://github.com/circuithub/rel8/pull/280))++- `aggregationFunction`, which allows custom aggregation functions to be used. ([#283](https://github.com/circuithub/rel8/pull/283))++- Add support for ordered-set aggregation functions, including `mode`, `percentile`, `percentileContinuous`, `hypotheticalRank`, `hypotheticalDenseRank`, `hypotheticalPercentRank` and `hypotheticalCumeDist`. ([#282](https://github.com/circuithub/rel8/pull/282))++- Added `index`, `index1`, `indexExpr`, and `index1Expr` functions for extracting individual elements from `ListTable`s and `NonEmptyTable`s. ([#285](https://github.com/circuithub/rel8/pull/285))++- Rel8 now supports GHC 9.8. ([#299](https://github.com/circuithub/rel8/pull/299))++## Changed++- Rel8's API regarding aggregation has changed significantly, and is now a closer match to Opaleye.++  The previous aggregation API had `aggregate` transform a `Table` from the `Aggregate` context back into the `Expr` context:++  ```haskell+  myQuery = aggregate do+    a <- each tableA+    return $ liftF2 (,) (sum (foo a)) (countDistinct (bar a))+  ```++  This API seemed convenient, but has some significant shortcomings. The new API requires an explicit `Aggregator` be passed to `aggregate`:++  ```haskell+  myQuery = aggregate (liftA2 (,) (sumOn foo) (countDistinctOn bar)) do+    each tableA+  ```++  For more details, see [#235](https://github.com/circuithub/rel8/pull/235)++- `TypeInformation`'s `decoder` field has changed. Instead of taking a `Hasql.Decoder`, it now takes a `Rel8.Decoder`, which itself is comprised of a `Hasql.Decoder` and an `attoparsec` `Parser`. This is necessitated by the fix for [#168](https://github.com/circuithub/rel8/issues/168); we generally decode things in PostgreSQL's binary format (using a `Hasql.Decoder`), but for nested arrays we now get things in PostgreSQL's text format (for which we need an `attoparsec` `Parser`), so must have both. Most `DBType` instances that use `mapTypeInformation` or `ParseTypeInformation`, or `DerivingVia` helpers like `ReadShow`, `JSONBEncoded`, `Enum` and `Composite` are unaffected by this change. ([#243](https://github.com/circuithub/rel8/pull/243))++- The `schema` field from `TableSchema` has been removed and the name field changed from `String` to `QualifiedName`. ([#257](https://github.com/circuithub/rel8/pull/257))++- `nextval`, `function` and `binaryOperator` now take a `QualifiedName` instead of a `String`. ([#262](https://github.com/circuithub/rel8/pull/262))++- `function` has been changed to accept a single argument (as opposed to variadic arguments). ([#258](https://github.com/circuithub/rel8/pull/258))++- `TypeInformation`'s `typeName` parameter from `String` to `TypeName`. ([#263](https://github.com/circuithub/rel8/pull/263))++- `DBEnum`'s `enumTypeName` method from `String` to `QualifiedName`. ([#263](https://github.com/circuithub/rel8/pull/263))++- `DBComposite`'s `compositeTypeName` method from `String` to `QualifiedName`. ([#263](https://github.com/circuithub/rel8/pull/263))++- Changed `Upsert` by adding a `predicate` field, which allows partial indexes to be specified as conflict targets. ([#264](https://github.com/circuithub/rel8/pull/264))++- The window functions `lag`, `lead`, `firstValue`, `lastValue` and `nthValue` can now operate on entire rows at once as opposed to just single columns. ([#281](https://github.com/circuithub/rel8/pull/281))++## Fixed++- Fixed a bug with `catListTable` and `catNonEmptyTable` where invalid SQL could be produced. ([#240](https://github.com/circuithub/rel8/pull/240))++- A fix for [#168](https://github.com/circuithub/rel8/issues/168), which prevented using `catListTable` on arrays of arrays. To achieve this we had to coerce arrays of arrays to text internally, which unfortunately isn't completely transparent; you can oberve it if you write something like `listTable [listTable [10]] > listTable [listTable [9]]`: previously that would be `false`, but now it's `true`. Arrays of non-arrays are unaffected by this.++- Fixes [#228](https://github.com/circuithub/rel8/issues/228) where it was impossible to call `nextval` with a qualified sequence name.++- Fixes [#71](https://github.com/circuithub/rel8/issues/71).++- Fixed a typo in the documentation for `/=.`. ([#312](https://github.com/circuithub/rel8/pull/312))++- Fixed a bug where `fromRational` could crash with repeating fractions. ([#309](https://github.com/circuithub/rel8/pull/309))++- Fixed a typo in the documentation for `min`. ([#306](https://github.com/circuithub/rel8/pull/306))++# 1.4.1.0 (2023-01-19)++## New features++* Rel8 now supports window functions. See the "Window functions" section of the `Rel8` module documentation for more details. ([#182](https://github.com/circuithub/rel8/pull/182))+* `Query` now has `Monoid` and `Semigroup` instances. ([#207](https://github.com/circuithub/rel8/pull/207))+* `createOrReplaceView` has been added (to run `CREATE OR REPLACE VIEW`). ([#209](https://github.com/circuithub/rel8/pull/209) and [#212](https://github.com/circuithub/rel8/pull/212))+* `deriving Rel8able` now supports more polymorphism. ([#215](https://github.com/circuithub/rel8/pull/215))+* Support GHC 9.4 ([#199](https://github.com/circuithub/rel8/pull/199))++## Bug fixes++* Insertion of `DEFAULT` values has been fixed. ([#206](https://github.com/circuithub/rel8/pull/206))+* Avoid some exponential SQL generation in `Rel8.Tabulate.alignWith`. ([#213](https://github.com/circuithub/rel8/pull/213))+* `nextVal` has been fixed to work with case-sensitive sequence names. ([#217](https://github.com/circuithub/rel8/pull/217))++## Other++* Correct the documentation for "Supplying `Rel8able` instances" ([#200](https://github.com/circuithub/rel8/pull/200))+* Removed some redundant internal code ([#202](https://github.com/circuithub/rel8/pull/202))+* Rel8 is now less dependant on the internal Opaleye API. ([#204](https://github.com/circuithub/rel8/pull/204))++# 1.4.0.0 (2022-08-17)++## Breaking changes++* The behavior of `greatest`/`least` has been corrected, and was previously flipped. ([#183](https://github.com/circuithub/rel8/pull/183))++## New features++* `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))+* Add `fromMaybeTable`. ([#179](https://github.com/circuithub/rel8/pull/179))+* Add `alignMaybeTable`. ([#196](https://github.com/circuithub/rel8/pull/196))++## Improvements++* Optimize implementation of `AltTable` for `Tabulation` ([#178](https://github.com/circuithub/rel8/pull/178))++## Other+ +* Documentation improvements for `HADT`. ([#177](https://github.com/circuithub/rel8/pull/177))+* Document example usage of `groupBy`. ([#184](https://github.com/circuithub/rel8/pull/184))+* Build with and require Opaleye >= 0.9.3.3. ([#190](https://github.com/circuithub/rel8/pull/190))+* Build with `hasql` 1.6. ([#195](https://github.com/circuithub/rel8/pull/195))++# 1.3.1.0 (2022-01-20)++## Other++* Rel8 now requires Opaleye >= 0.9.1. ([#165](https://github.com/circuithub/rel8/pull/165))++# 1.3.0.0 (2022-01-31)++## Breaking changes++* `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))++## New features++* `divMod` and `quotRem` functions have been added, matching Haskell's `Prelude` functions. ([#155](https://github.com/circuithub/rel8/pull/155))+* `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))+* The full `EqTable` and `OrdTable` classes have been exported, allowing for instances to be manually created. ([#157](https://github.com/circuithub/rel8/pull/157))+* Added `like` and `ilike` (for the `LIKE` and `ILIKE` operators). ([#146](https://github.com/circuithub/rel8/pull/146))++## Other++* Rel8 now requires Opaleye 0.9. ([#158](https://github.com/circuithub/rel8/pull/158))+* Rel8's test suite supports Hedgehog 1.1. ([#160](https://github.com/circuithub/rel8/pull/160))+* The documentation for binary operations has been corrected. ([#162](https://github.com/circuithub/rel8/pull/162))+ # 1.2.2.0 (2021-11-21)  ## Other
− README.md 
@@ -1,17 +0,0 @@-# Welcome!--Welcome to Rel8! Rel8 is a Haskell library for interacting with PostgreSQL databases, built on top of the fantastic Opaleye library.--The main objectives of Rel8 are:--* *Conciseness*: Users using Rel8 should not need to write boiler-plate code. By using expressive types, we can provide sufficient information for the compiler to infer code whenever possible.--* *Inferrable*: Despite using a lot of type level magic, Rel8 aims to have excellent and predictable type inference.--* *Familiar*: writing Rel8 queries should feel like normal Haskell programming.--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:--[![Rel8 presentation at ZuriHac 2021](https://img.youtube.com/vi/3uwrtjxiq6E/hqdefault.jpg)](http://www.youtube.com/watch?v=3uwrtjxiq6E)--For more details, check out the [official documentation](https://rel8.readthedocs.io/en/latest/).
rel8.cabal view
@@ -1,8 +1,8 @@-cabal-version:       2.0+cabal-version:       3.0 name:                rel8-version:             1.2.2.0+version:             1.8.0.0 synopsis:            Hey! Hey! Can u rel8?-license:             BSD3+license:             BSD-3-Clause license-file:        LICENSE author:              Oliver Charles maintainer:          ollie@ocharles.org.uk@@ -10,7 +10,6 @@ bug-reports:         https://github.com/circuithub/rel8/issues build-type:          Simple extra-doc-files:-    README.md     Changelog.md  source-repository head@@ -19,25 +18,20 @@  library   build-depends:-      aeson-    , base ^>= 4.14 || ^>=4.15 || ^>=4.16+      rel8-internal ==1.8.0.0+    , base >= 4.16 && < 4.23     , bifunctors     , bytestring-    , case-insensitive     , comonad-    , contravariant-    , hasql ^>= 1.4.5.1 || ^>= 1.5.0.0-    , opaleye ^>= 0.8.0.0-    , pretty+    , opaleye ^>= 0.10.8.0     , profunctors     , product-profunctors-    , scientific-    , semialign     , semigroupoids-    , text-    , these     , time-    , uuid+    , containers+    , template-haskell+    , th-abstraction+   default-language:     Haskell2010   ghc-options:@@ -46,177 +40,56 @@     -Wno-missing-import-lists -Wno-prepositive-qualified-module     -Wno-monomorphism-restriction     -Wno-missing-local-signatures+    -Wno-missing-kind-signatures+    -Wno-missing-role-annotations+    -Wno-missing-deriving-strategies+    -Wno-term-variable-capture+    -Wno-all-missed-specializations+   hs-source-dirs:     src+   exposed-modules:     Rel8+    Rel8.Array+    Rel8.Decoder+    Rel8.Encoder     Rel8.Expr.Num     Rel8.Expr.Text     Rel8.Expr.Time+    Rel8.Range     Rel8.Tabulate--  other-modules:-    Rel8.Aggregate--    Rel8.Column-    Rel8.Column.ADT-    Rel8.Column.Either-    Rel8.Column.Lift-    Rel8.Column.List-    Rel8.Column.Maybe-    Rel8.Column.NonEmpty-    Rel8.Column.These--    Rel8.Expr-    Rel8.Expr.Aggregate-    Rel8.Expr.Array-    Rel8.Expr.Bool-    Rel8.Expr.Default-    Rel8.Expr.Eq-    Rel8.Expr.Function-    Rel8.Expr.Null-    Rel8.Expr.Opaleye-    Rel8.Expr.Ord-    Rel8.Expr.Order-    Rel8.Expr.Sequence-    Rel8.Expr.Serialize--    Rel8.FCF--    Rel8.Kind.Algebra-    Rel8.Kind.Context--    Rel8.Generic.Construction-    Rel8.Generic.Construction.ADT-    Rel8.Generic.Construction.Record-    Rel8.Generic.Map-    Rel8.Generic.Record-    Rel8.Generic.Rel8able-    Rel8.Generic.Table-    Rel8.Generic.Table.ADT-    Rel8.Generic.Table.Record--    Rel8.Order--    Rel8.Query-    Rel8.Query.Aggregate-    Rel8.Query.Distinct-    Rel8.Query.Each-    Rel8.Query.Either-    Rel8.Query.Evaluate-    Rel8.Query.Exists-    Rel8.Query.Filter-    Rel8.Query.Indexed-    Rel8.Query.Limit-    Rel8.Query.List-    Rel8.Query.Maybe-    Rel8.Query.Null-    Rel8.Query.Opaleye-    Rel8.Query.Order-    Rel8.Query.Rebind-    Rel8.Query.Set-    Rel8.Query.SQL-    Rel8.Query.These-    Rel8.Query.Values--    Rel8.Schema.Context.Nullify-    Rel8.Schema.Dict-    Rel8.Schema.Field-    Rel8.Schema.HTable-    Rel8.Schema.HTable.Either-    Rel8.Schema.HTable.Identity-    Rel8.Schema.HTable.Label-    Rel8.Schema.HTable.List-    Rel8.Schema.HTable.MapTable-    Rel8.Schema.HTable.Maybe-    Rel8.Schema.HTable.NonEmpty-    Rel8.Schema.HTable.Nullify-    Rel8.Schema.HTable.Product-    Rel8.Schema.HTable.These-    Rel8.Schema.HTable.Vectorize-    Rel8.Schema.Kind-    Rel8.Schema.Name-    Rel8.Schema.Null-    Rel8.Schema.Result-    Rel8.Schema.Spec-    Rel8.Schema.Table--    Rel8.Statement.Delete-    Rel8.Statement.Insert-    Rel8.Statement.OnConflict-    Rel8.Statement.Returning-    Rel8.Statement.Select-    Rel8.Statement.Set-    Rel8.Statement.SQL-    Rel8.Statement.Update-    Rel8.Statement.Using-    Rel8.Statement.View-    Rel8.Statement.Where--    Rel8.Table-    Rel8.Table.ADT-    Rel8.Table.Aggregate-    Rel8.Table.Alternative-    Rel8.Table.Bool-    Rel8.Table.Cols-    Rel8.Table.Either-    Rel8.Table.Eq-    Rel8.Table.HKD-    Rel8.Table.List-    Rel8.Table.Maybe-    Rel8.Table.Name-    Rel8.Table.NonEmpty-    Rel8.Table.Nullify-    Rel8.Table.Opaleye-    Rel8.Table.Ord-    Rel8.Table.Order-    Rel8.Table.Projection-    Rel8.Table.Rel8able-    Rel8.Table.Serialize-    Rel8.Table.These-    Rel8.Table.Transpose-    Rel8.Table.Undefined--    Rel8.Type-    Rel8.Type.Array-    Rel8.Type.Composite-    Rel8.Type.Eq-    Rel8.Type.Enum-    Rel8.Type.Information-    Rel8.Type.JSONEncoded-    Rel8.Type.JSONBEncoded-    Rel8.Type.Monoid-    Rel8.Type.Num-    Rel8.Type.Ord-    Rel8.Type.ReadShow-    Rel8.Type.Semigroup-    Rel8.Type.String-    Rel8.Type.Sum-    Rel8.Type.Tag+    Rel8.TH  test-suite tests   type:             exitcode-stdio-1.0   build-depends:-      base+      aeson+    , base     , bytestring     , case-insensitive     , containers     , hasql     , hasql-transaction-    , hedgehog          ^>=1.0.2+    , hedgehog          >= 1.0 && < 1.8     , mmorph+    , iproute     , rel8+    , rel8-internal     , scientific     , tasty     , tasty-hedgehog     , text+    , these     , time-    , tmp-postgres      ^>=1.34.1.0+    , tmp-postgres >=1.34 && <1.36     , transformers     , uuid+    , vector    other-modules:     Rel8.Generic.Rel8able.Test+    Rel8.TH.Rel8able.Test    main-is:          Main.hs   hs-source-dirs:   tests@@ -226,3 +99,5 @@     -Wno-missing-import-lists -Wno-prepositive-qualified-module     -Wno-deprecations -Wno-monomorphism-restriction     -Wno-missing-local-signatures -Wno-implicit-prelude+    -Wno-missing-kind-signatures+    -Wno-missing-role-annotations
src/Rel8.hs view
@@ -19,6 +19,7 @@      -- *** @TypeInformation@   , TypeInformation(..)+  , TypeName(..)   , mapTypeInformation   , parseTypeInformation @@ -38,6 +39,7 @@   , HMaybe   , HList   , HNonEmpty+  , HNull   , HThese   , Lift @@ -46,8 +48,8 @@   , Transposes   , AltTable((<|>:))   , AlternativeTable( emptyTable )-  , EqTable, (==:), (/=:)-  , OrdTable, (<:), (<=:), (>:), (>=:), ascTable, descTable, greatest, least+  , EqTable(..), (==:), (/=:)+  , OrdTable(..), (<:), (<=:), (>:), (>=:), ascTable, descTable, greatest, least   , lit   , bool   , case_@@ -57,9 +59,11 @@   , MaybeTable   , maybeTable, ($?), nothingTable, justTable   , isNothingTable, isJustTable+  , fromMaybeTable   , optional   , catMaybeTable   , traverseMaybeTable+  , aggregateJustTable, aggregateJustTable1   , aggregateMaybeTable   , nameMaybeTable @@ -70,6 +74,8 @@   , keepLeftTable   , keepRightTable   , bitraverseEitherTable+  , aggregateLeftTable, aggregateLeftTable1+  , aggregateRightTable, aggregateRightTable1   , aggregateEitherTable   , nameEitherTable @@ -79,6 +85,7 @@   , isThisTable, isThatTable, isThoseTable   , hasHereTable, hasThereTable   , justHereTable, justThereTable+  , alignMaybeTable   , alignBy   , keepHereTable, loseHereTable   , keepThereTable, loseThereTable@@ -86,12 +93,17 @@   , keepThatTable, loseThatTable   , keepThoseTable, loseThoseTable   , bitraverseTheseTable+  , aggregateThisTable, aggregateThisTable1+  , aggregateThatTable, aggregateThatTable1+  , aggregateThoseTable, aggregateThoseTable1+  , aggregateHereTable, aggregateHereTable1+  , aggregateThereTable, aggregateThereTable1   , aggregateTheseTable   , nameTheseTable      -- ** @ListTable@   , ListTable-  , listTable, ($*)+  , listOf, listTable, ($*)   , nameListTable   , many   , manyExpr@@ -100,31 +112,52 @@      -- ** @NonEmptyTable@   , NonEmptyTable-  , nonEmptyTable, ($+)+  , nonEmptyOf, nonEmptyTable, ($+)   , nameNonEmptyTable   , some   , someExpr   , catNonEmptyTable   , catNonEmpty -    -- ** @ADT@+    -- ** @NullTable@+  , NullTable+  , nullableTable, nullTable, nullifyTable+  , isNullTable, isNonNullTable+  , catNullTable+  , nameNullTable+  , toNullTable, toMaybeTable+  , unsafeUnnullifyTable++    -- ** Algebraic data types / sum types+    -- $adts++    -- *** Naming of ADTs+    -- $naming+  , NameADT, nameADT   , ADT, ADTable++    -- *** Deconstruction of ADTs+    -- $deconstruction+  , DeconstructADT, deconstructADT++    -- *** Construction of ADTs+    -- $construction   , BuildADT, buildADT   , ConstructADT, constructADT-  , DeconstructADT, deconstructADT-  , NameADT, nameADT-  , AggregateADT, aggregateADT +    -- *** Miscellaneous notes+    -- $misc-notes+     -- ** @HKD@   , HKD, HKDable   , BuildHKD, buildHKD   , ConstructHKD, constructHKD   , DeconstructHKD, deconstructHKD   , NameHKD, nameHKD-  , AggregateHKD, aggregateHKD      -- ** Table schemas   , TableSchema(..)+  , QualifiedName(..)   , Name   , namesFromLabels   , namesFromLabelsWith@@ -134,11 +167,14 @@   , Sql   , litExpr   , unsafeCastExpr+  , unsafeCoerceExpr   , unsafeLiteral+  , unsafePrimExpr      -- ** @null@   , NotNull   , Nullable+  , Homonullable   , null   , nullify   , nullable@@ -148,6 +184,7 @@   , liftOpNull   , catNull   , coalesce+  , unsafeUnnullify      -- ** Boolean operations   , DBEq@@ -157,6 +194,7 @@   , (==.), (/=.), (==?), (/=?)   , in_   , boolExpr, caseExpr+  , like, ilike      -- ** Ordering   , DBOrd@@ -165,10 +203,12 @@   , leastExpr, greatestExpr      -- ** Functions-  , Function+  , Arguments   , function-  , nullaryFunction   , binaryOperator+  , queryFunction+  , rawFunction+  , rawBinaryOperator      -- * Queries   , Query@@ -218,25 +258,54 @@   , without   , withoutBy +    -- ** @WITH@+  , materialize++    -- ** @WITH RECURSIVE@+  , loop+  , loopDistinct+     -- ** Aggregation-  , Aggregate-  , Aggregates+  , Aggregator+  , Aggregator1+  , Aggregator'+  , Fold (Semi, Full)+  , toAggregator+  , toAggregator1   , aggregate+  , aggregate1+  , filterWhere+  , filterWhereOptional+  , distinctAggregate+  , orderAggregateBy+  , optionalAggregate   , countRows-  , groupBy-  , listAgg, listAggExpr-  , nonEmptyAgg, nonEmptyAggExpr-  , DBMax, max-  , DBMin, min-  , DBSum, sum, sumWhere+  , groupBy, groupByOn+  , listAgg, listAggOn, listAggExpr, listAggExprOn+  , listCat, listCatOn, listCatExpr, listCatExprOn+  , nonEmptyAgg, nonEmptyAggOn, nonEmptyAggExpr, nonEmptyAggExprOn+  , nonEmptyCat, nonEmptyCatOn, nonEmptyCatExpr, nonEmptyCatExprOn+  , DBMax, max, maxOn+  , DBMin, min, minOn+  , DBSum, sum, sumOn, sumWhere, avg, avgOn   , DBString, stringAgg-  , count+  , count, countOn   , countStar-  , countDistinct-  , countWhere-  , and-  , or+  , countDistinct, countDistinctOn+  , countWhere, countWhereOn+  , and, andOn+  , or, orOn+  , aggregateFunction+  , rawAggregateFunction +  , mode, modeOn+  , percentile, percentileOn+  , percentileContinuous, percentileContinuousOn+  , hypotheticalRank+  , hypotheticalDenseRank+  , hypotheticalPercentRank+  , hypotheticalCumeDist+     -- ** Ordering   , orderBy   , Order@@ -246,6 +315,25 @@   , nullsLast      -- ** Window functions+  , Window+  , window+  , Partition+  , over+  , partitionBy+  , orderPartitionBy+  , cumulative+  , currentRow+  , rowNumber+  , rank+  , denseRank+  , percentRank+  , cumeDist+  , ntile+  , lag, lagOn+  , lead, leadOn+  , firstValue, firstValueOn+  , lastValue, lastValueOn+  , nthValue, nthValueOn   , indexed      -- ** Bindings@@ -258,6 +346,13 @@      -- * Running statements     -- $running+  , run+  , run_+  , runN+  , run1+  , runMaybe+  , runVector+  , prepared      -- ** @SELECT@   , select@@ -265,6 +360,8 @@     -- ** @INSERT@   , Insert(..)   , OnConflict(..)+  , Conflict (..)+  , Index (..)   , Upsert(..)   , insert   , unsafeDefault@@ -283,8 +380,14 @@     -- ** @.. RETURNING@   , Returning(..) +    -- ** @WITH@+  , Statement+  , showStatement+  , showPreparedStatement+     -- ** @CREATE VIEW@   , createView+  , createOrReplaceView      -- ** Sequences   , nextval@@ -295,100 +398,331 @@ import Prelude ()  -- rel8-import Rel8.Aggregate-import Rel8.Column-import Rel8.Column.ADT-import Rel8.Column.Either-import Rel8.Column.Lift-import Rel8.Column.List-import Rel8.Column.Maybe-import Rel8.Column.NonEmpty-import Rel8.Column.These-import Rel8.Expr-import Rel8.Expr.Aggregate-import Rel8.Expr.Bool-import Rel8.Expr.Default-import Rel8.Expr.Eq-import Rel8.Expr.Function-import Rel8.Expr.Null-import Rel8.Expr.Opaleye (unsafeCastExpr, unsafeLiteral)-import Rel8.Expr.Ord-import Rel8.Expr.Order-import Rel8.Expr.Serialize-import Rel8.Expr.Sequence-import Rel8.Generic.Rel8able ( KRel8able, Rel8able )-import Rel8.Order-import Rel8.Query-import Rel8.Query.Aggregate-import Rel8.Query.Distinct-import Rel8.Query.Each-import Rel8.Query.Either-import Rel8.Query.Evaluate-import Rel8.Query.Exists-import Rel8.Query.Filter-import Rel8.Query.Indexed-import Rel8.Query.Limit-import Rel8.Query.List-import Rel8.Query.Maybe-import Rel8.Query.Null-import Rel8.Query.Order-import Rel8.Query.Rebind-import Rel8.Query.SQL (showQuery)-import Rel8.Query.Set-import Rel8.Query.These-import Rel8.Query.Values-import Rel8.Schema.Field-import Rel8.Schema.HTable-import Rel8.Schema.Name-import Rel8.Schema.Null hiding ( nullable )-import Rel8.Schema.Result ( Result )-import Rel8.Schema.Table-import Rel8.Statement.Delete-import Rel8.Statement.Insert-import Rel8.Statement.OnConflict-import Rel8.Statement.Returning-import Rel8.Statement.Select-import Rel8.Statement.SQL-import Rel8.Statement.Update-import Rel8.Statement.View-import Rel8.Table-import Rel8.Table.ADT-import Rel8.Table.Aggregate-import Rel8.Table.Alternative-import Rel8.Table.Bool-import Rel8.Table.Either-import Rel8.Table.Eq-import Rel8.Table.HKD-import Rel8.Table.List-import Rel8.Table.Maybe-import Rel8.Table.Name-import Rel8.Table.NonEmpty-import Rel8.Table.Opaleye ( castTable )-import Rel8.Table.Ord-import Rel8.Table.Order-import Rel8.Table.Projection-import Rel8.Table.Rel8able ()-import Rel8.Table.Serialize-import Rel8.Table.These-import Rel8.Table.Transpose-import Rel8.Type-import Rel8.Type.Composite-import Rel8.Type.Eq-import Rel8.Type.Enum-import Rel8.Type.Information-import Rel8.Type.JSONBEncoded-import Rel8.Type.JSONEncoded-import Rel8.Type.Monoid-import Rel8.Type.Num-import Rel8.Type.Ord-import Rel8.Type.ReadShow-import Rel8.Type.Semigroup-import Rel8.Type.String-import Rel8.Type.Sum+import Rel8.Internal.Aggregate+import Rel8.Internal.Aggregate.Fold+import Rel8.Internal.Aggregate.Function+import Rel8.Internal.Column+import Rel8.Internal.Column.ADT+import Rel8.Internal.Column.Either+import Rel8.Internal.Column.Lift+import Rel8.Internal.Column.List+import Rel8.Internal.Column.Maybe+import Rel8.Internal.Column.NonEmpty+import Rel8.Internal.Column.Null+import Rel8.Internal.Column.These+import Rel8.Internal.Expr+import Rel8.Internal.Expr.Aggregate+import Rel8.Internal.Expr.Array+import Rel8.Internal.Expr.Bool+import Rel8.Internal.Expr.Default+import Rel8.Internal.Expr.Eq+import Rel8.Internal.Expr.Function+import Rel8.Internal.Expr.Null+import Rel8.Internal.Expr.Opaleye (unsafeCastExpr, unsafeCoerceExpr, unsafeLiteral, unsafePrimExpr)+import Rel8.Internal.Expr.Ord+import Rel8.Internal.Expr.Order+import Rel8.Internal.Expr.Serialize+import Rel8.Internal.Expr.Sequence+import Rel8.Internal.Expr.Text ( like, ilike )+import Rel8.Internal.Expr.Window+import Rel8.Internal.Generic.Rel8able ( KRel8able, Rel8able )+import Rel8.Internal.Order+import Rel8.Internal.Query+import Rel8.Internal.Query.Aggregate+import Rel8.Internal.Query.Distinct+import Rel8.Internal.Query.Each+import Rel8.Internal.Query.Either+import Rel8.Internal.Query.Evaluate+import Rel8.Internal.Query.Exists+import Rel8.Internal.Query.Filter+import Rel8.Internal.Query.Function+import Rel8.Internal.Query.Indexed+import Rel8.Internal.Query.Limit+import Rel8.Internal.Query.List+import Rel8.Internal.Query.Loop+import Rel8.Internal.Query.Materialize+import Rel8.Internal.Query.Maybe+import Rel8.Internal.Query.Null+import Rel8.Internal.Query.Order+import Rel8.Internal.Query.Rebind+import Rel8.Internal.Query.SQL (showQuery)+import Rel8.Internal.Query.Set+import Rel8.Internal.Query.These+import Rel8.Internal.Query.Values+import Rel8.Internal.Query.Window+import Rel8.Internal.Schema.Field+import Rel8.Internal.Schema.HTable+import Rel8.Internal.Schema.Name+import Rel8.Internal.Schema.Null hiding ( nullable )+import Rel8.Internal.Schema.QualifiedName+import Rel8.Internal.Schema.Result ( Result )+import Rel8.Internal.Schema.Table+import Rel8.Internal.Statement+import Rel8.Internal.Statement.Delete+import Rel8.Internal.Statement.Insert+import Rel8.Internal.Statement.OnConflict+import Rel8.Internal.Statement.Prepared+import Rel8.Internal.Statement.Returning+import Rel8.Internal.Statement.Run+import Rel8.Internal.Statement.Select+import Rel8.Internal.Statement.SQL+import Rel8.Internal.Statement.Update+import Rel8.Internal.Statement.View+import Rel8.Internal.Table+import Rel8.Internal.Table.ADT+import Rel8.Internal.Table.Aggregate+import Rel8.Internal.Table.Aggregate.Maybe+import Rel8.Internal.Table.Alternative+import Rel8.Internal.Table.Bool+import Rel8.Internal.Table.Either+import Rel8.Internal.Table.Eq+import Rel8.Internal.Table.HKD+import Rel8.Internal.Table.List+import Rel8.Internal.Table.Maybe+import Rel8.Internal.Table.Name+import Rel8.Internal.Table.NonEmpty+import Rel8.Internal.Table.Null+import Rel8.Internal.Table.Opaleye ( castTable )+import Rel8.Internal.Table.Ord+import Rel8.Internal.Table.Order+import Rel8.Internal.Table.Projection+import Rel8.Internal.Table.Rel8able ()+import Rel8.Internal.Table.Serialize+import Rel8.Internal.Table.These+import Rel8.Internal.Table.Transpose+import Rel8.Internal.Table.Window+import Rel8.Internal.Type+import Rel8.Internal.Type.Composite+import Rel8.Internal.Type.Eq+import Rel8.Internal.Type.Enum+import Rel8.Internal.Type.Information+import Rel8.Internal.Type.JSONBEncoded+import Rel8.Internal.Type.JSONEncoded+import Rel8.Internal.Type.Monoid+import Rel8.Internal.Type.Name+import Rel8.Internal.Type.Num+import Rel8.Internal.Type.Ord+import Rel8.Internal.Type.ReadShow+import Rel8.Internal.Type.Semigroup+import Rel8.Internal.Type.String+import Rel8.Internal.Type.Sum+import Rel8.Internal.Window   -- $running -- To run queries and otherwise interact with a PostgreSQL database, Rel8--- provides 'select', 'insert', 'update' and 'delete' functions. Note that--- 'insert', 'update' and 'delete' will generally need the--- `DuplicateRecordFields` language extension enabled.+-- provides the @run@ functions. These produce a 'Hasql.Statement.Statement's+-- which can be passed to 'Hasql.Session.statement' to execute the statement+-- against a PostgreSQL 'Hasql.Connection.Connection'.+--+-- 'run' takes a 'Statement', which can be constructed using either 'select',+-- 'insert', 'update' or 'delete'. It decodes the rows returned by the+-- statement as a list of Haskell of values. See 'run_', 'runN', 'run1',+-- 'runMaybe' and 'runVector' for other variations.+--+-- Note that constructing an 'Insert', 'Update' or 'Delete' will require the+-- @DisambiguateRecordFields@ language extension to be enabled.++-- $adts+-- Algebraic data types can be modelled between Haskell and SQL.+--+-- * Your SQL table needs a certain text field that tags which Haskell constructor is in use.+-- * You have to use a few combinators to specify the sum type's individual constructors.+-- * If you want to do case analysis at the @Expr@ (SQL) level, you can use 'maybe'/'either'-like eliminators.+--+-- The documentation in this section will assume a set of database types like this:+--+-- @+-- data Thing f = ThingEmployer (Employer f) | ThingPotato (Potato f) | Nullary+--     deriving stock Generic+--+-- data Employer f = Employer { employerId :: Column f Int32, employerName :: Column f Text}+--   deriving stock Generic+--   deriving anyclass Rel8able+--+-- data Potato f = Potato { size :: Column f Int32, grower :: Column f Text }+--   deriving stock Generic+--   deriving anyclass Rel8able+-- @++-- $naming+--+-- First, in your 'TableSchema', name your type like this:+--+-- @+-- thingSchema :: TableSchema (ADT Thing Name)+-- thingSchema =+--   TableSchema+--     { name = \"thing\",+--       columns =+--         nameADT @Thing+--           \"tag\"+--           Employer+--             { employerName = \"name\",+--               employerId = \"id\"+--             }+--           Potato {size = \"size\", grower = \"Mary\"}+--     }+-- @+--+-- Note that @nameADT \@Thing "tag"@ is variadic: it accepts one+-- argument per constructor, except the nullary ones (Nullary) because+-- there's nothing to do for them.++-- $deconstruction+--+-- To deconstruct sum types at the SQL level, use 'deconstructADT',+-- which is also variadic, and has one argument for each+-- constructor. Similar to 'maybe'.+--+-- @+-- query :: Query (ADT Thing Expr)+-- query = do+--   thingExpr <- each thingSchema+--   where_ $+--     deconstructADT \@Thing+--       (\\employer -> employerName employer ==. lit \"Mary\")+--       (\\potato -> grower potato ==. lit \"Mary\")+--       (lit False) -- Nullary case+--       thingExpr+--   pure thingExpr+-- @+--+-- SQL output:+--+-- @+-- SELECT+-- CAST("tag0_1" AS text) as "tag",+-- CAST("id1_1" AS int4) as "ThingEmployer/_1/employerId",+-- CAST("name2_1" AS text) as "ThingEmployer/_1/employerName",+-- CAST("size3_1" AS int4) as "ThingPotato/_1/size",+-- CAST("Mary4_1" AS text) as "ThingPotato/_1/grower"+-- FROM (SELECT+--       *+--       FROM (SELECT+--             "tag" as "tag0_1",+--             "id" as "id1_1",+--             "name" as "name2_1",+--             "size" as "size3_1",+--             "Mary" as "Mary4_1"+--             FROM "thing" as "T1") as "T1"+--       WHERE (CASE WHEN ("tag0_1") = (CAST(E'ThingPotato' AS text)) THEN ("Mary4_1") = (CAST(E'Mary' AS text))+--                   WHEN ("tag0_1") = (CAST(E'Nullary' AS text)) THEN CAST(FALSE AS bool) ELSE ("name2_1") = (CAST(E'Mary' AS text)) END)) as "T1"+-- @++-- $construction+--+-- To construct an ADT, you can use 'buildADT' or 'constructADT'. Consider the following type:+--+-- @+-- data Task f = Pending | Complete (CompletedTask f)+-- @+--+-- 'buildADT' is for constructing values of 'Task' in the 'Expr'+-- context. 'buildADT' needs two type-level arguments before its type+-- makes any sense. The first argument is the type of the "ADT", which+-- in our case is 'Task'. The second is the name of the constructor we+-- want to use. So that means we have the following possible+-- instantiations of 'buildADT' for 'Task':+--+-- @+-- > :t buildADT \@Task \@\"Pending\"+-- buildADT \@Task \@\"Pending\" :: ADT Task Expr+-- > :t buildADT \@Task @\"Complete\"+-- buildADT \@Task \@\"Complete\" :: CompletedTask Expr -> ADT Task Expr+-- @+--+-- Note that as the "Pending" constructor has no fields, @buildADT+-- \@Task \@"Pending"@ is equivalent to @lit Pending@. But @buildADT+-- \@Task \@"Complete"@ is not the same as @lit . Complete@:+--+-- @+-- > :t lit . Complete+-- lit . Complete :: CompletedTask Result -> ADT Task Expr+-- @+--+--+-- Note that the former takes a @CompletedTask Expr@ while the latter+-- takes a @CompletedTask Result@. The former is more powerful because+-- you can construct @Task@s using dynamic values coming a database+-- query.+--+-- To show what this can look like in SQL, consider:+--+-- @+-- > :{+-- showQuery $ values+--   [ buildADT \@Task \@\"Pending\"+--   , buildADT \@Task \@\"Complete\" CompletedTask {date = Rel8.Expr.Time.now}+--   ]+-- :}+-- @+--+-- This produces the following SQL:+--+-- @+-- SELECT+-- CAST(\"values0_1\" AS text) as \"tag\",+-- CAST(\"values1_1\" AS timestamptz) as \"Complete/_1/date\"+-- FROM (SELECT+--       *+--       FROM (SELECT \"column1\" as \"values0_1\",+--                    \"column2\" as \"values1_1\"+--             FROM+--             (VALUES+--              (CAST(E'Pending' AS text),CAST(NULL AS timestamptz)),+--              (CAST(E'Complete' AS text),CAST(now() AS timestamptz))) as \"V\") as \"T1\") as \"T1\"+-- @+--+-- This is what you get if you run it in @psql@:+--+--+-- @+--    tag    |       Complete/_1/date+-- ----------+-------------------------------+--  Pending  |+--  Complete | 2022-05-19 21:28:23.969065+00+-- (2 rows)+-- @+--+-- "constructADT" is less convenient but more general alternative to+-- "buildADT". It requires only one type-level argument for its type+-- to make sense:+--+-- @+-- > :t constructADT @Task+-- constructADT @Task+--   :: (forall r. r -> (CompletedTask Expr -> r) -> r) -> ADT Task Expr+-- @+--+-- This might still seem a bit opaque, but basically it gives you a+-- Church-encoded constructor for arbitrary algebraic data types. You+-- might use it as follows:+--+-- @+-- let+--   pending :: ADT Task Expr+--   pending = constructADT \@Task $ \\pending _complete -> pending+--+--   complete :: ADT Task Expr+--   complete = constructADT \@Task $ \\_pending complete -> complete CompletedTask {date = Rel8.Expr.Time.now}+-- @+--+-- These values are otherwise identical to the ones we saw above with+-- @buildADT@, it's just a different style of constructing them.+--++-- $misc-notes+--+-- 1. Note that the order of the arguments for all of these functions+-- is determined by the order of the constructors in the data+-- definition. If it were @data Task = Complete (CompletedTask f) |+-- Pending@ then the order of all the invocations of @constructADT@+-- and @deconstructADT@ would need to change.+--+-- 2. Maybe this is obvious, but just to spell it out: once you're in+-- the @Result@ context, you can of course construct @Task@ values+-- normally and use standard Haskell pattern-matching. @constructADT@+-- and @deconstructADT@ are specifically only needed in the @Expr@+-- context, and they allow you to do the equivalent of pattern+-- matching in PostgreSQL.
− src/Rel8/Aggregate.hs 
@@ -1,91 +0,0 @@-{-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language MultiParamTypeClasses #-}-{-# language NamedFieldPuns #-}-{-# language RankNTypes #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}--module Rel8.Aggregate-  ( Aggregate(..), zipOutputs-  , Aggregator(..), unsafeMakeAggregate-  , Aggregates-  )-where---- base-import Control.Applicative ( liftA2 )-import Data.Functor.Identity ( Identity( Identity ) )-import Data.Kind ( Constraint, Type )-import Prelude---- opaleye-import qualified Opaleye.Internal.Aggregate as Opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye-import qualified Opaleye.Internal.PackMap as Opaleye---- rel8-import Rel8.Expr ( Expr )-import Rel8.Schema.HTable.Identity ( HIdentity(..) )-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Null ( Sql )-import Rel8.Table-  ( Table, Columns, Context, fromColumns, toColumns-  , FromExprs, fromResult, toResult-  , Transpose-  )-import Rel8.Table.Transpose ( Transposes )-import Rel8.Type ( DBType )----- | 'Aggregate' is a special context used by 'Rel8.aggregate'.-type Aggregate :: K.Context-newtype Aggregate a = Aggregate (Opaleye.Aggregator () (Expr a))---instance Sql DBType a => Table Aggregate (Aggregate a) where-  type Columns (Aggregate a) = HIdentity a-  type Context (Aggregate a) = Aggregate-  type FromExprs (Aggregate a) = a-  type Transpose to (Aggregate a) = to a--  toColumns = HIdentity-  fromColumns (HIdentity a) = a-  toResult = HIdentity . Identity-  fromResult (HIdentity (Identity a)) = a----- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate's--- for the 'Expr' columns in @b@.-type Aggregates :: Type -> Type -> Constraint-class Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs-instance Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs---zipOutputs :: ()-  => (Expr a -> Expr b -> Expr c) -> Aggregate a -> Aggregate b -> Aggregate c-zipOutputs f (Aggregate a) (Aggregate b) = Aggregate (liftA2 f a b)---type Aggregator :: Type-data Aggregator = Aggregator-  { operation :: Opaleye.AggrOp-  , ordering :: [Opaleye.OrderExpr]-  , distinction :: Opaleye.AggrDistinct-  }---unsafeMakeAggregate :: forall (input :: Type) (output :: Type). ()-  => (Expr input -> Opaleye.PrimExpr)-  -> (Opaleye.PrimExpr -> Expr output)-  -> Maybe Aggregator-  -> Expr input-  -> Aggregate output-unsafeMakeAggregate input output aggregator expr =-  Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ \f _ ->-    output <$> f (tuplize <$> aggregator, input expr)-  where-    tuplize Aggregator {operation, ordering, distinction} =-      (operation, ordering, distinction)
− src/Rel8/Aggregate.hs-boot 
@@ -1,11 +0,0 @@-{-# language PolyKinds #-}-{-# language RoleAnnotations #-}-{-# language StandaloneKindSignatures #-}--module Rel8.Aggregate where--import Data.Kind--type Aggregate :: k -> Type-type role Aggregate nominal-data Aggregate a
+ src/Rel8/Array.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Rel8.Array+  (+    -- ** @ListTable@+    ListTable+  , head, headExpr+  , index, indexExpr+  , last, lastExpr+  , length, lengthExpr+  , elem, notElem++    -- ** @NonEmptyTable@+  , NonEmptyTable+  , head1, head1Expr+  , index1, index1Expr+  , last1, last1Expr+  , length1, length1Expr+  , elem1, notElem1++    -- ** Unsafe+  , unsafeSubscript+  , unsafeSubscripts+  )+where++-- base+import Data.Int (Int32)+import Data.List.NonEmpty (NonEmpty)+import Prelude hiding (elem, head, last, length, notElem)++-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye++-- rel8+import Rel8.Internal.Expr (Expr)+import Rel8.Internal.Expr.Bool (not_)+import Rel8.Internal.Expr.Function (rawFunction)+import Rel8.Internal.Expr.List+import Rel8.Internal.Expr.NonEmpty+import Rel8.Internal.Expr.Null (isNonNull, isNull)+import Rel8.Internal.Expr.Opaleye (fromPrimExpr, toPrimExpr)+import Rel8.Internal.Expr.Subscript+import Rel8.Internal.Schema.Null (Nullity (NotNull, Null), Sql, nullable)+import Rel8.Internal.Table.List+import Rel8.Internal.Table.NonEmpty+import Rel8.Internal.Type (DBType)+import Rel8.Internal.Type.Eq (DBEq)+++-- | @'elem' a as@ tests whether @a@ is an element of the list @as@.+elem :: Sql DBEq a => Expr a -> Expr [a] -> Expr Bool+elem = memberOf+infix 4 `elem`+++-- | @'elem1' a as@ tests whether @a@ is an element of the non-empty list+-- @as@.+elem1 :: Sql DBEq a => Expr a -> Expr (NonEmpty a) -> Expr Bool+elem1 = memberOf+infix 4 `elem1`+++-- | @'notElem' a as@ tests whether @a@ is not an element of the list @as@.+notElem :: Sql DBEq a => Expr a -> Expr [a] -> Expr Bool+notElem = notMemberOf+infix 4 `notElem`+++-- | @'notElem1' a as@ tests whether @a@ is not an element of the non-empty+-- list @as@.+notElem1 :: Sql DBEq a => Expr a -> Expr (NonEmpty a) -> Expr Bool+notElem1 = notMemberOf+infix 4 `notElem1`+++memberOf :: forall a t. (Sql DBEq a, DBType (t a))+  => Expr a -> Expr (t a) -> Expr Bool+memberOf = case nullable @a of+  Null -> \ma mas -> isNonNull (position mas ma)+  NotNull -> eqAny+++notMemberOf :: forall a t. (Sql DBEq a, DBType (t a))+  => Expr a -> Expr (t a) -> Expr Bool+notMemberOf = case nullable @a of+  Null -> \ma mas -> isNull (position mas ma)+  NotNull -> \a as -> not_ (eqAny a as)+++position :: (DBType (t (Maybe a)), DBType a)+  => Expr (t (Maybe a)) -> Expr (Maybe a) -> Expr (Maybe Int32)+position as a = rawFunction "array_position" (as, a)+++eqAny :: Expr a -> Expr as -> Expr Bool+eqAny a as =+  fromPrimExpr (Opaleye.AnyExpr (Opaleye.:==) (toPrimExpr a) (toPrimExpr as))
− src/Rel8/Column.hs 
@@ -1,31 +0,0 @@-{-# language DataKinds #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}--module Rel8.Column-  ( Column-  , TColumn-  )-where---- base-import Data.Kind ( Type )-import Prelude ()---- rel8-import Rel8.FCF ( Eval, Exp )-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Result ( Result )----- | This type family is used to specify columns in 'Rel8able's. In @Column f--- a@, @f@ is the context of the column (which should be left polymorphic in--- 'Rel8able' definitions), and @a@ is the type of the column.-type Column :: K.Context -> Type -> Type-type family Column context a where-  Column Result  a = a-  Column context a = context a---data TColumn :: K.Context -> Type -> Exp Type-type instance Eval (TColumn f a) = Column f a
− src/Rel8/Column/ADT.hs 
@@ -1,23 +0,0 @@-{-# language DataKinds #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}--module Rel8.Column.ADT-  ( HADT-  )-where---- base-import Data.Kind ( Type )-import Prelude ()---- rel8-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Result ( Result )-import Rel8.Table.ADT ( ADT )---type HADT :: K.Context -> K.Rel8able -> Type-type family HADT context t where-  HADT Result t = t Result-  HADT context t = ADT t context
− src/Rel8/Column/Either.hs 
@@ -1,26 +0,0 @@-{-# language DataKinds #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeFamilyDependencies #-}--module Rel8.Column.Either-  ( HEither-  )-where---- base-import Data.Kind ( Type )-import Prelude---- rel8-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Result ( Result )-import Rel8.Table.Either ( EitherTable )----- | Nest an 'Either' value within a 'Rel8able'. @HEither f a b@ will produce a--- 'EitherTable' @a b@ in the 'Expr' context, and a 'Either' @a b@ in the--- 'Result' context.-type HEither :: K.Context -> Type -> Type -> Type-type family HEither context = either | either -> context where-  HEither Result = Either-  HEither context = EitherTable context
− src/Rel8/Column/Lift.hs 
@@ -1,23 +0,0 @@-{-# language DataKinds #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}--module Rel8.Column.Lift-  ( Lift-  )-where---- base-import Data.Kind ( Type )-import Prelude ()---- rel8-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Result ( Result )-import Rel8.Table.HKD ( HKD )---type Lift :: K.Context -> Type -> Type-type family Lift context a where-  Lift Result a = a-  Lift context a = HKD a context
− src/Rel8/Column/List.hs 
@@ -1,25 +0,0 @@-{-# language DataKinds #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeFamilyDependencies #-}--module Rel8.Column.List-  ( HList-  )-where---- base-import Data.Kind ( Type )-import Prelude ()---- rel8-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Result ( Result )-import Rel8.Table.List ( ListTable )----- | Nest a list within a 'Rel8able'. @HList f a@ will produce a 'ListTable'--- @a@ in the 'Expr' context, and a @[a]@ in the 'Result' context.-type HList :: K.Context -> Type -> Type-type family HList context = list | list -> context where-  HList Result = []-  HList context = ListTable context
− src/Rel8/Column/Maybe.hs 
@@ -1,26 +0,0 @@-{-# language DataKinds #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeFamilyDependencies #-}--module Rel8.Column.Maybe-  ( HMaybe-  )-where---- base-import Data.Kind ( Type )-import Prelude---- rel8-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Result ( Result )-import Rel8.Table.Maybe ( MaybeTable )----- | Nest a 'Maybe' value within a 'Rel8able'. @HMaybe f a@ will produce a--- 'MaybeTable' @a@ in the 'Expr' context, and a 'Maybe' @a@ in the 'Result'--- context.-type HMaybe :: K.Context -> Type -> Type-type family HMaybe context = maybe | maybe -> context where-  HMaybe Result = Maybe-  HMaybe context = MaybeTable context
− src/Rel8/Column/NonEmpty.hs 
@@ -1,27 +0,0 @@-{-# language DataKinds #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeFamilyDependencies #-}--module Rel8.Column.NonEmpty-  ( HNonEmpty-  )-where---- base-import Data.Kind ( Type )-import Data.List.NonEmpty ( NonEmpty )-import Prelude ()---- rel8-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Result ( Result )-import Rel8.Table.NonEmpty ( NonEmptyTable )----- | Nest a 'NonEmpty' list within a 'Rel8able'. @HNonEmpty f a@ will produce a--- 'NonEmptyTable' @a@ in the 'Expr' context, and a 'NonEmpty' @a@ in the--- 'Result' context.-type HNonEmpty :: K.Context -> Type -> Type-type family HNonEmpty context = nonEmpty | nonEmpty -> context where-  HNonEmpty Result = NonEmpty-  HNonEmpty context = NonEmptyTable context
− src/Rel8/Column/These.hs 
@@ -1,29 +0,0 @@-{-# language DataKinds #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeFamilyDependencies #-}--module Rel8.Column.These-  ( HThese-  )-where---- base-import Data.Kind ( Type )-import Prelude ()---- rel8-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Result ( Result )-import Rel8.Table.These ( TheseTable )---- these-import Data.These ( These )----- | Nest an 'These' value within a 'Rel8able'. @HThese f a b@ will produce a--- 'TheseTable' @a b@ in the 'Expr' context, and a 'These' @a b@ in the--- 'Result' context.-type HThese :: K.Context -> Type -> Type -> Type-type family HThese context = these | these -> context where-  HThese Result = These-  HThese context = TheseTable context
+ src/Rel8/Decoder.hs view
@@ -0,0 +1,6 @@+module Rel8.Decoder (+  Decoder (..),+  Parser,+  parseDecoder,+) where+import Rel8.Internal.Type.Decoder
+ src/Rel8/Encoder.hs view
@@ -0,0 +1,4 @@+module Rel8.Encoder (+  Encoder (..),+) where+import Rel8.Internal.Type.Encoder
− src/Rel8/Expr.hs 
@@ -1,125 +0,0 @@-{-# language DataKinds #-}-{-# language DerivingStrategies #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language MultiParamTypeClasses #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}--module Rel8.Expr-  ( Expr(..)-  )-where---- base-import Data.Functor.Identity ( Identity( Identity ) )-import Data.String ( IsString, fromString )-import Prelude hiding ( null )---- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye---- rel8-import Rel8.Expr.Function ( function, nullaryFunction )-import Rel8.Expr.Null ( liftOpNull, nullify )-import Rel8.Expr.Opaleye-  ( castExpr-  , fromPrimExpr-  , mapPrimExpr-  , zipPrimExprsWith-  )-import Rel8.Expr.Serialize ( litExpr )-import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )-import Rel8.Table-  ( Table, Columns, Context, fromColumns, toColumns-  , FromExprs, fromResult, toResult-  , Transpose-  )-import Rel8.Type ( DBType )-import Rel8.Type.Monoid ( DBMonoid, memptyExpr )-import Rel8.Type.Num ( DBFloating, DBFractional, DBNum )-import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )----- | Typed SQL expressions.-type Expr :: K.Context-newtype Expr a = Expr Opaleye.PrimExpr-  deriving stock Show---instance Sql DBSemigroup a => Semigroup (Expr a) where-  (<>) = case nullable @a of-    Null -> liftOpNull (<>.)-    NotNull -> (<>.)-  {-# INLINABLE (<>) #-}---instance Sql DBMonoid a => Monoid (Expr a) where-  mempty = case nullable @a of-    Null -> nullify memptyExpr-    NotNull -> memptyExpr-  {-# INLINABLE mempty #-}---instance (Sql IsString a, Sql DBType a) => IsString (Expr a) where-  fromString = litExpr . case nullable @a of-    Null -> Just . fromString-    NotNull -> fromString---instance Sql DBNum a => Num (Expr a) where-  (+) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:+))-  (*) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:*))-  (-) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:-))--  abs = mapPrimExpr (Opaleye.UnExpr Opaleye.OpAbs)-  negate = mapPrimExpr (Opaleye.UnExpr Opaleye.OpNegate)--  signum = castExpr . mapPrimExpr (Opaleye.UnExpr (Opaleye.UnOpOther "SIGN"))--  fromInteger = castExpr . fromPrimExpr . Opaleye.ConstExpr . Opaleye.IntegerLit---instance Sql DBFractional a => Fractional (Expr a) where-  (/) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:/))--  fromRational =-    castExpr . Expr . Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac---instance Sql DBFloating a => Floating (Expr a) where-  pi = nullaryFunction "PI"-  exp = function "exp"-  log = function "ln"-  sqrt = function "sqrt"-  (**) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:^))-  logBase = function "log"-  sin = function "sin"-  cos = function "cos"-  tan = function "tan"-  asin = function "asin"-  acos = function "acos"-  atan = function "atan"-  sinh = function "sinh"-  cosh = function "cosh"-  tanh = function "tanh"-  asinh = function "asinh"-  acosh = function "acosh"-  atanh = function "atanh"---instance Sql DBType a => Table Expr (Expr a) where-  type Columns (Expr a) = HIdentity a-  type Context (Expr a) = Expr-  type FromExprs (Expr a) = a-  type Transpose to (Expr a) = to a--  toColumns a = HIdentity a-  fromColumns (HIdentity a) = a-  toResult a = HIdentity (Identity a)-  fromResult (HIdentity (Identity a)) = a
− src/Rel8/Expr.hs-boot 
@@ -1,20 +0,0 @@-{-# language DataKinds #-}-{-# language StandaloneKindSignatures #-}--module Rel8.Expr-  ( Expr(..)-  )-where---- base-import Prelude ()---- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye---- rel8-import Rel8.Schema.Kind ( Context )---type Expr :: Context-newtype Expr a = Expr Opaleye.PrimExpr
− src/Rel8/Expr/Aggregate.hs 
@@ -1,189 +0,0 @@-{-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language ScopedTypeVariables #-}-{-# language TypeFamilies #-}--{-# options_ghc -fno-warn-redundant-constraints #-}--module Rel8.Expr.Aggregate-  ( count, countDistinct, countStar, countWhere-  , and, or-  , min, max-  , sum, sumWhere-  , stringAgg-  , groupByExpr-  , listAggExpr, nonEmptyAggExpr-  , slistAggExpr, snonEmptyAggExpr-  )-where---- base-import Data.Int ( Int64 )-import Data.List.NonEmpty ( NonEmpty )-import Prelude hiding ( and, max, min, null, or, sum )---- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye---- rel8-import Rel8.Aggregate ( Aggregate, Aggregator(..), unsafeMakeAggregate )-import Rel8.Expr ( Expr )-import Rel8.Expr.Bool ( caseExpr )-import Rel8.Expr.Opaleye-  ( castExpr-  , fromPrimExpr-  , fromPrimExpr-  , toPrimExpr-  )-import Rel8.Expr.Null ( null )-import Rel8.Expr.Serialize ( litExpr )-import Rel8.Schema.Null ( Sql, Unnullify )-import Rel8.Type ( DBType, typeInformation )-import Rel8.Type.Array ( encodeArrayElement )-import Rel8.Type.Eq ( DBEq )-import Rel8.Type.Information ( TypeInformation )-import Rel8.Type.Num ( DBNum )-import Rel8.Type.Ord ( DBMax, DBMin )-import Rel8.Type.String ( DBString )-import Rel8.Type.Sum ( DBSum )----- | Count the occurances of a single column. Corresponds to @COUNT(a)@-count :: Expr a -> Aggregate Int64-count = unsafeMakeAggregate toPrimExpr fromPrimExpr $-  Just Aggregator-    { operation = Opaleye.AggrCount-    , ordering = []-    , distinction = Opaleye.AggrAll-    }----- | Count the number of distinct occurances of a single column. Corresponds to--- @COUNT(DISTINCT a)@-countDistinct :: Sql DBEq a => Expr a -> Aggregate Int64-countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $-  Just Aggregator-    { operation = Opaleye.AggrCount-    , ordering = []-    , distinction = Opaleye.AggrDistinct-    }----- | Corresponds to @COUNT(*)@.-countStar :: Aggregate Int64-countStar = count (litExpr True)----- | A count of the number of times a given expression is @true@.-countWhere :: Expr Bool -> Aggregate Int64-countWhere condition = count (caseExpr [(condition, litExpr (Just True))] null)----- | Corresponds to @bool_and@.-and :: Expr Bool -> Aggregate Bool-and = unsafeMakeAggregate toPrimExpr fromPrimExpr $-  Just Aggregator-    { operation = Opaleye.AggrBoolAnd-    , ordering = []-    , distinction = Opaleye.AggrAll-    }----- | Corresponds to @bool_or@.-or :: Expr Bool -> Aggregate Bool-or = unsafeMakeAggregate toPrimExpr fromPrimExpr $-  Just Aggregator-    { operation = Opaleye.AggrBoolOr-    , ordering = []-    , distinction = Opaleye.AggrAll-    }----- | Produce an aggregation for @Expr a@ using the @max@ function.-max :: Sql DBMax a => Expr a -> Aggregate a-max = unsafeMakeAggregate toPrimExpr fromPrimExpr $-  Just Aggregator-    { operation = Opaleye.AggrMax-    , ordering = []-    , distinction = Opaleye.AggrAll-    }----- | Produce an aggregation for @Expr a@ using the @max@ function.-min :: Sql DBMin a => Expr a -> Aggregate a-min = unsafeMakeAggregate toPrimExpr fromPrimExpr $-  Just Aggregator-    { operation = Opaleye.AggrMin-    , ordering = []-    , distinction = Opaleye.AggrAll-    }---- | Corresponds to @sum@. Note that in SQL, @sum@ is type changing - for--- example the @sum@ of @integer@ returns a @bigint@. Rel8 doesn't support--- this, and will add explicit cast back to the original input type. This can--- lead to overflows, and if you anticipate very large sums, you should upcast--- your input.-sum :: Sql DBSum a => Expr a -> Aggregate a-sum = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $-  Just Aggregator-    { operation = Opaleye.AggrSum-    , ordering = []-    , distinction = Opaleye.AggrAll-    }----- | Take the sum of all expressions that satisfy a predicate.-sumWhere :: (Sql DBNum a, Sql DBSum a)-  => Expr Bool -> Expr a -> Aggregate a-sumWhere condition a = sum (caseExpr [(condition, a)] 0)----- | Corresponds to @string_agg()@.-stringAgg :: Sql DBString a-  => Expr db -> Expr a -> Aggregate a-stringAgg delimiter =-  unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $-    Just Aggregator-      { operation = Opaleye.AggrStringAggr (toPrimExpr delimiter)-      , ordering = []-      , distinction = Opaleye.AggrAll-      }----- | Aggregate a value by grouping by it.-groupByExpr :: Sql DBEq a => Expr a -> Aggregate a-groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Nothing----- | Collect expressions values as a list.-listAggExpr :: Sql DBType a => Expr a -> Aggregate [a]-listAggExpr = slistAggExpr typeInformation----- | Collect expressions values as a non-empty list.-nonEmptyAggExpr :: Sql DBType a => Expr a -> Aggregate (NonEmpty a)-nonEmptyAggExpr = snonEmptyAggExpr typeInformation---slistAggExpr :: ()-  => TypeInformation (Unnullify a) -> Expr a -> Aggregate [a]-slistAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just-  Aggregator-    { operation = Opaleye.AggrArr-    , ordering = []-    , distinction = Opaleye.AggrAll-    }-  where-    to = encodeArrayElement info . toPrimExpr---snonEmptyAggExpr :: ()-  => TypeInformation (Unnullify a) -> Expr a -> Aggregate (NonEmpty a)-snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just-  Aggregator-    { operation = Opaleye.AggrArr-    , ordering = []-    , distinction = Opaleye.AggrAll-    }-  where-    to = encodeArrayElement info . toPrimExpr
− src/Rel8/Expr/Array.hs 
@@ -1,58 +0,0 @@-{-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language TypeFamilies #-}--{-# options_ghc -fno-warn-redundant-constraints #-}--module Rel8.Expr.Array-  ( listOf, nonEmptyOf-  , slistOf, snonEmptyOf-  , sappend, sappend1, sempty-  )-where---- base-import Data.List.NonEmpty ( NonEmpty )-import Prelude---- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye---- rel8-import {-# SOURCE #-} Rel8.Expr ( Expr )-import Rel8.Expr.Opaleye-  ( fromPrimExpr, toPrimExpr-  , zipPrimExprsWith-  )-import Rel8.Type ( DBType, typeInformation )-import Rel8.Type.Array ( array )-import Rel8.Type.Information ( TypeInformation(..) )-import Rel8.Schema.Null ( Unnullify, Sql )---sappend :: Expr [a] -> Expr [a] -> Expr [a]-sappend = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))---sappend1 :: Expr (NonEmpty a) -> Expr (NonEmpty a) -> Expr (NonEmpty a)-sappend1 = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))---sempty :: TypeInformation (Unnullify a) -> Expr [a]-sempty info = fromPrimExpr $ array info []---slistOf :: TypeInformation (Unnullify a) -> [Expr a] -> Expr [a]-slistOf info = fromPrimExpr . array info . fmap toPrimExpr---snonEmptyOf :: TypeInformation (Unnullify a) -> NonEmpty (Expr a) -> Expr (NonEmpty a)-snonEmptyOf info = fromPrimExpr . array info . fmap toPrimExpr---listOf :: Sql DBType a => [Expr a] -> Expr [a]-listOf = slistOf typeInformation---nonEmptyOf :: Sql DBType a => NonEmpty (Expr a) -> Expr (NonEmpty a)-nonEmptyOf = snonEmptyOf typeInformation
− src/Rel8/Expr/Bool.hs 
@@ -1,90 +0,0 @@-{-# language GADTs #-}--module Rel8.Expr.Bool-  ( false, true-  , (&&.), (||.), not_-  , and_, or_-  , boolExpr-  , caseExpr-  , coalesce-  )-where---- base-import Data.Foldable ( foldl' )-import Prelude hiding ( null )---- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye---- rel8-import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )-import Rel8.Expr.Opaleye ( mapPrimExpr, toPrimExpr, zipPrimExprsWith )-import Rel8.Expr.Serialize ( litExpr )----- | The SQL @false@ literal.-false :: Expr Bool-false = litExpr False----- | The SQL @true@ literal.-true :: Expr Bool-true = litExpr True----- | The SQL @AND@ operator.-(&&.) :: Expr Bool -> Expr Bool -> Expr Bool-(&&.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpAnd)-infixr 3 &&.----- | The SQL @OR@ operator.-(||.) :: Expr Bool -> Expr Bool -> Expr Bool-(||.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpOr)-infixr 2 ||.----- | The SQL @NOT@ operator.-not_ :: Expr Bool -> Expr Bool-not_ = mapPrimExpr (Opaleye.UnExpr Opaleye.OpNot)----- | Fold @AND@ over a collection of expressions.-and_ :: Foldable f => f (Expr Bool) -> Expr Bool-and_ = foldl' (&&.) true----- | Fold @OR@ over a collection of expressions.-or_ :: Foldable f => f (Expr Bool) -> Expr Bool-or_ = foldl' (||.) false----- | Eliminate a boolean-valued expression.------ Corresponds to 'Data.Bool.bool'.-boolExpr :: Expr a -> Expr a -> Expr Bool -> Expr a-boolExpr ifFalse ifTrue condition = caseExpr [(condition, ifTrue)] ifFalse----- | A multi-way if/then/else statement. The first argument to @caseExpr@ is a--- list of alternatives. The first alternative that is of the form @(true, x)@--- will be returned. If no such alternative is found, a fallback expression is--- returned.------ Corresponds to a @CASE@ expression in SQL.-caseExpr :: [(Expr Bool, Expr a)] -> Expr a -> Expr a-caseExpr branches (Expr fallback) =-  Expr $ Opaleye.CaseExpr (map go branches) fallback-  where-    go (condition, value) = (toPrimExpr condition, toPrimExpr value)----- | Convert a @Expr (Maybe Bool)@ to a @Expr Bool@ by treating @Nothing@ as--- @False@. This can be useful when combined with 'Rel8.where_', which expects--- a @Bool@, and produces expressions that optimize better than general case--- analysis.-coalesce :: Expr (Maybe Bool) -> Expr Bool-coalesce (Expr a) = Expr a &&. Expr (Opaleye.FunExpr "COALESCE" [a, untrue])-  where-    untrue = Opaleye.ConstExpr (Opaleye.BoolLit False)
− src/Rel8/Expr/Default.hs 
@@ -1,35 +0,0 @@-module Rel8.Expr.Default-  ( unsafeDefault-  )-where---- base-import Prelude ()---- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye---- rel8-import Rel8.Expr ( Expr )-import Rel8.Expr.Opaleye ( fromPrimExpr )----- | Corresponds to the SQL @DEFAULT@ expression.------ This 'Expr' is unsafe for numerous reasons, and should be used with care:------ 1. This 'Expr' only makes sense in an @INSERT@ or @UPDATE@ statement.------ 2. Rel8 is not able to verify that a particular column actually has a--- @DEFAULT@ value. Trying to use @unsafeDefault@ where there is no default--- will cause a runtime crash------ 3. @DEFAULT@ values can not be transformed. For example, the innocuous Rel8--- code @unsafeDefault + 1@ will crash, despite type checking.------ Given all these caveats, we suggest avoiding the use of default values where--- possible, instead being explicit. A common scenario where default values are--- used is with auto-incrementing identifier columns. In this case, we suggest--- using 'Rel8.nextval' instead.-unsafeDefault :: Expr a-unsafeDefault = fromPrimExpr Opaleye.DefaultInsertExpr
− src/Rel8/Expr/Eq.hs 
@@ -1,101 +0,0 @@-{-# language FlexibleContexts #-}-{-# language GADTs #-}-{-# language ScopedTypeVariables #-}-{-# language TypeApplications #-}-{-# language ViewPatterns #-}--{-# options_ghc -fno-warn-redundant-constraints #-}--module Rel8.Expr.Eq-  ( (==.), (/=.)-  , (==?), (/=?)-  , in_-  )-where---- base-import Data.Foldable ( toList )-import Data.List.NonEmpty ( nonEmpty )-import Prelude---- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye---- rel8-import Rel8.Expr ( Expr )-import Rel8.Expr.Bool ( (&&.), (||.), false, or_, coalesce )-import Rel8.Expr.Null ( isNull, unsafeLiftOpNull )-import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr, zipPrimExprsWith )-import Rel8.Schema.Null ( Nullity( NotNull, Null ), Sql, nullable )-import Rel8.Type.Eq ( DBEq )---eq :: DBEq a => Expr a -> Expr a -> Expr Bool-eq = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:==))---ne :: DBEq a => Expr a -> Expr a -> Expr Bool-ne = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:<>))----- | Compare two expressions for equality. ------ This corresponds to the SQL @IS NOT DISTINCT FROM@ operator, and will equate--- @null@ values as @true@. This differs from @=@ which would return @null@.--- This operator matches Haskell's '==' operator. For an operator identical to--- SQL @=@, see '==?'.-(==.) :: forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool-(==.) = case nullable @a of-  Null -> \ma mb -> isNull ma &&. isNull mb ||. ma ==? mb-  NotNull -> eq-infix 4 ==.-{-# INLINABLE (==.) #-}----- | Test if two expressions are different (not equal).------ This corresponds to the SQL @IS DISTINCT FROM@ operator, and will return--- @false@ when comparing two @null@ values. This differs from ordinary @=@--- which would return @null@. This operator is closer to Haskell's '=='--- operator. For an operator identical to SQL @=@, see '/=?'.-(/=.) :: forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool-(/=.) = case nullable @a of-  Null -> \ma mb -> isNull ma `ne` isNull mb ||. ma /=? mb-  NotNull -> ne-infix 4 /=.-{-# INLINABLE (/=.) #-}----- | Test if two expressions are equal. This operator is usually the best--- choice when forming join conditions, as PostgreSQL has a much harder time--- optimizing a join that has multiple 'True' conditions.------ This corresponds to the SQL @=@ operator, though it will always return a--- 'Bool'.-(==?) :: DBEq a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool-a ==? b = coalesce $ unsafeLiftOpNull eq a b-infix 4 ==?----- | Test if two expressions are different. ------ This corresponds to the SQL @<>@ operator, though it will always return a--- 'Bool'.-(/=?) :: DBEq a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool-a /=? b = coalesce $ unsafeLiftOpNull ne a b-infix 4 /=?----- | Like the SQL @IN@ operator, but implemented by folding over a list with--- '==.' and '||.'.-in_ :: forall a f. (Sql DBEq a, Foldable f)-  => Expr a -> f (Expr a) -> Expr Bool-in_ a (toList -> as) = case nullable @a of-  Null -> or_ $ map (a ==.) as-  NotNull -> case nonEmpty as of-     Nothing -> false-     Just xs ->-       fromPrimExpr $-         Opaleye.BinExpr Opaleye.OpIn-           (toPrimExpr a)-           (Opaleye.ListExpr (toPrimExpr <$> xs))
− src/Rel8/Expr/Function.hs 
@@ -1,63 +0,0 @@-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language MultiParamTypeClasses #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}--module Rel8.Expr.Function-  ( Function, function-  , nullaryFunction-  , binaryOperator-  )-where---- base-import Data.Kind ( Constraint, Type )-import Prelude---- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye---- rel8-import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )-import Rel8.Expr.Opaleye-  ( castExpr-  , fromPrimExpr, toPrimExpr, zipPrimExprsWith-  )-import Rel8.Schema.Null ( Sql )-import Rel8.Type ( DBType )----- | This type class exists to allow 'function' to have arbitrary arity. It's--- mostly an implementation detail, and typical uses of 'Function' shouldn't--- need this to be specified.-type Function :: Type -> Type -> Constraint-class Function arg res where-  applyArgument :: ([Opaleye.PrimExpr] -> Opaleye.PrimExpr) -> arg -> res---instance (arg ~ Expr a, Sql DBType b) => Function arg (Expr b) where-  applyArgument f a = castExpr $ fromPrimExpr $ f [toPrimExpr a]---instance (arg ~ Expr a, Function args res) => Function arg (args -> res) where-  applyArgument f a = applyArgument (f . (toPrimExpr a :))----- | Construct an n-ary function that produces an 'Expr' that when called runs--- a SQL function.-function :: Function args result => String -> args -> result-function = applyArgument . Opaleye.FunExpr----- | Construct a function call for functions with no arguments.-nullaryFunction :: Sql DBType a => String -> Expr a-nullaryFunction name = castExpr $ Expr (Opaleye.FunExpr name [])----- | Construct an expression by applying an infix binary operator to two--- operands.-binaryOperator :: Sql DBType c => String -> Expr a -> Expr b -> Expr c-binaryOperator operator a b =-  castExpr $ zipPrimExprsWith (Opaleye.BinExpr (Opaleye.OpOther operator)) a b
− src/Rel8/Expr/Null.hs 
@@ -1,102 +0,0 @@-{-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language TypeFamilies #-}--{-# options -fno-warn-redundant-constraints #-}--module Rel8.Expr.Null-  ( null, snull, nullableExpr, nullableOf-  , isNull, isNonNull-  , nullify, unsafeUnnullify-  , mapNull, liftOpNull-  , unsafeMapNull, unsafeLiftOpNull-  )-where---- base-import Prelude hiding ( null )---- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye---- rel8-import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )-import Rel8.Expr.Bool ( (||.), boolExpr )-import Rel8.Expr.Opaleye ( scastExpr, mapPrimExpr )-import Rel8.Schema.Null ( NotNull )-import Rel8.Type ( DBType, typeInformation )-import Rel8.Type.Information ( TypeInformation )----- | Lift an expression that can't be @null@ to a type that might be @null@.--- This is an identity operation in terms of any generated query, and just--- modifies the query's type.-nullify :: NotNull a => Expr a -> Expr (Maybe a)-nullify (Expr a) = Expr a---unsafeUnnullify :: Expr (Maybe a) -> Expr a-unsafeUnnullify (Expr a) = Expr a----- | Like 'maybe', but to eliminate @null@.-nullableExpr :: Expr b -> (Expr a -> Expr b) -> Expr (Maybe a) -> Expr b-nullableExpr b f ma = boolExpr (f (unsafeUnnullify ma)) b (isNull ma)---nullableOf :: DBType a => Maybe (Expr a) -> Expr (Maybe a)-nullableOf = maybe null nullify----- | Like 'Data.Maybe.isNothing', but for @null@.-isNull :: Expr (Maybe a) -> Expr Bool-isNull = mapPrimExpr (Opaleye.UnExpr Opaleye.OpIsNull)----- | Like 'Data.Maybe.isJust', but for @null@.-isNonNull :: Expr (Maybe a) -> Expr Bool-isNonNull = mapPrimExpr (Opaleye.UnExpr Opaleye.OpIsNotNull)----- | Lift an operation on non-@null@ values to an operation on possibly @null@--- values. When given @null@, @mapNull f@ returns @null@.--- --- This is like 'fmap' for 'Maybe'.-mapNull :: DBType b-  => (Expr a -> Expr b) -> Expr (Maybe a) -> Expr (Maybe b)-mapNull f ma = boolExpr (unsafeMapNull f ma) null (isNull ma)----- | Lift a binary operation on non-@null@ expressions to an equivalent binary--- operator on possibly @null@ expressions. If either of the final arguments--- are @null@, @liftOpNull@ returns @null@.------ This is like 'liftA2' for 'Maybe'.-liftOpNull :: DBType c-  => (Expr a -> Expr b -> Expr c)-  -> Expr (Maybe a) -> Expr (Maybe b) -> Expr (Maybe c)-liftOpNull f ma mb =-  boolExpr (unsafeLiftOpNull f ma mb) null-    (isNull ma ||. isNull mb)-{-# INLINABLE liftOpNull #-}---snull :: TypeInformation a -> Expr (Maybe a)-snull info = scastExpr info $ Expr $ Opaleye.ConstExpr Opaleye.NullLit----- | Corresponds to SQL @null@.-null :: DBType a => Expr (Maybe a)-null = snull typeInformation---unsafeMapNull :: NotNull b-  => (Expr a -> Expr b) -> Expr (Maybe a) -> Expr (Maybe b)-unsafeMapNull f ma = nullify (f (unsafeUnnullify ma))---unsafeLiftOpNull :: NotNull c-  => (Expr a -> Expr b -> Expr c)-  -> Expr (Maybe a) -> Expr (Maybe b) -> Expr (Maybe c)-unsafeLiftOpNull f ma mb =-  nullify (f (unsafeUnnullify ma) (unsafeUnnullify mb))
src/Rel8/Expr/Num.hs view
@@ -1,22 +1,29 @@ {-# language FlexibleContexts #-}+{-# language OverloadedStrings #-} {-# language TypeFamilies #-}  {-# options_ghc -fno-warn-redundant-constraints #-}  module Rel8.Expr.Num-  ( fromIntegral, realToFrac, div, mod, ceiling, floor, round, truncate+  ( fromIntegral+  , realToFrac+  , div, mod, divMod+  , quot, rem, quotRem+  , ceiling, floor, round, truncate   ) where  -- base-import Prelude ()+import Prelude ( (+), (-), fst, negate, signum, snd )  -- rel-import Rel8.Expr ( Expr( Expr ) )-import Rel8.Expr.Function ( function )-import Rel8.Expr.Opaleye ( castExpr )-import Rel8.Schema.Null ( Homonullable, Sql )-import Rel8.Type.Num ( DBFractional, DBIntegral, DBNum )+import Rel8.Internal.Expr ( Expr( Expr ) )+import Rel8.Internal.Expr.Eq ( (==.) )+import Rel8.Internal.Expr.Function (function)+import Rel8.Internal.Expr.Opaleye ( castExpr )+import Rel8.Internal.Schema.Null ( Homonullable, Sql )+import Rel8.Internal.Table.Bool ( bool )+import Rel8.Internal.Type.Num ( DBFractional, DBIntegral, DBNum )   -- | Cast 'DBIntegral' types to 'DBNum' types. For example, this can be useful@@ -26,7 +33,7 @@ fromIntegral (Expr a) = castExpr (Expr a)  --- | Cast 'DBNum' types to 'DBFractional' types. For example, his can be useful+-- | Cast 'DBNum' types to 'DBFractional' types. For example, this can be useful -- to convert @Expr Float@ to @Expr Double@. realToFrac :: (Sql DBNum a, Sql DBFractional b, Homonullable a b)   => Expr a -> Expr b@@ -42,14 +49,41 @@ ceiling = function "ceiling"  --- | Perform integral division. Corresponds to the @div()@ function.+-- | Emulates the behaviour of the Haskell function 'Prelude.div' in+-- PostgreSQL. div :: Sql DBIntegral a => Expr a -> Expr a -> Expr a-div = function "div"+div n d = fst (divMod n d)  --- | Corresponds to the @mod()@ function.+-- | Emulates the behaviour of the Haskell function 'Prelude.mod' in+-- PostgreSQL. mod :: Sql DBIntegral a => Expr a -> Expr a -> Expr a-mod = function "mod"+mod n d = snd (divMod n d)+++-- | Simultaneous 'div' and 'mod'.+divMod :: Sql DBIntegral a => Expr a -> Expr a -> (Expr a, Expr a)+divMod n d = bool qr (q - 1, r + d) (signum r ==. negate (signum d))+  where+    qr@(q, r) = quotRem n d+++-- | Perform integral division. Corresponds to the @div()@ function in+-- PostgreSQL, which behaves like Haskell's 'Prelude.quot' rather than+-- 'Prelude.div'.+quot :: Sql DBIntegral a => Expr a -> Expr a -> Expr a+quot n d = function "div" (n, d)+++-- | Corresponds to the @mod()@ function in PostgreSQL, which behaves like+-- Haskell's 'Prelude.rem' rather than 'Prelude.mod'.+rem :: Sql DBIntegral a => Expr a -> Expr a -> Expr a+rem n d = function "mod" (n, d)+++-- | Simultaneous 'quot' and 'rem'.+quotRem :: Sql DBIntegral a => Expr a -> Expr a -> (Expr a, Expr a)+quotRem n d = (quot n d, rem n d)   -- | Round a 'DFractional' to a 'DBIntegral' by rounding to the nearest smaller
− src/Rel8/Expr/Opaleye.hs 
@@ -1,88 +0,0 @@-{-# language FlexibleContexts #-}-{-# language NamedFieldPuns #-}-{-# language ScopedTypeVariables #-}-{-# language TypeFamilies #-}--{-# options_ghc -fno-warn-redundant-constraints #-}--module Rel8.Expr.Opaleye-  ( castExpr, unsafeCastExpr-  , scastExpr, sunsafeCastExpr-  , unsafeLiteral-  , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith, traversePrimExpr-  , toColumn, fromColumn-  )-where---- base-import Prelude---- opaleye-import qualified Opaleye.Internal.Column as Opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye---- rel8-import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )-import Rel8.Schema.Null ( Unnullify, Sql )-import Rel8.Type ( DBType, typeInformation )-import Rel8.Type.Information ( TypeInformation(..) )---castExpr :: Sql DBType a => Expr a -> Expr a-castExpr = scastExpr typeInformation----- | Cast an expression to a different type. Corresponds to a @CAST()@ function--- call.-unsafeCastExpr :: Sql DBType b => Expr a -> Expr b-unsafeCastExpr = sunsafeCastExpr typeInformation---scastExpr :: TypeInformation (Unnullify a) -> Expr a -> Expr a-scastExpr = sunsafeCastExpr---sunsafeCastExpr :: ()-  => TypeInformation (Unnullify b) -> Expr a -> Expr b-sunsafeCastExpr TypeInformation {typeName} =-  fromPrimExpr . Opaleye.CastExpr typeName . toPrimExpr----- | Unsafely construct an expression from literal SQL.------ This is an escape hatch, and can be used if Rel8 can not adequately express--- the query you need. If you find yourself using this function, please let us--- know, as it may indicate that something is missing from Rel8!-unsafeLiteral :: String -> Expr a-unsafeLiteral = Expr . Opaleye.ConstExpr . Opaleye.OtherLit---fromPrimExpr :: Opaleye.PrimExpr -> Expr a-fromPrimExpr = Expr---toPrimExpr :: Expr a -> Opaleye.PrimExpr-toPrimExpr (Expr a) = a---mapPrimExpr :: (Opaleye.PrimExpr -> Opaleye.PrimExpr) -> Expr a -> Expr b-mapPrimExpr f = fromPrimExpr . f . toPrimExpr---zipPrimExprsWith :: ()-  => (Opaleye.PrimExpr -> Opaleye.PrimExpr -> Opaleye.PrimExpr)-  -> Expr a -> Expr b -> Expr c-zipPrimExprsWith f a b = fromPrimExpr (f (toPrimExpr a) (toPrimExpr b))---traversePrimExpr :: Functor f-  => (Opaleye.PrimExpr -> f Opaleye.PrimExpr) -> Expr a -> f (Expr b)-traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr---toColumn :: Opaleye.PrimExpr -> Opaleye.Column b-toColumn = Opaleye.Column---fromColumn :: Opaleye.Column b -> Opaleye.PrimExpr-fromColumn (Opaleye.Column a) = a
− src/Rel8/Expr/Ord.hs 
@@ -1,137 +0,0 @@-{-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language GADTs #-}-{-# language ScopedTypeVariables #-}-{-# language TypeApplications #-}--{-# options_ghc -fno-warn-redundant-constraints #-}--module Rel8.Expr.Ord-  ( (<.), (<=.), (>.), (>=.)-  , (<?), (<=?), (>?), (>=?)-  , leastExpr, greatestExpr-  )-where---- base-import Prelude---- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye---- rel8-import Rel8.Expr ( Expr( Expr ) )-import Rel8.Expr.Bool ( (&&.), (||.), coalesce )-import Rel8.Expr.Null ( isNull, isNonNull, nullableExpr, unsafeLiftOpNull )-import Rel8.Expr.Opaleye ( toPrimExpr, zipPrimExprsWith )-import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )-import Rel8.Type.Ord ( DBOrd )---lt :: DBOrd a => Expr a -> Expr a -> Expr Bool-lt = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:<))---le :: DBOrd a => Expr a -> Expr a -> Expr Bool-le = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:<=))---gt :: DBOrd a => Expr a -> Expr a -> Expr Bool-gt = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:>))---ge :: DBOrd a => Expr a -> Expr a -> Expr Bool-ge = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:>=))----- | Corresponds to the SQL @<@ operator. Note that this differs from SQL @<@--- as @null@ will sort below any other value. For a version of @<@ that exactly--- matches SQL, see '(<?)'.-(<.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool-(<.) = case nullable @a of-  Null -> \ma mb -> isNull ma &&. isNonNull mb ||. ma <? mb-  NotNull -> lt-infix 4 <.----- | Corresponds to the SQL @<=@ operator. Note that this differs from SQL @<=@--- as @null@ will sort below any other value. For a version of @<=@ that exactly--- matches SQL, see '(<=?)'.-(<=.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool-(<=.) = case nullable @a of-  Null -> \ma mb -> isNull ma ||. ma <=? mb-  NotNull -> le-infix 4 <=.----- | Corresponds to the SQL @>@ operator. Note that this differs from SQL @>@--- as @null@ will sort below any other value. For a version of @>@ that exactly--- matches SQL, see '(>?)'.-(>.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool-(>.) = case nullable @a of-  Null -> \ma mb -> isNonNull ma &&. isNull mb ||. ma >? mb-  NotNull -> gt-infix 4 >.----- | Corresponds to the SQL @>=@ operator. Note that this differs from SQL @>@--- as @null@ will sort below any other value. For a version of @>=@ that--- exactly matches SQL, see '(>=?)'.-(>=.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool-(>=.) = case nullable @a of-  Null -> \ma mb -> isNull mb ||. ma >=? mb-  NotNull -> ge-infix 4 >=.----- | Corresponds to the SQL @<@ operator. Returns @null@ if either arguments--- are @null@.-(<?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool-a <? b = coalesce $ unsafeLiftOpNull lt a b-infix 4 <?----- | Corresponds to the SQL @<=@ operator. Returns @null@ if either arguments--- are @null@.-(<=?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool-a <=? b = coalesce $ unsafeLiftOpNull le a b-infix 4 <=?----- | Corresponds to the SQL @>@ operator. Returns @null@ if either arguments--- are @null@.-(>?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool-a >? b = coalesce $ unsafeLiftOpNull gt a b-infix 4 >?----- | Corresponds to the SQL @>=@ operator. Returns @null@ if either arguments--- are @null@.-(>=?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool-a >=? b = coalesce $ unsafeLiftOpNull ge a b-infix 4 >=?----- | Given two expressions, return the expression that sorts less than the--- other.--- --- Corresponds to the SQL @least()@ function.-leastExpr :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr a-leastExpr ma mb = case nullable @a of-  Null -> nullableExpr ma (\a -> nullableExpr mb (least_ a) mb) ma-  NotNull -> least_ ma mb-  where-    least_ a b = Expr (Opaleye.FunExpr "LEAST" [toPrimExpr a, toPrimExpr b])----- | Given two expressions, return the expression that sorts greater than the--- other.--- --- Corresponds to the SQL @greatest()@ function.-greatestExpr :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr a-greatestExpr ma mb = case nullable @a of-  Null -> nullableExpr mb (\a -> nullableExpr ma (greatest_ a) mb) ma-  NotNull -> greatest_ ma mb-  where-    greatest_ a b =-      Expr (Opaleye.FunExpr "GREATEST" [toPrimExpr a, toPrimExpr b])
− src/Rel8/Expr/Order.hs 
@@ -1,69 +0,0 @@-{-# language DataKinds #-}--{-# options_ghc -fno-warn-redundant-constraints #-}--module Rel8.Expr.Order-  ( asc-  , desc-  , nullsFirst-  , nullsLast-  )-where---- base-import Data.Bifunctor ( first )-import Prelude---- opaleye-import Opaleye.Internal.HaskellDB.PrimQuery ( OrderOp( orderDirection, orderNulls ) )-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye-import qualified Opaleye.Internal.Order as Opaleye---- rel8-import Rel8.Expr ( Expr )-import Rel8.Expr.Null ( unsafeUnnullify )-import Rel8.Expr.Opaleye ( toPrimExpr )-import Rel8.Order ( Order( Order ) )-import Rel8.Type.Ord ( DBOrd )----- | Sort a column in ascending order.-asc :: DBOrd a => Order (Expr a)-asc = Order $ Opaleye.Order (\expr -> [(orderOp, toPrimExpr expr)])-  where-    orderOp :: Opaleye.OrderOp-    orderOp = Opaleye.OrderOp-      { orderDirection = Opaleye.OpAsc-      , orderNulls = Opaleye.NullsLast-      }----- | Sort a column in descending order.-desc :: DBOrd a => Order (Expr a)-desc = Order $ Opaleye.Order (\expr -> [(orderOp, toPrimExpr expr)])-  where-    orderOp :: Opaleye.OrderOp-    orderOp = Opaleye.OrderOp-      { orderDirection = Opaleye.OpDesc-      , orderNulls = Opaleye.NullsFirst-      }----- | Transform an ordering so that @null@ values appear first. This corresponds--- to @NULLS FIRST@ in SQL.-nullsFirst :: Order (Expr a) -> Order (Expr (Maybe a))-nullsFirst (Order (Opaleye.Order f)) =-  Order $ Opaleye.Order $ fmap (first g) . f . unsafeUnnullify-  where-    g :: Opaleye.OrderOp -> Opaleye.OrderOp-    g orderOp = orderOp { Opaleye.orderNulls = Opaleye.NullsFirst }----- | Transform an ordering so that @null@ values appear first. This corresponds--- to @NULLS LAST@ in SQL.-nullsLast :: Order (Expr a) -> Order (Expr (Maybe a))-nullsLast (Order (Opaleye.Order f)) =-  Order $ Opaleye.Order $ fmap (first g) . f . unsafeUnnullify-  where-    g :: Opaleye.OrderOp -> Opaleye.OrderOp-    g orderOp = orderOp { Opaleye.orderNulls = Opaleye.NullsLast }
− src/Rel8/Expr/Sequence.hs 
@@ -1,21 +0,0 @@-module Rel8.Expr.Sequence-  ( nextval-  )-where---- base-import Data.Int ( Int64 )-import Prelude---- rel8-import Rel8.Expr ( Expr )-import Rel8.Expr.Function ( function )-import Rel8.Expr.Serialize ( litExpr )---- text-import Data.Text ( pack )----- | See https://www.postgresql.org/docs/current/functions-sequence.html-nextval :: String -> Expr Int64-nextval = function "nextval" . litExpr . pack
− src/Rel8/Expr/Serialize.hs 
@@ -1,49 +0,0 @@-{-# language FlexibleContexts #-}-{-# language NamedFieldPuns #-}-{-# language TypeFamilies #-}--module Rel8.Expr.Serialize-  ( litExpr-  , slitExpr-  , sparseValue-  )-where---- base-import Prelude---- hasql-import qualified Hasql.Decoders as Hasql---- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye---- rel8-import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )-import Rel8.Expr.Opaleye ( scastExpr )-import Rel8.Schema.Null ( Unnullify, Nullity( Null, NotNull ), Sql, nullable )-import Rel8.Type ( DBType, typeInformation )-import Rel8.Type.Information ( TypeInformation(..) )----- | Produce an expression from a literal.------ Note that you can usually use 'Rel8.lit', but @litExpr@ can solve problems--- of inference in polymorphic code.-litExpr :: Sql DBType a => a -> Expr a-litExpr = slitExpr nullable typeInformation---slitExpr :: Nullity a -> TypeInformation (Unnullify a) -> a -> Expr a-slitExpr nullity info@TypeInformation {encode} =-  scastExpr info . Expr . encoder-  where-    encoder = case nullity of-      Null -> maybe (Opaleye.ConstExpr Opaleye.NullLit) encode-      NotNull -> encode---sparseValue :: Nullity a -> TypeInformation (Unnullify a) -> Hasql.Row a-sparseValue nullity TypeInformation {decode} = case nullity of-  Null -> Hasql.column $ Hasql.nullable decode-  NotNull -> Hasql.column $ Hasql.nonNullable decode
src/Rel8/Expr/Text.hs view
@@ -1,5 +1,3 @@-{-# language DataKinds #-}- module Rel8.Expr.Text   (     -- * String concatenation@@ -17,259 +15,14 @@   , pgClientEncoding, quoteIdent, quoteLiteral, quoteNullable, regexpReplace   , regexpSplitToArray, repeat, replace, reverse, right, rpad, rtrim   , splitPart, strpos, substr, translate++    -- * @LIKE@ and @ILIKE@+  , like, ilike   ) where  -- base-import Data.Bool ( Bool )-import Data.Int ( Int32 )-import Data.Maybe ( Maybe( Nothing, Just ) )-import Prelude ()---- bytestring-import Data.ByteString ( ByteString )+import Prelude hiding (length, repeat, reverse)  -- rel8-import Rel8.Expr ( Expr )-import Rel8.Expr.Function ( binaryOperator, function, nullaryFunction )---- text-import Data.Text (Text)----- | The PostgreSQL string concatenation operator.-(++.) :: Expr Text -> Expr Text -> Expr Text-(++.) = binaryOperator "||"-infixr 6 ++.----- * Regular expression operators---- See https://www.postgresql.org/docs/9.5/static/functions-matching.html#FUNCTIONS-POSIX-REGEXP----- | Matches regular expression, case sensitive--- --- Corresponds to the @~.@ operator.-(~.) :: Expr Text -> Expr Text -> Expr Bool-(~.) = binaryOperator "~."-infix 2 ~.----- | Matches regular expression, case insensitive------ Corresponds to the @~*@ operator.-(~*) :: Expr Text -> Expr Text -> Expr Bool-(~*) = binaryOperator "~*"-infix 2 ~*----- | Does not match regular expression, case sensitive------ Corresponds to the @!~@ operator.-(!~) :: Expr Text -> Expr Text -> Expr Bool-(!~) = binaryOperator "!~"-infix 2 !~----- | Does not match regular expression, case insensitive------ Corresponds to the @!~*@ operator.-(!~*) :: Expr Text -> Expr Text -> Expr Bool-(!~*) = binaryOperator "!~*"-infix 2 !~*----- See https://www.postgresql.org/docs/9.5/static/functions-Expr.'PGHtml---- * Standard SQL functions----- | Corresponds to the @bit_length@ function.-bitLength :: Expr Text -> Expr Int32-bitLength = function "bit_length"----- | Corresponds to the @char_length@ function.-charLength :: Expr Text -> Expr Int32-charLength = function "char_length"----- | Corresponds to the @lower@ function.-lower :: Expr Text -> Expr Text-lower = function "lower"----- | Corresponds to the @octet_length@ function.-octetLength :: Expr Text -> Expr Int32-octetLength = function "octet_length"----- | Corresponds to the @upper@ function.-upper :: Expr Text -> Expr Text-upper = function "upper"----- | Corresponds to the @ascii@ function.-ascii :: Expr Text -> Expr Int32-ascii = function "ascii"----- | Corresponds to the @btrim@ function.-btrim :: Expr Text -> Maybe (Expr Text) -> Expr Text-btrim a (Just b) = function "btrim" a b-btrim a Nothing = function "btrim" a----- | Corresponds to the @chr@ function.-chr :: Expr Int32 -> Expr Text-chr = function "chr"----- | Corresponds to the @convert@ function.-convert :: Expr ByteString -> Expr Text -> Expr Text -> Expr ByteString-convert = function "convert"----- | Corresponds to the @convert_from@ function.-convertFrom :: Expr ByteString -> Expr Text -> Expr Text-convertFrom = function "convert_from"----- | Corresponds to the @convert_to@ function.-convertTo :: Expr Text -> Expr Text -> Expr ByteString-convertTo = function "convert_to"----- | Corresponds to the @decode@ function.-decode :: Expr Text -> Expr Text -> Expr ByteString-decode = function "decode"----- | Corresponds to the @encode@ function.-encode :: Expr ByteString -> Expr Text -> Expr Text-encode = function "encode"----- | Corresponds to the @initcap@ function.-initcap :: Expr Text -> Expr Text-initcap = function "initcap"----- | Corresponds to the @left@ function.-left :: Expr Text -> Expr Int32 -> Expr Text-left = function "left"----- | Corresponds to the @length@ function.-length :: Expr Text -> Expr Int32-length = function "length"----- | Corresponds to the @length@ function.-lengthEncoding :: Expr ByteString -> Expr Text -> Expr Int32-lengthEncoding = function "length"----- | Corresponds to the @lpad@ function.-lpad :: Expr Text -> Expr Int32 -> Maybe (Expr Text) -> Expr Text-lpad a b (Just c) = function "lpad" a b c-lpad a b Nothing = function "lpad" a b----- | Corresponds to the @ltrim@ function.-ltrim :: Expr Text -> Maybe (Expr Text) -> Expr Text-ltrim a (Just b) = function "ltrim" a b-ltrim a Nothing = function "ltrim" a----- | Corresponds to the @md5@ function.-md5 :: Expr Text -> Expr Text-md5 = function "md5"----- | Corresponds to the @pg_client_encoding()@ expression.-pgClientEncoding :: Expr Text-pgClientEncoding = nullaryFunction "pg_client_encoding"----- | Corresponds to the @quote_ident@ function.-quoteIdent :: Expr Text -> Expr Text-quoteIdent = function "quote_ident"----- | Corresponds to the @quote_literal@ function.-quoteLiteral :: Expr Text -> Expr Text-quoteLiteral = function "quote_literal"----- | Corresponds to the @quote_nullable@ function.-quoteNullable :: Expr Text -> Expr Text-quoteNullable = function "quote_nullable"----- | Corresponds to the @regexp_replace@ function.-regexpReplace :: ()-  => Expr Text -> Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr Text-regexpReplace a b c (Just d) = function "regexp_replace" a b c d-regexpReplace a b c Nothing = function "regexp_replace" a b c----- | Corresponds to the @regexp_split_to_array@ function.-regexpSplitToArray :: ()-  => Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr [Text]-regexpSplitToArray a b (Just c) = function "regexp_split_to_array" a b c-regexpSplitToArray a b Nothing = function "regexp_split_to_array" a b----- | Corresponds to the @repeat@ function.-repeat :: Expr Text -> Expr Int32 -> Expr Text-repeat = function "repeat"----- | Corresponds to the @replace@ function.-replace :: Expr Text -> Expr Text -> Expr Text -> Expr Text-replace = function "replace"----- | Corresponds to the @reverse@ function.-reverse :: Expr Text -> Expr Text-reverse = function "reverse"----- | Corresponds to the @right@ function.-right :: Expr Text -> Expr Int32 -> Expr Text-right = function "right"----- | Corresponds to the @rpad@ function.-rpad :: Expr Text -> Expr Int32 -> Maybe (Expr Text) -> Expr Text-rpad a b (Just c) = function "rpad" a b c-rpad a b Nothing = function "rpad" a b----- | Corresponds to the @rtrim@ function.-rtrim :: Expr Text -> Maybe (Expr Text) -> Expr Text-rtrim a (Just b) = function "rtrim" a b-rtrim a Nothing = function "rtrim" a----- | Corresponds to the @split_part@ function.-splitPart :: Expr Text -> Expr Text -> Expr Int32 -> Expr Text-splitPart = function "split_part"----- | Corresponds to the @strpos@ function.-strpos :: Expr Text -> Expr Text -> Expr Int32-strpos = function "strpos"----- | Corresponds to the @substr@ function.-substr :: Expr Text -> Expr Int32 -> Maybe (Expr Int32) -> Expr Text-substr a b (Just c) = function "substr" a b c-substr a b Nothing = function "substr" a b----- | Corresponds to the @translate@ function.-translate :: Expr Text -> Expr Text -> Expr Text -> Expr Text-translate = function "translate"+import Rel8.Internal.Expr.Text
src/Rel8/Expr/Time.hs view
@@ -1,3 +1,5 @@+{-# language OverloadedStrings #-}+ module Rel8.Expr.Time   ( -- * Working with @Day@     today@@ -29,9 +31,9 @@ import Prelude  -- rel8-import Rel8.Expr ( Expr )-import Rel8.Expr.Function ( binaryOperator, nullaryFunction )-import Rel8.Expr.Opaleye ( castExpr, unsafeCastExpr, unsafeLiteral )+import Rel8.Internal.Expr ( Expr )+import Rel8.Internal.Expr.Function (binaryOperator, function)+import Rel8.Internal.Expr.Opaleye ( castExpr, unsafeCastExpr, unsafeLiteral )  -- time import Data.Time.Calendar ( Day )@@ -71,7 +73,7 @@  -- | Corresponds to @now()@. now :: Expr UTCTime-now = nullaryFunction "now"+now = function "now" ()   -- | Add a time interval to a point in time, yielding a new point in time.
− src/Rel8/FCF.hs 
@@ -1,26 +0,0 @@-{-# language DataKinds #-}-{-# language PolyKinds #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}--module Rel8.FCF-  ( Exp, Eval-  , Id-  )-where---- base-import Data.Kind ( Type )-import Prelude ()---type Exp :: Type -> Type-type Exp e = e -> Type---type Eval :: Exp e -> e-type family Eval a---data Id :: a -> Exp a-type instance Eval (Id a) = a
− src/Rel8/Generic/Construction.hs 
@@ -1,352 +0,0 @@-{-# language AllowAmbiguousTypes #-}-{-# language ConstraintKinds #-}-{-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language NamedFieldPuns #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}-{-# language ViewPatterns #-}--module Rel8.Generic.Construction-  ( GGBuildable-  , GGBuild, ggbuild-  , GGConstructable-  , GGConstruct, ggconstruct-  , GGDeconstruct, ggdeconstruct-  , GGName, ggname-  , GGAggregate, ggaggregate-  )-where---- base-import Data.Bifunctor ( first )-import Data.Kind ( Constraint, Type )-import Data.List.NonEmpty ( NonEmpty( (:|) ) )-import GHC.TypeLits ( Symbol )-import Prelude---- rel8-import Rel8.Aggregate ( Aggregate( Aggregate ) )-import Rel8.Expr ( Expr )-import Rel8.Expr.Aggregate ( groupByExpr )-import Rel8.Expr.Eq ( (==.) )-import Rel8.Expr.Null ( nullify, snull, unsafeUnnullify )-import Rel8.Expr.Serialize ( litExpr )-import Rel8.FCF ( Eval, Exp, Id )-import Rel8.Generic.Construction.ADT-  ( GConstructorADT, GMakeableADT, gmakeADT-  , GConstructableADT-  , GBuildADT, gbuildADT, gunbuildADT-  , GConstructADT, gconstructADT, gdeconstructADT-  , RepresentableConstructors, GConstructors, gcindex, gctabulate-  , RepresentableFields, gfindex, gftabulate-  )-import Rel8.Generic.Construction.Record-  ( GConstructor-  , GConstructable, GConstruct, gconstruct, gdeconstruct-  , Representable, gindex, gtabulate-  )-import Rel8.Generic.Table ( GGColumns )-import Rel8.Kind.Algebra-  ( SAlgebra( SProduct, SSum )-  , KnownAlgebra, algebraSing-  )-import qualified Rel8.Kind.Algebra as K-import Rel8.Schema.Context.Nullify ( sguard, snullify )-import Rel8.Schema.HTable ( HTable )-import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Name ( Name( Name ) )-import Rel8.Schema.Null ( Nullity( Null, NotNull ) )-import Rel8.Schema.Spec ( Spec( Spec, nullity, info ) )-import Rel8.Table-  ( TTable, TColumns-  , Table, fromColumns, toColumns-  )-import Rel8.Table.Bool ( case_ )-import Rel8.Type.Tag ( Tag )---type GGBuildable :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Constraint-type GGBuildable algebra name rep =-  ( KnownAlgebra algebra-  , Eval (GGColumns algebra TColumns (Eval (rep Aggregate))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))-  , Eval (GGColumns algebra TColumns (Eval (rep Expr))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))-  , Eval (GGColumns algebra TColumns (Eval (rep Name))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))-  , HTable (Eval (GGColumns algebra TColumns (Eval (rep Expr))))-  , GGBuildable' algebra name rep-  )---type GGBuildable' :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Constraint-type family GGBuildable' algebra name rep where-  GGBuildable' 'K.Product name rep =-    ( name ~ GConstructor (Eval (rep Expr))-    , Representable Id (Eval (rep Expr))-    , GConstructable (TTable Expr) TColumns Id Expr (Eval (rep Expr))-    )-  GGBuildable' 'K.Sum name rep =-    ( Representable Id (GConstructorADT name (Eval (rep Expr)))-    , GMakeableADT (TTable Expr) TColumns Id Expr name (Eval (rep Expr))-    )---type GGBuild :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Type -> Type-type family GGBuild algebra name rep r where-  GGBuild 'K.Product _name rep r =-    GConstruct Id (Eval (rep Expr)) r-  GGBuild 'K.Sum name rep r =-    GConstruct Id (GConstructorADT name (Eval (rep Expr))) r---ggbuild :: forall algebra name rep a. GGBuildable algebra name rep-  => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a)-  -> GGBuild algebra name rep a-ggbuild gfromColumns = case algebraSing @algebra of-  SProduct ->-    gtabulate @Id @(Eval (rep Expr)) @a $-    gfromColumns .-    gconstruct-      @(TTable Expr)-      @TColumns-      @Id-      @Expr-      @(Eval (rep Expr))-      (const toColumns)-  SSum ->-    gtabulate @Id @(GConstructorADT name (Eval (rep Expr))) @a $-    gfromColumns .-    gmakeADT-      @(TTable Expr)-      @TColumns-      @Id-      @Expr-      @name-      @(Eval (rep Expr))-      (const toColumns)-      (\Spec {info} -> snull info)-      (\Spec {nullity} -> case nullity of-        Null -> id-        NotNull -> nullify)-      (HIdentity . litExpr)---type GGConstructable :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint-type GGConstructable algebra rep =-  ( KnownAlgebra algebra-  , Eval (GGColumns algebra TColumns (Eval (rep Aggregate))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))-  , Eval (GGColumns algebra TColumns (Eval (rep Expr))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))-  , Eval (GGColumns algebra TColumns (Eval (rep Name))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))-  , HTable (Eval (GGColumns algebra TColumns (Eval (rep Expr))))-  , GGConstructable' algebra rep-  )---type GGConstructable' :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint-type family GGConstructable' algebra rep where-  GGConstructable' 'K.Product rep =-    ( Representable Id (Eval (rep Aggregate))-    , Representable Id (Eval (rep Expr))-    , Representable Id (Eval (rep Name))-    , GConstructable (TTable Aggregate) TColumns Id Aggregate (Eval (rep Aggregate))-    , GConstructable (TTable Expr) TColumns Id Expr (Eval (rep Expr))-    , GConstructable (TTable Name) TColumns Id Name (Eval (rep Name))-    )-  GGConstructable' 'K.Sum rep =-    ( RepresentableConstructors Id (Eval (rep Expr))-    , RepresentableFields Id (Eval (rep Aggregate))-    , RepresentableFields Id (Eval (rep Expr))-    , RepresentableFields Id (Eval (rep Name))-    , Functor (GConstructors Id (Eval (rep Expr)))-    , GConstructableADT (TTable Aggregate) TColumns Id Aggregate (Eval (rep Aggregate))-    , GConstructableADT (TTable Expr) TColumns Id Expr (Eval (rep Expr))-    , GConstructableADT (TTable Name) TColumns Id Name (Eval (rep Name))-    )---type GGConstruct :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type-type family GGConstruct algebra rep r where-  GGConstruct 'K.Product rep r = GConstruct Id (Eval (rep Expr)) r -> r-  GGConstruct 'K.Sum rep r = GConstructADT Id (Eval (rep Expr)) r r---ggconstruct :: forall algebra rep a. GGConstructable algebra rep-  => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a)-  -> GGConstruct algebra rep a -> a-ggconstruct gfromColumns f = case algebraSing @algebra of-  SProduct ->-    f $-    gtabulate @Id @(Eval (rep Expr)) @a $-    gfromColumns .-    gconstruct-      @(TTable Expr)-      @TColumns-      @Id-      @Expr-      @(Eval (rep Expr))-      (const toColumns)-  SSum ->-    gcindex @Id @(Eval (rep Expr)) @a f $-    fmap gfromColumns $-    gconstructADT-      @(TTable Expr)-      @TColumns-      @Id-      @Expr-      @(Eval (rep Expr))-      (const toColumns)-      (\Spec {info} -> snull info)-      (\Spec {nullity} -> case nullity of-        Null -> id-        NotNull -> nullify)-      (HIdentity . litExpr)---type GGDeconstruct :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type -> Type-type family GGDeconstruct algebra rep a r where-  GGDeconstruct 'K.Product rep a r =-    GConstruct Id (Eval (rep Expr)) r -> a -> r-  GGDeconstruct 'K.Sum rep a r =-    GConstructADT Id (Eval (rep Expr)) r (a -> r)---ggdeconstruct :: forall algebra rep a r. (GGConstructable algebra rep, Table Expr r)-  => (a -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)-  -> GGDeconstruct algebra rep a r-ggdeconstruct gtoColumns = case algebraSing @algebra of-  SProduct -> \build ->-    gindex @Id @(Eval (rep Expr)) @r build .-    gdeconstruct-      @(TTable Expr)-      @TColumns-      @Id-      @Expr-      @(Eval (rep Expr))-      (const fromColumns) .-    gtoColumns-  SSum ->-    gctabulate @Id @(Eval (rep Expr)) @r @(a -> r) $ \constructors as ->-      let-        (HIdentity tag, cases) =-          gdeconstructADT-            @(TTable Expr)-            @TColumns-            @Id-            @Expr-            @(Eval (rep Expr))-            (const fromColumns)-            (\Spec {nullity} -> case nullity of-              Null -> id-              NotNull -> unsafeUnnullify)-            constructors $-          gtoColumns as-      in-        case cases of-          ((_, r) :| (map (first ((tag ==.) . litExpr)) -> cases')) ->-            case_ cases' r---type GGName :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type-type family GGName algebra rep a where-  GGName 'K.Product rep a = GConstruct Id (Eval (rep Name)) a-  GGName 'K.Sum rep a = Name Tag -> GBuildADT Id (Eval (rep Name)) a---ggname :: forall algebra rep a. GGConstructable algebra rep-  => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Name -> a)-  -> GGName algebra rep a-ggname gfromColumns = case algebraSing @algebra of-  SProduct ->-    gtabulate @Id @(Eval (rep Name)) @a $-    gfromColumns .-    gconstruct-      @(TTable Name)-      @TColumns-      @Id-      @Name-      @(Eval (rep Name))-      (const toColumns)-  SSum -> \tag ->-    gftabulate @Id @(Eval (rep Name)) @a $-    gfromColumns .-    gbuildADT-      @(TTable Name)-      @TColumns-      @Id-      @Name-      @(Eval (rep Name))-      (const toColumns)-      (\_ _ (Name a) -> Name a)-      (HIdentity tag)---type GGAggregate :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type-type family GGAggregate algebra rep r where-  GGAggregate 'K.Product rep r =-    GConstruct Id (Eval (rep Aggregate)) r ->-      GConstruct Id (Eval (rep Expr)) r-  GGAggregate 'K.Sum rep r =-    GBuildADT Id (Eval (rep Aggregate)) r ->-      GBuildADT Id (Eval (rep Expr)) r---ggaggregate :: forall algebra rep exprs agg. GGConstructable algebra rep-  => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Aggregate -> agg)-  -> (exprs -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)-  -> GGAggregate algebra rep agg -> exprs -> agg-ggaggregate gfromColumns gtoColumns agg es = case algebraSing @algebra of-  SProduct -> flip f exprs $-    gfromColumns .-    gconstruct-      @(TTable Aggregate)-      @TColumns-      @Id-      @Aggregate-      @(Eval (rep Aggregate))-      (const toColumns)-    where-      f =-        gindex @Id @(Eval (rep Expr)) @agg .-        agg .-        gtabulate @Id @(Eval (rep Aggregate)) @agg-      exprs =-        gdeconstruct-          @(TTable Expr)-          @TColumns-          @Id-          @Expr-          @(Eval (rep Expr))-          (const fromColumns) $-        gtoColumns es-  SSum -> flip f exprs $-    gfromColumns .-    gbuildADT-      @(TTable Aggregate)-      @TColumns-      @Id-      @Aggregate-      @(Eval (rep Aggregate))-      (const toColumns)-      (\tag' Spec {nullity} (Aggregate a) ->-        Aggregate $ sguard (tag ==. litExpr tag') . snullify nullity <$> a)-      (HIdentity (groupByExpr tag))-    where-      f =-        gfindex @Id @(Eval (rep Expr)) @agg .-        agg .-        gftabulate @Id @(Eval (rep Aggregate)) @agg-      (HIdentity tag, exprs) =-        gunbuildADT-          @(TTable Expr)-          @TColumns-          @Id-          @Expr-          @(Eval (rep Expr))-          (const fromColumns)-          (\Spec {nullity} -> case nullity of-            Null -> id-            NotNull -> unsafeUnnullify) $-        gtoColumns es
− src/Rel8/Generic/Construction/ADT.hs 
@@ -1,478 +0,0 @@-{-# language AllowAmbiguousTypes #-}-{-# language BlockArguments #-}-{-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language MultiParamTypeClasses #-}-{-# language RankNTypes #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TupleSections #-}-{-# language TypeApplications #-}-{-# language TypeFamilies #-}-{-# language TypeOperators #-}-{-# language UndecidableInstances #-}--module Rel8.Generic.Construction.ADT-  ( GConstructableADT-  , GBuildADT, gbuildADT, gunbuildADT-  , GConstructADT, gconstructADT, gdeconstructADT-  , GFields, RepresentableFields, gftabulate, gfindex-  , GConstructors, RepresentableConstructors, gctabulate, gcindex-  , GConstructorADT, GMakeableADT, gmakeADT-  )-where---- base-import Data.Bifunctor ( first )-import Data.Functor.Identity ( runIdentity )-import Data.Kind ( Constraint, Type )-import Data.List.NonEmpty ( NonEmpty )-import Data.Proxy ( Proxy( Proxy ) )-import GHC.Generics-  ( (:+:), (:*:)( (:*:) ), M1, U1-  , C, D-  , Meta( MetaData, MetaCons )-  )-import GHC.TypeLits-  ( ErrorMessage( (:<>:), Text ), TypeError-  , Symbol, KnownSymbol, symbolVal-  )-import Prelude hiding ( null )---- rel8-import Rel8.FCF ( Exp )-import Rel8.Generic.Construction.Record-  ( GConstruct, GConstructable, gconstruct, gdeconstruct-  , GFields, Representable, gtabulate, gindex-  , FromColumns, ToColumns-  )-import Rel8.Generic.Table.ADT ( GColumnsADT, GColumnsADT' )-import Rel8.Generic.Table.Record ( GColumns )-import Rel8.Schema.HTable ( HTable )-import Rel8.Schema.HTable.Identity ( HIdentity )-import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )-import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify )-import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )-import Rel8.Schema.Null ( Nullify )-import Rel8.Schema.Spec ( Spec )-import qualified Rel8.Schema.Kind as K-import Rel8.Type.Tag ( Tag( Tag ) )---- text-import Data.Text ( pack )---type Null :: K.Context -> Type-type Null context = forall a. Spec a -> context (Nullify a)---type Nullifier :: K.Context -> Type-type Nullifier context = forall a. Spec a -> context a -> context (Nullify a)---type Unnullifier :: K.Context -> Type-type Unnullifier context = forall a. Spec a -> context (Nullify a) -> context a---type NoConstructor :: Symbol -> Symbol -> ErrorMessage-type NoConstructor datatype constructor =-  ( 'Text "The type `" ':<>:-    'Text datatype ':<>:-    'Text "` has no constructor `" ':<>:-    'Text constructor ':<>:-    'Text "`."-  )---type GConstructorADT :: Symbol -> (Type -> Type) -> Type -> Type-type family GConstructorADT name rep where-  GConstructorADT name (M1 D ('MetaData datatype _ _ _) rep) =-    GConstructorADT' name rep (TypeError (NoConstructor datatype name))---type GConstructorADT' :: Symbol -> (Type -> Type) -> (Type -> Type) -> Type -> Type-type family GConstructorADT' name rep fallback where-  GConstructorADT' name (M1 D _ rep) fallback =-    GConstructorADT' name rep fallback-  GConstructorADT' name (a :+: b) fallback =-    GConstructorADT' name a (GConstructorADT' name b fallback)-  GConstructorADT' name (M1 C ('MetaCons name _ _) rep) _ = rep-  GConstructorADT' _ _ fallback = fallback---type GConstructADT-  :: (Type -> Exp Type)-  -> (Type -> Type) -> Type -> Type -> Type-type family GConstructADT f rep r x where-  GConstructADT f (M1 D _ rep) r x = GConstructADT f rep r x-  GConstructADT f (a :+: b) r x = GConstructADT f a r (GConstructADT f b r x)-  GConstructADT f (M1 C _ rep) r x = GConstruct f rep r -> x---type GConstructors :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type-type family GConstructors f rep where-  GConstructors f (M1 D _ rep) = GConstructors f rep-  GConstructors f (a :+: b) = GConstructors f a :*: GConstructors f b-  GConstructors f (M1 C _ rep) = (->) (GFields f rep)---type RepresentableConstructors :: (Type -> Exp Type) -> (Type -> Type) -> Constraint-class RepresentableConstructors f rep where-  gctabulate :: (GConstructors f rep r -> a) -> GConstructADT f rep r a-  gcindex :: GConstructADT f rep r a -> GConstructors f rep r -> a---instance RepresentableConstructors f rep => RepresentableConstructors f (M1 D meta rep) where-  gctabulate = gctabulate @f @rep-  gcindex = gcindex @f @rep---instance (RepresentableConstructors f a, RepresentableConstructors f b) =>-  RepresentableConstructors f (a :+: b)- where-  gctabulate f =-    gctabulate @f @a \a -> gctabulate @f @b \b -> f (a :*: b)-  gcindex f (a :*: b) = gcindex @f @b (gcindex @f @a f a) b---instance Representable f rep => RepresentableConstructors f (M1 C meta rep) where-  gctabulate f = f . gindex @f @rep-  gcindex f = f . gtabulate @f @rep---type GBuildADT :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type-type family GBuildADT f rep r where-  GBuildADT f (M1 D _ rep) r = GBuildADT f rep r-  GBuildADT f (a :+: b) r = GBuildADT f a (GBuildADT f b r)-  GBuildADT f (M1 C _ rep) r = GConstruct f rep r---type GFieldsADT :: (Type -> Exp Type) -> (Type -> Type) -> Type-type family GFieldsADT f rep where-  GFieldsADT f (M1 D _ rep) = GFieldsADT f rep-  GFieldsADT f (a :+: b) = (GFieldsADT f a, GFieldsADT f b)-  GFieldsADT f (M1 C _ rep) = GFields f rep---type RepresentableFields :: (Type -> Exp Type) -> (Type -> Type) -> Constraint-class RepresentableFields f rep where-  gftabulate :: (GFieldsADT f rep -> a) -> GBuildADT f rep a-  gfindex :: GBuildADT f rep a -> GFieldsADT f rep -> a---instance RepresentableFields f rep => RepresentableFields f (M1 D meta rep) where-  gftabulate = gftabulate @f @rep-  gfindex = gfindex @f @rep---instance (RepresentableFields f a, RepresentableFields f b) => RepresentableFields f (a :+: b) where-  gftabulate f =-    gftabulate @f @a \a -> gftabulate @f @b \b -> f (a, b)-  gfindex f (a, b) = gfindex @f @b (gfindex @f @a f a) b---instance Representable f rep => RepresentableFields f (M1 C meta rep) where-  gftabulate = gtabulate @f @rep-  gfindex = gindex @f @rep---type GConstructableADT-  :: (Type -> Exp Constraint)-  -> (Type -> Exp K.HTable)-  -> (Type -> Exp Type)-  -> K.Context -> (Type -> Type) -> Constraint-class GConstructableADT _Table _Columns f context rep where-  gbuildADT :: ()-    => ToColumns _Table _Columns f context-    -> (Tag -> Nullifier context)-    -> HIdentity Tag context-    -> GFieldsADT f rep-    -> GColumnsADT _Columns rep context--  gunbuildADT :: ()-    => FromColumns _Table _Columns f context-    -> Unnullifier context-    -> GColumnsADT _Columns rep context-    -> (HIdentity Tag context, GFieldsADT f rep)--  gconstructADT :: ()-    => ToColumns _Table _Columns f context-    -> Null context-    -> Nullifier context-    -> (Tag -> HIdentity Tag context)-    -> GConstructors f rep (GColumnsADT _Columns rep context)--  gdeconstructADT :: ()-    => FromColumns _Table _Columns f context-    -> Unnullifier context-    -> GConstructors f rep r-    -> GColumnsADT _Columns rep context-    -> (HIdentity Tag context, NonEmpty (Tag, r))---instance-  ( htable ~ HLabel "tag" (HIdentity Tag)-  , GConstructableADT' _Table _Columns f context htable rep-  )-  => GConstructableADT _Table _Columns f context (M1 D meta rep)- where-  gbuildADT toColumns nullifier =-    gbuildADT' @_Table @_Columns @f @context @htable @rep toColumns nullifier .-    hlabel--  gunbuildADT fromColumns unnullifier =-    first hunlabel .-    gunbuildADT' @_Table @_Columns @f @context @htable @rep fromColumns unnullifier--  gconstructADT toColumns null nullifier mk =-    gconstructADT' @_Table @_Columns @f @context @htable @rep toColumns null nullifier-      (hlabel . mk)--  gdeconstructADT fromColumns unnullifier cases =-    first hunlabel .-    gdeconstructADT' @_Table @_Columns @f @context @htable @rep fromColumns unnullifier cases---type GConstructableADT'-  :: (Type -> Exp Constraint)-  -> (Type -> Exp K.HTable)-  -> (Type -> Exp Type)-  -> K.Context -> K.HTable -> (Type -> Type) -> Constraint-class GConstructableADT' _Table _Columns f context htable rep where-  gbuildADT' :: ()-    => ToColumns _Table _Columns f context-    -> (Tag -> Nullifier context)-    -> htable context-    -> GFieldsADT f rep-    -> GColumnsADT' _Columns htable rep context--  gunbuildADT' :: ()-    => FromColumns _Table _Columns f context-    -> Unnullifier context-    -> GColumnsADT' _Columns htable rep context-    -> (htable context, GFieldsADT f rep)--  gconstructADT' :: ()-    => ToColumns _Table _Columns f context-    -> Null context-    -> Nullifier context-    -> (Tag -> htable context)-    -> GConstructors f rep (GColumnsADT' _Columns htable rep context)--  gdeconstructADT' :: ()-    => FromColumns _Table _Columns f context-    -> Unnullifier context-    -> GConstructors f rep r-    -> GColumnsADT' _Columns htable rep context-    -> (htable context, NonEmpty (Tag, r))--  gfill :: ()-    => Null context-    -> htable context-    -> GColumnsADT' _Columns htable rep context---instance-  ( htable' ~ GColumnsADT' _Columns htable a-  , Functor (GConstructors f a)-  , GConstructableADT' _Table _Columns f context htable a-  , GConstructableADT' _Table _Columns f context htable' b-  )-  => GConstructableADT' _Table _Columns f context htable (a :+: b)- where-  gbuildADT' toColumns nullifier htable (a, b) =-    gbuildADT' @_Table @_Columns @f @context @htable' @b toColumns nullifier-      (gbuildADT' @_Table @_Columns @f @context @htable @a toColumns nullifier htable a)-      b--  gunbuildADT' fromColumns unnullifier columns =-    case gunbuildADT' @_Table @_Columns @f @context @htable' @b fromColumns unnullifier columns of-      (htable', b) ->-        case gunbuildADT' @_Table @_Columns @f @context @htable @a fromColumns unnullifier htable' of-          (htable, a) -> (htable, (a, b))--  gconstructADT' toColumns null nullifier mk =-    fmap (gfill @_Table @_Columns @f @context @htable' @b null) (gconstructADT' @_Table @_Columns @f @context @htable @a toColumns null nullifier mk) :*:-    gconstructADT' @_Table @_Columns @f @context @htable' @b toColumns null nullifier (gfill @_Table @_Columns @f @context @htable @a null . mk)--  gdeconstructADT' fromColumns unnullifier (a :*: b) columns =-    case gdeconstructADT' @_Table @_Columns @f @context @htable' @b fromColumns unnullifier b columns of-      (htable', cases) ->-        case gdeconstructADT' @_Table @_Columns @f @context @htable @a fromColumns unnullifier a htable' of-          (htable, cases') -> (htable, cases' <> cases)--  gfill null =-    gfill @_Table @_Columns @f @context @htable' @b null .-    gfill @_Table @_Columns @f @context @htable @a null---instance (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) =>-  GConstructableADT' _Table _Columns f context htable (M1 C meta U1)- where-  gbuildADT' _ _ = const-  gunbuildADT' _ _ = (, ())-  gconstructADT' _ _ _ f _ = f tag-    where-      tag = Tag $ pack $ symbolVal (Proxy @label)-  gdeconstructADT' _ _ r htable = (htable, pure (tag, r ()))-    where-      tag = Tag $ pack $ symbolVal (Proxy @label)-  gfill _ = id---instance {-# OVERLAPPABLE #-}-  ( HTable (GColumns _Columns rep)-  , KnownSymbol label-  , meta ~ 'MetaCons label _fixity _isRecord-  , GConstructable _Table _Columns f context rep-  , GColumnsADT' _Columns htable (M1 C meta rep) ~-      HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))-  )-  => GConstructableADT' _Table _Columns f context htable (M1 C meta rep)- where-  gbuildADT' toColumns nullifier htable =-    HProduct htable .-    hlabel .-    hnullify (nullifier tag) .-    gconstruct @_Table @_Columns @f @context @rep toColumns-    where-      tag = Tag $ pack $ symbolVal (Proxy @label)--  gunbuildADT' fromColumns unnullifier (HProduct htable a) =-    ( htable-    , gdeconstruct @_Table @_Columns @f @context @rep fromColumns $-        runIdentity $-        hunnullify (\spec -> pure . unnullifier spec) $-        hunlabel-        a-    )--  gconstructADT' toColumns _ nullifier mk =-    HProduct htable .-    hlabel .-    hnullify nullifier .-    gconstruct @_Table @_Columns @f @context @rep toColumns-    where-      tag = Tag $ pack $ symbolVal (Proxy @label)-      htable = mk tag--  gdeconstructADT' fromColumns unnullifier r (HProduct htable columns) =-    ( htable-    , pure (tag, r a)-    )-    where-      a = gdeconstruct @_Table @_Columns @f @context @rep fromColumns $-        runIdentity $-        hunnullify (\spec -> pure . unnullifier spec) $-        hunlabel-        columns-      tag = Tag $ pack $ symbolVal (Proxy @label)--  gfill null htable = HProduct htable (hlabel (hnulls null))---type GMakeableADT-  :: (Type -> Exp Constraint)-  -> (Type -> Exp K.HTable)-  -> (Type -> Exp Type)-  -> K.Context -> Symbol -> (Type -> Type) -> Constraint-class GMakeableADT _Table _Columns f context name rep where-  gmakeADT :: ()-    => ToColumns _Table _Columns f context-    -> Null context-    -> Nullifier context-    -> (Tag -> HIdentity Tag context)-    -> GFields f (GConstructorADT name rep)-    -> GColumnsADT _Columns rep context---instance-  ( htable ~ HLabel "tag" (HIdentity Tag)-  , meta ~ 'MetaData datatype _module _package _newtype-  , fallback ~ TypeError (NoConstructor datatype name)-  , fields ~ GFields f (GConstructorADT' name rep fallback)-  , GMakeableADT' _Table _Columns f context htable name rep fields-  , KnownSymbol name-  )-  => GMakeableADT _Table _Columns f context name (M1 D meta rep)- where-  gmakeADT toColumns null nullifier wrap =-    gmakeADT'-      @_Table @_Columns @f @context @htable @name @rep @fields-      toColumns null nullifier htable-    where-      tag = Tag $ pack $ symbolVal (Proxy @name)-      htable = hlabel (wrap tag)---type GMakeableADT'-  :: (Type -> Exp Constraint)-  -> (Type -> Exp K.HTable)-  -> (Type -> Exp Type)-  -> K.Context -> K.HTable -> Symbol -> (Type -> Type) -> Type -> Constraint-class GMakeableADT' _Table _Columns f context htable name rep fields where-  gmakeADT' :: ()-    => ToColumns _Table _Columns f context-    -> Null context-    -> Nullifier context-    -> htable context-    -> fields-    -> GColumnsADT' _Columns htable rep context---instance-  ( htable' ~ GColumnsADT' _Columns htable a-  , GMakeableADT' _Table _Columns f context htable name a fields-  , GMakeableADT' _Table _Columns f context htable' name b fields-  )-  => GMakeableADT' _Table _Columns f context htable name (a :+: b) fields- where-  gmakeADT' toColumns null nullifier htable x =-    gmakeADT' @_Table @_Columns @f @context @htable' @name @b @fields-      toColumns null nullifier-      (gmakeADT'-         @_Table @_Columns @f @context @htable @name @a @fields toColumns-         null nullifier htable x)-      x---instance {-# OVERLAPPING #-}-  GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons name _fixity _isRecord) U1) fields- where-  gmakeADT' _ _ _ = const---instance {-# OVERLAPS #-}-  GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons label _fixity _isRecord) U1) fields- where-  gmakeADT' _ _ _ = const---instance {-# OVERLAPS #-}-  ( HTable (GColumns _Columns rep)-  , GConstructable _Table _Columns f context rep-  , fields ~ GFields f rep-  , GColumnsADT' _Columns htable (M1 C ('MetaCons name _fixity _isRecord) rep) ~-      HProduct htable (HLabel name (HNullify (GColumns _Columns rep)))-  )-  => GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons name _fixity _isRecord) rep) fields- where-  gmakeADT' toColumns _ nullifier htable =-    HProduct htable .-    hlabel .-    hnullify nullifier .-    gconstruct @_Table @_Columns @f @context @rep toColumns---instance {-# OVERLAPPABLE #-}-  ( HTable (GColumns _Columns rep)-  , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) rep) ~-      HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))-  )-  => GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons label _fixity _isRecord) rep) fields- where-  gmakeADT' _ null _ htable _ =-    HProduct htable $-    hlabel $-    hnulls null
− src/Rel8/Generic/Construction/Record.hs 
@@ -1,168 +0,0 @@-{-# language AllowAmbiguousTypes #-}-{-# language BlockArguments #-}-{-# language DataKinds #-}-{-# language FlexibleInstances #-}-{-# language MultiParamTypeClasses #-}-{-# language RankNTypes #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-}-{-# language TypeFamilies #-}-{-# language TypeOperators #-}-{-# language UndecidableInstances #-}--module Rel8.Generic.Construction.Record-  ( GConstructor, GConstruct, GConstructable, gconstruct, gdeconstruct-  , GFields, Representable, gtabulate, gindex-  , FromColumns, ToColumns-  )-where---- base-import Data.Kind ( Constraint, Type )-import Data.Proxy ( Proxy( Proxy ) )-import GHC.Generics-  ( (:*:), K1, M1, U1-  , D, C, S, Meta( MetaData, MetaCons, MetaSel )-  )-import GHC.TypeLits-  ( ErrorMessage( (:<>:), Text ), TypeError-  , Symbol-  )-import Prelude---- rel8-import Rel8.FCF ( Eval, Exp )-import Rel8.Generic.Table.Record ( GColumns )-import Rel8.Schema.HTable.Label ( hlabel, hunlabel )-import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )-import qualified Rel8.Schema.Kind as K---type FromColumns-  :: (Type -> Exp Constraint)-  -> (Type -> Exp K.HTable)-  -> (Type -> Exp Type)-  -> K.Context-  -> Type-type FromColumns _Table _Columns f context = forall proxy x.-  Eval (_Table x) => proxy x -> Eval (_Columns x) context -> Eval (f x)---type ToColumns-  :: (Type -> Exp Constraint)-  -> (Type -> Exp K.HTable)-  -> (Type -> Exp Type)-  -> K.Context-  -> Type-type ToColumns _Table _Columns f context = forall proxy x.-  Eval (_Table x) => proxy x -> Eval (f x) -> Eval (_Columns x) context---type GConstructor :: (Type -> Type) -> Symbol-type family GConstructor rep where-  GConstructor (M1 D _ (M1 C ('MetaCons name _ _) _)) = name-  GConstructor (M1 D ('MetaData name _ _ _) _) = TypeError (-    'Text "`" ':<>:-    'Text name ':<>:-    'Text "` does not appear to have exactly 1 constructor"-   )---type GConstruct :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type-type family GConstruct f rep r where-  GConstruct f (M1 _ _ rep) r = GConstruct f rep r-  GConstruct f (a :*: b) r = GConstruct f a (GConstruct f b r)-  GConstruct _ U1 r = r-  GConstruct f (K1 _ a) r = Eval (f a) -> r---type GFields :: (Type -> Exp Type) -> (Type -> Type) -> Type-type family GFields f rep where-  GFields f (M1 _ _ rep) = GFields f rep-  GFields f (a :*: b) = (GFields f a, GFields f b)-  GFields _ U1 = ()-  GFields f (K1 _ a) = Eval (f a)---type Representable :: (Type -> Exp Type) -> (Type -> Type) -> Constraint-class Representable f rep where-  gtabulate :: (GFields f rep -> a) -> GConstruct f rep a-  gindex :: GConstruct f rep a -> GFields f rep -> a---instance Representable f rep => Representable f (M1 i meta rep) where-  gtabulate = gtabulate @f @rep-  gindex = gindex @f @rep---instance (Representable f a, Representable f b) =>-  Representable f (a :*: b)- where-  gtabulate f = gtabulate @f @a \a -> gtabulate @f @b \b -> f (a, b)-  gindex f (a, b) = gindex @f @b (gindex @f @a f a) b---instance Representable f U1 where-  gtabulate = ($ ())-  gindex = const---instance Representable f (K1 i a) where-  gtabulate = id-  gindex = id---type GConstructable-  :: (Type -> Exp Constraint)-  -> (Type -> Exp K.HTable)-  -> (Type -> Exp Type)-  -> K.Context -> (Type -> Type) -> Constraint-class GConstructable _Table _Columns f context rep where-  gconstruct :: ()-    => ToColumns _Table _Columns f context-    -> GFields f rep-    -> GColumns _Columns rep context-  gdeconstruct :: ()-    => FromColumns _Table _Columns f context-    -> GColumns _Columns rep context-    -> GFields f rep---instance (GConstructable _Table _Columns f context rep) =>-  GConstructable _Table _Columns f context (M1 D meta rep)- where-  gconstruct = gconstruct @_Table @_Columns @f @context @rep-  gdeconstruct = gdeconstruct @_Table @_Columns @f @context @rep---instance (GConstructable _Table _Columns f context rep) =>-  GConstructable _Table _Columns f context (M1 C meta rep)- where-  gconstruct = gconstruct @_Table @_Columns @f @context @rep-  gdeconstruct = gdeconstruct @_Table @_Columns @f @context @rep---instance-  ( GConstructable _Table _Columns f context a-  , GConstructable _Table _Columns f context b-  )-  => GConstructable _Table _Columns f context (a :*: b)- where-  gconstruct toColumns (a, b) = HProduct-    (gconstruct @_Table @_Columns @f @context @a toColumns a)-    (gconstruct @_Table @_Columns @f @context @b toColumns b)-  gdeconstruct fromColumns (HProduct a b) =-    ( gdeconstruct @_Table @_Columns @f @context @a fromColumns a-    , gdeconstruct @_Table @_Columns @f @context @b fromColumns b-    )---instance-  ( Eval (_Table a)-  , meta ~ 'MetaSel ('Just label) _su _ss _ds-  )-  => GConstructable _Table _Columns f context (M1 S meta (K1 i a))- where-  gconstruct toColumns = hlabel . toColumns (Proxy @a)-  gdeconstruct fromColumns = fromColumns (Proxy @a) . hunlabel
− src/Rel8/Generic/Map.hs 
@@ -1,49 +0,0 @@-{-# language DataKinds #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}-{-# language TypeOperators #-}-{-# language UndecidableInstances #-}--module Rel8.Generic.Map-  ( GMap-  , Map-  )-where---- base-import Data.Kind ( Type )-import GHC.Generics-  ( (:+:), (:*:), K1, M1, U1, V1-  )-import Prelude ()---- rel8-import Rel8.FCF ( Eval, Exp )---type GMap :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type-type family GMap f rep where-  GMap f (M1 i c rep) = M1 i c (GMap f rep)-  GMap _ V1 = V1-  GMap f (rep1 :+: rep2) = GMap f rep1 :+: GMap f rep2-  GMap _ U1 = U1-  GMap f (rep1 :*: rep2) = GMap f rep1 :*: GMap f rep2-  GMap f (K1 i a) = K1 i (Eval (f a))----- | Map a @Type -> Type@ function over the @Type@-kinded type variables in--- of a type constructor.-type Map :: (Type -> Exp Type) -> Type -> Type-type family Map f a where-  Map p (t a b c d e f g) =-    t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e))-      (Eval (p f)) (Eval (p g))-  Map p (t a b c d e f) =-    t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e))-      (Eval (p f))-  Map p (t a b c d e) =-    t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e))-  Map p (t a b c d) = t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d))-  Map p (t a b c) = t (Eval (p a)) (Eval (p b)) (Eval (p c))-  Map p (t a b) = t (Eval (p a)) (Eval (p b))-  Map p (t a) = t (Eval (p a))
− src/Rel8/Generic/Record.hs 
@@ -1,154 +0,0 @@-{-# language AllowAmbiguousTypes #-}-{-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language MultiParamTypeClasses #-}-{-# language PolyKinds #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-}-{-# language TypeFamilies #-}-{-# language TypeOperators #-}-{-# language UndecidableInstances #-}--module Rel8.Generic.Record-  ( Record(..)-  , GRecordable, GRecord, grecord, gunrecord-  )-where---- base-import Data.Kind ( Constraint, Type )-import GHC.Generics-  ( Generic, Rep, from, to-  , (:+:)( L1, R1 ), (:*:)( (:*:) ), M1( M1 )-  , Meta( MetaCons, MetaSel ), D, C, S-  )-import GHC.TypeLits ( type (+), AppendSymbol, Div, Mod, Nat, Symbol )-import Prelude hiding ( Show )---type GRecord :: (Type -> Type) -> Type -> Type-type family GRecord rep where-  GRecord (M1 D meta rep) = M1 D meta (GRecord rep)-  GRecord (l :+: r) = GRecord l :+: GRecord r-  GRecord (M1 C ('MetaCons name fixity 'False) rep) =-    M1 C ('MetaCons name fixity 'True) (Snd (Count 0 rep))-  GRecord rep = rep---type Count :: Nat -> (Type -> Type) -> (Nat, Type -> Type)-type family Count n rep where-  Count n (M1 S ('MetaSel _selector su ss ds) rep) =-    '(n + 1, M1 S ('MetaSel ('Just (Show (n + 1))) su ss ds) rep)-  Count n (a :*: b) = CountHelper1 (Count n a) b-  Count n rep = '(n, rep)---type CountHelper1 :: (Nat, Type -> Type) -> (Type -> Type) -> (Nat, Type -> Type)-type family CountHelper1 tuple b where-  CountHelper1 '(n, a) b = CountHelper2 a (Count n b)---type CountHelper2 :: (Type -> Type) -> (Nat, Type -> Type) -> (Nat, Type -> Type)-type family CountHelper2 a tuple where-  CountHelper2 a '(n, b) = '(n, a :*: b)---type Show :: Nat -> Symbol-type Show n =-  AppendSymbol "_" (AppendSymbol (Show' (Div n 10)) (ShowDigit (Mod n 10)))---type Show' :: Nat -> Symbol-type family Show' n where-  Show' 0 = ""-  Show' n = AppendSymbol (Show' (Div n 10)) (ShowDigit (Mod n 10))---type ShowDigit :: Nat -> Symbol-type family ShowDigit n where-  ShowDigit 0 = "0"-  ShowDigit 1 = "1"-  ShowDigit 2 = "2"-  ShowDigit 3 = "3"-  ShowDigit 4 = "4"-  ShowDigit 5 = "5"-  ShowDigit 6 = "6"-  ShowDigit 7 = "7"-  ShowDigit 8 = "8"-  ShowDigit 9 = "9"---type Snd :: (a, b) -> b-type family Snd tuple where-  Snd '(_a, b) = b---type GRecordable :: (Type -> Type) -> Constraint-class GRecordable rep where-  grecord :: rep x -> GRecord rep x-  gunrecord :: GRecord rep x -> rep x---instance GRecordable rep => GRecordable (M1 D meta rep) where-  grecord (M1 a) = M1 (grecord a)-  gunrecord (M1 a) = M1 (gunrecord a)---instance (GRecordable l, GRecordable r) => GRecordable (l :+: r) where-  grecord (L1 a) = L1 (grecord a)-  grecord (R1 a) = R1 (grecord a)-  gunrecord (L1 a) = L1 (gunrecord a)-  gunrecord (R1 a) = R1 (gunrecord a)---instance Countable 0 rep =>-  GRecordable (M1 C ('MetaCons name fixity 'False) rep)- where-  grecord (M1 a) = M1 (count @0 a)-  gunrecord (M1 a) = M1 (uncount @0 a)---instance {-# OVERLAPPABLE #-} GRecord rep ~ rep => GRecordable rep where-  grecord = id-  gunrecord = id---type Countable :: Nat -> (Type -> Type) -> Constraint-class Countable n rep where-  count :: rep x -> Snd (Count n rep) x-  uncount :: Snd (Count n rep) x -> rep x---instance Countable n (M1 S ('MetaSel selector su ss ds) rep) where-  count (M1 a) = M1 a-  uncount (M1 a) = M1 a---instance-  ( Countable n a, Countable n' b-  , '(n', a') ~ Count n a-  , Snd (CountHelper2 a' (Count n' b)) ~ (a' :*: Snd (Count n' b))-  )-  => Countable n (a :*: b)- where-  count (a :*: b) = count @n a :*: count @n' b-  uncount (a :*: b) = uncount @n a :*: uncount @n' b---instance {-# OVERLAPPABLE #-} Snd (Count n rep) ~ rep => Countable n rep where-  count = id-  uncount = id---newtype Record a = Record-  { unrecord :: a-  }---instance (Generic a, GRecordable (Rep a)) => Generic (Record a) where-  type Rep (Record a) = GRecord (Rep a)--  from (Record a) = grecord (from a)-  to = Record . to . gunrecord
− src/Rel8/Generic/Rel8able.hs 
@@ -1,276 +0,0 @@-{-# language AllowAmbiguousTypes #-}-{-# language ConstraintKinds #-}-{-# language DataKinds #-}-{-# language DefaultSignatures #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language LambdaCase #-}-{-# language MultiParamTypeClasses #-}-{-# language PolyKinds #-}-{-# language QuantifiedConstraints #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-}-{-# language TypeFamilyDependencies #-}-{-# language TypeOperators #-}-{-# language UndecidableInstances #-}--module Rel8.Generic.Rel8able-  ( KRel8able, Rel8able-  , Algebra-  , GRep-  , GColumns, gfromColumns, gtoColumns-  , GFromExprs, gfromResult, gtoResult-  , TSerialize, serialize, deserialize-  )-where---- base-import Data.Functor.Identity ( Identity )-import Data.Kind ( Constraint, Type )-import Data.Type.Bool ( type (&&) )-import GHC.Generics ( Generic, Rep, from, to )-import Prelude---- rel8-import Rel8.Aggregate ( Aggregate )-import Rel8.Expr ( Expr )-import Rel8.FCF ( Exp, Eval )-import Rel8.Generic.Record ( Record(..) )-import Rel8.Generic.Table ( GAlgebra )-import qualified Rel8.Generic.Table.Record as G-import qualified Rel8.Kind.Algebra as K ( Algebra(..) )-import Rel8.Kind.Context ( SContext(..) )-import Rel8.Schema.Field ( Field )-import Rel8.Schema.HTable ( HTable )-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Name ( Name )-import Rel8.Schema.Result ( Result )-import Rel8.Table-  ( Table, Columns, Context, fromColumns, toColumns-  , FromExprs, fromResult, toResult-  , Transpose-  , TTable, TColumns-  )-import Rel8.Table.Transpose ( Transposes )----- | The kind of 'Rel8able' types-type KRel8able :: Type-type KRel8able = K.Rel8able----- This is almost 'Data.Type.Equality.==', but we add an extra case.-type (==) :: k -> k -> Bool-type family a == b where-  -- This extra case is needed to solve the equation "a == Identity a", -  -- which occurs when we have polymorphic Rel8ables -  -- (e.g., newtype T a f = T { x :: Column f a })-  a == Identity a = 'False-  -  -- These cases are exactly the same as those in 'Data.Type.Equality.==.-  f a == g b = f == g && a == b-  a == a = 'True-  _ == _ = 'False---type Serialize :: Bool -> Type -> Type -> Constraint-class transposition ~ (a == Transpose Result expr) =>-  Serialize transposition expr a- where-  serialize :: a -> Columns expr Result-  deserialize :: Columns expr Result -> a---instance-  ( (a == Transpose Result expr) ~ 'True-  , Transposes Expr Result expr a-  )-  => Serialize 'True expr a- where-  serialize = toColumns-  deserialize = fromColumns---instance-  ( (a == Transpose Result expr) ~ 'False-  , Table (Context expr) expr-  , FromExprs expr ~ a-  )-  => Serialize 'False expr a- where-  serialize = toResult @_ @expr-  deserialize = fromResult @_ @expr---data TSerialize :: Type -> Type -> Exp Constraint-type instance Eval (TSerialize expr a) =-  Serialize (a == Transpose Result expr) expr a----- | This type class allows you to define custom 'Table's using higher-kinded--- data types. Higher-kinded data types are data types of the pattern:------ @--- data MyType f =---   MyType { field1 :: Column f T1 OR HK1 f---          , field2 :: Column f T2 OR HK2 f---          , ...---          , fieldN :: Column f Tn OR HKn f---          }--- @------ where @Tn@ is any Haskell type, and @HKn@ is any higher-kinded type.------ That is, higher-kinded data are records where all fields in the record are--- all either of the type @Column f T@ (for any @T@), or are themselves--- higher-kinded data:------ [Nested]------ @--- data Nested f =---   Nested { nested1 :: MyType f---          , nested2 :: MyType f---          }--- @------ The @Rel8able@ type class is used to give us a special mapping operation--- that lets us change the type parameter @f@.------ [Supplying @Rel8able@ instances]------ This type class should be derived generically for all table types in your--- project. To do this, enable the @DeriveAnyType@ and @DeriveGeneric@ language--- extensions:------ @--- \{\-\# LANGUAGE DeriveAnyClass, DeriveGeneric #-\}------ data MyType f = MyType { fieldA :: Column f T }---   deriving ( GHC.Generics.Generic, Rel8able )--- @-type Rel8able :: K.Rel8able -> Constraint-class HTable (GColumns t) => Rel8able t where-  type GColumns t :: K.HTable-  type GFromExprs t :: Type--  gfromColumns :: SContext context -> GColumns t context -> t context-  gtoColumns :: SContext context -> t context -> GColumns t context--  gfromResult :: GColumns t Result -> GFromExprs t-  gtoResult :: GFromExprs t -> GColumns t Result--  type GColumns t = G.GColumns TColumns (GRep t Expr)-  type GFromExprs t = t Result--  default gfromColumns :: forall context.-    ( SRel8able t Aggregate-    , SRel8able t Expr-    , forall table. SRel8able t (Field table)-    , SRel8able t Name-    , SSerialize t-    )-    => SContext context -> GColumns t context -> t context-  gfromColumns = \case-    SAggregate -> sfromColumns-    SExpr -> sfromColumns-    SField -> sfromColumns-    SName -> sfromColumns-    SResult -> sfromResult--  default gtoColumns :: forall context.-    ( SRel8able t Aggregate-    , SRel8able t Expr-    , forall table. SRel8able t (Field table)-    , SRel8able t Name-    , SSerialize t-    )-    => SContext context -> t context -> GColumns t context-  gtoColumns = \case-    SAggregate -> stoColumns-    SExpr -> stoColumns-    SField -> stoColumns-    SName -> stoColumns-    SResult -> stoResult--  default gfromResult :: (SSerialize t, GFromExprs t ~ t Result)-    => GColumns t Result -> GFromExprs t-  gfromResult = sfromResult--  default gtoResult :: (SSerialize t, GFromExprs t ~ t Result)-    => GFromExprs t -> GColumns t Result-  gtoResult = stoResult---type Algebra :: K.Rel8able -> K.Algebra-type Algebra t = GAlgebra (GRep t Expr)---type GRep :: K.Rel8able -> K.Context -> Type -> Type-type GRep t context = Rep (Record (t context))---type SRel8able :: K.Rel8able -> K.Context -> Constraint-class-  ( Generic (Record (t context))-  , G.GTable (TTable context) TColumns (GRep t context)-  , G.GColumns TColumns (GRep t context) ~ GColumns t-  )-  => SRel8able t context-instance-  ( Generic (Record (t context))-  , G.GTable (TTable context) TColumns (GRep t context)-  , G.GColumns TColumns (GRep t context) ~ GColumns t-  )-  => SRel8able t context---type SSerialize :: K.Rel8able -> Constraint-type SSerialize t =-  ( Generic (Record (t Result))-  , G.GSerialize TSerialize TColumns (GRep t Expr) (GRep t Result)-  , G.GColumns TColumns (GRep t Expr) ~ GColumns t-  )---sfromColumns :: forall t context. SRel8able t context-  => GColumns t context -> t context-sfromColumns =-  unrecord .-  to .-  G.gfromColumns @(TTable context) @TColumns fromColumns---stoColumns :: forall t context. SRel8able t context-  => t context -> GColumns t context-stoColumns =-  G.gtoColumns @(TTable context) @TColumns toColumns .-  from .-  Record---sfromResult :: forall t. SSerialize t-  => GColumns t Result -> t Result-sfromResult =-  unrecord .-  to .-  G.gfromResult-    @TSerialize-    @TColumns-    @(GRep t Expr)-    @(GRep t Result)-    (\(_ :: proxy x) -> deserialize @_ @x)---stoResult :: forall t. SSerialize t-  => t Result -> GColumns t Result-stoResult =-  G.gtoResult-    @TSerialize-    @TColumns-    @(GRep t Expr)-    @(GRep t Result)-    (\(_ :: proxy x) -> serialize @_ @x) .-  from .-  Record
− src/Rel8/Generic/Table.hs 
@@ -1,103 +0,0 @@-{-# language AllowAmbiguousTypes #-}-{-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language MultiParamTypeClasses #-}-{-# language RankNTypes #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-}-{-# language TypeFamilies #-}-{-# language TypeOperators #-}-{-# language UndecidableInstances #-}--module Rel8.Generic.Table-  ( GGSerialize, GGColumns, ggfromResult, ggtoResult-  , GAlgebra-  )-where---- base-import Data.Kind ( Constraint, Type )-import GHC.Generics ( (:+:), (:*:), K1, M1, U1, V1 )-import Prelude ()---- rel8-import Rel8.FCF ( Eval, Exp )-import Rel8.Generic.Table.ADT-  ( GSerializeADT, GColumnsADT, gtoResultADT, gfromResultADT-  )-import Rel8.Generic.Table.Record ( GSerialize, GColumns, gtoResult, gfromResult )-import Rel8.Kind.Algebra-  ( Algebra( Product, Sum )-  , SAlgebra( SProduct, SSum )-  , KnownAlgebra, algebraSing-  )-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Result ( Result )---data GGSerialize-  :: Algebra-  -> (Type -> Type -> Exp Constraint)-  -> (Type -> Exp K.HTable)-  -> (Type -> Type)-  -> (Type -> Type)-  -> Exp Constraint---type instance Eval (GGSerialize 'Product _Serialize _Columns exprs rep) =-  GSerialize _Serialize _Columns exprs rep---type instance Eval (GGSerialize 'Sum _Serialize _Columns exprs rep) =-  GSerializeADT _Serialize _Columns exprs rep---data GGColumns-  :: Algebra-  -> (Type -> Exp K.HTable)-  -> (Type -> Type)-  -> Exp K.HTable---type instance Eval (GGColumns 'Product _Columns rep) = GColumns _Columns rep---type instance Eval (GGColumns 'Sum _Columns rep) = GColumnsADT _Columns rep---type GAlgebra :: (Type -> Type) -> Algebra-type family GAlgebra rep where-  GAlgebra (M1 _ _ rep) = GAlgebra rep-  GAlgebra V1 = 'Sum-  GAlgebra (_ :+: _) = 'Sum-  GAlgebra U1 = 'Sum-  GAlgebra (_ :*: _) = 'Product-  GAlgebra (K1 _ _) = 'Product---ggfromResult :: forall algebra _Serialize _Columns exprs rep x.-  ( KnownAlgebra algebra-  , Eval (GGSerialize algebra _Serialize _Columns exprs rep)-  )-  => (forall expr a proxy. Eval (_Serialize expr a)-      => proxy expr -> Eval (_Columns expr) Result -> a)-  -> Eval (GGColumns algebra _Columns exprs) Result-  -> rep x-ggfromResult f x = case algebraSing @algebra of-  SProduct -> gfromResult @_Serialize @_Columns @exprs @rep f x-  SSum -> gfromResultADT @_Serialize @_Columns @exprs @rep f x---ggtoResult :: forall algebra _Serialize _Columns exprs rep x.-  ( KnownAlgebra algebra-  , Eval (GGSerialize algebra _Serialize _Columns exprs rep)-  )-  => (forall expr a proxy. Eval (_Serialize expr a)-      => proxy expr -> a -> Eval (_Columns expr) Result)-  -> rep x-  -> Eval (GGColumns algebra _Columns exprs) Result-ggtoResult f x = case algebraSing @algebra of-  SProduct -> gtoResult @_Serialize @_Columns @exprs @rep f x-  SSum -> gtoResultADT @_Serialize @_Columns @exprs @rep f x
− src/Rel8/Generic/Table/ADT.hs 
@@ -1,221 +0,0 @@-{-# language AllowAmbiguousTypes #-}-{-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language LambdaCase #-}-{-# language MultiParamTypeClasses #-}-{-# language RankNTypes #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-}-{-# language TypeFamilies #-}-{-# language TypeOperators #-}-{-# language UndecidableInstances #-}--module Rel8.Generic.Table.ADT-  ( GSerializeADT, GColumnsADT, gfromResultADT, gtoResultADT-  , GSerializeADT', GColumnsADT'-  )-where---- base-import Data.Functor.Identity ( Identity( Identity ) )-import Data.Kind ( Constraint, Type )-import Data.Proxy ( Proxy( Proxy ) )-import GHC.Generics-  ( (:+:)( L1, R1 ), M1( M1 ), U1( U1 )-  , C, D-  , Meta( MetaCons )-  )-import GHC.TypeLits ( KnownSymbol, symbolVal )-import Prelude hiding ( null )---- rel8-import Rel8.FCF ( Eval, Exp )-import Rel8.Generic.Table.Record ( GSerialize, GColumns, gfromResult, gtoResult )-import Rel8.Schema.HTable ( HTable )-import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )-import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )-import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify )-import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Result ( Result, null, nullifier, unnullifier )-import Rel8.Type.Tag ( Tag( Tag ) )---- text-import Data.Text ( pack )---type GColumnsADT-  :: (Type -> Exp K.HTable)-  -> (Type -> Type) -> K.HTable-type family GColumnsADT _Columns rep where-  GColumnsADT _Columns (M1 D _ rep) =-    GColumnsADT' _Columns (HLabel "tag" (HIdentity Tag)) rep---type GColumnsADT'-  :: (Type -> Exp K.HTable)-  -> K.HTable -> (Type -> Type) -> K.HTable-type family GColumnsADT' _Columns htable rep  where-  GColumnsADT' _Columns htable (a :+: b) =-    GColumnsADT' _Columns (GColumnsADT' _Columns htable a) b-  GColumnsADT' _Columns htable (M1 C ('MetaCons _ _ _) U1) = htable-  GColumnsADT' _Columns htable (M1 C ('MetaCons label _ _) rep) =-    HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))---type GSerializeADT-  :: (Type -> Type -> Exp Constraint)-  -> (Type -> Exp K.HTable)-  -> (Type -> Type) -> (Type -> Type) -> Constraint-class GSerializeADT _Serialize _Columns exprs rep where-  gfromResultADT :: ()-    => (forall expr a proxy. Eval (_Serialize expr a)-        => proxy expr -> Eval (_Columns expr) Result -> a)-    -> GColumnsADT _Columns exprs Result-    -> rep x--  gtoResultADT :: ()-    => (forall expr a proxy. Eval (_Serialize expr a)-        => proxy expr -> a -> Eval (_Columns expr) Result)-    -> rep x-    -> GColumnsADT _Columns exprs Result---instance-  ( htable ~ HLabel "tag" (HIdentity Tag)-  , GSerializeADT' _Serialize _Columns htable exprs rep-  )-  => GSerializeADT _Serialize _Columns (M1 D meta exprs) (M1 D meta rep)- where-  gfromResultADT fromResult columns =-    case gfromResultADT' @_Serialize @_Columns @htable @exprs @rep fromResult tag columns of-      Just rep -> M1 rep-      _ -> error "ADT.fromColumns: mismatch between tag and data"-    where-      tag = (\(HIdentity (Identity a)) -> a) . hunlabel @"tag"--  gtoResultADT toResult (M1 rep) =-    gtoResultADT' @_Serialize @_Columns @htable @exprs @rep toResult tag (Just rep)-    where-      tag = hlabel @"tag" . HIdentity . Identity---type GSerializeADT'-  :: (Type -> Type -> Exp Constraint)-  -> (Type -> Exp K.HTable)-  -> K.HTable -> (Type -> Type) -> (Type -> Type) -> Constraint-class GSerializeADT' _Serialize _Columns htable exprs rep where-  gfromResultADT' :: context ~ Result-    => (forall expr a proxy. Eval (_Serialize expr a)-        => proxy expr -> Eval (_Columns expr) context -> a)-    -> (htable Result -> Tag)-    -> GColumnsADT' _Columns htable exprs context-    -> Maybe (rep x)--  gtoResultADT' :: context ~ Result-    => (forall expr a proxy. Eval (_Serialize expr a)-        => proxy expr -> a -> Eval (_Columns expr) context)-    -> (Tag -> htable Result)-    -> Maybe (rep x)-    -> GColumnsADT' _Columns htable exprs context--  extract :: GColumnsADT' _Columns htable exprs context -> htable context---instance-  ( htable' ~ GColumnsADT' _Columns htable exprs1-  , GSerializeADT' _Serialize _Columns htable exprs1 a-  , GSerializeADT' _Serialize _Columns htable' exprs2 b-  )-  => GSerializeADT' _Serialize _Columns htable (exprs1 :+: exprs2) (a :+: b)- where-  gfromResultADT' fromResult f columns =-    case ma of-      Just a -> Just (L1 a)-      Nothing -> R1 <$>-        gfromResultADT' @_Serialize @_Columns @_ @exprs2 @b-          fromResult-          (f . extract @_Serialize @_Columns @_ @exprs1 @a)-          columns-    where-      ma =-        gfromResultADT' @_Serialize @_Columns @_ @exprs1 @a-          fromResult-          f-          (extract @_Serialize @_Columns @_ @exprs2 @b columns)--  gtoResultADT' toResult tag = \case-    Just (L1 a) ->-      gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b-        toResult-        (\_ -> gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a-          toResult-          tag-          (Just a))-        Nothing-    Just (R1 b) ->-      gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b-        toResult-        (\tag' ->-          gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a-            toResult-            (\_ -> tag tag')-            Nothing)-        (Just b)-    Nothing ->-      gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b-        toResult-        (\_ -> gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a toResult tag Nothing)-        Nothing--  extract =-    extract @_Serialize @_Columns @_ @exprs1 @a .-    extract @_Serialize @_Columns @_ @exprs2 @b---instance (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) =>-  GSerializeADT' _Serialize _Columns _htable (M1 C meta U1) (M1 C meta U1)- where-  gfromResultADT' _ tag columns-    | tag columns == tag' = Just (M1 U1)-    | otherwise = Nothing-    where-      tag' = Tag $ pack $ symbolVal (Proxy @label)--  gtoResultADT' _ tag _ = tag tag'-    where-      tag' = Tag $ pack $ symbolVal (Proxy @label)--  extract = id---instance {-# OVERLAPPABLE #-}-  ( HTable (GColumns _Columns exprs)-  , GSerialize _Serialize _Columns exprs rep-  , meta ~ 'MetaCons label _fixity _isRecord-  , KnownSymbol label-  , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) exprs) ~-      HProduct htable (HLabel label (HNullify (GColumns _Columns exprs)))-  )-  => GSerializeADT' _Serialize _Columns htable (M1 C meta exprs) (M1 C meta rep)- where-  gfromResultADT' fromResult tag (HProduct a b)-    | tag a == tag' =-        M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult <$>-          hunnullify unnullifier (hunlabel b)-    | otherwise = Nothing-    where-      tag' = Tag $ pack $ symbolVal (Proxy @label)--  gtoResultADT' toResult tag = \case-    Nothing -> HProduct (tag tag') (hlabel (hnulls (const null)))-    Just (M1 rep) -> HProduct (tag tag') $-      hlabel $-      hnullify nullifier $-      gtoResult @_Serialize @_Columns @exprs @rep toResult rep-    where-      tag' = Tag $ pack $ symbolVal (Proxy @label)--  extract (HProduct a _) = a
− src/Rel8/Generic/Table/Record.hs 
@@ -1,181 +0,0 @@-{-# language AllowAmbiguousTypes #-}-{-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language MultiParamTypeClasses #-}-{-# language PolyKinds #-}-{-# language RankNTypes #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-}-{-# language TypeFamilies #-}-{-# language TypeOperators #-}-{-# language UndecidableInstances #-}--module Rel8.Generic.Table.Record-  ( GTable, GColumns, GContext, gfromColumns, gtoColumns, gtable-  , GSerialize, gfromResult, gtoResult-  )-where---- base-import Data.Kind ( Constraint, Type )-import Data.Proxy ( Proxy( Proxy ) )-import GHC.Generics-  ( (:*:)( (:*:) ), K1( K1 ), M1( M1 )-  , C, D, S-  , Meta( MetaSel )-  )-import Prelude hiding ( null )---- rel8-import Rel8.FCF ( Eval, Exp )-import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )-import Rel8.Schema.HTable.Product ( HProduct(..) )-import qualified Rel8.Schema.Kind as K---type GColumns :: (Type -> Exp K.HTable) -> (Type -> Type) -> K.HTable-type family GColumns _Columns rep where-  GColumns _Columns (M1 D _ rep) = GColumns _Columns rep-  GColumns _Columns (M1 C _ rep) = GColumns _Columns rep-  GColumns _Columns (rep1 :*: rep2) =-    HProduct (GColumns _Columns rep1) (GColumns _Columns rep2)-  GColumns _Columns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ a)) =-    HLabel label (Eval (_Columns a))---type GContext :: (Type -> Exp K.Context) -> (Type -> Type) -> K.Context-type family GContext _Context rep where-  GContext _Context (M1 _ _ rep) = GContext _Context rep-  GContext _Context (rep1 :*: _rep2) = GContext _Context rep1-  GContext _Context (K1 _ a) = Eval (_Context a)---type GTable-  :: (Type -> Exp Constraint)-  -> (Type -> Exp K.HTable)-  -> (Type -> Type) -> Constraint-class GTable _Table _Columns rep- where-  gfromColumns :: ()-    => (forall a. Eval (_Table a) => Eval (_Columns a) context -> a)-    -> GColumns _Columns rep context-    -> rep x--  gtoColumns :: ()-    => (forall a. Eval (_Table a) => a -> Eval (_Columns a) context)-    -> rep x-    -> GColumns _Columns rep context--  gtable :: ()-    => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)-    -> GColumns _Columns rep context---type GSerialize-  :: (Type -> Type -> Exp Constraint)-  -> (Type -> Exp K.HTable)-  -> (Type -> Type) -> (Type -> Type) -> Constraint-class GSerialize _Serialize _Columns exprs rep- where-  gfromResult :: ()-    => (forall expr a proxy. Eval (_Serialize expr a)-        => proxy expr -> Eval (_Columns expr) context -> a)-    -> GColumns _Columns exprs context-    -> rep x--  gtoResult :: ()-    => (forall expr a proxy. Eval (_Serialize expr a)-        => proxy expr -> a -> Eval (_Columns expr) context)-    -> rep x-    -> GColumns _Columns exprs context---instance GTable _Table _Columns rep => GTable _Table _Columns (M1 D c rep)- where-  gfromColumns fromColumns =-    M1 . gfromColumns @_Table @_Columns @rep fromColumns-  gtoColumns toColumns (M1 a) =-    gtoColumns @_Table @_Columns @rep toColumns a-  gtable = gtable @_Table @_Columns @rep---instance GSerialize _Serialize _Columns exprs rep =>-  GSerialize _Serialize _Columns (M1 D c exprs) (M1 D c rep)- where-  gfromResult fromResult =-    M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult-  gtoResult toResult (M1 a) =-    gtoResult @_Serialize @_Columns @exprs @rep toResult a---instance GTable _Table _Columns rep => GTable _Table _Columns (M1 C c rep)- where-  gfromColumns fromColumns =-    M1 . gfromColumns @_Table @_Columns @rep fromColumns-  gtoColumns toColumns (M1 a) =-    gtoColumns @_Table @_Columns @rep toColumns a-  gtable = gtable @_Table @_Columns @rep---instance GSerialize _Serialize _Columns exprs rep =>-  GSerialize _Serialize _Columns (M1 C c exprs) (M1 C c rep)- where-  gfromResult fromResult =-    M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult-  gtoResult toResult (M1 a) =-    gtoResult @_Serialize @_Columns @exprs @rep toResult a---instance (GTable _Table _Columns rep1, GTable _Table _Columns rep2) =>-  GTable _Table _Columns (rep1 :*: rep2)- where-  gfromColumns fromColumns (HProduct a b) =-    gfromColumns @_Table @_Columns @rep1 fromColumns a :*:-    gfromColumns @_Table @_Columns @rep2 fromColumns b-  gtoColumns toColumns (a :*: b) = HProduct-    (gtoColumns @_Table @_Columns @rep1 toColumns a)-    (gtoColumns @_Table @_Columns @rep2 toColumns b)-  gtable table = HProduct-    (gtable @_Table @_Columns @rep1 table)-    (gtable @_Table @_Columns @rep2 table)---instance-  ( GSerialize _Serialize _Columns expr1 rep1-  , GSerialize _Serialize _Columns expr2 rep2-  )-  => GSerialize _Serialize _Columns (expr1 :*: expr2) (rep1 :*: rep2)- where-  gfromResult fromResult (HProduct a b) =-    gfromResult @_Serialize @_Columns @expr1 @rep1 fromResult a :*:-    gfromResult @_Serialize @_Columns @expr2 @rep2 fromResult b-  gtoResult toResult (a :*: b) =-    HProduct-      (gtoResult @_Serialize @_Columns @expr1 @rep1 toResult a)-      (gtoResult @_Serialize @_Columns @expr2 @rep2 toResult b)---instance-  ( Eval (_Table a)-  , meta ~ 'MetaSel ('Just label) _su _ss _ds-  , k1 ~ K1 i a-  )-  => GTable _Table _Columns (M1 S meta k1)- where-  gfromColumns fromColumns = M1 . K1 . fromColumns . hunlabel-  gtoColumns toColumns (M1 (K1 a)) = hlabel (toColumns a)-  gtable table = hlabel (table (Proxy @a))---instance-  ( Eval (_Serialize expr a)-  , meta ~ 'MetaSel ('Just label) _su _ss _ds-  , k1 ~ K1 i expr-  , k1' ~ K1 i a-  )-  => GSerialize _Serialize _Columns (M1 S meta k1) (M1 S meta k1')- where-  gfromResult fromResult = M1 . K1 . fromResult (Proxy @expr) . hunlabel-  gtoResult toResult (M1 (K1 a)) = hlabel (toResult (Proxy @expr) a)
− src/Rel8/Kind/Algebra.hs 
@@ -1,38 +0,0 @@-{-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language GADTs #-}-{-# language StandaloneKindSignatures #-}--module Rel8.Kind.Algebra-  ( Algebra( Product, Sum )-  , SAlgebra( SProduct, SSum )-  , KnownAlgebra( algebraSing )-  )-where---- base-import Data.Kind ( Constraint, Type )-import Prelude ()---type Algebra :: Type-data Algebra = Product | Sum---type SAlgebra :: Algebra -> Type-data SAlgebra algebra where-  SProduct :: SAlgebra 'Product-  SSum :: SAlgebra 'Sum---type KnownAlgebra :: Algebra -> Constraint-class KnownAlgebra algebra where-  algebraSing :: SAlgebra algebra---instance KnownAlgebra 'Product where-  algebraSing = SProduct---instance KnownAlgebra 'Sum where-  algebraSing = SSum
− src/Rel8/Kind/Context.hs 
@@ -1,56 +0,0 @@-{-# language DataKinds #-}-{-# language GADTs #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeSynonymInstances #-}--module Rel8.Kind.Context-  ( Reifiable( contextSing )-  , SContext(..)-  )-where---- base-import Data.Kind ( Constraint, Type )-import Prelude ()---- rel8-import Rel8.Aggregate ( Aggregate )-import Rel8.Expr ( Expr )-import Rel8.Schema.Field ( Field )-import Rel8.Schema.Kind ( Context )-import Rel8.Schema.Name ( Name )-import Rel8.Schema.Result ( Result )---type SContext :: Context -> Type-data SContext context where-  SAggregate :: SContext Aggregate-  SExpr :: SContext Expr-  SField :: SContext (Field table)-  SName :: SContext Name-  SResult :: SContext Result---type Reifiable :: Context -> Constraint-class Reifiable context where-  contextSing :: SContext context---instance Reifiable Aggregate where-  contextSing = SAggregate---instance Reifiable Expr where-  contextSing = SExpr---instance Reifiable (Field table) where-  contextSing = SField---instance Reifiable Result where-  contextSing = SResult---instance Reifiable Name where-  contextSing = SName
− src/Rel8/Order.hs 
@@ -1,37 +0,0 @@-{-# language DerivingStrategies #-}-{-# language GeneralizedNewtypeDeriving #-}-{-# language StandaloneKindSignatures #-}--module Rel8.Order-  ( Order(..)-  , toOrderExprs-  )-where---- base-import Data.Functor.Contravariant ( Contravariant )-import Data.Kind ( Type )-import Prelude---- contravariant-import Data.Functor.Contravariant.Divisible ( Decidable, Divisible )---- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye-import qualified Opaleye.Internal.Order as Opaleye----- | An ordering expression for @a@. Primitive orderings are defined with--- 'Rel8.asc' and 'Rel8.desc', and you can combine @Order@ via its various--- instances.------ A common pattern is to use '<>' to combine multiple orderings in sequence,--- and 'Data.Functor.Contravariant.>$<' to select individual columns.-type Order :: Type -> Type-newtype Order a = Order (Opaleye.Order a)-  deriving newtype (Contravariant, Divisible, Decidable, Semigroup, Monoid)---toOrderExprs :: Order a -> a -> [Opaleye.OrderExpr]-toOrderExprs (Order (Opaleye.Order order)) a =-  uncurry Opaleye.OrderExpr <$> order a
− src/Rel8/Query.hs 
@@ -1,210 +0,0 @@-{-# language StandaloneKindSignatures #-}--module Rel8.Query-  ( Query( Query )-  )-where---- base-import Control.Applicative ( liftA2 )-import Control.Monad ( liftM2 )-import Data.Kind ( Type )-import Data.Monoid ( Any( Any ) )-import Prelude---- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye-import qualified Opaleye.Internal.PackMap as Opaleye-import qualified Opaleye.Internal.PrimQuery as Opaleye-import qualified Opaleye.Internal.QueryArr as Opaleye-import qualified Opaleye.Internal.Tag as Opaleye---- rel8-import Rel8.Query.Set ( unionAll )-import Rel8.Query.Opaleye ( fromOpaleye )-import Rel8.Query.Values ( values )-import Rel8.Table ( fromColumns, toColumns )-import Rel8.Table.Alternative-  ( AltTable, (<|>:)-  , AlternativeTable, emptyTable-  )-import Rel8.Table.Projection ( Projectable, apply, project )---- semigroupoids-import Data.Functor.Apply ( Apply, (<.>) )-import Data.Functor.Bind ( Bind, (>>-) )----- | The @Query@ monad allows you to compose a @SELECT@ query. This monad has--- semantics similar to the list (@[]@) monad.-type Query :: Type -> Type-newtype Query a =-  Query (-    -- This is based on Opaleye's Select monad, but with two addtions. We-    -- maintain a stack of PrimExprs from parent previous subselects. In-    -- practice, these are always the results of dummy calls to random().-    ---    -- We also return a Bool that indicates to the parent subselect whether-    -- or not that stack of PrimExprs were used at any point. If they weren't,-    -- then the call to random() is never added to the query.-    ---    -- This is all needed to implement evaluate. Consider the following code:-    ---    -- do-    --   x <- values [lit 'a', lit 'b', lit 'c']-    --   y <- evaluate $ nextval "user_id_seq"-    --   pure (x, y)-    ---    -- If we just used Opaleye's Select monad directly, the SQL would come out-    -- like this:-    ---    -- SELECT-    --   a, b-    -- FROM-    --   (VALUES ('a'), ('b'), ('c')) Q1(a),-    --   LATERAL (SELECT nextval('user_id_seq')) Q2(b);-    ---    -- From the Haskell code, you would intuitively expect to get back the-    -- results of three different calls to nextval(), but from Postgres' point-    -- of view, because the Q2 subquery doesn't reference anything from the Q1-    -- query, it thinks it only needs to call nextval() once. This is actually-    -- exactly the same problem you get with the deprecated ListT IO monad from-    -- the transformers package — *> behaves differently to >>=, so-    -- using ApplicativeDo can change the results of a program. ApplicativeDo-    -- is exactly the optimisation Postgres does on a "LATERAL" query that-    -- doesn't make any references to previous subselects.-    ---    -- Rel8's solution is generate the following SQL instead:-    ---    -- SELECT-    --   a, b-    -- FROM-    --   (SELECT-    --      random() AS dummy,-    --      *-    --    FROM-    --      (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1,-    --   LATERAL (SELECT-    --     CASE-    --       WHEN dummy IS NOT NULL-    --       THEN nextval('user_id_seq')-    --     END) Q2(b);-    ---    -- We use random() here as the dummy value (and not some constant) because-    -- Postgres will again optimize if it sees that a value is constant-    -- (and thus only call nextval() once), but because random() is marked as-    -- VOLATILE, this inhibits Postgres from doing that optimisation.-    ---    -- Why not just reference the a column from the previous query directly-    -- instead of adding a dummy value? Basically, even if we extract out all-    -- the bindings introduced in a PrimQuery, we can't always be sure which-    -- ones refer to constant values, so if we end up laterally referencing a-    -- constant value, then all of this would be for nothing.-    ---    -- Why not just add the call to the previous subselect directly, like so:-    ---    -- SELECT-    --   a, b-    -- FROM-    --   (SELECT-    --      nextval('user_id_seq') AS eval,-    --      *-    --    FROM-    --      (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1,-    --   LATERAL (SELECT eval) Q2(b);-    ---    -- That would work in this case. But consider the following Rel8 code:-    ---    -- do-    --   x <- values [lit 'a', lit 'b', lit 'c']-    --   y <- values [lit 'd', lit 'e', lit 'f']-    --   z <- evaluate $ nextval "user_id_seq"-    --   pure (x, y, z)-    ---    -- How many calls to nextval should there be? Our Haskell intuition says-    -- nine. But that's not what you would get if you used the above-    -- technique. The problem is, which VALUES query should the nextval be-    -- added to? You can choose one or the other to get three calls to-    -- nextval, but you still need to make a superfluous LATERAL references to-    -- the other if you want nine calls. So for the above Rel8 code we generate-    -- the following SQL:-    ---    -- SELECT-    --   a, b, c-    -- FROM-    --   (SELECT-    --      random() AS dummy,-    --      *-    --    FROM-    --      (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1,-    --   (SELECT-    --      random() AS dummy,-    --      *-    --    FROM-    --      (VALUES ('d'), ('e'), ('f')) Q2(b)) Q2,-    --   LATERAL (SELECT-    --     CASE-    --       WHEN Q1.dummy IS NOT NULL AND Q2.dummy IS NOT NULL-    --       THEN nextval('user_id_seq')-    --     END) Q3(c);-    ---    -- This gives nine calls to nextval() as we would expect.-    [Opaleye.PrimExpr] -> Opaleye.Select (Any, a)-  )---instance Projectable Query where-  project f = fmap (fromColumns . apply f . toColumns)---instance Functor Query where-  fmap f (Query a) = Query (fmap (fmap (fmap f)) a)---instance Apply Query where-  (<.>) = (<*>)---instance Applicative Query where-  pure = fromOpaleye . pure-  liftA2 = liftM2---instance Bind Query where-  (>>-) = (>>=)---instance Monad Query where-  Query q >>= f = Query $ \dummies -> Opaleye.QueryArr $ \(_, tag) ->-    let-      Opaleye.QueryArr qa = q dummies-      ((m, a), query, tag') = qa ((), tag)-      Query q' = f a-      (dummies', query', tag'') =-        ( dummy : dummies-        , \lateral -> Opaleye.Rebind True bindings . query lateral-        , Opaleye.next tag'-        )-        where-          (dummy, bindings) = Opaleye.run $ name random-            where-              random = Opaleye.FunExpr "random" []-              name = Opaleye.extractAttr "dummy" tag'-      Opaleye.QueryArr qa' = Opaleye.lateral $ \_ -> q' dummies'-      ((m'@(Any needsDummies), b), query'', tag''') = qa' ((), tag'')-      query'''-        | needsDummies = \lateral -> query'' lateral . query' lateral-        | otherwise = \lateral -> query'' lateral . query lateral-      m'' = m <> m'-    in-      ((m'', b), query''', tag''')----- | '<|>:' = 'unionAll'.-instance AltTable Query where-  (<|>:) = unionAll----- | 'emptyTable' = 'values' @[]@.-instance AlternativeTable Query where-  emptyTable = values []
− src/Rel8/Query.hs-boot 
@@ -1,19 +0,0 @@-{-# language StandaloneKindSignatures #-}--module Rel8.Query-  ( Query( Query )-  )-where---- base-import Data.Kind ( Type )-import Data.Monoid ( Any )-import Prelude ()---- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye-import qualified Opaleye.Select as Opaleye---type Query :: Type -> Type-newtype Query a = Query ([Opaleye.PrimExpr] -> Opaleye.Select (Any, a))
− src/Rel8/Query/Aggregate.hs 
@@ -1,37 +0,0 @@-{-# language FlexibleContexts #-}-{-# language MonoLocalBinds #-}--module Rel8.Query.Aggregate-  ( aggregate-  , countRows-  )-where---- base-import Data.Int ( Int64 )-import Prelude---- opaleye-import qualified Opaleye.Aggregate as Opaleye---- rel8-import Rel8.Aggregate ( Aggregates )-import Rel8.Expr ( Expr )-import Rel8.Expr.Aggregate ( countStar )-import Rel8.Query ( Query )-import Rel8.Query.Maybe ( optional )-import Rel8.Query.Opaleye ( mapOpaleye )-import Rel8.Table.Opaleye ( aggregator )-import Rel8.Table.Maybe ( maybeTable )----- | Apply an aggregation to all rows returned by a 'Query'.-aggregate :: Aggregates aggregates exprs => Query aggregates -> Query exprs-aggregate = mapOpaleye (Opaleye.aggregate aggregator)----- | Count the number of rows returned by a query. Note that this is different--- from @countStar@, as even if the given query yields no rows, @countRows@--- will return @0@.-countRows :: Query a -> Query (Expr Int64)-countRows = fmap (maybeTable 0 id) . optional . aggregate . fmap (const countStar)
− src/Rel8/Query/Distinct.hs 
@@ -1,45 +0,0 @@-{-# options_ghc -fno-warn-redundant-constraints #-}--module Rel8.Query.Distinct-  ( distinct-  , distinctOn-  , distinctOnBy-  )-where---- base-import Prelude---- opaleye-import qualified Opaleye.Distinct as Opaleye hiding ( distinctOn, distinctOnBy )-import qualified Opaleye.Internal.Order as Opaleye-import qualified Opaleye.Internal.QueryArr as Opaleye---- rel8-import Rel8.Order ( Order( Order ) )-import Rel8.Query ( Query )-import Rel8.Query.Opaleye ( mapOpaleye )-import Rel8.Table.Eq ( EqTable )-import Rel8.Table.Opaleye ( distinctspec, unpackspec )----- | Select all distinct rows from a query, removing duplicates.  @distinct q@--- is equivalent to the SQL statement @SELECT DISTINCT q@.-distinct :: EqTable a => Query a -> Query a-distinct = mapOpaleye (Opaleye.distinctExplicit distinctspec)----- | Select all distinct rows from a query, where rows are equivalent according--- to a projection. If multiple rows have the same projection, it is--- unspecified which row will be returned. If this matters, use 'distinctOnBy'.-distinctOn :: EqTable b => (a -> b) -> Query a -> Query a-distinctOn proj =-  mapOpaleye (\q -> Opaleye.productQueryArr (Opaleye.distinctOn unpackspec proj . Opaleye.runSimpleQueryArr q))----- | Select all distinct rows from a query, where rows are equivalent according--- to a projection. If there are multiple rows with the same projection, the--- first row according to the specified 'Order' will be returned.-distinctOnBy :: EqTable b => (a -> b) -> Order a -> Query a -> Query a-distinctOnBy proj (Order order) =-  mapOpaleye (\q -> Opaleye.productQueryArr (Opaleye.distinctOnBy unpackspec proj order . Opaleye.runSimpleQueryArr q))
− src/Rel8/Query/Each.hs 
@@ -1,32 +0,0 @@-{-# language FlexibleContexts #-}-{-# language MonoLocalBinds #-}--module Rel8.Query.Each-  ( each-  )-where---- base-import Prelude---- opaleye-import qualified Opaleye.Table as Opaleye---- rel8-import Rel8.Query ( Query )-import Rel8.Query.Opaleye ( fromOpaleye )-import Rel8.Schema.Name ( Selects )-import Rel8.Schema.Table ( TableSchema )-import Rel8.Table.Cols ( fromCols, toCols )-import Rel8.Table.Opaleye ( table, unpackspec )----- | Select each row from a table definition. This is equivalent to @FROM--- table@.-each :: Selects names exprs => TableSchema names -> Query exprs-each =-  fmap fromCols .-  fromOpaleye .-  Opaleye.selectTableExplicit unpackspec .-  table .-  fmap toCols
− src/Rel8/Query/Either.hs 
@@ -1,69 +0,0 @@-{-# language FlexibleContexts #-}--module Rel8.Query.Either-  ( keepLeftTable-  , keepRightTable-  , bitraverseEitherTable-  )-where---- base-import Prelude---- comonad-import Control.Comonad ( extract )---- rel8-import Rel8.Expr ( Expr )-import Rel8.Expr.Eq ( (==.) )-import Rel8.Query ( Query )-import Rel8.Query.Filter ( where_ )-import Rel8.Query.Maybe ( optional )-import Rel8.Table.Either-  ( EitherTable( EitherTable )-  , isLeftTable, isRightTable-  )-import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )----- | Filter 'EitherTable's, keeping only 'leftTable's.-keepLeftTable :: EitherTable Expr a b -> Query a-keepLeftTable e@(EitherTable _ a _) = do-  where_ $ isLeftTable e-  pure (extract a)----- | Filter 'EitherTable's, keeping only 'rightTable's.-keepRightTable :: EitherTable Expr a b -> Query b-keepRightTable e@(EitherTable _ _ b) = do-  where_ $ isRightTable e-  pure (extract b)----- | @bitraverseEitherTable f g x@ will pass all @leftTable@s through @f@ and--- all @rightTable@s through @g@. The results are then lifted back into--- @leftTable@ and @rightTable@, respectively. This is similar to 'bitraverse'--- for 'Either'.------ For example,------ >>> :{--- select do---   x <- values (map lit [ Left True, Right (42 :: Int32) ])---   bitraverseEitherTable (\y -> values [y, not_ y]) (\y -> pure (y * 100)) x--- :}--- [ Left True--- , Left False--- , Right 4200--- ]-bitraverseEitherTable :: ()-  => (a -> Query c)-  -> (b -> Query d)-  -> EitherTable Expr a b-  -> Query (EitherTable Expr c d)-bitraverseEitherTable f g e@(EitherTable tag _ _) = do-  mc@(MaybeTable _ c) <- optional (f =<< keepLeftTable e)-  md@(MaybeTable _ d) <- optional (g =<< keepRightTable e)-  where_ $ isJustTable mc ==. isLeftTable e-  where_ $ isJustTable md ==. isRightTable e-  pure $ EitherTable tag c d
− src/Rel8/Query/Evaluate.hs 
@@ -1,49 +0,0 @@-{-# language FlexibleContexts #-}-{-# language TupleSections #-}--module Rel8.Query.Evaluate-  ( evaluate-  )-where---- base-import Control.Monad ( (>=>) )-import Data.Foldable ( foldl' )-import Data.List.NonEmpty ( NonEmpty( (:|) ), nonEmpty )-import Data.Monoid ( Any( Any ) )-import Prelude hiding ( undefined )---- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye---- rel8-import Rel8.Expr ( Expr )-import Rel8.Expr.Bool ( (&&.) )-import Rel8.Expr.Opaleye ( fromPrimExpr )-import Rel8.Query ( Query( Query ) )-import Rel8.Query.Rebind ( rebind )-import Rel8.Table ( Table )-import Rel8.Table.Bool ( case_ )-import Rel8.Table.Undefined ( undefined )----- | 'evaluate' takes expressions that could potentially have side effects and--- \"runs\" them in the 'Query' monad. The returned expressions have no side--- effects and can safely be reused.-evaluate :: Table Expr a => a -> Query a-evaluate = laterally >=> rebind "eval"---laterally :: Table Expr a => a -> Query a-laterally a = Query $ \bindings -> pure $ (Any True,) $-  case nonEmpty bindings of-    Nothing -> a-    Just bindings' -> case_ [(condition, a)] undefined-      where-        condition = foldl1' (&&.) (fmap go bindings')-          where-            go = fromPrimExpr . Opaleye.UnExpr Opaleye.OpIsNotNull---foldl1' :: (a -> a -> a) -> NonEmpty a -> a-foldl1' f (a :| as) = foldl' f a as
− src/Rel8/Query/Exists.hs 
@@ -1,66 +0,0 @@-{-# language DataKinds #-}--module Rel8.Query.Exists-  ( exists, inQuery-  , present, with, withBy-  , absent, without, withoutBy-  )-where---- base-import Prelude hiding ( filter )---- opaleye-import qualified Opaleye.Exists as Opaleye-import qualified Opaleye.Operators as Opaleye hiding ( exists )---- rel8-import Rel8.Expr ( Expr )-import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )-import Rel8.Query ( Query )-import Rel8.Query.Filter ( filter )-import Rel8.Query.Opaleye ( mapOpaleye )-import Rel8.Table.Eq ( EqTable, (==:) )----- | Checks if a query returns at least one row.-exists :: Query a -> Query (Expr Bool)-exists = fmap (fromPrimExpr . fromColumn) . mapOpaleye Opaleye.exists---inQuery :: EqTable a => a -> Query a -> Query (Expr Bool)-inQuery a = exists . (>>= filter (a ==:))----- | Produce the empty query if the given query returns no rows. @present@--- is equivalent to @WHERE EXISTS@ in SQL.-present :: Query a -> Query ()-present = mapOpaleye Opaleye.restrictExists----- | Produce the empty query if the given query returns rows. @absent@--- is equivalent to @WHERE NOT EXISTS@ in SQL.-absent :: Query a -> Query ()-absent = mapOpaleye Opaleye.restrictNotExists----- | @with@ is similar to 'filter', but allows the predicate to be a full query.------ @with f a = a <$ present (f a)@, but this form matches 'filter'.-with :: (a -> Query b) -> a -> Query a-with f a = a <$ present (f a)----- | Like @with@, but with a custom membership test.-withBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a-withBy predicate bs = with $ \a -> bs >>= filter (predicate a)----- | Filter rows where @a -> Query b@ yields no rows.-without :: (a -> Query b) -> a -> Query a-without f a = a <$ absent (f a)----- | Like @without@, but with a custom membership test.-withoutBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a-withoutBy predicate bs = without $ \a -> bs >>= filter (predicate a)
− src/Rel8/Query/Filter.hs 
@@ -1,35 +0,0 @@-module Rel8.Query.Filter-  ( filter-  , where_-  )-where---- base-import Prelude hiding ( filter )---- opaleye-import qualified Opaleye.Operators as Opaleye---- profunctors-import Data.Profunctor ( lmap )---- rel8-import Rel8.Expr ( Expr )-import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )-import Rel8.Query ( Query )-import Rel8.Query.Opaleye ( fromOpaleye )----- | @filter f x@ will be a zero-row query when @f x@ is @False@, and will--- return @x@ unchanged when @f x@ is @True@. This is similar to--- 'Control.Monad.guard', but as the predicate is separate from the argument,--- it is easy to use in a pipeline of 'Query' transformations.-filter :: (a -> Expr Bool) -> a -> Query a-filter f a = a <$ where_ (f a)----- | Drop any rows that don't match a predicate.  @where_ expr@ is equivalent--- to the SQL @WHERE expr@.-where_ :: Expr Bool -> Query ()-where_ condition =-  fromOpaleye $ lmap (\_ -> toColumn $ toPrimExpr condition) Opaleye.restrict
− src/Rel8/Query/Indexed.hs 
@@ -1,34 +0,0 @@-module Rel8.Query.Indexed-  ( indexed-  )-where---- base-import Data.Int ( Int64 )-import Prelude---- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye-import qualified Opaleye.Internal.PackMap as Opaleye-import qualified Opaleye.Internal.PrimQuery as Opaleye-import qualified Opaleye.Internal.QueryArr as Opaleye-import qualified Opaleye.Internal.Tag as Opaleye---- rel8-import Rel8.Expr ( Expr )-import Rel8.Expr.Opaleye ( fromPrimExpr )-import Rel8.Query ( Query )-import Rel8.Query.Opaleye ( mapOpaleye )----- | Pair each row of a query with its index within the query.-indexed :: Query a -> Query (Expr Int64, a)-indexed = mapOpaleye $ \(Opaleye.QueryArr f) -> Opaleye.QueryArr $ \(_, tag) ->-  let-    (a, query, tag') = f ((), tag)-    tag'' = Opaleye.next tag'-    window = Opaleye.ConstExpr $ Opaleye.OtherLit "ROW_NUMBER() OVER () - 1"-    (index, bindings) = Opaleye.run $ Opaleye.extractAttr "index" tag' window-    query' lateral = Opaleye.Rebind True bindings . query lateral-  in-    ((fromPrimExpr index, a), query', tag'')
− src/Rel8/Query/Limit.hs 
@@ -1,27 +0,0 @@-module Rel8.Query.Limit-  ( limit-  , offset-  )-where---- base-import Prelude---- opaleye-import qualified Opaleye---- rel8-import Rel8.Query ( Query )-import Rel8.Query.Opaleye ( mapOpaleye )----- | @limit n@ select at most @n@ rows from a query.  @limit n@ is equivalent--- to the SQL @LIMIT n@.-limit :: Word -> Query a -> Query a-limit = mapOpaleye . Opaleye.limit . fromIntegral----- | @offset n@ drops the first @n@ rows from a query. @offset n@ is equivalent--- to the SQL @OFFSET n@.-offset :: Word -> Query a -> Query a-offset = mapOpaleye . Opaleye.offset . fromIntegral
− src/Rel8/Query/List.hs 
@@ -1,122 +0,0 @@-{-# language FlexibleContexts #-}-{-# language GADTs #-}-{-# language NamedFieldPuns #-}--module Rel8.Query.List-  ( many, some-  , manyExpr, someExpr-  , catListTable, catNonEmptyTable-  , catList, catNonEmpty-  )-where---- base-import Data.Functor.Identity ( runIdentity )-import Data.List.NonEmpty ( NonEmpty )-import Prelude---- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye---- rel8-import Rel8.Expr ( Expr )-import Rel8.Expr.Aggregate ( listAggExpr, nonEmptyAggExpr )-import Rel8.Expr.Opaleye ( mapPrimExpr )-import Rel8.Query ( Query )-import Rel8.Query.Aggregate ( aggregate )-import Rel8.Query.Maybe ( optional )-import Rel8.Query.Rebind ( rebind )-import Rel8.Schema.HTable.Vectorize ( hunvectorize )-import Rel8.Schema.Null ( Sql, Unnullify )-import Rel8.Schema.Spec ( Spec( Spec, info ) )-import Rel8.Table ( Table, fromColumns )-import Rel8.Table.Cols ( toCols )-import Rel8.Table.Aggregate ( listAgg, nonEmptyAgg )-import Rel8.Table.List ( ListTable( ListTable ) )-import Rel8.Table.Maybe ( maybeTable )-import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )-import Rel8.Type ( DBType, typeInformation )-import Rel8.Type.Array ( extractArrayElement )-import Rel8.Type.Information ( TypeInformation )----- | Aggregate a 'Query' into a 'ListTable'. If the supplied query returns 0--- rows, this function will produce a 'Query' that returns one row containing--- the empty @ListTable@. If the supplied @Query@ does return rows, @many@ will--- return exactly one row, with a @ListTable@ collecting all returned rows.------ @many@ is analogous to 'Control.Applicative.many' from--- @Control.Applicative@.-many :: Table Expr a => Query a -> Query (ListTable Expr a)-many =-  fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .-  optional .-  aggregate .-  fmap (listAgg . toCols)----- | Aggregate a 'Query' into a 'NonEmptyTable'. If the supplied query returns--- 0 rows, this function will produce a 'Query' that is empty - that is, will--- produce zero @NonEmptyTable@s. If the supplied @Query@ does return rows,--- @some@ will return exactly one row, with a @NonEmptyTable@ collecting all--- returned rows.------ @some@ is analogous to 'Control.Applicative.some' from--- @Control.Applicative@.-some :: Table Expr a => Query a -> Query (NonEmptyTable Expr a)-some =-  fmap (\(NonEmptyTable a) -> NonEmptyTable a) .-  aggregate .-  fmap (nonEmptyAgg . toCols)----- | A version of 'many' specialised to single expressions.-manyExpr :: Sql DBType a => Query (Expr a) -> Query (Expr [a])-manyExpr = fmap (maybeTable mempty id) . optional . aggregate . fmap listAggExpr----- | A version of 'many' specialised to single expressions.-someExpr :: Sql DBType a => Query (Expr a) -> Query (Expr (NonEmpty a))-someExpr = aggregate . fmap nonEmptyAggExpr----- | Expand a 'ListTable' into a 'Query', where each row in the query is an--- element of the given @ListTable@.------ @catListTable@ is an inverse to 'many'.-catListTable :: Table Expr a => ListTable Expr a -> Query a-catListTable (ListTable as) =-  rebind "unnest" $ fromColumns $ runIdentity $-    hunvectorize (\Spec {info} -> pure . sunnest info) as----- | Expand a 'NonEmptyTable' into a 'Query', where each row in the query is an--- element of the given @NonEmptyTable@.------ @catNonEmptyTable@ is an inverse to 'some'.-catNonEmptyTable :: Table Expr a => NonEmptyTable Expr a -> Query a-catNonEmptyTable (NonEmptyTable as) =-  rebind "unnest" $ fromColumns $ runIdentity $-    hunvectorize (\Spec {info} -> pure . sunnest info) as----- | Expand an expression that contains a list into a 'Query', where each row--- in the query is an element of the given list.------ @catList@ is an inverse to 'manyExpr'.-catList :: Sql DBType a => Expr [a] -> Query (Expr a)-catList = rebind "unnest" . sunnest typeInformation----- | Expand an expression that contains a non-empty list into a 'Query', where--- each row in the query is an element of the given list.------ @catNonEmpty@ is an inverse to 'someExpr'.-catNonEmpty :: Sql DBType a => Expr (NonEmpty a) -> Query (Expr a)-catNonEmpty = rebind "unnest" . sunnest typeInformation---sunnest :: TypeInformation (Unnullify a) -> Expr (list a) -> Expr a-sunnest info = mapPrimExpr $-  extractArrayElement info .-  Opaleye.UnExpr (Opaleye.UnOpOther "UNNEST")
− src/Rel8/Query/Maybe.hs 
@@ -1,68 +0,0 @@-{-# language GADTs #-}-{-# language LambdaCase #-}-{-# language NamedFieldPuns #-}--module Rel8.Query.Maybe-  ( optional-  , catMaybeTable-  , traverseMaybeTable-  )-where---- base-import Prelude---- comonad-import Control.Comonad ( extract )---- opaleye-import qualified Opaleye.Internal.MaybeFields as Opaleye---- rel8-import Rel8.Expr ( Expr )-import Rel8.Expr.Eq ( (==.) )-import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )-import Rel8.Query ( Query )-import Rel8.Query.Filter ( where_ )-import Rel8.Query.Opaleye ( mapOpaleye )-import Rel8.Table.Maybe ( MaybeTable(..), isJustTable )----- | Convert a query that might return zero rows to a query that always returns--- at least one row.------ To speak in more concrete terms, 'optional' is most useful to write @LEFT--- JOIN@s.-optional :: Query a -> Query (MaybeTable Expr a)-optional = mapOpaleye $ Opaleye.optionalInternal $ \tag a -> MaybeTable-  { tag = fromPrimExpr $ fromColumn tag-  , just = pure a-  }----- | Filter out 'MaybeTable's, returning only the tables that are not-null.------ This operation can be used to "undo" the effect of 'optional', which--- operationally is like turning a @LEFT JOIN@ back into a full @JOIN@.  You--- can think of this as analogous to 'Data.Maybe.catMaybes'.-catMaybeTable :: MaybeTable Expr a -> Query a-catMaybeTable ma@(MaybeTable _ a) = do-  where_ $ isJustTable ma-  pure (extract a)----- | Extend an optional query with another query.  This is useful if you want--- to step through multiple @LEFT JOINs@.------ Note that @traverseMaybeTable@ takes a @a -> Query b@ function, which means--- you also have the ability to "expand" one row into multiple rows.  If the--- @a -> Query b@ function returns no rows, then the resulting query will also--- have no rows. However, regardless of the given @a -> Query b@ function, if--- the input is @nothingTable@, you will always get exactly one @nothingTable@--- back.-traverseMaybeTable :: (a -> Query b) -> MaybeTable Expr  a -> Query (MaybeTable Expr b)-traverseMaybeTable query ma@(MaybeTable input _) = do-  optional (query =<< catMaybeTable ma) >>= \case-    MaybeTable output b -> do-      where_ $ output ==. input-      pure $ MaybeTable input b
− src/Rel8/Query/Null.hs 
@@ -1,23 +0,0 @@-module Rel8.Query.Null-  ( catNull-  )-where---- base-import Prelude---- rel8-import Rel8.Expr ( Expr )-import Rel8.Expr.Null ( isNonNull, unsafeUnnullify )-import Rel8.Query ( Query )-import Rel8.Query.Filter ( where_ )----- | Filter a 'Query' that might return @null@ to a 'Query' without any--- @null@s.------ Corresponds to 'Data.Maybe.catMaybes'.-catNull :: Expr (Maybe a) -> Query (Expr a)-catNull a = do-  where_ $ isNonNull a-  pure $ unsafeUnnullify a
− src/Rel8/Query/Opaleye.hs 
@@ -1,70 +0,0 @@-{-# language TupleSections #-}--module Rel8.Query.Opaleye-  ( fromOpaleye-  , toOpaleye-  , mapOpaleye-  , zipOpaleyeWith-  , unsafePeekQuery-  )-where---- base-import Control.Applicative ( liftA2 )-import Prelude---- opaleye-import qualified Opaleye.Internal.QueryArr as Opaleye-import qualified Opaleye.Internal.Tag as Opaleye---- rel8-import {-# SOURCE #-} Rel8.Query ( Query( Query ) )---fromOpaleye :: Opaleye.Select a -> Query a-fromOpaleye = Query . pure . fmap pure---toOpaleye :: Query a -> Opaleye.Select a-toOpaleye (Query a) = snd <$> a mempty---mapOpaleye :: (Opaleye.Select a -> Opaleye.Select b) -> Query a -> Query b-mapOpaleye f (Query a) = Query (fmap (mapping f) a)---zipOpaleyeWith :: ()-  => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)-  -> Query a -> Query b -> Query c-zipOpaleyeWith f (Query a) (Query b) = Query $ liftA2 (zipping f) a b---unsafePeekQuery :: Query a -> a-unsafePeekQuery (Query q) = case q mempty of-  Opaleye.QueryArr f -> case f ((), Opaleye.start) of-    ((_, a), _, _) -> a---mapping :: ()-  => (Opaleye.Select a -> Opaleye.Select b)-  -> Opaleye.Select (m, a) -> Opaleye.Select (m, b)-mapping f q@(Opaleye.QueryArr qa) = Opaleye.QueryArr $ \(_, tag) ->-  let-    ((m, _), _, _) = qa ((), tag)-    Opaleye.QueryArr qa' = (m,) <$> f (snd <$> q)-  in-    qa' ((), tag)---zipping :: Semigroup m-  => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)-  -> Opaleye.Select (m, a) -> Opaleye.Select (m, b) -> Opaleye.Select (m, c)-zipping f q@(Opaleye.QueryArr qa) q'@(Opaleye.QueryArr qa') =-  Opaleye.QueryArr $ \(_, tag) ->-    let-      ((m, _), _, _) = qa ((), tag)-      ((m', _), _, _) = qa' ((), tag)-      m'' = m <> m'-      Opaleye.QueryArr qa'' = (m'',) <$> f (snd <$> q) (snd <$> q')-    in-      qa'' ((), tag)
− src/Rel8/Query/Order.hs 
@@ -1,20 +0,0 @@-module Rel8.Query.Order-  ( orderBy-  )-where---- base-import Prelude ()---- opaleye-import qualified Opaleye.Order as Opaleye ( orderBy )---- rel8-import Rel8.Order ( Order( Order ) )-import Rel8.Query ( Query )-import Rel8.Query.Opaleye ( mapOpaleye )----- | Order the rows returned by a query.-orderBy :: Order a -> Query a -> Query a-orderBy (Order o) = mapOpaleye (Opaleye.orderBy o)
− src/Rel8/Query/Rebind.hs 
@@ -1,35 +0,0 @@-{-# language FlexibleContexts #-}--module Rel8.Query.Rebind-  ( rebind-  )-where---- base-import Prelude---- opaleye-import qualified Opaleye.Internal.PackMap as Opaleye-import qualified Opaleye.Internal.PrimQuery as Opaleye-import qualified Opaleye.Internal.QueryArr as Opaleye-import qualified Opaleye.Internal.Tag as Opaleye-import qualified Opaleye.Internal.Unpackspec as Opaleye---- rel8-import Rel8.Expr ( Expr )-import Rel8.Query ( Query( Query ) )-import Rel8.Table ( Table )-import Rel8.Table.Opaleye ( unpackspec )----- | 'rebind' takes a variable name, some expressions, and binds each of them--- to a new variable in the SQL. The @a@ returned consists only of these--- variables. It's essentially a @let@ binding for Postgres expressions.-rebind :: Table Expr a => String -> a -> Query a-rebind prefix a = Query $ \_ -> Opaleye.QueryArr $ \(_, tag) ->-  let-    tag' = Opaleye.next tag-    (a', bindings) = Opaleye.run $-      Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr prefix tag) a-  in-    ((mempty, a'), \_ -> Opaleye.Rebind True bindings, tag')
− src/Rel8/Query/SQL.hs 
@@ -1,21 +0,0 @@-{-# language FlexibleContexts #-}-{-# language MonoLocalBinds #-}--module Rel8.Query.SQL-  ( showQuery-  )-where---- base-import Prelude---- rel8-import Rel8.Expr ( Expr )-import Rel8.Query ( Query )-import Rel8.Statement.Select ( ppSelect )-import Rel8.Table ( Table )----- | Convert a 'Query' to a 'String' containing a @SELECT@ statement.-showQuery :: Table Expr a => Query a -> String-showQuery = show . ppSelect
− src/Rel8/Query/Set.hs 
@@ -1,58 +0,0 @@-{-# language FlexibleContexts #-}--module Rel8.Query.Set-  ( union, unionAll-  , intersect, intersectAll-  , except, exceptAll-  )-where---- base-import Prelude ()---- opaleye-import qualified Opaleye.Binary as Opaleye---- rel8-import Rel8.Expr ( Expr )-import {-# SOURCE #-} Rel8.Query ( Query )-import Rel8.Query.Opaleye ( zipOpaleyeWith )-import Rel8.Table ( Table  )-import Rel8.Table.Eq ( EqTable )-import Rel8.Table.Opaleye ( binaryspec )----- | Combine the results of two queries of the same type, collapsing--- duplicates.  @union a b@ is the same as the SQL statement @x UNION b@.-union :: EqTable a => Query a -> Query a -> Query a-union = zipOpaleyeWith (Opaleye.unionExplicit binaryspec)----- | Combine the results of two queries of the same type, retaining duplicates.--- @unionAll a b@ is the same as the SQL statement @x UNION ALL b@.-unionAll :: Table Expr a => Query a -> Query a -> Query a-unionAll = zipOpaleyeWith (Opaleye.unionAllExplicit binaryspec)----- | Find the intersection of two queries, collapsing duplicates.  @intersect a--- b@ is the same as the SQL statement @x INTERSECT b@.-intersect :: EqTable a => Query a -> Query a -> Query a-intersect = zipOpaleyeWith (Opaleye.intersectExplicit binaryspec)----- | Find the intersection of two queries, retaining duplicates.  @intersectAll--- a b@ is the same as the SQL statement @x INTERSECT ALL b@.-intersectAll :: EqTable a => Query a -> Query a -> Query a-intersectAll = zipOpaleyeWith (Opaleye.intersectAllExplicit binaryspec)----- | Find the difference of two queries, collapsing duplicates @except a b@ is--- the same as the SQL statement @x EXCEPT b@.-except :: EqTable a => Query a -> Query a -> Query a-except = zipOpaleyeWith (Opaleye.exceptExplicit binaryspec)----- | Find the difference of two queries, retaining duplicates.  @exceptAll a b@--- is the same as the SQL statement @x EXCEPT ALL b@.-exceptAll :: EqTable a => Query a -> Query a -> Query a-exceptAll = zipOpaleyeWith (Opaleye.exceptAllExplicit binaryspec)
− src/Rel8/Query/These.hs 
@@ -1,138 +0,0 @@-{-# language FlexibleContexts #-}-{-# language GADTs #-}--module Rel8.Query.These-  ( alignBy-  , keepHereTable, loseHereTable-  , keepThereTable, loseThereTable-  , keepThisTable, loseThisTable-  , keepThatTable, loseThatTable-  , keepThoseTable, loseThoseTable-  , bitraverseTheseTable-  )-where---- base-import Prelude---- comonad-import Control.Comonad ( extract )---- opaleye-import qualified Opaleye.Internal.PackMap as Opaleye-import qualified Opaleye.Internal.PrimQuery as Opaleye-import qualified Opaleye.Internal.QueryArr as Opaleye-import qualified Opaleye.Internal.Tag as Opaleye---- rel8-import Rel8.Expr ( Expr )-import Rel8.Expr.Bool ( boolExpr, not_ )-import Rel8.Expr.Eq ( (==.) )-import Rel8.Expr.Opaleye ( toPrimExpr, traversePrimExpr )-import Rel8.Expr.Serialize ( litExpr )-import Rel8.Query ( Query )-import Rel8.Query.Filter ( where_ )-import Rel8.Query.Maybe ( optional )-import Rel8.Query.Opaleye ( zipOpaleyeWith )-import Rel8.Table.Either ( EitherTable( EitherTable ) )-import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )-import Rel8.Table.These-  ( TheseTable( TheseTable, here, there )-  , hasHereTable, hasThereTable-  , isThisTable, isThatTable, isThoseTable-  )-import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) )----- | Corresponds to a @FULL OUTER JOIN@ between two queries.-alignBy :: ()-  => (a -> b -> Expr Bool)-  -> Query a -> Query b -> Query (TheseTable Expr a b)-alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.QueryArr $ \i -> case i of-  (_, tag) -> (tab, join', tag''')-    where-      (ma, left', tag') = Opaleye.runSimpleQueryArr (pure <$> left) ((), tag)-      (mb, right', tag'') = Opaleye.runSimpleQueryArr (pure <$> right) ((), tag')-      MaybeTable hasHere a = ma-      MaybeTable hasThere b = mb-      (hasHere', lbindings) = Opaleye.run $ do-        traversePrimExpr (Opaleye.extractAttr "hasHere" tag'') hasHere-      (hasThere', rbindings) = Opaleye.run $ do-        traversePrimExpr (Opaleye.extractAttr "hasThere" tag'') hasThere-      tag''' = Opaleye.next tag''-      join lateral = Opaleye.Join Opaleye.FullJoin on left'' right''-        where-          on = toPrimExpr $ condition (extract a) (extract b)-          left'' = (lateral, Opaleye.Rebind True lbindings left')-          right'' = (lateral, Opaleye.Rebind True rbindings right')-      ma' = MaybeTable hasHere' a-      mb' = MaybeTable hasThere' b-      tab = TheseTable {here = ma', there = mb'}-      join' lateral input = Opaleye.times lateral input (join lateral)---keepHereTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)-keepHereTable = loseThatTable---loseHereTable :: TheseTable Expr a b -> Query b-loseHereTable = keepThatTable---keepThereTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)-keepThereTable = loseThisTable---loseThereTable :: TheseTable Expr a b -> Query a-loseThereTable = keepThisTable---keepThisTable :: TheseTable Expr a b -> Query a-keepThisTable t@(TheseTable (MaybeTable _ a) _) = do-  where_ $ isThisTable t-  pure (extract a)---loseThisTable :: TheseTable Expr a b -> Query (MaybeTable Expr a, b)-loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do-  where_ $ not_ $ isThisTable t-  pure (ma, extract b)---keepThatTable :: TheseTable Expr a b -> Query b-keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do-  where_ $ isThatTable t-  pure (extract b)---loseThatTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)-loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do-  where_ $ not_ $ isThatTable t-  pure (extract a, mb)---keepThoseTable :: TheseTable Expr a b -> Query (a, b)-keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do-  where_ $ isThoseTable t-  pure (extract a, extract b)---loseThoseTable :: TheseTable Expr a b -> Query (EitherTable Expr a b)-loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do-  where_ $ not_ $ isThoseTable t-  pure $ EitherTable tag a b-  where-    tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)---bitraverseTheseTable :: ()-  => (a -> Query c)-  -> (b -> Query d)-  -> TheseTable Expr a b-  -> Query (TheseTable Expr c d)-bitraverseTheseTable f g t = do-  mc <- optional (f . fst =<< keepHereTable t)-  md <- optional (g . snd =<< keepThereTable t)-  where_ $ isJustTable mc ==. hasHereTable t-  where_ $ isJustTable md ==. hasThereTable t-  pure $ TheseTable mc md
− src/Rel8/Query/Values.hs 
@@ -1,27 +0,0 @@-{-# language FlexibleContexts #-}--module Rel8.Query.Values-  ( values-  )-where---- base-import Data.Foldable ( toList )-import Prelude---- opaleye-import qualified Opaleye.Values as Opaleye---- rel8-import Rel8.Expr ( Expr )-import {-# SOURCE #-} Rel8.Query ( Query )-import Rel8.Query.Opaleye ( fromOpaleye )-import Rel8.Table ( Table )-import Rel8.Table.Opaleye ( valuesspec )----- | Construct a query that returns the given input list of rows. This is like--- folding a list of 'return' statements under 'Rel8.union', but uses the SQL--- @VALUES@ expression for efficiency.-values :: (Table Expr a, Foldable f) => f a -> Query a-values = fromOpaleye . Opaleye.valuesExplicit valuesspec . toList
+ src/Rel8/Range.hs view
@@ -0,0 +1,33 @@+module Rel8.Range (+  -- * Basic range functionality+  Bound (Incl, Excl, Inf),+  Range (Empty, Range),+  Multirange (Multirange),+  range,+  multirange,+  rangeAgg,+ +  -- * Defining new range types+  DBRange (+    rangeTypeName, rangeDecoder, rangeEncoder,+    multirangeTypeName, multirangeDecoder, multirangeEncoder+  )+) where++-- base+import Prelude ()++-- rel8+import Rel8.Internal.Aggregate.Range (rangeAgg)+import Rel8.Internal.Data.Range (+  Bound (Incl, Excl, Inf),+  Range (Empty, Range),+  Multirange (Multirange),+ )+import Rel8.Internal.Expr.Range (range, multirange)+import Rel8.Internal.Type.Range (+  DBRange (+    rangeTypeName, rangeDecoder, rangeEncoder,+    multirangeTypeName, multirangeDecoder, multirangeEncoder+  ),+ )
− src/Rel8/Schema/Context/Nullify.hs 
@@ -1,144 +0,0 @@-{-# language DataKinds #-}-{-# language EmptyCase #-}-{-# language FlexibleContexts #-}-{-# language GADTs #-}-{-# language LambdaCase #-}-{-# language NamedFieldPuns #-}-{-# language StandaloneKindSignatures #-}--module Rel8.Schema.Context.Nullify-  ( Nullifiability(..), NonNullifiability(..), nullifiableOrNot, absurd-  , Nullifiable, nullifiability-  , guarder, nullifier, unnullifier-  , sguard, snullify-  )-where---- base-import Data.Bool ( bool )-import Data.Functor.Identity ( Identity( Identity ) )-import Data.Kind ( Constraint, Type )-import Prelude hiding ( null )---- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye---- rel8-import Rel8.Aggregate ( Aggregate(..), zipOutputs )-import Rel8.Expr ( Expr )-import Rel8.Expr.Bool ( boolExpr )-import Rel8.Expr.Null ( nullify, unsafeUnnullify )-import Rel8.Expr.Opaleye ( fromPrimExpr )-import Rel8.Kind.Context ( SContext(..) )-import Rel8.Schema.Field ( Field )-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Name ( Name( Name ) )-import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )-import Rel8.Schema.Result ( Result )-import Rel8.Schema.Spec ( Spec(..) )---type Nullifiability :: K.Context -> Type-data Nullifiability context where-  NAggregate :: Nullifiability Aggregate-  NExpr :: Nullifiability Expr-  NName :: Nullifiability Name---type Nullifiable :: K.Context -> Constraint-class Nullifiable context where-  nullifiability :: Nullifiability context---instance Nullifiable Aggregate where-  nullifiability = NAggregate---instance Nullifiable Expr where-  nullifiability = NExpr---instance Nullifiable Name where-  nullifiability = NName---type NonNullifiability :: K.Context -> Type-data NonNullifiability context where-  NField :: NonNullifiability (Field table)-  NResult :: NonNullifiability Result---nullifiableOrNot :: ()-  => SContext context-  -> Either (NonNullifiability context) (Nullifiability context)-nullifiableOrNot = \case-  SAggregate -> Right NAggregate-  SExpr -> Right NExpr-  SField -> Left NField-  SName -> Right NName-  SResult -> Left NResult---absurd :: Nullifiability context -> NonNullifiability context -> a-absurd = \case-  NAggregate -> \case-  NExpr -> \case-  NName -> \case---guarder :: ()-  => SContext context-  -> context tag-  -> (tag -> Bool)-  -> (Expr tag -> Expr Bool)-  -> context (Maybe a)-  -> context (Maybe a)-guarder = \case-  SAggregate -> \tag _ isNonNull -> zipOutputs (sguard . isNonNull) tag-  SExpr -> \tag _ isNonNull -> sguard (isNonNull tag)-  SField -> \_ _ _ -> id-  SName -> \_ _ _ -> id-  SResult -> \(Identity tag) isNonNull _ (Identity a) ->-    Identity (bool Nothing a (isNonNull tag))---nullifier :: ()-  => Nullifiability context-  -> Spec a-  -> context a-  -> context (Nullify a)-nullifier = \case-  NAggregate -> \Spec {nullity} (Aggregate a) ->-    Aggregate $ snullify nullity <$> a-  NExpr -> \Spec {nullity} a -> snullify nullity a-  NName -> \_ (Name a) -> Name a---unnullifier :: ()-  => Nullifiability context-  -> Spec a-  -> context (Nullify a)-  -> context a-unnullifier = \case-  NAggregate -> \Spec {nullity} (Aggregate a) ->-    Aggregate $ sunnullify nullity <$> a-  NExpr -> \Spec {nullity} a -> sunnullify nullity a-  NName -> \_ (Name a) -> Name a---sguard :: Expr Bool -> Expr (Maybe a) -> Expr (Maybe a)-sguard condition a = boolExpr null a condition-  where-    null = fromPrimExpr $ Opaleye.ConstExpr Opaleye.NullLit---snullify :: Nullity a -> Expr a -> Expr (Nullify a)-snullify nullity a = case nullity of-  Null -> a-  NotNull -> nullify a---sunnullify :: Nullity a -> Expr (Nullify a) -> Expr a-sunnullify nullity a = case nullity of-  Null -> a-  NotNull -> unsafeUnnullify a
− src/Rel8/Schema/Dict.hs 
@@ -1,18 +0,0 @@-{-# language ConstraintKinds #-}-{-# language GADTs #-}-{-# language PolyKinds #-}-{-# language StandaloneKindSignatures #-}--module Rel8.Schema.Dict-  ( Dict( Dict )-  )-where---- base-import Data.Kind ( Constraint, Type )-import Prelude ()---type Dict :: (a -> Constraint) -> a -> Type-data Dict c a where-  Dict :: c a => Dict c a
− src/Rel8/Schema/Field.hs 
@@ -1,50 +0,0 @@-{-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language MultiParamTypeClasses #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}--module Rel8.Schema.Field-  ( Field(..)-  , fields-  )-where---- base-import Data.Functor.Identity ( Identity( Identity ) )-import Data.Kind ( Type )-import Prelude---- rel8-import Rel8.Schema.HTable ( HField, htabulate )-import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )-import Rel8.Schema.Kind as K-import Rel8.Schema.Null ( Sql )-import Rel8.Table-  ( Table, Columns, Context, fromColumns, toColumns-  , FromExprs, fromResult, toResult-  , Transpose-  )-import Rel8.Table.Transpose ( Transposes )-import Rel8.Type ( DBType )----- | A special context used in the construction of 'Rel8.Projection's.-type Field :: Type -> K.Context-newtype Field table a = Field (HField (Columns table) a)---instance Sql DBType a => Table (Field table) (Field table a) where-  type Columns (Field table a) = HIdentity a-  type Context (Field table a) = Field table-  type FromExprs (Field table a) = a-  type Transpose to (Field table a) = to a--  toColumns = HIdentity-  fromColumns (HIdentity a) = a-  toResult a = HIdentity (Identity a)-  fromResult (HIdentity (Identity a)) = a---fields :: Transposes context (Field table) table fields => fields-fields = fromColumns $ htabulate Field
− src/Rel8/Schema/HTable.hs 
@@ -1,181 +0,0 @@-{-# language AllowAmbiguousTypes #-}-{-# language DataKinds #-}-{-# language DefaultSignatures #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language FunctionalDependencies #-}-{-# language LambdaCase #-}-{-# language RankNTypes #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-}-{-# language TypeFamilyDependencies #-}-{-# language TypeOperators #-}-{-# language UndecidableInstances #-}--module Rel8.Schema.HTable-  ( HTable (HField, HConstrainTable)-  , hfield, htabulate, htraverse, hdicts, hspecs-  , hmap, htabulateA-  )-where---- base-import Data.Kind ( Constraint, Type )-import Data.Functor.Compose ( Compose( Compose ), getCompose )-import Data.Proxy ( Proxy )-import GHC.Generics-  ( (:*:)( (:*:) )-  , Generic (Rep, from, to)-  , K1( K1 )-  , M1( M1 )-  )-import Prelude---- rel8-import Rel8.Schema.Dict ( Dict )-import Rel8.Schema.Spec ( Spec )-import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )-import qualified Rel8.Schema.Kind as K---- semigroupoids-import Data.Functor.Apply ( Apply, (<.>) )----- | A @HTable@ is a functor-indexed/higher-kinded data type that is--- representable ('htabulate'/'hfield'), constrainable ('hdicts'), and--- specified ('hspecs').------ This is an internal concept for Rel8, and you should not need to define--- instances yourself or specify this constraint.-type HTable :: K.HTable -> Constraint-class HTable t where-  type HField t = (field :: Type -> Type) | field -> t-  type HConstrainTable t (c :: Type -> Constraint) :: Constraint--  hfield :: t context -> HField t a -> context a-  htabulate :: (forall a. HField t a -> context a) -> t context-  htraverse :: Apply m => (forall a. f a -> m (g a)) -> t f -> m (t g)-  hdicts :: HConstrainTable t c => t (Dict c)-  hspecs :: t Spec--  type HField t = GHField t-  type HConstrainTable t c = HConstrainTable (GHColumns (Rep (t Proxy))) c--  default hfield ::-    ( Generic (t context)-    , HField t ~ GHField t-    , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))-    , GHTable context (Rep (t context))-    )-    => t context -> HField t a -> context a-  hfield table (GHField field) = hfield (toGHColumns (from table)) field--  default htabulate ::-    ( Generic (t context)-    , HField t ~ GHField t-    , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))-    , GHTable context (Rep (t context))-    )-    => (forall a. HField t a -> context a) -> t context-  htabulate f = to $ fromGHColumns $ htabulate (f . GHField)--  default htraverse-    :: forall f g m-     . ( Apply m-       , Generic (t f), GHTable f (Rep (t f))-       , Generic (t g), GHTable g (Rep (t g))-       , GHColumns (Rep (t f)) ~ GHColumns (Rep (t g))-       )-    => (forall a. f a -> m (g a)) -> t f -> m (t g)-  htraverse f = fmap (to . fromGHColumns) . htraverse f . toGHColumns . from--  default hdicts-    :: forall c-     . ( Generic (t (Dict c))-       , GHTable (Dict c) (Rep (t (Dict c)))-       , GHColumns (Rep (t Proxy)) ~ GHColumns (Rep (t (Dict c)))-       , HConstrainTable (GHColumns (Rep (t Proxy))) c-       )-    => t (Dict c)-  hdicts = to $ fromGHColumns (hdicts @(GHColumns (Rep (t Proxy))) @c)--  default hspecs ::-    ( Generic (t Spec)-    , GHTable Spec (Rep (t Spec))-    )-    => t Spec-  hspecs = to $ fromGHColumns hspecs--  {-# INLINABLE hfield #-}-  {-# INLINABLE htabulate #-}-  {-# INLINABLE htraverse #-}-  {-# INLINABLE hdicts #-}-  {-# INLINABLE hspecs #-}---hmap :: HTable t-  => (forall a. context a -> context' a) -> t context -> t context'-hmap f a = htabulate $ \field -> f (hfield a field)---htabulateA :: (HTable t, Apply m)-  => (forall a. HField t a -> m (context a)) -> m (t context)-htabulateA f = htraverse getCompose $ htabulate $ Compose . f-{-# INLINABLE htabulateA #-}---type GHField :: K.HTable -> Type -> Type-newtype GHField t a = GHField (HField (GHColumns (Rep (t Proxy))) a)---type GHTable :: K.Context -> (Type -> Type) -> Constraint-class HTable (GHColumns rep) => GHTable context rep | rep -> context where-  type GHColumns rep :: K.HTable-  toGHColumns :: rep x -> GHColumns rep context-  fromGHColumns :: GHColumns rep context -> rep x---instance GHTable context rep => GHTable context (M1 i c rep) where-  type GHColumns (M1 i c rep) = GHColumns rep-  toGHColumns (M1 a) = toGHColumns a-  fromGHColumns = M1 . fromGHColumns---instance HTable table => GHTable context (K1 i (table context)) where-  type GHColumns (K1 i (table context)) = table-  toGHColumns (K1 a) = a-  fromGHColumns = K1---instance (GHTable context a, GHTable context b) => GHTable context (a :*: b) where-  type GHColumns (a :*: b) = HProduct (GHColumns a) (GHColumns b)-  toGHColumns (a :*: b) = HProduct (toGHColumns a) (toGHColumns b)-  fromGHColumns (HProduct a b) = fromGHColumns a :*: fromGHColumns b----- | A HField type for indexing into HProduct.-type HProductField :: K.HTable -> K.HTable -> Type -> Type-data HProductField x y a-  = HFst (HField x a)-  | HSnd (HField y a)---instance (HTable x, HTable y) => HTable (HProduct x y) where-  type HConstrainTable (HProduct x y) c = (HConstrainTable x c, HConstrainTable y c)-  type HField (HProduct x y) = HProductField x y--  hfield (HProduct l r) = \case-    HFst i -> hfield l i-    HSnd i -> hfield r i--  htabulate f = HProduct (htabulate (f . HFst)) (htabulate (f . HSnd))-  htraverse f (HProduct x y) = HProduct <$> htraverse f x <.> htraverse f y-  hdicts = HProduct hdicts hdicts-  hspecs = HProduct hspecs hspecs--  {-# INLINABLE hfield #-}-  {-# INLINABLE htabulate #-}-  {-# INLINABLE htraverse #-}-  {-# INLINABLE hdicts #-}-  {-# INLINABLE hspecs #-}
− src/Rel8/Schema/HTable/Either.hs 
@@ -1,32 +0,0 @@-{-# language DataKinds #-}-{-# language DeriveAnyClass #-}-{-# language DeriveGeneric #-}-{-# language DerivingStrategies #-}-{-# language StandaloneKindSignatures #-}--module Rel8.Schema.HTable.Either-  ( HEitherTable(..)-  )-where---- base-import GHC.Generics ( Generic )-import Prelude ()---- rel8-import Rel8.Schema.HTable ( HTable )-import Rel8.Schema.HTable.Identity ( HIdentity )-import Rel8.Schema.HTable.Label ( HLabel )-import Rel8.Schema.HTable.Nullify ( HNullify )-import qualified Rel8.Schema.Kind as K-import Rel8.Type.Tag ( EitherTag )---type HEitherTable :: K.HTable -> K.HTable -> K.HTable-data HEitherTable left right context = HEitherTable-  { htag :: HLabel "isRight" (HIdentity EitherTag) context-  , hleft :: HLabel "Left" (HNullify left) context-  , hright :: HLabel "Right" (HNullify right) context-  }-  deriving stock Generic-  deriving anyclass HTable
− src/Rel8/Schema/HTable/Identity.hs 
@@ -1,43 +0,0 @@-{-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}--module Rel8.Schema.HTable.Identity-  ( HIdentity( HIdentity, unHIdentity )-  )-where---- base-import Data.Kind ( Type )-import Data.Type.Equality ( (:~:)( Refl ) )-import Prelude---- rel8-import Rel8.Schema.Dict ( Dict( Dict ) )-import Rel8.Schema.HTable-  ( HTable, HConstrainTable, HField-  , hfield, htabulate, htraverse, hdicts, hspecs-  )-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Null ( Sql )-import Rel8.Schema.Spec ( specification )-import Rel8.Type ( DBType )---type HIdentity :: Type -> K.HTable-newtype HIdentity a context = HIdentity-  { unHIdentity :: context a-  }---instance Sql DBType a => HTable (HIdentity a) where-  type HConstrainTable (HIdentity a) constraint = constraint a-  type HField (HIdentity a) = (:~:) a--  hfield (HIdentity a) Refl = a-  htabulate f = HIdentity $ f Refl-  htraverse f (HIdentity a) = HIdentity <$> f a-  hdicts = HIdentity Dict-  hspecs = HIdentity specification
− src/Rel8/Schema/HTable/Label.hs 
@@ -1,70 +0,0 @@-{-# language DataKinds #-}-{-# language RankNTypes #-}-{-# language RecordWildCards #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-}-{-# language TypeFamilies #-}--module Rel8.Schema.HTable.Label-  ( HLabel, hlabel, hrelabel, hunlabel-  , hproject-  )-where---- base-import Data.Kind ( Type )-import Data.Proxy ( Proxy( Proxy ) )-import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )-import Prelude---- rel8-import Rel8.Schema.HTable-  ( HTable, HConstrainTable, HField-  , htabulate, hfield, htraverse, hdicts, hspecs-  )-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Spec ( Spec(..) )---type HLabel :: Symbol -> K.HTable -> K.HTable-newtype HLabel label table context = HLabel (table context)---type HLabelField :: Symbol -> K.HTable -> Type -> Type-newtype HLabelField label table a = HLabelField (HField table a)---instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where-  type HField (HLabel label table) = HLabelField label table-  type HConstrainTable (HLabel label table) constraint =-    HConstrainTable table constraint--  hfield (HLabel a) (HLabelField field) = hfield a field-  htabulate f = HLabel (htabulate (f . HLabelField))-  htraverse f (HLabel a) = HLabel <$> htraverse f a-  hdicts = HLabel (hdicts @table)-  hspecs = HLabel $ htabulate $ \field -> case hfield (hspecs @table) field of-    Spec {..} -> Spec {labels = symbolVal (Proxy @label) : labels, ..}-  {-# INLINABLE hspecs #-}---hlabel :: forall label t context. t context -> HLabel label t context-hlabel = HLabel-{-# INLINABLE hlabel #-}---hrelabel :: forall label' label t context. HLabel label t context -> HLabel label' t context-hrelabel = hlabel . hunlabel-{-# INLINABLE hrelabel #-}---hunlabel :: forall label t context. HLabel label t context -> t context-hunlabel (HLabel a) = a-{-# INLINABLE hunlabel #-}---hproject :: ()-  => (forall ctx. t ctx -> t' ctx)-  -> HLabel label t context -> HLabel label t' context-hproject f (HLabel a) = HLabel (f a)
− src/Rel8/Schema/HTable/List.hs 
@@ -1,18 +0,0 @@-{-# language DataKinds #-}-{-# language StandaloneKindSignatures #-}--module Rel8.Schema.HTable.List-  ( HListTable-  )-where---- base-import Prelude ()---- rel8-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.HTable.Vectorize ( HVectorize )---type HListTable :: K.HTable -> K.HTable-type HListTable = HVectorize []
− src/Rel8/Schema/HTable/MapTable.hs 
@@ -1,99 +0,0 @@-{-# language AllowAmbiguousTypes #-}-{-# language BlockArguments #-}-{-# language ConstraintKinds #-}-{-# language DataKinds #-}-{-# language FlexibleInstances #-}-{-# language GADTs #-}-{-# language InstanceSigs #-}-{-# language MultiParamTypeClasses #-}-{-# language RankNTypes #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}-{-# language UndecidableSuperClasses #-}--module Rel8.Schema.HTable.MapTable-  ( HMapTable(..)-  , MapSpec(..)-  , Precompose(..)-  , HMapTableField(..)-  , hproject-  )-where---- base-import Data.Kind ( Constraint, Type )-import Prelude---- rel8-import Rel8.FCF ( Exp, Eval )-import Rel8.Schema.HTable-  ( HTable, HConstrainTable, HField-  , hfield, htabulate, htraverse, hdicts, hspecs-  )-import Rel8.Schema.Spec ( Spec )-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Dict ( Dict( Dict ) )---type HMapTable :: (Type -> Exp Type) -> K.HTable -> K.HTable-newtype HMapTable f t context = HMapTable-  { unHMapTable :: t (Precompose f context)-  }---type Precompose :: (Type -> Exp Type) -> K.Context -> K.Context-newtype Precompose f g x = Precompose-  { precomposed :: g (Eval (f x))-  }---type HMapTableField :: (Type -> Exp Type) -> K.HTable -> K.Context-data HMapTableField f t x where-  HMapTableField :: HField t a -> HMapTableField f t (Eval (f a))---instance (HTable t, MapSpec f) => HTable (HMapTable f t) where-  type HField (HMapTable f t) = -    HMapTableField f t--  type HConstrainTable (HMapTable f t) c =-    HConstrainTable t (ComposeConstraint f c)--  hfield (HMapTable x) (HMapTableField i) = -    precomposed (hfield x i) --  htabulate f = -    HMapTable $ htabulate (Precompose . f . HMapTableField)--  htraverse f (HMapTable x) = -    HMapTable <$> htraverse (fmap Precompose . f . precomposed) x-  {-# INLINABLE htraverse #-}--  hdicts :: forall c. HConstrainTable (HMapTable f t) c => HMapTable f t (Dict c)-  hdicts = -    htabulate \(HMapTableField j) ->-      case hfield (hdicts @_ @(ComposeConstraint f c)) j of-        Dict -> Dict--  hspecs = -    HMapTable $ htabulate $ Precompose . mapInfo @f . hfield hspecs-  {-# INLINABLE hspecs #-}---type MapSpec :: (Type -> Exp Type) -> Constraint-class MapSpec f where-  mapInfo :: Spec x -> Spec (Eval (f x))---type ComposeConstraint :: (Type -> Exp Type) -> (Type -> Constraint) -> Type -> Constraint-class c (Eval (f a)) => ComposeConstraint f c a-instance c (Eval (f a)) => ComposeConstraint f c a---hproject :: ()-  => (forall ctx. t ctx -> t' ctx)-  -> HMapTable f t context -> HMapTable f t' context-hproject f (HMapTable a) = HMapTable (f a)
− src/Rel8/Schema/HTable/Maybe.hs 
@@ -1,31 +0,0 @@-{-# language DataKinds #-}-{-# language DeriveAnyClass #-}-{-# language DeriveGeneric #-}-{-# language DerivingStrategies #-}-{-# language StandaloneKindSignatures #-}--module Rel8.Schema.HTable.Maybe-  ( HMaybeTable(..)-  )-where---- base-import GHC.Generics ( Generic )-import Prelude---- rel8-import Rel8.Schema.HTable ( HTable )-import Rel8.Schema.HTable.Identity ( HIdentity )-import Rel8.Schema.HTable.Label ( HLabel )-import Rel8.Schema.HTable.Nullify ( HNullify )-import qualified Rel8.Schema.Kind as K-import Rel8.Type.Tag ( MaybeTag )---type HMaybeTable :: K.HTable -> K.HTable-data HMaybeTable table context = HMaybeTable-  { htag :: HLabel "isJust" (HIdentity (Maybe MaybeTag)) context-  , hjust :: HLabel "Just" (HNullify table) context-  }-  deriving stock Generic-  deriving anyclass HTable
− src/Rel8/Schema/HTable/NonEmpty.hs 
@@ -1,19 +0,0 @@-{-# language DataKinds #-}-{-# language StandaloneKindSignatures #-}--module Rel8.Schema.HTable.NonEmpty-  ( HNonEmptyTable-  )-where---- base-import Data.List.NonEmpty ( NonEmpty )-import Prelude ()---- rel8-import Rel8.Schema.HTable.Vectorize ( HVectorize )-import qualified Rel8.Schema.Kind as K---type HNonEmptyTable :: K.HTable -> K.HTable-type HNonEmptyTable = HVectorize NonEmpty
− src/Rel8/Schema/HTable/Nullify.hs 
@@ -1,117 +0,0 @@-{-# language ConstraintKinds #-}-{-# language DataKinds #-}-{-# language DeriveAnyClass #-}-{-# language DerivingStrategies #-}-{-# language DeriveGeneric #-}-{-# language FlexibleInstances #-}-{-# language GADTs #-}-{-# language LambdaCase #-}-{-# language MultiParamTypeClasses #-}-{-# language NamedFieldPuns #-}-{-# language QuantifiedConstraints #-}-{-# language RankNTypes #-}-{-# language RecordWildCards #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}--module Rel8.Schema.HTable.Nullify-  ( HNullify( HNullify )-  , Nullify-  , hguard-  , hnulls-  , hnullify-  , hunnullify-  , hproject-  )-where---- base-import Data.Kind ( Type )-import GHC.Generics ( Generic )-import Prelude hiding ( null )---- rel8-import Rel8.FCF ( Eval, Exp )-import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )-import Rel8.Schema.HTable.MapTable-  ( HMapTable, HMapTableField( HMapTableField )-  , MapSpec, mapInfo-  )-import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Null ( Nullity( Null, NotNull ) )-import qualified Rel8.Schema.Null as Type ( Nullify )-import Rel8.Schema.Spec ( Spec(..) )---- semigroupoids-import Data.Functor.Apply ( Apply )---type HNullify :: K.HTable -> K.HTable-newtype HNullify table context = HNullify (HMapTable Nullify table context)-  deriving stock Generic-  deriving anyclass HTable----- | Transform a 'Type' by allowing it to be @null@.-data Nullify :: Type -> Exp Type-type instance Eval (Nullify a) = Type.Nullify a---instance MapSpec Nullify where-  mapInfo = \case-    Spec {nullity, ..} -> Spec-      { nullity = case nullity of-          Null    -> Null-          NotNull -> Null-      , ..-      }---hguard :: HTable t-  => (forall a. context (Maybe a) -> context (Maybe a))-  -> HNullify t context -> HNullify t context-hguard guarder (HNullify as) = HNullify $ htabulate $ \(HMapTableField field) ->-  case hfield hspecs field of-    Spec {nullity} -> case hfield as (HMapTableField field) of-      a -> case nullity of-        Null -> guarder a-        NotNull -> guarder a---hnulls :: HTable t-  => (forall a. Spec a -> context (Type.Nullify a))-  -> HNullify t context-hnulls null = HNullify $ htabulate $ \(HMapTableField field) ->-  case hfield hspecs field of-    spec@Spec {} -> null spec-{-# INLINABLE hnulls #-}---hnullify :: HTable t-  => (forall a. Spec a -> context a -> context (Type.Nullify a))-  -> t context-  -> HNullify t context-hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->-  case hfield hspecs field of-    spec@Spec {} -> nullifier spec (hfield a field)-{-# INLINABLE hnullify #-}---hunnullify :: (HTable t, Apply m)-  => (forall a. Spec a -> context (Type.Nullify a) -> m (context a))-  -> HNullify t context-  -> m (t context)-hunnullify unnullifier (HNullify as) =-  htabulateA $ \field -> case hfield hspecs field of-    spec@Spec {} -> case hfield as (HMapTableField field) of-      a -> unnullifier spec a-{-# INLINABLE hunnullify #-}---hproject :: ()-  => (forall ctx. t ctx -> t' ctx)-  -> HNullify t context -> HNullify t' context-hproject f (HNullify a) = HNullify (HMapTable.hproject f a)
− src/Rel8/Schema/HTable/Product.hs 
@@ -1,17 +0,0 @@-{-# language DataKinds #-}-{-# language StandaloneKindSignatures #-}--module Rel8.Schema.HTable.Product-  ( HProduct(..)-  )-where---- base-import Prelude ()---- rel8-import qualified Rel8.Schema.Kind as K---type HProduct :: K.HTable -> K.HTable -> K.HTable-data HProduct a b context = HProduct (a context) (b context)
− src/Rel8/Schema/HTable/These.hs 
@@ -1,33 +0,0 @@-{-# language DataKinds #-}-{-# language DeriveAnyClass #-}-{-# language DeriveGeneric #-}-{-# language DerivingStrategies #-}-{-# language StandaloneKindSignatures #-}--module Rel8.Schema.HTable.These-  ( HTheseTable(..)-  )-where---- base-import GHC.Generics ( Generic )-import Prelude---- rel8-import Rel8.Schema.HTable ( HTable )-import Rel8.Schema.HTable.Identity ( HIdentity )-import Rel8.Schema.HTable.Label ( HLabel )-import Rel8.Schema.HTable.Nullify ( HNullify )-import qualified Rel8.Schema.Kind as K-import Rel8.Type.Tag ( MaybeTag )---type HTheseTable :: K.HTable -> K.HTable -> K.HTable-data HTheseTable here there context = HTheseTable-  { hhereTag :: HLabel "hereTag" (HIdentity (Maybe MaybeTag)) context-  , hhere :: HLabel "Here" (HNullify here) context-  , hthereTag :: HLabel "thereTag" (HIdentity (Maybe MaybeTag)) context-  , hthere :: HLabel "There" (HNullify there) context-  }-  deriving stock Generic-  deriving anyclass HTable
− src/Rel8/Schema/HTable/Vectorize.hs 
@@ -1,142 +0,0 @@-{-# language AllowAmbiguousTypes #-}-{-# language ConstraintKinds #-}-{-# language DataKinds #-}-{-# language DeriveAnyClass #-}-{-# language DeriveGeneric #-}-{-# language DerivingStrategies #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language GADTs #-}-{-# language LambdaCase #-}-{-# language MultiParamTypeClasses #-}-{-# language RankNTypes #-}-{-# language RecordWildCards #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}--module Rel8.Schema.HTable.Vectorize-  ( HVectorize-  , hvectorize, hunvectorize-  , happend, hempty-  , hproject-  , hcolumn-  )-where---- base-import Data.Kind ( Type )-import Data.List.NonEmpty ( NonEmpty )-import GHC.Generics (Generic)-import Prelude---- rel8-import Rel8.FCF ( Eval, Exp )-import Rel8.Schema.Dict ( Dict( Dict ) )-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )-import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )-import Rel8.Schema.HTable.MapTable-  ( HMapTable( HMapTable ), HMapTableField( HMapTableField )-  , MapSpec, mapInfo-  , Precompose( Precompose )-  )-import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )-import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )-import Rel8.Schema.Spec ( Spec(..) )-import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )-import Rel8.Type.Information ( TypeInformation )---- semialign-import Data.Zip ( Unzip, Zip, Zippy(..) )---class Vector list where-  listNotNull :: proxy a -> Dict NotNull (list a)-  vectorTypeInformation :: ()-    => Nullity a-    -> TypeInformation (Unnullify a)-    -> TypeInformation (list a)---instance Vector [] where-  listNotNull _ = Dict-  vectorTypeInformation = listTypeInformation---instance Vector NonEmpty where-  listNotNull _ = Dict-  vectorTypeInformation = nonEmptyTypeInformation---type HVectorize :: (Type -> Type) -> K.HTable -> K.HTable-newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) table context)-  deriving stock Generic-  deriving anyclass HTable---data Vectorize :: (Type -> Type) -> Type -> Exp Type---type instance Eval (Vectorize list a) = list a---instance Vector list => MapSpec (Vectorize list) where-  mapInfo = \case-    Spec {..} -> case listNotNull @list nullity of-      Dict -> Spec-        { nullity = NotNull-        , info = vectorTypeInformation nullity info-        , ..-        }---hvectorize :: (HTable t, Unzip f, Vector list)-  => (forall a. Spec a -> f (context a) -> context' (list a))-  -> f (t context)-  -> HVectorize list t context'-hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->-  case hfield hspecs field of-    spec -> vectorizer spec (fmap (`hfield` field) as)-{-# INLINABLE hvectorize #-}---hunvectorize :: (HTable t, Zip f, Vector list)-  => (forall a. Spec a -> context (list a) -> f (context' a))-  -> HVectorize list t context-  -> f (t context')-hunvectorize unvectorizer (HVectorize table) =-  getZippy $ htabulateA $ \field -> case hfield hspecs field of-    spec -> case hfield table (HMapTableField field) of-      a -> Zippy (unvectorizer spec a)-{-# INLINABLE hunvectorize #-}---happend :: (HTable t, Vector list)-  => (forall a. Spec a -> context (list a) -> context (list a) -> context (list a))-  -> HVectorize list t context-  -> HVectorize list t context-  -> HVectorize list t context-happend append (HVectorize as) (HVectorize bs) = HVectorize $-  htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of-    (a, b) -> case hfield hspecs j of-      spec -> append spec a b---hempty :: HTable t-  => (forall a. Spec a -> context [a])-  -> HVectorize [] t context-hempty empty = HVectorize $ htabulate $ \(HMapTableField field) ->-  empty (hfield hspecs field)---hproject :: ()-  => (forall ctx. t ctx -> t' ctx)-  -> HVectorize list t context -> HVectorize list t' context-hproject f (HVectorize a) = HVectorize (HMapTable.hproject f a)---hcolumn :: HVectorize list (HIdentity a) context -> context (list a)-hcolumn (HVectorize (HMapTable (HIdentity (Precompose a)))) = a
− src/Rel8/Schema/Kind.hs 
@@ -1,24 +0,0 @@-{-# language StandaloneKindSignatures #-}--module Rel8.Schema.Kind-  ( Rel8able-  , Context-  , HTable-  )-where---- base-import Data.Kind ( Type )-import Prelude ()---type Context :: Type-type Context = Type -> Type---type HTable :: Type-type HTable = Context -> Type---type Rel8able :: Type-type Rel8able = Context -> Type
− src/Rel8/Schema/Name.hs 
@@ -1,77 +0,0 @@-{-# language DataKinds #-}-{-# language DerivingStrategies #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language GADTs #-}-{-# language GeneralizedNewtypeDeriving #-}-{-# language MultiParamTypeClasses #-}-{-# language RankNTypes #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}--module Rel8.Schema.Name-  ( Name(..)-  , Selects-  , ppColumn-  )-where---- base-import Data.Functor.Identity ( Identity( Identity ) )-import Data.Kind ( Constraint, Type )-import Data.String ( IsString )-import Prelude---- opaleye-import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye-import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye---- pretty-import Text.PrettyPrint ( Doc )---- rel8-import Rel8.Expr ( Expr )-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )-import Rel8.Schema.Null ( Sql )-import Rel8.Table-  ( Table, Columns, Context, fromColumns, toColumns-  , FromExprs, fromResult, toResult-  , Transpose-  )-import Rel8.Table.Transpose ( Transposes )-import Rel8.Type ( DBType )----- | A @Name@ is the name of a column, as it would be defined in a table's--- schema definition. You can construct names by using the @OverloadedStrings@--- extension and writing string literals. This is typically done when providing--- a 'TableSchema' value.-type Name :: K.Context-newtype Name a = Name String-  deriving stock Show-  deriving newtype IsString---instance Sql DBType a => Table Name (Name a) where-  type Columns (Name a) = HIdentity a-  type Context (Name a) = Name-  type FromExprs (Name a) = a-  type Transpose to (Name a) = to a--  toColumns a = HIdentity a-  fromColumns (HIdentity a) = a-  toResult a = HIdentity (Identity a)-  fromResult (HIdentity (Identity a)) = a----- | @Selects a b@ means that @a@ is a schema (i.e., a 'Table' of 'Name's) for--- the 'Expr' columns in @b@.-type Selects :: Type -> Type -> Constraint-class Transposes Name Expr names exprs => Selects names exprs-instance Transposes Name Expr names exprs => Selects names exprs---ppColumn :: String -> Doc-ppColumn = Opaleye.ppSqlExpr . Opaleye.ColumnSqlExpr . Opaleye.SqlColumn
− src/Rel8/Schema/Name.hs-boot 
@@ -1,11 +0,0 @@-{-# language PolyKinds #-}-{-# language RoleAnnotations #-}-{-# language StandaloneKindSignatures #-}--module Rel8.Schema.Name where--import Data.Kind ( Type )--type Name :: k -> Type-type role Name nominal-data Name a
− src/Rel8/Schema/Null.hs 
@@ -1,110 +0,0 @@-{-# language ConstraintKinds #-}-{-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language GADTs #-}-{-# language MultiParamTypeClasses #-}-{-# language RankNTypes #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}-{-# language UndecidableSuperClasses #-}--module Rel8.Schema.Null-  ( Nullify, Unnullify-  , NotNull-  , Homonullable-  , Nullity( Null, NotNull )-  , Nullable, nullable-  , Sql-  )-where---- base-import Data.Kind ( Constraint, Type )-import Prelude---type IsMaybe :: Type -> Bool-type family IsMaybe a where-  IsMaybe (Maybe _) = 'True-  IsMaybe _ = 'False---type Unnullify' :: Bool -> Type -> Type-type family Unnullify' isMaybe ma where-  Unnullify' 'False a = a-  Unnullify' 'True (Maybe a) = a---type Unnullify :: Type -> Type-type Unnullify a = Unnullify' (IsMaybe a) a---type Nullify' :: Bool -> Type -> Type-type family Nullify' isMaybe a where-  Nullify' 'False a = a-  Nullify' 'True a = Maybe a---type Nullify :: Type -> Type-type Nullify a = Maybe (Unnullify a)----- | @nullify a@ means @a@ cannot take @null@ as a value.-type NotNull :: Type -> Constraint-class (Nullable a, IsMaybe a ~ 'False) => NotNull a-instance (Nullable a, IsMaybe a ~ 'False) => NotNull a----- | @Homonullable a b@ means that both @a@ and @b@ can be @null@, or neither--- @a@ or @b@ can be @null@.-type Homonullable :: Type -> Type -> Constraint-class IsMaybe a ~ IsMaybe b => Homonullable a b-instance IsMaybe a ~ IsMaybe b => Homonullable a b---type Nullity :: Type -> Type-data Nullity a where-  NotNull :: NotNull a => Nullity a-  Null :: NotNull a => Nullity (Maybe a)---type Nullable' :: Bool -> Type -> Constraint-class-  ( IsMaybe a ~ isMaybe-  , IsMaybe (Unnullify a) ~ 'False-  , Nullify' isMaybe (Unnullify a) ~ a-  ) => Nullable' isMaybe a- where-  nullable' :: Nullity a---instance IsMaybe a ~ 'False => Nullable' 'False a where-  nullable' = NotNull---instance IsMaybe a ~ 'False => Nullable' 'True (Maybe a) where-  nullable' = Null----- | @Nullable a@ means that @rel8@ is able to check if the type @a@ is a--- type that can take @null@ values or not.-type Nullable :: Type -> Constraint-class Nullable' (IsMaybe a) a => Nullable a-instance Nullable' (IsMaybe a) a => Nullable a---nullable :: Nullable a => Nullity a-nullable = nullable'----- | The @Sql@ type class describes both null and not null database values,--- constrained by a specific class.------ For example, if you see @Sql DBEq a@, this means any database type that--- supports equality, and @a@ can either be exactly an @a@, or it could also be--- @Maybe a@.-type Sql :: (Type -> Constraint) -> Type -> Constraint-class (constraint (Unnullify a), Nullable a) => Sql constraint a-instance (constraint (Unnullify a), Nullable a) => Sql constraint a
− src/Rel8/Schema/Result.hs 
@@ -1,54 +0,0 @@-{-# language DataKinds #-}-{-# language GADTs #-}-{-# language NamedFieldPuns #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}--module Rel8.Schema.Result-  ( Result-  , null, nullifier, unnullifier-  , vectorizer, unvectorizer-  )-where---- base-import Data.Functor.Identity ( Identity( Identity), runIdentity )-import Prelude hiding ( null )---- rel8-import Rel8.Schema.Kind ( Context )-import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )-import Rel8.Schema.Spec ( Spec(..) )----- | The @Result@ context is the context used for decoded query results.------ When a query is executed against a PostgreSQL database, Rel8 parses the--- returned rows, decoding each row into the @Result@ context.-type Result :: Context-type Result = Identity---null :: Result (Maybe a)-null = Identity Nothing---nullifier :: Spec a -> Result a -> Result (Nullify a)-nullifier Spec {nullity} (Identity a) = Identity $ case nullity of-  Null -> a-  NotNull -> Just a---unnullifier :: Spec a -> Result (Nullify a) -> Maybe (Result a)-unnullifier Spec {nullity} (Identity a) =-  case nullity of-    Null -> pure $ Identity a-    NotNull -> Identity <$> a---vectorizer :: Functor f => Spec a -> f (Result a) -> Result (f a)-vectorizer _ = Identity . fmap runIdentity---unvectorizer :: Functor f => Spec a -> Result (f a) -> f (Result a)-unvectorizer _ (Identity results) = Identity <$> results
− src/Rel8/Schema/Spec.hs 
@@ -1,34 +0,0 @@-{-# language FlexibleContexts #-}-{-# language MonoLocalBinds #-}-{-# language StandaloneKindSignatures #-}--module Rel8.Schema.Spec-  ( Spec( Spec, labels, info, nullity )-  , specification-  )-where---- base-import Data.Kind ( Type )-import Prelude---- rel8-import Rel8.Schema.Null ( Nullity, Sql, Unnullify, nullable )-import Rel8.Type ( DBType, typeInformation )-import Rel8.Type.Information ( TypeInformation )---type Spec :: Type -> Type-data Spec a = Spec-  { labels :: [String]-  , info :: TypeInformation (Unnullify a)-  , nullity :: Nullity a-  }---specification :: Sql DBType a => Spec a-specification = Spec-  { labels = []-  , info = typeInformation-  , nullity = nullable-  }
− src/Rel8/Schema/Table.hs 
@@ -1,46 +0,0 @@-{-# language DeriveFunctor #-}-{-# language DerivingStrategies #-}-{-# language DisambiguateRecordFields #-}-{-# language NamedFieldPuns #-}--module Rel8.Schema.Table-  ( TableSchema(..)-  , ppTable-  )-where---- base-import Prelude---- opaleye-import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye-import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye---- pretty-import Text.PrettyPrint ( Doc )----- | The schema for a table. This is used to specify the name and schema that a--- table belongs to (the @FROM@ part of a SQL query), along with the schema of--- the columns within this table.--- --- For each selectable table in your database, you should provide a--- @TableSchema@ in order to interact with the table via Rel8.-data TableSchema names = TableSchema-  { name :: String-    -- ^ The name of the table.-  , schema :: Maybe String-    -- ^ The schema that this table belongs to. If 'Nothing', whatever is on-    -- the connection's @search_path@ will be used.-  , columns :: names-    -- ^ The columns of the table. Typically you would use a a higher-kinded-    -- data type here, parameterized by the 'Rel8.ColumnSchema.ColumnSchema' functor.-  }-  deriving stock Functor---ppTable :: TableSchema a -> Doc-ppTable TableSchema {name, schema} = Opaleye.ppTable Opaleye.SqlTable-  { sqlTableSchemaName = schema-  , sqlTableName = name-  }
− src/Rel8/Statement/Delete.hs 
@@ -1,79 +0,0 @@-{-# language DuplicateRecordFields #-}-{-# language GADTs #-}-{-# language NamedFieldPuns #-}-{-# language RankNTypes #-}-{-# language RecordWildCards #-}-{-# language StandaloneKindSignatures #-}-{-# language StrictData #-}--module Rel8.Statement.Delete-  ( Delete(..)-  , delete-  , ppDelete-  )-where---- base-import Data.Kind ( Type )-import Prelude---- hasql-import qualified Hasql.Encoders as Hasql-import qualified Hasql.Statement as Hasql---- pretty-import Text.PrettyPrint ( Doc, (<+>), ($$), text )---- rel8-import Rel8.Expr ( Expr )-import Rel8.Query ( Query )-import Rel8.Schema.Name ( Selects )-import Rel8.Schema.Table ( TableSchema, ppTable )-import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )-import Rel8.Statement.Using ( ppUsing )-import Rel8.Statement.Where ( ppWhere )---- text-import qualified Data.Text as Text-import Data.Text.Encoding ( encodeUtf8 )----- | The constituent parts of a @DELETE@ statement.-type Delete :: Type -> Type-data Delete a where-  Delete :: Selects names exprs =>-    { from :: TableSchema names-      -- ^ Which table to delete from.-    , using :: Query using-      -- ^ @USING@ clause — this can be used to join against other tables,-      -- and its results can be referenced in the @WHERE@ clause-    , deleteWhere :: using -> exprs -> Expr Bool-      -- ^ Which rows should be selected for deletion.-    , returning :: Returning names a-      -- ^ What to return from the @DELETE@ statement.-    }-    -> Delete a---ppDelete :: Delete a -> Doc-ppDelete Delete {..} = case ppUsing using of-  Nothing ->-    text "DELETE FROM" <+> ppTable from $$-    text "WHERE false"-  Just (usingDoc, i) ->-    text "DELETE FROM" <+> ppTable from $$-    usingDoc $$-    ppWhere from (deleteWhere i) $$-    ppReturning from returning----- | Run a 'Delete' statement.-delete :: Delete a -> Hasql.Statement () a-delete d@Delete {returning} = Hasql.Statement bytes params decode prepare-  where-    bytes = encodeUtf8 $ Text.pack sql-    params = Hasql.noParams-    decode = decodeReturning returning-    prepare = False-    sql = show doc-    doc = ppDelete d
− src/Rel8/Statement/Insert.hs 
@@ -1,89 +0,0 @@-{-# language DuplicateRecordFields #-}-{-# language FlexibleContexts #-}-{-# language GADTs #-}-{-# language NamedFieldPuns #-}-{-# language RecordWildCards #-}-{-# language StandaloneKindSignatures #-}-{-# language StrictData #-}--module Rel8.Statement.Insert-  ( Insert(..)-  , insert-  , ppInsert-  , ppInto-  )-where---- base-import Data.Foldable ( toList )-import Data.Kind ( Type )-import Prelude---- hasql-import qualified Hasql.Encoders as Hasql-import qualified Hasql.Statement as Hasql---- opaleye-import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye---- pretty-import Text.PrettyPrint ( Doc, (<+>), ($$), parens, text )---- rel8-import Rel8.Query ( Query )-import Rel8.Schema.Name ( Name, Selects, ppColumn )-import Rel8.Schema.Table ( TableSchema(..), ppTable )-import Rel8.Statement.OnConflict ( OnConflict, ppOnConflict )-import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )-import Rel8.Statement.Select ( ppRows )-import Rel8.Table ( Table )-import Rel8.Table.Name ( showNames )---- text-import qualified Data.Text as Text ( pack )-import Data.Text.Encoding ( encodeUtf8 )----- | The constituent parts of a SQL @INSERT@ statement.-type Insert :: Type -> Type-data Insert a where-  Insert :: Selects names exprs =>-    { into :: TableSchema names-      -- ^ Which table to insert into.-    , rows :: Query exprs-      -- ^ The rows to insert. This can be an arbitrary query — use-      -- 'Rel8.values' insert a static list of rows.-    , onConflict :: OnConflict names-      -- ^ What to do if the inserted rows conflict with data already in the-      -- table.-    , returning :: Returning names a-      -- ^ What information to return on completion.-    }-    -> Insert a---ppInsert :: Insert a -> Doc-ppInsert Insert {..} =-  text "INSERT INTO" <+>-  ppInto into $$-  ppRows rows $$-  ppOnConflict into onConflict $$-  ppReturning into returning---ppInto :: Table Name a => TableSchema a -> Doc-ppInto table@TableSchema {columns} =-  ppTable table <+>-  parens (Opaleye.commaV ppColumn (toList (showNames columns)))----- | Run an 'Insert' statement.-insert :: Insert a -> Hasql.Statement () a-insert i@Insert {returning} = Hasql.Statement bytes params decode prepare-  where-    bytes = encodeUtf8 $ Text.pack sql-    params = Hasql.noParams-    decode = decodeReturning returning-    prepare = False-    sql = show doc-    doc = ppInsert i
− src/Rel8/Statement/OnConflict.hs 
@@ -1,106 +0,0 @@-{-# language DuplicateRecordFields #-}-{-# language FlexibleContexts #-}-{-# language GADTs #-}-{-# language LambdaCase #-}-{-# language NamedFieldPuns #-}-{-# language RecordWildCards #-}-{-# language StandaloneKindSignatures #-}-{-# language StrictData #-}--module Rel8.Statement.OnConflict-  ( OnConflict(..)-  , Upsert(..)-  , ppOnConflict-  )-where---- base-import Data.Foldable ( toList )-import Data.Kind ( Type )-import Prelude---- opaleye-import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye---- pretty-import Text.PrettyPrint ( Doc, (<+>), ($$), parens, text )---- rel8-import Rel8.Expr ( Expr )-import Rel8.Schema.Name ( Name, Selects, ppColumn )-import Rel8.Schema.Table ( TableSchema(..) )-import Rel8.Statement.Set ( ppSet )-import Rel8.Statement.Where ( ppWhere )-import Rel8.Table ( Table, toColumns )-import Rel8.Table.Cols ( Cols( Cols ) )-import Rel8.Table.Name ( showNames )-import Rel8.Table.Opaleye ( attributes )-import Rel8.Table.Projection ( Projecting, Projection, apply )----- | 'OnConflict' represents the @ON CONFLICT@ clause of an @INSERT@--- statement. This specifies what ought to happen when one or more of the--- rows proposed for insertion conflict with an existing row in the table.-type OnConflict :: Type -> Type-data OnConflict names-  = Abort-    -- ^ Abort the transaction if there are conflicting rows (Postgres' default)-  | DoNothing-    -- ^ @ON CONFLICT DO NOTHING@-  | DoUpdate (Upsert names)-    -- ^ @ON CONFLICT DO UPDATE@----- | The @ON CONFLICT (...) DO UPDATE@ clause of an @INSERT@ statement, also--- known as \"upsert\".------ When an existing row conflicts with a row proposed for insertion,--- @ON CONFLICT DO UPDATE@ allows you to instead update this existing row. The--- conflicting row proposed for insertion is then \"excluded\", but its values--- can still be referenced from the @SET@ and @WHERE@ clauses of the @UPDATE@--- statement.------ Upsert in Postgres requires an explicit set of \"conflict targets\" — the--- set of columns comprising the @UNIQUE@ index from conflicts with which we--- would like to recover.-type Upsert :: Type -> Type-data Upsert names where-  Upsert :: (Selects names exprs, Projecting names index, excluded ~ exprs) =>-    { index :: Projection names index-      -- ^ The set of conflict targets, projected from the set of columns for-      -- the whole table-    , set :: excluded -> exprs -> exprs-      -- ^ How to update each selected row.-    , updateWhere :: excluded -> exprs -> Expr Bool-      -- ^ Which rows to select for update.-    }-    -> Upsert names---ppOnConflict :: TableSchema names -> OnConflict names -> Doc-ppOnConflict schema = \case-  Abort -> mempty-  DoNothing -> text "ON CONFLICT DO NOTHING"-  DoUpdate upsert -> ppUpsert schema upsert---ppUpsert :: TableSchema names -> Upsert names -> Doc-ppUpsert schema@TableSchema {columns} Upsert {..} =-  text "ON CONFLICT" <+>-  ppIndex schema index <+>-  text "DO UPDATE" $$-  ppSet schema (set excluded) $$-  ppWhere schema (updateWhere excluded)-  where-    excluded = attributes TableSchema-      { schema = Nothing-      , name = "excluded"-      , columns-      }---ppIndex :: (Table Name names, Projecting names index)-  => TableSchema names -> Projection names index -> Doc-ppIndex TableSchema {columns} index =-  parens $ Opaleye.commaV ppColumn $ toList $-    showNames $ Cols $ apply index $ toColumns columns
− src/Rel8/Statement/Returning.hs 
@@ -1,133 +0,0 @@-{-# language GADTs #-}-{-# language LambdaCase #-}-{-# language NamedFieldPuns #-}-{-# language RankNTypes #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language StrictData #-}-{-# language TypeApplications #-}--module Rel8.Statement.Returning-  ( Returning( NumberOfRowsAffected, Projection )-  , decodeReturning-  , ppReturning-  )-where---- base-import Control.Applicative ( liftA2 )-import Data.Foldable ( toList )-import Data.Int ( Int64 )-import Data.Kind ( Type )-import Data.List.NonEmpty ( NonEmpty )-import Prelude---- hasql-import qualified Hasql.Decoders as Hasql---- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye-import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye-import qualified Opaleye.Internal.Sql as Opaleye---- pretty-import Text.PrettyPrint ( Doc, (<+>), text )---- rel8-import Rel8.Schema.Name ( Selects )-import Rel8.Schema.Table ( TableSchema(..) )-import Rel8.Table.Opaleye ( castTable, exprs, view )-import Rel8.Table.Serialize ( Serializable, parse )---- semigropuoids-import Data.Functor.Apply ( Apply, (<.>) )----- | 'Rel8.Insert', 'Rel8.Update' and 'Rel8.Delete' all support returning either--- the number of rows affected, or the actual rows modified.-type Returning :: Type -> Type -> Type-data Returning names a where-  Pure :: a -> Returning names a-  Ap :: Returning names (a -> b) -> Returning names a -> Returning names b--  -- | Return the number of rows affected.-  NumberOfRowsAffected :: Returning names Int64--  -- | 'Projection' allows you to project out of the affected rows, which can-  -- be useful if you want to log exactly which rows were deleted, or to view-  -- a generated id (for example, if using a column with an autoincrementing-  -- counter via 'Rel8.nextval').-  Projection :: (Selects names exprs, Serializable returning a)-    => (exprs -> returning)-    -> Returning names [a]---instance Functor (Returning names) where-  fmap f = \case-    Pure a -> Pure (f a)-    Ap g a -> Ap (fmap (f .) g) a-    m -> Ap (Pure f) m---instance Apply (Returning names) where-  (<.>) = Ap---instance Applicative (Returning names) where-  pure = Pure-  (<*>) = Ap---projections :: ()-  => TableSchema names -> Returning names a -> Maybe (NonEmpty Opaleye.PrimExpr)-projections schema@TableSchema {columns} = \case-  Pure _ -> Nothing-  Ap f a -> projections schema f <> projections schema a-  NumberOfRowsAffected -> Nothing-  Projection f -> Just (exprs (castTable (f (view columns))))---runReturning :: ()-  => ((Int64 -> a) -> r)-  -> (forall x. Hasql.Row x -> ([x] -> a) -> r)-  -> Returning names a-  -> r-runReturning rowCount rowList = \case-  Pure a -> rowCount (const a)-  Ap fs as ->-    runReturning-      (\withCount ->-         runReturning-           (\withCount' -> rowCount (withCount <*> withCount'))-           (\decoder -> rowList decoder . liftA2 withCount length64)-           as)-      (\decoder withRows ->-         runReturning-           (\withCount -> rowList decoder $ withRows <*> withCount . length64)-           (\decoder' withRows' ->-             rowList (liftA2 (,) decoder decoder') $-               withRows <$> fmap fst <*> withRows' . fmap snd)-           as)-      fs-  NumberOfRowsAffected -> rowCount id-  Projection (_ :: exprs -> returning) -> rowList decoder' id-    where-      decoder' = parse @returning-  where-    length64 :: Foldable f => f x -> Int64-    length64 = fromIntegral . length---decodeReturning :: Returning names a -> Hasql.Result a-decodeReturning = runReturning-  (<$> Hasql.rowsAffected)-  (\decoder withRows -> withRows <$> Hasql.rowList decoder)---ppReturning :: TableSchema names -> Returning names a -> Doc-ppReturning schema returning = case projections schema returning of-  Nothing -> mempty-  Just columns ->-    text "RETURNING" <+> Opaleye.commaV Opaleye.ppSqlExpr (toList sqlExprs)-    where-      sqlExprs = Opaleye.sqlExpr <$> columns
− src/Rel8/Statement/SQL.hs 
@@ -1,29 +0,0 @@-module Rel8.Statement.SQL-  ( showDelete-  , showInsert-  , showUpdate-  )-where---- base-import Prelude---- rel8-import Rel8.Statement.Delete ( Delete, ppDelete )-import Rel8.Statement.Insert ( Insert, ppInsert )-import Rel8.Statement.Update ( Update, ppUpdate )----- | Convert a 'Delete' to a 'String' containing a @DELETE@ statement.-showDelete :: Delete a -> String-showDelete = show . ppDelete----- | Convert an 'Insert' to a 'String' containing an @INSERT@ statement.-showInsert :: Insert a -> String-showInsert = show . ppInsert----- | Convert an 'Update' to a 'String' containing an @UPDATE@ statement.-showUpdate :: Update a -> String-showUpdate = show . ppUpdate
− src/Rel8/Statement/Select.hs 
@@ -1,145 +0,0 @@-{-# language DeriveTraversable #-}-{-# language DerivingStrategies #-}-{-# language FlexibleContexts #-}-{-# language MonoLocalBinds #-}-{-# language ScopedTypeVariables #-}-{-# language TypeApplications #-}--module Rel8.Statement.Select-  ( select-  , ppSelect--  , Optimized(..)-  , ppPrimSelect-  , ppRows-  )-where---- base-import Data.Foldable ( toList )-import Data.List.NonEmpty ( NonEmpty( (:|) ) )-import Data.Void ( Void )-import Prelude hiding ( undefined )---- hasql-import qualified Hasql.Decoders as Hasql-import qualified Hasql.Encoders as Hasql-import qualified Hasql.Statement as Hasql---- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye-import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye-import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye-import qualified Opaleye.Internal.PrimQuery as Opaleye-import qualified Opaleye.Internal.Print as Opaleye-import qualified Opaleye.Internal.Optimize as Opaleye-import qualified Opaleye.Internal.QueryArr as Opaleye hiding ( Select )-import qualified Opaleye.Internal.Sql as Opaleye hiding ( Values )-import qualified Opaleye.Internal.Tag as Opaleye---- pretty-import Text.PrettyPrint ( Doc )---- rel8-import Rel8.Expr ( Expr )-import Rel8.Expr.Bool ( false )-import Rel8.Expr.Opaleye ( toPrimExpr )-import Rel8.Query ( Query )-import Rel8.Query.Opaleye ( toOpaleye )-import Rel8.Schema.Name ( Selects )-import Rel8.Table ( Table )-import Rel8.Table.Cols ( toCols )-import Rel8.Table.Name ( namesFromLabels )-import Rel8.Table.Opaleye ( castTable, exprsWithNames )-import qualified Rel8.Table.Opaleye as T-import Rel8.Table.Serialize ( Serializable, parse )-import Rel8.Table.Undefined ( undefined )---- text-import qualified Data.Text as Text-import Data.Text.Encoding ( encodeUtf8 )----- | Run a @SELECT@ statement, returning all rows.-select :: forall exprs a. Serializable exprs a-  => Query exprs -> Hasql.Statement () [a]-select query = Hasql.Statement bytes params decode prepare-  where-    bytes = encodeUtf8 (Text.pack sql)-    params = Hasql.noParams-    decode = Hasql.rowList (parse @exprs @a)-    prepare = False-    sql = show doc-    doc = ppSelect query---ppSelect :: Table Expr a => Query a -> Doc-ppSelect query =-  Opaleye.ppSql $ primSelectWith names (toCols exprs') primQuery'-  where-    names = namesFromLabels-    (exprs, primQuery, _) =-      Opaleye.runSimpleQueryArrStart (toOpaleye query) ()-    (exprs', primQuery') = case optimize primQuery of-      Empty -> (undefined, Opaleye.Product (pure (pure Opaleye.Unit)) never)-      Unit -> (exprs, Opaleye.Unit)-      Optimized pq -> (exprs, pq)-    never = pure (toPrimExpr false)---ppRows :: Table Expr a => Query a -> Doc-ppRows query = case optimize primQuery of-  -- Special case VALUES because we can't use DEFAULT inside a SELECT-  Optimized (Opaleye.Product ((_, Opaleye.Values symbols rows) :| []) [])-    | eqSymbols symbols (toList (T.exprs a)) ->-        Opaleye.ppValues_ (map Opaleye.sqlExpr <$> toList rows)-  _ -> ppSelect query-  where-    (a, primQuery, _) = Opaleye.runSimpleQueryArrStart (toOpaleye query) ()--    eqSymbols (symbol : symbols) (Opaleye.AttrExpr symbol' : exprs)-      | eqSymbol symbol symbol' = eqSymbols symbols exprs-      | otherwise = False-    eqSymbols [] [] = True-    eqSymbols _ _ = False--    eqSymbol-      (Opaleye.Symbol name (Opaleye.UnsafeTag tag))-      (Opaleye.Symbol name' (Opaleye.UnsafeTag tag'))-      = name == name' && tag == tag'---ppPrimSelect :: Query a -> (Optimized Doc, a)-ppPrimSelect query =-  (Opaleye.ppSql . primSelect <$> optimize primQuery, a)-  where-    (a, primQuery, _) = Opaleye.runSimpleQueryArrStart (toOpaleye query) ()---data Optimized a = Empty | Unit | Optimized a-  deriving stock (Functor, Foldable, Traversable)---optimize :: Opaleye.PrimQuery' a -> Optimized (Opaleye.PrimQuery' Void)-optimize query = case Opaleye.removeEmpty (Opaleye.optimize query) of-  Nothing -> Empty-  Just Opaleye.Unit -> Unit-  Just query' -> Optimized query'---primSelect :: Opaleye.PrimQuery' Void -> Opaleye.Select-primSelect = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator---primSelectWith :: Selects names exprs-  => names -> exprs -> Opaleye.PrimQuery' Void -> Opaleye.Select-primSelectWith names exprs query =-  Opaleye.SelectFrom $ Opaleye.newSelect-    { Opaleye.attrs = Opaleye.SelectAttrs attrs-    , Opaleye.tables = Opaleye.oneTable (primSelect query)-    }-  where-    attrs = makeAttr <$> exprsWithNames names (castTable exprs)-      where-        makeAttr (label, expr) =-          (Opaleye.sqlExpr expr, Just (Opaleye.SqlColumn label))
− src/Rel8/Statement/Set.hs 
@@ -1,33 +0,0 @@-{-# language MonoLocalBinds #-}-{-# language NamedFieldPuns #-}--module Rel8.Statement.Set-  ( ppSet-  )-where---- base-import Data.Foldable ( toList )-import Prelude ()---- opaleye-import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye-import qualified Opaleye.Internal.Sql as Opaleye---- pretty-import Text.PrettyPrint ( Doc, (<+>), equals, text )---- rel8-import Rel8.Schema.Name ( Selects, ppColumn )-import Rel8.Schema.Table ( TableSchema(..) )-import Rel8.Table.Opaleye ( attributes, exprsWithNames )---ppSet :: Selects names exprs-  => TableSchema names -> (exprs -> exprs) -> Doc-ppSet schema@TableSchema {columns} f =-  text "SET" <+> Opaleye.commaV ppAssign (toList assigns)-  where-    assigns = exprsWithNames columns (f (attributes schema))-    ppAssign (column, expr) =-      ppColumn column <+> equals <+> Opaleye.ppSqlExpr (Opaleye.sqlExpr expr)
− src/Rel8/Statement/Update.hs 
@@ -1,83 +0,0 @@-{-# language DuplicateRecordFields #-}-{-# language GADTs #-}-{-# language NamedFieldPuns #-}-{-# language RecordWildCards #-}-{-# language StandaloneKindSignatures #-}-{-# language StrictData #-}--module Rel8.Statement.Update-  ( Update(..)-  , update-  , ppUpdate-  )-where---- base-import Data.Kind ( Type )-import Prelude---- hasql-import qualified Hasql.Encoders as Hasql-import qualified Hasql.Statement as Hasql---- pretty-import Text.PrettyPrint ( Doc, (<+>), ($$), text )---- rel8-import Rel8.Expr ( Expr )-import Rel8.Query ( Query )-import Rel8.Schema.Name ( Selects )-import Rel8.Schema.Table ( TableSchema(..), ppTable )-import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )-import Rel8.Statement.Set ( ppSet )-import Rel8.Statement.Using ( ppFrom )-import Rel8.Statement.Where ( ppWhere )---- text-import qualified Data.Text as Text-import Data.Text.Encoding ( encodeUtf8 )----- | The constituent parts of an @UPDATE@ statement.-type Update :: Type -> Type-data Update a where-  Update :: Selects names exprs =>-    { target :: TableSchema names-      -- ^ Which table to update.-    , from :: Query from-      -- ^ @FROM@ clause — this can be used to join against other tables,-      -- and its results can be referenced in the @SET@ and @WHERE@ clauses.-    , set :: from -> exprs -> exprs-      -- ^ How to update each selected row.-    , updateWhere :: from -> exprs -> Expr Bool-      -- ^ Which rows to select for update.-    , returning :: Returning names a-      -- ^ What to return from the @UPDATE@ statement.-    }-    -> Update a---ppUpdate :: Update a -> Doc-ppUpdate Update {..} = case ppFrom from of-  Nothing ->-    text "UPDATE" <+> ppTable target $$-    ppSet target id $$-    text "WHERE false"-  Just (fromDoc, i) ->-    text "UPDATE" <+> ppTable target $$-    ppSet target (set i) $$-    fromDoc $$-    ppWhere target (updateWhere i) $$-    ppReturning target returning----- | Run an @UPDATE@ statement.-update :: Update a -> Hasql.Statement () a-update u@Update {returning} = Hasql.Statement bytes params decode prepare-  where-    bytes = encodeUtf8 $ Text.pack sql-    params = Hasql.noParams-    decode = decodeReturning returning-    prepare = False-    sql = show doc-    doc = ppUpdate u
− src/Rel8/Statement/Using.hs 
@@ -1,36 +0,0 @@-module Rel8.Statement.Using-  ( ppFrom-  , ppUsing-  )-where---- base-import Prelude---- pretty-import Text.PrettyPrint ( Doc, (<+>), parens, text )---- rel8-import Rel8.Query ( Query )-import Rel8.Schema.Table ( TableSchema(..), ppTable )-import Rel8.Statement.Select ( Optimized(..), ppPrimSelect )---ppFrom :: Query a -> Maybe (Doc, a)-ppFrom = ppJoin "FROM"---ppUsing :: Query a -> Maybe (Doc, a)-ppUsing = ppJoin "USING"---ppJoin :: String -> Query a -> Maybe (Doc, a)-ppJoin clause join = do-  doc <- case ofrom of-    Empty -> Nothing-    Unit -> Just mempty-    Optimized doc -> Just $ text clause <+> parens doc <+> ppTable alias-  pure (doc, a)-  where-    alias = TableSchema {name = "T1", schema = Nothing, columns = ()}-    (ofrom, a) = ppPrimSelect join
− src/Rel8/Statement/View.hs 
@@ -1,53 +0,0 @@-{-# language FlexibleContexts #-}-{-# language MonoLocalBinds #-}--module Rel8.Statement.View-  ( createView-  )-where---- base-import Prelude---- hasql-import qualified Hasql.Decoders as Hasql-import qualified Hasql.Encoders as Hasql-import qualified Hasql.Statement as Hasql---- rel8-import Rel8.Query ( Query )-import Rel8.Schema.Name ( Selects )-import Rel8.Schema.Table ( TableSchema )-import Rel8.Statement.Insert ( ppInto )-import Rel8.Statement.Select ( ppSelect )---- pretty-import Text.PrettyPrint ( Doc, (<+>), ($$), text )---- text-import qualified Data.Text as Text-import Data.Text.Encoding ( encodeUtf8 )----- | Given a 'TableSchema' and 'Query', @createView@ runs a @CREATE VIEW@--- statement that will save the given query as a view. This can be useful if--- you want to share Rel8 queries with other applications.-createView :: Selects names exprs-  => TableSchema names -> Query exprs -> Hasql.Statement () ()-createView schema query = Hasql.Statement bytes params decode prepare-  where-    bytes = encodeUtf8 (Text.pack sql)-    params = Hasql.noParams-    decode = Hasql.noResult-    prepare = False-    sql = show doc-    doc = ppCreateView schema query---ppCreateView :: Selects names exprs-  => TableSchema names -> Query exprs -> Doc-ppCreateView schema query =-  text "CREATE VIEW" <+>-  ppInto schema $$-  text "AS" <+>-  ppSelect query
− src/Rel8/Statement/Where.hs 
@@ -1,31 +0,0 @@-{-# language MonoLocalBinds #-}--module Rel8.Statement.Where-  ( ppWhere-  )-where---- base-import Prelude---- opaleye-import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye-import qualified Opaleye.Internal.Sql as Opaleye---- pretty-import Text.PrettyPrint ( Doc, (<+>), text )---- rel8-import Rel8.Expr ( Expr )-import Rel8.Expr.Opaleye ( toPrimExpr )-import Rel8.Schema.Name ( Selects )-import Rel8.Schema.Table ( TableSchema )-import Rel8.Table.Opaleye ( attributes )---ppWhere :: Selects names exprs-  => TableSchema names -> (exprs -> Expr Bool) -> Doc-ppWhere schema where_ = text "WHERE" <+> ppExpr condition-  where-    ppExpr = Opaleye.ppSqlExpr . Opaleye.sqlExpr . toPrimExpr-    condition = where_ (attributes schema)
+ src/Rel8/TH.hs view
@@ -0,0 +1,279 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}++module Rel8.TH+  ( deriveRel8able+  , deriveRel8ables+  ) where++import Control.Monad (zipWithM)+import Data.Foldable (toList)+import Data.Foldable1 (foldr1)+import Data.List (unsnoc)+import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty)+import qualified Data.Map.Strict as M+import Data.Proxy (Proxy (Proxy))+import Data.Type.Equality (type (==))+import Language.Haskell.TH (Q)+import qualified Language.Haskell.TH as TH+import Language.Haskell.TH.Datatype (ConstructorVariant (RecordConstructor), DatatypeInfo (..), constructorFields, constructorVariant, datatypeCons, reifyDatatype)+import qualified Language.Haskell.TH.Datatype as TH.Datatype+import qualified Language.Haskell.TH.Syntax as TH+import Rel8.Internal.Column (Column)+import Rel8.Internal.Expr (Expr)+import Rel8.Internal.Generic.Rel8able (Rel8able (..), Serialize, deserialize, serialize)+import Rel8.Internal.Kind.Context (SContext (..))+import Rel8.Internal.Schema.HTable.Identity (HIdentity)+import Rel8.Internal.Schema.HTable.Label (HLabel (..))+import Rel8.Internal.Schema.HTable.Product (HProduct (HProduct))+import Rel8.Internal.Schema.Kind (Context)+import Rel8.Internal.Schema.Result (Result)+import Rel8.Internal.Table (Columns, Transpose, fromColumns, toColumns)+import Rel8.Internal.Table.Serialize (ToExprs)+import Prelude hiding (foldr1)++-- | Represent a valid datatype+data ParsedDatatype+    = ParsedDatatype+    { name :: TH.Name+    , conName :: TH.Name+    , fBinder :: TH.Name+    , fields :: NonEmpty ParsedField+    }+    deriving (Show)++-- | Represent a valid field+data ParsedField+    = ParsedField+    { fieldSelector :: Maybe TH.Name+    , fieldType :: TH.Type+    , fieldColumnType :: TH.Type+    , fieldFreshName :: TH.Name+    }+    deriving (Show)++-- | 'fail' but indicate that the failure is coming from our code+prettyFail :: String -> Q a+prettyFail str = fail $ "deriveRel8able: " ++ str++parseDatatype :: DatatypeInfo -> Q ParsedDatatype+parseDatatype datatypeInfo = do+    constructor <-+        -- Check that it only has one constructor+        case datatypeCons datatypeInfo of+            [cons] -> pure cons+            _ -> prettyFail "exepecting a datatype with exactly 1 constructor"+    let conName = TH.Datatype.constructorName constructor+    let name = datatypeName datatypeInfo+    fBinder <- case unsnoc $ datatypeInstTypes datatypeInfo of+        Just (_, candidate) -> parseFBinder candidate+        Nothing -> prettyFail "expecting the datatype to have a context type parameter like `data Foo f = ...`"+    let fieldSelectors = case constructorVariant constructor of+            -- Only record constructors have field names+            RecordConstructor names -> map Just names+            _ -> repeat Nothing+    fieldList <- zipWithM (parseField fBinder) (constructorFields constructor) fieldSelectors+    fields <- maybe (prettyFail "Expected at least one field") pure $ nonEmpty fieldList+    pure ParsedDatatype{..}++parseFBinder :: TH.Type -> Q TH.Name+parseFBinder (TH.SigT x (TH.ConT kind))+    | kind == ''Context = parseFBinder x+    | otherwise = prettyFail $ "expected kind encountered for the context type argument: " ++ show kind+-- type Context = Type -> Type+parseFBinder (TH.SigT x (TH.ArrowT `TH.AppT` TH.StarT `TH.AppT` TH.StarT)) = parseFBinder x+parseFBinder (TH.VarT name) = pure name+parseFBinder typ = prettyFail $ "unexpected type encountered while looking for the context type argument to the datatype: " ++ show typ++parseField :: TH.Name -> TH.Type -> Maybe TH.Name -> Q ParsedField+parseField fBinder fieldType fieldSelector = do+    n <- TH.newName "x"+    let ft = TH.Datatype.applySubstitution (M.fromList [(fBinder, TH.ConT ''Expr)]) $ resolveColumnF fBinder fieldType+    columnType <- case ft of+        -- Without special casing this, we get lots of UndecidableInstance errors+        -- ie, rewrite Expr \phi to HIdentity \phi+        (TH.ConT exprName' `TH.AppT` x) | exprName' == ''Expr -> [t|HIdentity $(pure x)|] --+        _ -> [t|Columns $(pure ft)|]+    pure $ ParsedField{fieldSelector = fieldSelector, fieldType = ft, fieldColumnType = columnType, fieldFreshName = n}++-- | Like foldr1, but we create a mostly balanced binary tree.+-- This makes a big difference for compile times, since we want the depth of the HProduct tree to be minimal.+-- Each layer adds a lot of overhead.+foldr1Tree :: (a -> a -> a ) -> NonEmpty a -> a+foldr1Tree f xs0 = go (toList xs0) size0+  where+    size0 = length xs0+    go [] _ = error "impossible"+    go [x] _ = x+    go [x,y] _ = f x y+    go xs size = f (go left half) (go right (size - half))+      where+        -- Invariants:+        -- half > 0, since size is >2, this will always be the case+        -- size - half > 0+        half = size `div` 2+        (left, right) = splitAt half xs++generateGColumns :: ParsedDatatype -> Q TH.Type+generateGColumns ParsedDatatype{..} =+    foldr1Tree (\x y -> [t|HProduct $x $y|]) $ fmap generateGColumn fields+  where+    generateGColumn ParsedField{..} =+        labelled fieldSelector [t|$(pure fieldColumnType)|]+    labelled Nothing x = x+    labelled (Just (TH.Name (TH.OccName fieldSelector) _)) x = [t|HLabel $(TH.litT $ TH.strTyLit fieldSelector) $x|]++-- | Generate an expression to construct a column value+generateColumnsE :: ParsedDatatype -> (Q TH.Type -> Q TH.Exp -> Q TH.Exp) -> Q TH.Exp+generateColumnsE ParsedDatatype{..} g =+    foldr1Tree (\x y -> TH.conE 'HProduct `TH.appE` x `TH.appE` y) $ fmap generateColumnE fields+  where+    generateColumnE ParsedField{..} =+        labelled fieldSelector $+            g (pure fieldType) $+                TH.varE fieldFreshName+    labelled Nothing x = x+    labelled (Just _) x = TH.conE 'HLabel `TH.appE` x++-- | Generate a pattern to destruct a column+generateColumnsP :: ParsedDatatype -> TH.Pat+generateColumnsP ParsedDatatype{..} =+    foldr1Tree (\x y -> TH.ConP 'HProduct [] [x, y]) $ fmap generateColumnP fields+  where+    generateColumnP ParsedField{..} =+        labelled fieldSelector $+            TH.VarP fieldFreshName+    labelled Nothing x = x+    labelled (Just _) x = TH.ConP 'HLabel [] [x]++-- | Generate an expression to create the constructor+generateConstructorE :: ParsedDatatype -> (Q TH.Type -> Q TH.Exp -> Q TH.Exp) -> Q TH.Exp+generateConstructorE parsedDatatype g =+    foldl' TH.appE (TH.conE (conName parsedDatatype)) . fmap generateFieldE $ fields parsedDatatype+  where+    generateFieldE ParsedField{..} =+        g (pure fieldType) $ TH.varE fieldFreshName++-- | Generate a pattern to destruct the datatype+generateConstructorP :: ParsedDatatype -> Q TH.Pat+generateConstructorP parsedDatatype =+  pure $ TH.ConP (conName parsedDatatype) [] . toList . fmap (TH.VarP . fieldFreshName) $ fields parsedDatatype+++-- These two functions exist solely so we can write the splices without using TypeApplications, which require an extra language extension in client code, and are required here to appease the type checker.+-- Otherwise it gets confused.+deserialize' :: forall transposition expr a. Proxy expr -> (Serialize transposition expr a, transposition ~ (a == Transpose Result expr)) => Columns expr Result -> a+deserialize' _ = deserialize @_ @expr++serialize' :: forall transposition expr a. Proxy expr -> (Serialize transposition expr a, transposition ~ (a == Transpose Result expr)) => a -> Columns expr Result+serialize' _ = serialize @_ @expr++-- | Derive a 'Rel8able' instance using TemplateHaskell.+-- Using TH can be signficantly faster than using Generics.+-- Currently, this doesn't support all of the features of the Generics deriving machinery.+--+-- You might have to enable @UndecidableInstances@ for instances to compile.+--+-- >>> data Foo f  = Foo+-- >>>   { fooId :: Column f Word64+-- >>>   , fooName :: Column f Text+-- >>>   }+-- >>>+-- >>>  deriveRel8able ''Foo+deriveRel8able :: TH.Name -> Q [TH.Dec]+deriveRel8able name = do+    datatypeInfo <- reifyDatatype name+    parsedDatatype <- parseDatatype datatypeInfo+    let gColumns = generateGColumns parsedDatatype+    let constructorE = generateConstructorE parsedDatatype+    let constructorP = generateConstructorP parsedDatatype+    let columnsE = generateColumnsE parsedDatatype+    let columnsP = pure $ generateColumnsP parsedDatatype+    contextName <- TH.newName "context"+    [d|+        -- We already derive ToExprs for Rel8able instances but we assumed they are Generically derived.+        -- So, we need to allow this one to overlap, but this is fine since this instance is always more specific.+        instance {-# OVERLAPPING #-} (x ~ $(TH.conT name) Expr, result ~ Result) => ToExprs x ($(TH.conT name) result)++        instance Rel8able $(TH.conT name) where+            -- Really the Generic code substitutes Expr for f and then does stuff. Maybe we want to move closer to that?+            type+                GColumns $(TH.conT name) =+                    $gColumns++            type+                GFromExprs $(TH.conT name) =+                    $(TH.conT name) Result++            -- the rest of the definition is just a few functions to go back and forth between Columns and the datatype+            gfromColumns $(TH.varP contextName) v =+                case $(TH.varE contextName) of+                    SResult -> case v of $columnsP -> $(constructorE (\ft x -> [|deserialize' (Proxy :: Proxy $ft) $x|]))+                    SExpr -> case v of $columnsP -> $(constructorE (\_ x -> [|fromColumns $x|]))+                    SField -> case v of $columnsP -> $(constructorE (\_ x -> [|fromColumns $x|]))+                    SName -> case v of $columnsP -> $(constructorE (\_ x -> [|fromColumns $x|]))++            gtoColumns $(TH.varP contextName) $constructorP =+                case $(TH.varE contextName) of+                    SExpr -> $(columnsE (\_ x -> [|toColumns $x|]))+                    SField -> $(columnsE (\_ x -> [|toColumns $x|]))+                    SName -> $(columnsE (\_ x -> [|toColumns $x|]))+                    SResult -> $(columnsE (\ft x -> [|serialize' (Proxy :: Proxy $ft) $x|]))++            gfromResult $columnsP =+                $(constructorE (\ft x -> [|deserialize' (Proxy :: Proxy $ft) $x|]))++            gtoResult $constructorP =+                $(columnsE (\ft x -> [|serialize' (Proxy :: Proxy $ft) $x|]))+        |]++-- | Like 'deriveRel8able' but for a list of datatypes.+-- This is helpful as all of the instances live in a single splice.+-- Each TH splice creates a new decleration group, so they cannot see instances later in the file.+-- By deriving the instances in the same splice, we can ensure that they see each other.+-- This is necessary when deriving cyclic instances, but also reduces the amount of splice sorting required.+-- There is also a small performance overhead to each TH splice.+deriveRel8ables :: [TH.Name] -> Q [TH.Dec]+deriveRel8ables xs = concat <$> traverse deriveRel8able xs++-- | Walk 'TH.Type' and replace all occurences of @Column f x@ with @Expr x@.+resolveColumnF :: TH.Name -> TH.Type -> TH.Type+resolveColumnF fBinder (TH.ForallT tvs context t) =+    TH.ForallT tvs context (resolveColumnF fBinder t)+resolveColumnF fBinder (TH.AppT f x)+    | TH.ConT columnName `TH.AppT` (TH.VarT fBinder') <- f+    , columnName == ''Column+    , fBinder == fBinder' =+        TH.AppT (TH.ConT ''Expr) (resolveColumnF fBinder x)+    | otherwise = TH.AppT (resolveColumnF fBinder f) (resolveColumnF fBinder x)+resolveColumnF fBinder (TH.SigT t k) = TH.SigT (resolveColumnF fBinder t) (resolveColumnF fBinder k) -- k could be Kind+resolveColumnF fBinder (TH.InfixT l c r) = TH.InfixT (resolveColumnF fBinder l) c (resolveColumnF fBinder r)+resolveColumnF fBinder (TH.UInfixT l c r) = TH.UInfixT (resolveColumnF fBinder l) c (resolveColumnF fBinder r)+resolveColumnF fBinder (TH.ParensT t) = TH.ParensT (resolveColumnF fBinder t)+#if MIN_VERSION_template_haskell(2,15,0)+resolveColumnF fBinder (TH.AppKindT t k)  = TH.AppKindT (resolveColumnF fBinder t) (resolveColumnF fBinder k)+resolveColumnF fBinder (TH.ImplicitParamT n t)+  = TH.ImplicitParamT n (resolveColumnF fBinder t)+#endif+#if MIN_VERSION_template_haskell(2,16,0)+resolveColumnF fBinder (TH.ForallVisT tvs t) =+  TH.ForallVisT tvs (resolveColumnF fBinder t)+#endif+#if MIN_VERSION_template_haskell(2,19,0)+resolveColumnF fBinder (TH.PromotedInfixT l c r)+  = TH.PromotedInfixT (resolveColumnF fBinder l) c (resolveColumnF fBinder r)+resolveColumnF fBinder (TH.PromotedUInfixT l c r)+  = TH.PromotedUInfixT (resolveColumnF fBinder l) c (resolveColumnF fBinder r)+#endif+resolveColumnF _ t = t
− src/Rel8/Table.hs 
@@ -1,222 +0,0 @@-{-# language AllowAmbiguousTypes #-}-{-# language DataKinds #-}-{-# language DefaultSignatures #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language FunctionalDependencies #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}--module Rel8.Table-  ( Table-      ( Columns, Context, fromColumns, toColumns-      , FromExprs, fromResult, toResult-      , Transpose-      )-  , Congruent-  , TTable, TColumns, TContext, TFromExprs, TTranspose-  , TSerialize-  )-where---- base-import Data.Functor.Identity ( Identity( Identity ) )-import Data.Kind ( Constraint, Type )-import GHC.Generics ( Generic, Rep, from, to )-import Prelude hiding ( null )---- rel8-import Rel8.FCF ( Eval, Exp )-import Rel8.Generic.Map ( Map )-import Rel8.Generic.Table.Record-  ( GTable, GColumns, GContext, gfromColumns, gtoColumns-  , GSerialize, gfromResult, gtoResult-  )-import Rel8.Generic.Record ( Record(..) )-import Rel8.Schema.HTable ( HTable )-import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Null ( Sql )-import Rel8.Schema.Result ( Result )-import Rel8.Type ( DBType )----- | @Table@s are one of the foundational elements of Rel8, and describe data--- types that have a finite number of columns. Each of these columns contains--- data under a shared context, and contexts describe how to interpret the--- metadata about a column to a particular Haskell type. In Rel8, we have--- contexts for expressions (the 'Rel8.Expr' context), aggregations (the--- 'Rel8.Aggregate' context), insert values (the 'Rel8.Insert' contex), among--- others.------ In typical usage of Rel8 you don't need to derive instances of 'Table'--- yourself, as anything that's an instance of 'Rel8.Rel8able' is always a--- 'Table'.-type Table :: K.Context -> Type -> Constraint-class-  ( HTable (Columns a)-  , context ~ Context a-  , a ~ Transpose context a-  )-  => Table context a | a -> context- where-  -- | The 'HTable' functor that describes the schema of this table.-  type Columns a :: K.HTable--  -- | The common context that all columns use as an interpretation.-  type Context a :: K.Context--  -- | The @FromExprs@ type family maps a type in the @Expr@ context to the-  -- corresponding Haskell type.-  type FromExprs a :: Type--  type Transpose (context' :: K.Context) a :: Type---  toColumns :: a -> Columns a context-  fromColumns :: Columns a context -> a--  fromResult :: Columns a Result -> FromExprs a-  toResult :: FromExprs a -> Columns a Result--  type Columns a = GColumns TColumns (Rep (Record a))-  type Context a = GContext TContext (Rep (Record a))-  type FromExprs a = Map TFromExprs a-  type Transpose context a = Map (TTranspose context) a--  default toColumns ::-    ( Generic (Record a)-    , GTable (TTable context) TColumns (Rep (Record a))-    , Columns a ~ GColumns TColumns (Rep (Record a))-    )-    => a -> Columns a context-  toColumns =-    gtoColumns @(TTable context) @TColumns toColumns .-    from .-    Record--  default fromColumns ::-    ( Generic (Record a)-    , GTable (TTable context) TColumns (Rep (Record a))-    , Columns a ~ GColumns TColumns (Rep (Record a))-    )-    => Columns a context -> a-  fromColumns =-    unrecord .-    to .-    gfromColumns @(TTable context) @TColumns fromColumns--  default toResult ::-    ( Generic (Record (FromExprs a))-    , GSerialize TSerialize TColumns (Rep (Record a)) (Rep (Record (FromExprs a)))-    , Columns a ~ GColumns TColumns (Rep (Record a))-    )-    => FromExprs a -> Columns a Result-  toResult =-    gtoResult-      @TSerialize-      @TColumns-      @(Rep (Record a))-      @(Rep (Record (FromExprs a)))-      (\(_ :: proxy x) -> toResult @(Context x) @x) .-    from .-    Record--  default fromResult ::-    ( Generic (Record (FromExprs a))-    , GSerialize TSerialize TColumns (Rep (Record a)) (Rep (Record (FromExprs a)))-    , Columns a ~ GColumns TColumns (Rep (Record a))-    )-    => Columns a Result -> FromExprs a-  fromResult =-    unrecord .-    to .-    gfromResult-      @TSerialize-      @TColumns-      @(Rep (Record a))-      @(Rep (Record (FromExprs a)))-      (\(_ :: proxy x) -> fromResult @(Context x) @x)---instance Sql DBType a => Table Result (Identity a) where-  type Columns (Identity a) = HIdentity a-  type Context (Identity a) = Result-  type FromExprs (Identity a) = a-  type Transpose to (Identity a) = to a--  toColumns = HIdentity-  fromColumns (HIdentity a) = a-  toResult a = HIdentity (Identity a)-  fromResult (HIdentity (Identity a)) = a---data TTable :: K.Context -> Type -> Exp Constraint-type instance Eval (TTable context a) = Table context a---data TColumns :: Type -> Exp K.HTable-type instance Eval (TColumns a) = Columns a---data TContext :: Type -> Exp K.Context-type instance Eval (TContext a) = Context a---data TFromExprs :: Type -> Exp Type-type instance Eval (TFromExprs a) = FromExprs a---data TTranspose :: K.Context -> Type -> Exp Type-type instance Eval (TTranspose context a) = Transpose context a---data TSerialize :: Type -> Type -> Exp Constraint-type instance Eval (TSerialize expr a) =-  ( Table (Context expr) expr-  , a ~ FromExprs expr-  )---instance (Table context a, Table context b) => Table context (a, b)---instance-  ( Table context a, Table context b, Table context c-  )-  => Table context (a, b, c)---instance-  ( Table context a, Table context b, Table context c, Table context d-  )-  => Table context (a, b, c, d)---instance-  ( Table context a, Table context b, Table context c, Table context d-  , Table context e-  )-  => Table context (a, b, c, d, e)---instance-  ( Table context a, Table context b, Table context c, Table context d-  , Table context e, Table context f-  )-  => Table context (a, b, c, d, e, f)---instance-  ( Table context a, Table context b, Table context c, Table context d-  , Table context e, Table context f, Table context g-  )-  => Table context (a, b, c, d, e, f, g)---type Congruent :: Type -> Type -> Constraint-class Columns a ~ Columns b => Congruent a b-instance Columns a ~ Columns b => Congruent a b
− src/Rel8/Table/ADT.hs 
@@ -1,173 +0,0 @@-{-# language AllowAmbiguousTypes #-}-{-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language MultiParamTypeClasses #-}-{-# language RankNTypes #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-}-{-# language TypeFamilyDependencies #-}-{-# language UndecidableInstances #-}-{-# language UndecidableSuperClasses #-}--module Rel8.Table.ADT-  ( ADT( ADT )-  , ADTable-  , BuildableADT-  , BuildADT, buildADT-  , ConstructableADT-  , ConstructADT, constructADT-  , DeconstructADT, deconstructADT-  , NameADT, nameADT-  , AggregateADT, aggregateADT-  , ADTRep-  )-where---- base-import Data.Kind ( Constraint, Type )-import GHC.Generics ( Generic, from, to )-import GHC.TypeLits ( Symbol )-import Prelude---- rel8-import Rel8.Aggregate ( Aggregate )-import Rel8.Expr ( Expr )-import Rel8.FCF ( Eval, Exp )-import Rel8.Generic.Construction-  ( GGBuildable-  , GGBuild, ggbuild-  , GGConstructable-  , GGConstruct, ggconstruct-  , GGDeconstruct, ggdeconstruct-  , GGName, ggname-  , GGAggregate, ggaggregate-  )-import Rel8.Generic.Record ( Record( Record ), unrecord )-import Rel8.Generic.Rel8able-  ( Rel8able-  , GRep, GColumns, gfromColumns, gtoColumns-  , GFromExprs, gfromResult, gtoResult-  , TSerialize, deserialize, serialize-  )-import qualified Rel8.Generic.Table.ADT as G-import qualified Rel8.Kind.Algebra as K-import Rel8.Schema.HTable ( HTable )-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Name ( Name )-import Rel8.Schema.Result ( Result )-import Rel8.Table ( Table, TColumns )---type ADT :: K.Rel8able -> K.Rel8able-newtype ADT t context = ADT (GColumnsADT t context)---instance ADTable t => Rel8able (ADT t) where-  type GColumns (ADT t) = GColumnsADT t-  type GFromExprs (ADT t) = t Result--  gfromColumns _ = ADT-  gtoColumns _ (ADT a) = a--  gfromResult =-    unrecord .-    to .-    G.gfromResultADT-      @TSerialize-      @TColumns-      @(Eval (ADTRep t Expr))-      @(Eval (ADTRep t Result))-      (\(_ :: proxy x) -> deserialize @_ @x)--  gtoResult =-    G.gtoResultADT-      @TSerialize-      @TColumns-      @(Eval (ADTRep t Expr))-      @(Eval (ADTRep t Result))-      (\(_ :: proxy x) -> serialize @_ @x) .-    from .-    Record---type ADTable :: K.Rel8able -> Constraint-class-  ( Generic (Record (t Result))-  , HTable (GColumnsADT t)-  , G.GSerializeADT TSerialize TColumns (Eval (ADTRep t Expr)) (Eval (ADTRep t Result))-  )-  => ADTable t-instance-  ( Generic (Record (t Result))-  , HTable (GColumnsADT t)-  , G.GSerializeADT TSerialize TColumns (Eval (ADTRep t Expr)) (Eval (ADTRep t Result))-  )-  => ADTable t---type BuildableADT :: K.Rel8able -> Symbol -> Constraint-class GGBuildable 'K.Sum name (ADTRep t) => BuildableADT t name-instance GGBuildable 'K.Sum name (ADTRep t) => BuildableADT t name---type BuildADT :: K.Rel8able -> Symbol -> Type-type BuildADT t name = GGBuild 'K.Sum name (ADTRep t) (ADT t Expr)---buildADT :: forall t name. BuildableADT t name => BuildADT t name-buildADT =-  ggbuild @'K.Sum @name @(ADTRep t) @(ADT t Expr) ADT---type ConstructableADT :: K.Rel8able -> Constraint-class GGConstructable 'K.Sum (ADTRep t) => ConstructableADT t-instance GGConstructable 'K.Sum (ADTRep t) => ConstructableADT t---type ConstructADT :: K.Rel8able -> Type-type ConstructADT t = forall r. GGConstruct 'K.Sum (ADTRep t) r---constructADT :: forall t. ConstructableADT t => ConstructADT t -> ADT t Expr-constructADT f =-  ggconstruct @'K.Sum @(ADTRep t) @(ADT t Expr) ADT-    (f @(ADT t Expr))---type DeconstructADT :: K.Rel8able -> Type -> Type-type DeconstructADT t r = GGDeconstruct 'K.Sum (ADTRep t) (ADT t Expr) r---deconstructADT :: forall t r. (ConstructableADT t, Table Expr r)-  => DeconstructADT t r-deconstructADT =-  ggdeconstruct @'K.Sum @(ADTRep t) @(ADT t Expr) @r (\(ADT a) -> a)---type NameADT :: K.Rel8able -> Type-type NameADT t = GGName 'K.Sum (ADTRep t) (ADT t Name)---nameADT :: forall t. ConstructableADT t => NameADT t-nameADT = ggname @'K.Sum @(ADTRep t) @(ADT t Name) ADT---type AggregateADT :: K.Rel8able -> Type-type AggregateADT t = forall r. GGAggregate 'K.Sum (ADTRep t) r---aggregateADT :: forall t. ConstructableADT t-  => AggregateADT t -> ADT t Expr -> ADT t Aggregate-aggregateADT f =-  ggaggregate @'K.Sum @(ADTRep t) @(ADT t Expr) @(ADT t Aggregate) ADT (\(ADT a) -> a)-    (f @(ADT t Aggregate))---data ADTRep :: K.Rel8able -> K.Context -> Exp (Type -> Type)-type instance Eval (ADTRep t context) = GRep t context---type GColumnsADT :: K.Rel8able -> K.HTable-type GColumnsADT t = G.GColumnsADT TColumns (GRep t Expr)
− src/Rel8/Table/Aggregate.hs 
@@ -1,80 +0,0 @@-{-# language FlexibleContexts #-}-{-# language NamedFieldPuns #-}-{-# language ScopedTypeVariables #-}-{-# language TypeApplications #-}-{-# language TypeFamilies #-}-{-# language ViewPatterns #-}--module Rel8.Table.Aggregate-  ( groupBy, hgroupBy-  , listAgg, nonEmptyAgg-  )-where---- base-import Data.Functor.Identity ( Identity( Identity ) )-import Prelude---- rel8-import Rel8.Aggregate ( Aggregate, Aggregates )-import Rel8.Expr ( Expr )-import Rel8.Expr.Aggregate-  ( groupByExpr-  , slistAggExpr-  , snonEmptyAggExpr-  )-import Rel8.Schema.Dict ( Dict( Dict ) )-import Rel8.Schema.HTable ( HTable, hfield, htabulate )-import Rel8.Schema.HTable.Vectorize ( hvectorize )-import Rel8.Schema.Null ( Sql )-import Rel8.Schema.Spec ( Spec( Spec, info ) )-import Rel8.Table ( toColumns, fromColumns )-import Rel8.Table.Eq ( EqTable, eqTable )-import Rel8.Table.List ( ListTable )-import Rel8.Table.NonEmpty ( NonEmptyTable )-import Rel8.Type.Eq ( DBEq )----- | Group equal tables together. This works by aggregating each column in the--- given table with 'groupByExpr'.-groupBy :: forall exprs aggregates. (EqTable exprs, Aggregates aggregates exprs)-  => exprs -> aggregates-groupBy = fromColumns . hgroupBy (eqTable @exprs) . toColumns---hgroupBy :: HTable t => t (Dict (Sql DBEq)) -> t Expr -> t Aggregate-hgroupBy eqs exprs = htabulate $ \field ->-  case hfield eqs field of-    Dict -> case hfield exprs field of-      expr -> groupByExpr expr----- | Aggregate rows into a single row containing an array of all aggregated--- rows. This can be used to associate multiple rows with a single row, without--- changing the over cardinality of the query. This allows you to essentially--- return a tree-like structure from queries.------ For example, if we have a table of orders and each orders contains multiple--- items, we could aggregate the table of orders, pairing each order with its--- items:------ @--- ordersWithItems :: Query (Order Expr, ListTable Expr (Item Expr))--- ordersWithItems = do---   order <- each orderSchema---   items <- aggregate $ listAgg <$> itemsFromOrder order---   return (order, items)--- @-listAgg :: Aggregates aggregates exprs => exprs -> ListTable Aggregate aggregates-listAgg (toColumns -> exprs) = fromColumns $-  hvectorize-    (\Spec {info} (Identity a) -> slistAggExpr info a)-    (pure exprs)----- | Like 'listAgg', but the result is guaranteed to be a non-empty list.-nonEmptyAgg :: Aggregates aggregates exprs => exprs -> NonEmptyTable Aggregate aggregates-nonEmptyAgg (toColumns -> exprs) = fromColumns $-  hvectorize-    (\Spec {info} (Identity a) -> snonEmptyAggExpr info a)-    (pure exprs)
− src/Rel8/Table/Alternative.hs 
@@ -1,37 +0,0 @@-{-# language FlexibleContexts #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}--module Rel8.Table.Alternative-  ( AltTable ( (<|>:) )-  , AlternativeTable ( emptyTable )-  )-where---- base-import Data.Kind ( Constraint, Type )-import Prelude ()---- rel8-import Rel8.Expr ( Expr )-import Rel8.Table ( Table )----- | Like 'Alt' in Haskell. This class is purely a Rel8 concept, and allows you--- to take a choice between two tables. See also 'AlternativeTable'.------ For example, using '<|>:' on 'Rel8.MaybeTable' allows you to combine two--- tables and to return the first one that is a "just" MaybeTable.-type AltTable :: (Type -> Type) -> Constraint-class AltTable f where-  -- | An associative binary operation on 'Table's.-  (<|>:) :: Table Expr a => f a -> f a -> f a-  infixl 3 <|>:----- | Like 'Alternative' in Haskell, some 'Table's form a monoid on applicative--- functors.-type AlternativeTable :: (Type -> Type) -> Constraint-class AltTable f => AlternativeTable f where-  -- | The identity of '<|>:'.-  emptyTable :: Table Expr a => f a
− src/Rel8/Table/Bool.hs 
@@ -1,48 +0,0 @@-{-# language FlexibleContexts #-}-{-# language TypeFamilies #-}-{-# language ViewPatterns #-}--module Rel8.Table.Bool-  ( bool-  , case_-  , nullable-  )-where---- base-import Prelude---- rel8-import Rel8.Expr ( Expr )-import Rel8.Expr.Bool ( boolExpr, caseExpr )-import Rel8.Expr.Null ( isNull, unsafeUnnullify )-import Rel8.Schema.HTable ( htabulate, hfield )-import Rel8.Table ( Table, fromColumns, toColumns )----- | An if-then-else expression on tables.------ @bool x y p@ returns @x@ if @p@ is @False@, and returns @y@ if @p@ is--- @True@.-bool :: Table Expr a => a -> a -> Expr Bool -> a-bool (toColumns -> false) (toColumns -> true) condition =-  fromColumns $ htabulate $ \field ->-    case (hfield false field, hfield true field) of-      (falseExpr, trueExpr) -> boolExpr falseExpr trueExpr condition-{-# INLINABLE bool #-}----- | Produce a table expression from a list of alternatives. Returns the first--- table where the @Expr Bool@ expression is @True@. If no alternatives are--- true, the given default is returned.-case_ :: Table Expr a => [(Expr Bool, a)] -> a -> a-case_ (map (fmap toColumns) -> branches) (toColumns -> fallback) =-  fromColumns $ htabulate $ \field -> case hfield fallback field of-    fallbackExpr ->-      case map (fmap (`hfield` field)) branches of-        branchExprs -> caseExpr branchExprs fallbackExpr----- | Like 'maybe', but to eliminate @null@.-nullable :: Table Expr b => b -> (Expr a -> b) -> Expr (Maybe a) -> b-nullable b f ma = bool (f (unsafeUnnullify ma)) b (isNull ma)
− src/Rel8/Table/Cols.hs 
@@ -1,50 +0,0 @@-{-# language DataKinds #-}-{-# language FlexibleInstances #-}-{-# language MultiParamTypeClasses #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}--module Rel8.Table.Cols-  ( Cols( Cols )-  , fromCols-  , toCols-  )-where---- base-import Data.Kind ( Type )-import Prelude---- rel8-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.HTable ( HTable )-import Rel8.Schema.Result ( Result )-import Rel8.Table ( Table(..) )---type Cols :: K.Context -> K.HTable -> Type-newtype Cols context columns = Cols (columns context)---instance (HTable columns, context ~ context') =>-  Table context' (Cols context columns)- where-  type Columns (Cols context columns) = columns-  type Context (Cols context columns) = context-  type FromExprs (Cols context columns) = Cols Result columns-  type Transpose to (Cols context columns) = Cols to columns--  toColumns (Cols a) = a-  fromColumns = Cols--  toResult (Cols a) = a-  fromResult = Cols---fromCols :: Table context a => Cols context (Columns a) -> a-fromCols (Cols a) = fromColumns a---toCols :: Table context a => a -> Cols context (Columns a)-toCols = Cols . toColumns
− src/Rel8/Table/Either.hs 
@@ -1,243 +0,0 @@-{-# language DataKinds #-}-{-# language DeriveFunctor #-}-{-# language DerivingStrategies #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language LambdaCase #-}-{-# language MultiParamTypeClasses #-}-{-# language NamedFieldPuns #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}--{-# options_ghc -fno-warn-orphans #-}--module Rel8.Table.Either-  ( EitherTable(..)-  , eitherTable, leftTable, rightTable-  , isLeftTable, isRightTable-  , aggregateEitherTable-  , nameEitherTable-  )-where---- base-import Data.Bifunctor ( Bifunctor, bimap )-import Data.Functor.Identity ( Identity( Identity ) )-import Data.Kind ( Type )-import Prelude hiding ( undefined )---- comonad-import Control.Comonad ( extract )---- rel8-import Rel8.Aggregate ( Aggregate )-import Rel8.Expr ( Expr )-import Rel8.Expr.Aggregate ( groupByExpr )-import Rel8.Expr.Serialize ( litExpr )-import Rel8.Kind.Context ( Reifiable )-import Rel8.Schema.Context.Nullify ( Nullifiable )-import Rel8.Schema.Dict ( Dict( Dict ) )-import Rel8.Schema.HTable.Either ( HEitherTable(..) )-import Rel8.Schema.HTable.Identity ( HIdentity(..) )-import Rel8.Schema.HTable.Label ( hlabel, hunlabel )-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Name ( Name )-import Rel8.Table-  ( Table, Columns, Context, fromColumns, toColumns-  , FromExprs, fromResult, toResult-  , Transpose-  )-import Rel8.Table.Bool ( bool )-import Rel8.Table.Eq ( EqTable, eqTable )-import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )-import Rel8.Table.Ord ( OrdTable, ordTable )-import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )-import Rel8.Table.Serialize ( ToExprs )-import Rel8.Table.Undefined ( undefined )-import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )---- semigroupoids-import Data.Functor.Apply ( Apply, (<.>) )-import Data.Functor.Bind ( Bind, (>>-) )----- | An @EitherTable a b@ is a Rel8 table that contains either the table @a@ or--- the table @b@. You can construct an @EitherTable@ using 'leftTable' and--- 'rightTable', and eliminate/pattern match using 'eitherTable'.------ An @EitherTable@ is operationally the same as Haskell's 'Either' type, but--- adapted to work with Rel8.-type EitherTable :: K.Context -> Type -> Type -> Type-data EitherTable context a b = EitherTable-  { tag :: context EitherTag-  , left :: Nullify context a-  , right :: Nullify context b-  }-  deriving stock Functor---instance Biprojectable (EitherTable context) where-  biproject f g (EitherTable tag a b) =-    EitherTable tag (project f a) (project g b)---instance Nullifiable context => Bifunctor (EitherTable context) where-  bimap f g (EitherTable tag a b) = EitherTable tag (fmap f a) (fmap g b)---instance Projectable (EitherTable context a) where-  project f (EitherTable tag a b) = EitherTable tag a (project f b)---instance (context ~ Expr, Table Expr a) => Apply (EitherTable context a) where-  EitherTable tag l1 f <.> EitherTable tag' l2 a =-    EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f <.> a)---instance (context ~ Expr, Table Expr a) => Applicative (EitherTable context a) where-  pure = rightTable-  (<*>) = (<.>)---instance (context ~ Expr, Table Expr a) => Bind (EitherTable context a) where-  EitherTable tag l1 a >>- f = case f (extract a) of-    EitherTable tag' l2 b ->-      EitherTable (tag <> tag') (bool l1 l2 (isRight tag)) b---instance (context ~ Expr, Table Expr a) => Monad (EitherTable context a) where-  (>>=) = (>>-)---instance (context ~ Expr, Table Expr a, Table Expr b) =>-  Semigroup (EitherTable context a b)- where-  a <> b = bool a b (isRightTable a)---instance-  ( Table context a, Table context b-  , Reifiable context, context ~ context'-  )-  => Table context' (EitherTable context a b)- where-  type Columns (EitherTable context a b) = HEitherTable (Columns a) (Columns b)-  type Context (EitherTable context a b) = Context a-  type FromExprs (EitherTable context a b) = Either (FromExprs a) (FromExprs b)-  type Transpose to (EitherTable context a b) =-    EitherTable to (Transpose to a) (Transpose to b)--  toColumns EitherTable {tag, left, right} = HEitherTable-    { htag = hlabel $ HIdentity tag-    , hleft = hlabel $ guard tag (== IsLeft) isLeft $ toColumns left-    , hright = hlabel $ guard tag (== IsRight) isRight $ toColumns right-    }--  fromColumns HEitherTable {htag, hleft, hright} = EitherTable-    { tag = unHIdentity $ hunlabel htag-    , left = fromColumns $ hunlabel hleft-    , right = fromColumns $ hunlabel hright-    }--  toResult = \case-    Left table -> HEitherTable-      { htag = hlabel (HIdentity (Identity IsLeft))-      , hleft = hlabel (toResult @_ @(Nullify context a) (Just table))-      , hright = hlabel (toResult @_ @(Nullify context b) Nothing)-      }-    Right table -> HEitherTable-      { htag = hlabel (HIdentity (Identity IsRight))-      , hleft = hlabel (toResult @_ @(Nullify context a) Nothing)-      , hright = hlabel (toResult @_ @(Nullify context b) (Just table))-      }--  fromResult HEitherTable {htag, hleft, hright} = case hunlabel htag of-    HIdentity (Identity tag) -> case tag of-      IsLeft -> maybe err Left $ fromResult @_ @(Nullify context a) (hunlabel hleft)-      IsRight -> maybe err Right $ fromResult @_ @(Nullify context b) (hunlabel hright)-    where-      err = error "Either.fromColumns: mismatch between tag and data"---instance (EqTable a, EqTable b, context ~ Expr) =>-  EqTable (EitherTable context a b)- where-  eqTable = HEitherTable-    { htag = hlabel (HIdentity Dict)-    , hleft = hlabel (eqTable @(Nullify context a))-    , hright = hlabel (eqTable @(Nullify context b))-    }---instance (OrdTable a, OrdTable b, context ~ Expr) =>-  OrdTable (EitherTable context a b)- where-  ordTable = HEitherTable-    { htag = hlabel (HIdentity Dict)-    , hleft = hlabel (ordTable @(Nullify context a))-    , hright = hlabel (ordTable @(Nullify context b))-    }---instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable Expr exprs1 exprs2) =>-  ToExprs x (Either a b)----- | Test if an 'EitherTable' is a 'leftTable'.-isLeftTable :: EitherTable Expr a b -> Expr Bool-isLeftTable EitherTable {tag} = isLeft tag----- | Test if an 'EitherTable' is a 'rightTable'.-isRightTable :: EitherTable Expr a b -> Expr Bool-isRightTable EitherTable {tag} = isRight tag----- | Pattern match/eliminate an 'EitherTable', by providing mappings from a--- 'leftTable' and 'rightTable'.-eitherTable :: Table Expr c-  => (a -> c) -> (b -> c) -> EitherTable Expr a b -> c-eitherTable f g EitherTable {tag, left, right} =-  bool (f (extract left)) (g (extract right)) (isRight tag)----- | Construct a left 'EitherTable'. Like 'Left'.-leftTable :: Table Expr b => a -> EitherTable Expr a b-leftTable a = EitherTable (litExpr IsLeft) (pure a) undefined----- | Construct a right 'EitherTable'. Like 'Right'.-rightTable :: Table Expr a => b -> EitherTable Expr a b-rightTable = EitherTable (litExpr IsRight) undefined . pure----- | Lift a pair of aggregating functions to operate on an 'EitherTable'.--- @leftTable@s and @rightTable@s are grouped separately.-aggregateEitherTable :: ()-  => (exprs -> aggregates)-  -> (exprs' -> aggregates')-  -> EitherTable Expr exprs exprs'-  -> EitherTable Aggregate aggregates aggregates'-aggregateEitherTable f g (EitherTable tag a b) = EitherTable-  { tag = groupByExpr tag-  , left = aggregateNullify f a-  , right = aggregateNullify g b-  }----- | Construct a 'EitherTable' in the 'Name' context. This can be useful if you--- have a 'EitherTable' that you are storing in a table and need to construct a--- 'TableSchema'.-nameEitherTable-  :: Name EitherTag-     -- ^ The name of the column to track whether a row is a 'leftTable' or-     -- 'rightTable'.-  -> a-     -- ^ Names of the columns in the @a@ table.-  -> b-     -- ^ Names of the columns in the @b@ table.-  -> EitherTable Name a b-nameEitherTable tag left right = EitherTable tag (pure left) (pure right)
− src/Rel8/Table/Eq.hs 
@@ -1,118 +0,0 @@-{-# language AllowAmbiguousTypes #-}-{-# language BlockArguments #-}-{-# language DataKinds #-}-{-# language DefaultSignatures #-}-{-# language DisambiguateRecordFields #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-}-{-# language TypeFamilies #-}-{-# language TypeOperators #-}-{-# language UndecidableInstances #-}-{-# language ViewPatterns #-}--module Rel8.Table.Eq-  ( EqTable( eqTable ), (==:), (/=:)-  )-where---- base-import Data.Foldable ( foldl' )-import Data.Functor.Const ( Const( Const ), getConst )-import Data.Kind ( Constraint, Type )-import Data.List.NonEmpty ( NonEmpty( (:|) ) )-import GHC.Generics ( Rep )-import Prelude---- rel8-import Rel8.Expr ( Expr )-import Rel8.Expr.Bool ( (||.), (&&.) )-import Rel8.Expr.Eq ( (==.), (/=.) )-import Rel8.FCF ( Eval, Exp )-import Rel8.Generic.Record ( Record )-import Rel8.Generic.Table.Record ( GTable, GColumns, gtable )-import Rel8.Schema.Dict ( Dict( Dict ) )-import Rel8.Schema.HTable ( htabulateA, hfield )-import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )-import Rel8.Schema.Null ( Sql )-import Rel8.Table ( Table, Columns, toColumns, TColumns )-import Rel8.Type.Eq ( DBEq )----- | The class of 'Table's that can be compared for equality. Equality on--- tables is defined by equality of all columns all columns, so this class--- means "all columns in a 'Table' have an instance of 'DBEq'".-type EqTable :: Type -> Constraint-class Table Expr a => EqTable a where-  eqTable :: Columns a (Dict (Sql DBEq))--  default eqTable ::-    ( GTable TEqTable TColumns (Rep (Record a))-    , Columns a ~ GColumns TColumns (Rep (Record a))-    )-    => Columns a (Dict (Sql DBEq))-  eqTable = gtable @TEqTable @TColumns @(Rep (Record a)) table-    where-      table (_ :: proxy x) = eqTable @x---data TEqTable :: Type -> Exp Constraint-type instance Eval (TEqTable a) = EqTable a---instance Sql DBEq a => EqTable (Expr a) where-  eqTable = HIdentity Dict---instance (EqTable a, EqTable b) => EqTable (a, b)---instance (EqTable a, EqTable b, EqTable c) => EqTable (a, b, c)---instance (EqTable a, EqTable b, EqTable c, EqTable d) => EqTable (a, b, c, d)---instance (EqTable a, EqTable b, EqTable c, EqTable d, EqTable e) =>-  EqTable (a, b, c, d, e)---instance (EqTable a, EqTable b, EqTable c, EqTable d, EqTable e, EqTable f) =>-  EqTable (a, b, c, d, e, f)---instance-  ( EqTable a, EqTable b, EqTable c, EqTable d, EqTable e, EqTable f-  , EqTable g-  )-  => EqTable (a, b, c, d, e, f, g)----- | Compare two 'Table's for equality. This corresponds to comparing all--- columns inside each table for equality, and combining all comparisons with--- @AND@.-(==:) :: forall a. EqTable a => a -> a -> Expr Bool-(toColumns -> as) ==: (toColumns -> bs) =-  foldl1' (&&.) $ getConst $ htabulateA $ \field ->-    case (hfield as field, hfield bs field) of-      (a, b) -> case hfield (eqTable @a) field of-        Dict -> Const (pure (a ==. b))-infix 4 ==:----- | Test if two 'Table's are different. This corresponds to comparing all--- columns inside each table for inequality, and combining all comparisons with--- @OR@.-(/=:) :: forall a. EqTable a => a -> a -> Expr Bool-(toColumns -> as) /=: (toColumns -> bs) =-  foldl1' (||.) $ getConst $ htabulateA $ \field ->-    case (hfield as field, hfield bs field) of-      (a, b) -> case hfield (eqTable @a) field of-        Dict -> Const (pure (a /=. b))-infix 4 /=:---foldl1' :: (a -> a -> a) -> NonEmpty a -> a-foldl1' f (a :| as) = foldl' f a as
− src/Rel8/Table/HKD.hs 
@@ -1,227 +0,0 @@-{-# language AllowAmbiguousTypes #-}-{-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language MultiParamTypeClasses #-}-{-# language RankNTypes #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}-{-# language UndecidableSuperClasses #-}--module Rel8.Table.HKD-  ( HKD( HKD )-  , HKDable-  , BuildableHKD-  , BuildHKD, buildHKD-  , ConstructableHKD-  , ConstructHKD, constructHKD-  , DeconstructHKD, deconstructHKD-  , NameHKD, nameHKD-  , AggregateHKD, aggregateHKD-  , HKDRep-  )-where---- base-import Data.Kind ( Constraint, Type )-import GHC.Generics ( Generic, Rep, from, to )-import GHC.TypeLits ( Symbol )-import Prelude---- rel8-import Rel8.Aggregate ( Aggregate )-import Rel8.Column ( TColumn )-import Rel8.Expr ( Expr )-import Rel8.FCF ( Eval, Exp )-import Rel8.Kind.Algebra ( KnownAlgebra )-import Rel8.Generic.Construction-  ( GGBuildable-  , GGBuild, ggbuild-  , GGConstructable-  , GGConstruct, ggconstruct-  , GGDeconstruct, ggdeconstruct-  , GGName, ggname-  , GGAggregate, ggaggregate-  )-import Rel8.Generic.Map ( GMap )-import Rel8.Generic.Record-  ( GRecord, GRecordable, grecord, gunrecord-  , Record( Record ), unrecord-  )-import Rel8.Generic.Rel8able-  ( Rel8able-  , GColumns, gfromColumns, gtoColumns-  , GFromExprs, gfromResult, gtoResult-  )-import Rel8.Generic.Table-  ( GGSerialize, GGColumns, GAlgebra, ggfromResult, ggtoResult-  )-import Rel8.Generic.Table.Record ( GTable, GContext )-import qualified Rel8.Generic.Table.Record as G-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.HTable ( HTable )-import Rel8.Schema.Name ( Name )-import Rel8.Schema.Result ( Result )-import Rel8.Table-  ( Table, fromColumns, toColumns, fromResult, toResult-  , TTable, TColumns, TContext-  , TSerialize-  )---type GColumnsHKD :: Type -> K.HTable-type GColumnsHKD a =-  Eval (GGColumns (GAlgebra (Rep a)) TColumns (GRecord (GMap (TColumn Expr) (Rep a))))---type HKD :: Type -> K.Rel8able-newtype HKD a f = HKD (GColumnsHKD a f)---instance HKDable a => Rel8able (HKD a) where-  type GColumns (HKD a) = GColumnsHKD a-  type GFromExprs (HKD a) = a--  gfromColumns _ = HKD-  gtoColumns _ (HKD a) = a--  gfromResult =-    unrecord .-    to .-    ggfromResult-      @(GAlgebra (Rep a))-      @TSerialize-      @TColumns-      @(Eval (HKDRep a Expr))-      @(Eval (HKDRep a Result))-      (\(_ :: proxy x) -> fromResult @_ @x)--  gtoResult =-    ggtoResult-      @(GAlgebra (Rep a))-      @TSerialize-      @TColumns-      @(Eval (HKDRep a Expr))-      @(Eval (HKDRep a Result))-      (\(_ :: proxy x) -> toResult @_ @x) .-    from .-    Record---instance-  ( GTable (TTable f) TColumns (GRecord (GMap (TColumn f) (Rep a)))-  , G.GColumns TColumns (GRecord (GMap (TColumn f) (Rep a))) ~ GColumnsHKD a-  , GContext TContext (GRecord (GMap (TColumn f) (Rep a))) ~ f-  , GRecordable (GMap (TColumn f) (Rep a))-  )-  => Generic (HKD a f)- where-  type Rep (HKD a f) = GMap (TColumn f) (Rep a)--  from =-    gunrecord @(GMap (TColumn f) (Rep a)) .-    G.gfromColumns-      @(TTable f)-      @TColumns-      fromColumns .-    (\(HKD a) -> a)--  to =-    HKD .-    G.gtoColumns-      @(TTable f)-      @TColumns-      toColumns .-    grecord @(GMap (TColumn f) (Rep a))---type HKDable :: Type -> Constraint-class-  ( Generic (Record a)-  , HTable (GColumns (HKD a))-  , KnownAlgebra (GAlgebra (Rep a))-  , Eval (GGSerialize (GAlgebra (Rep a)) TSerialize TColumns (Eval (HKDRep a Expr)) (Eval (HKDRep a Result)))-  , GRecord (GMap (TColumn Result) (Rep a)) ~ Rep (Record a)-  )-  => HKDable a-instance-  ( Generic (Record a)-  , HTable (GColumns (HKD a))-  , KnownAlgebra (GAlgebra (Rep a))-  , Eval (GGSerialize (GAlgebra (Rep a)) TSerialize TColumns (Eval (HKDRep a Expr)) (Eval (HKDRep a Result)))-  , GRecord (GMap (TColumn Result) (Rep a)) ~ Rep (Record a)-  )-  => HKDable a---class Top_-instance Top_---data Top :: Type -> Exp Constraint-type instance Eval (Top _) = Top_---type BuildableHKD :: Type -> Symbol -> Constraint-class GGBuildable (GAlgebra (Rep a)) name (HKDRep a) => BuildableHKD a name-instance GGBuildable (GAlgebra (Rep a)) name (HKDRep a) => BuildableHKD a name---type BuildHKD :: Type -> Symbol -> Type-type BuildHKD a name = GGBuild (GAlgebra (Rep a)) name (HKDRep a) (HKD a Expr)---buildHKD :: forall a name. BuildableHKD a name => BuildHKD a name-buildHKD =-  ggbuild @(GAlgebra (Rep a)) @name @(HKDRep a) @(HKD a Expr) HKD---type ConstructableHKD :: Type -> Constraint-class GGConstructable (GAlgebra (Rep a)) (HKDRep a) => ConstructableHKD a-instance GGConstructable (GAlgebra (Rep a)) (HKDRep a) => ConstructableHKD a---type ConstructHKD :: Type -> Type-type ConstructHKD a = forall r. GGConstruct (GAlgebra (Rep a)) (HKDRep a) r---constructHKD :: forall a. ConstructableHKD a => ConstructHKD a -> HKD a Expr-constructHKD f =-  ggconstruct @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) HKD-    (f @(HKD a Expr))---type DeconstructHKD :: Type -> Type -> Type-type DeconstructHKD a r = GGDeconstruct (GAlgebra (Rep a)) (HKDRep a) (HKD a Expr) r---deconstructHKD :: forall a r. (ConstructableHKD a, Table Expr r)-  => DeconstructHKD a r-deconstructHKD = ggdeconstruct @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) @r (\(HKD a) -> a)---type NameHKD :: Type -> Type-type NameHKD a = GGName (GAlgebra (Rep a)) (HKDRep a) (HKD a Name)---nameHKD :: forall a. ConstructableHKD a => NameHKD a-nameHKD = ggname @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Name) HKD---type AggregateHKD :: Type -> Type-type AggregateHKD a = forall r. GGAggregate (GAlgebra (Rep a)) (HKDRep a) r---aggregateHKD :: forall a. ConstructableHKD a-  => AggregateHKD a -> HKD a Expr -> HKD a Aggregate-aggregateHKD f =-  ggaggregate @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) @(HKD a Aggregate) HKD (\(HKD a) -> a)-    (f @(HKD a Aggregate))---data HKDRep :: Type -> K.Context -> Exp (Type -> Type)-type instance Eval (HKDRep a context) =-  GRecord (GMap (TColumn context) (Rep a))
− src/Rel8/Table/List.hs 
@@ -1,149 +0,0 @@-{-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language MultiParamTypeClasses #-}-{-# language NamedFieldPuns #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}--module Rel8.Table.List-  ( ListTable(..)-  , ($*)-  , listTable-  , nameListTable-  )-where---- base-import Data.Functor.Identity ( Identity( Identity ) )-import Data.Kind ( Type )-import Prelude---- rel8-import Rel8.Expr ( Expr )-import Rel8.Expr.Array ( sappend, sempty, slistOf )-import Rel8.Schema.Dict ( Dict( Dict ) )-import Rel8.Schema.HTable.List ( HListTable )-import Rel8.Schema.HTable.Vectorize-  ( hvectorize, hunvectorize-  , happend, hempty-  , hproject, hcolumn-  )-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Name ( Name( Name ) )-import Rel8.Schema.Null ( Nullity( Null, NotNull ) )-import Rel8.Schema.Result ( vectorizer, unvectorizer )-import Rel8.Schema.Spec ( Spec(..) )-import Rel8.Table-  ( Table, Context, Columns, fromColumns, toColumns-  , FromExprs, fromResult, toResult-  , Transpose-  )-import Rel8.Table.Alternative-  ( AltTable, (<|>:)-  , AlternativeTable, emptyTable-  )-import Rel8.Table.Eq ( EqTable, eqTable )-import Rel8.Table.Ord ( OrdTable, ordTable )-import Rel8.Table.Projection-  ( Projectable, Projecting, Projection, project, apply-  )-import Rel8.Table.Serialize ( ToExprs )----- | A @ListTable@ value contains zero or more instances of @a@. You construct--- @ListTable@s with 'Rel8.many' or 'Rel8.listAgg'.-type ListTable :: K.Context -> Type -> Type-newtype ListTable context a =-  ListTable (HListTable (Columns a) (Context a))---instance Projectable (ListTable context) where-  project f (ListTable a) = ListTable (hproject (apply f) a)---instance (Table context a, context ~ context') =>-  Table context' (ListTable context a)- where-  type Columns (ListTable context a) = HListTable (Columns a)-  type Context (ListTable context a) = Context a-  type FromExprs (ListTable context a) = [FromExprs a]-  type Transpose to (ListTable context a) = ListTable to (Transpose to a)--  fromColumns = ListTable-  toColumns (ListTable a) = a-  fromResult = fmap (fromResult @_ @a) . hunvectorize unvectorizer-  toResult = hvectorize vectorizer . fmap (toResult @_ @a)---instance (EqTable a, context ~ Expr) => EqTable (ListTable context a) where-  eqTable =-    hvectorize-      (\Spec {nullity} (Identity Dict) -> case nullity of-        Null -> Dict-        NotNull -> Dict)-      (Identity (eqTable @a))---instance (OrdTable a, context ~ Expr) => OrdTable (ListTable context a) where-  ordTable =-    hvectorize-      (\Spec {nullity} (Identity Dict) -> case nullity of-        Null -> Dict-        NotNull -> Dict)-      (Identity (ordTable @a))---instance (ToExprs exprs a, context ~ Expr) =>-  ToExprs (ListTable context exprs) [a]---instance context ~ Expr => AltTable (ListTable context) where-  (<|>:) = (<>)---instance context ~ Expr => AlternativeTable (ListTable context) where-  emptyTable = mempty---instance (context ~ Expr, Table Expr a) => Semigroup (ListTable context a)- where-  ListTable as <> ListTable bs = ListTable $ happend (const sappend) as bs---instance (context ~ Expr, Table Expr a) =>-  Monoid (ListTable context a)- where-  mempty = ListTable $ hempty $ \Spec {info} -> sempty info----- | Project a single expression out of a 'ListTable'.-($*) :: Projecting a (Expr b)-  => Projection a (Expr b) -> ListTable Expr a -> Expr [b]-f $* ListTable a = hcolumn $ hproject (apply f) a-infixl 4 $*----- | Construct a @ListTable@ from a list of expressions.-listTable :: Table Expr a => [a] -> ListTable Expr a-listTable =-  ListTable .-  hvectorize (\Spec {info} -> slistOf info) .-  fmap toColumns----- | Construct a 'ListTable' in the 'Name' context. This can be useful if you--- have a 'ListTable' that you are storing in a table and need to construct a--- 'TableSchema'.-nameListTable-  :: Table Name a-  => a -- ^ The names of the columns of elements of the list.-  -> ListTable Name a-nameListTable =-  ListTable .-  hvectorize (\_ (Identity (Name a)) -> Name a) .-  pure .-  toColumns
− src/Rel8/Table/Maybe.hs 
@@ -1,240 +0,0 @@-{-# language DataKinds #-}-{-# language DeriveFunctor #-}-{-# language DerivingStrategies #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language MultiParamTypeClasses #-}-{-# language NamedFieldPuns #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}--module Rel8.Table.Maybe-  ( MaybeTable(..)-  , maybeTable, nothingTable, justTable-  , isNothingTable, isJustTable-  , ($?)-  , aggregateMaybeTable-  , nameMaybeTable-  )-where---- base-import Data.Functor ( ($>) )-import Data.Functor.Identity ( Identity( Identity ) )-import Data.Kind ( Type )-import Data.Maybe ( fromMaybe, isJust )-import Prelude hiding ( null, undefined )---- comonad-import Control.Comonad ( extract )---- rel8-import Rel8.Aggregate ( Aggregate )-import Rel8.Expr ( Expr )-import Rel8.Expr.Aggregate ( groupByExpr )-import Rel8.Expr.Bool ( boolExpr )-import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )-import Rel8.Kind.Context ( Reifiable )-import Rel8.Schema.Dict ( Dict( Dict ) )-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.HTable.Identity ( HIdentity(..) )-import Rel8.Schema.HTable.Label ( hlabel, hunlabel )-import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )-import Rel8.Schema.Name ( Name )-import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )-import qualified Rel8.Schema.Null as N-import Rel8.Table-  ( Table, Columns, Context, fromColumns, toColumns-  , FromExprs, fromResult, toResult-  , Transpose-  )-import Rel8.Table.Alternative-  ( AltTable, (<|>:)-  , AlternativeTable, emptyTable-  )-import Rel8.Table.Bool ( bool )-import Rel8.Table.Eq ( EqTable, eqTable )-import Rel8.Table.Ord ( OrdTable, ordTable )-import Rel8.Table.Projection ( Projectable, project )-import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )-import Rel8.Table.Serialize ( ToExprs )-import Rel8.Table.Undefined ( undefined )-import Rel8.Type ( DBType )-import Rel8.Type.Tag ( MaybeTag( IsJust ) )---- semigroupoids-import Data.Functor.Apply ( Apply, (<.>) )-import Data.Functor.Bind ( Bind, (>>-) )----- | @MaybeTable t@ is the table @t@, but as the result of an outer join. If--- the outer join fails to match any rows, this is essentialy @Nothing@, and if--- the outer join does match rows, this is like @Just@. Unfortunately, SQL--- makes it impossible to distinguish whether or not an outer join matched any--- rows based generally on the row contents - if you were to join a row--- entirely of nulls, you can't distinguish if you matched an all null row, or--- if the match failed.  For this reason @MaybeTable@ contains an extra field ---- a "nullTag" - to track whether or not the outer join produced any rows.-type MaybeTable :: K.Context -> Type -> Type-data MaybeTable context a = MaybeTable-  { tag :: context (Maybe MaybeTag)-  , just :: Nullify context a-  }-  deriving stock Functor---instance Projectable (MaybeTable context) where-  project f (MaybeTable tag a) = MaybeTable tag (project f a)---instance context ~ Expr => Apply (MaybeTable context) where-  MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f <.> a)----- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:--- 'Rel8.traverseMaybeTable'.-instance context ~ Expr => Applicative (MaybeTable context) where-  (<*>) = (<.>)-  pure = justTable---instance context ~ Expr => Bind (MaybeTable context) where-  MaybeTable tag a >>- f = case f (extract a) of-    MaybeTable tag' b -> MaybeTable (tag <> tag') b----- | Has the same behavior as the @Monad@ instance for @Maybe@.-instance context ~ Expr => Monad (MaybeTable context) where-  (>>=) = (>>-)---instance context ~ Expr => AltTable (MaybeTable context) where-  ma <|>: mb = bool ma mb (isNothingTable ma)---instance context ~ Expr => AlternativeTable (MaybeTable context) where-  emptyTable = nothingTable---instance (context ~ Expr, Table Expr a, Semigroup a) =>-  Semigroup (MaybeTable context a)- where-  ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma---instance (context ~ Expr, Table Expr a, Semigroup a) =>-  Monoid (MaybeTable context a)- where-  mempty = nothingTable---instance (Table context a, Reifiable context, context ~ context') =>-  Table context' (MaybeTable context a)- where-  type Columns (MaybeTable context a) = HMaybeTable (Columns a)-  type Context (MaybeTable context a) = Context a-  type FromExprs (MaybeTable context a) = Maybe (FromExprs a)-  type Transpose to (MaybeTable context a) = MaybeTable to (Transpose to a)--  toColumns MaybeTable {tag, just} = HMaybeTable-    { htag = hlabel $ HIdentity tag-    , hjust = hlabel $ guard tag isJust isNonNull $ toColumns just-    }--  fromColumns HMaybeTable {htag, hjust} = MaybeTable-    { tag = unHIdentity $ hunlabel htag-    , just = fromColumns $ hunlabel hjust-    }--  toResult ma = HMaybeTable-    { htag = hlabel (HIdentity (Identity (IsJust <$ ma)))-    , hjust = hlabel (toResult @_ @(Nullify context a) ma)-    }--  fromResult HMaybeTable {htag, hjust} = case hunlabel htag of-    HIdentity (Identity tag) -> tag $>-      fromMaybe err (fromResult @_ @(Nullify context a) (hunlabel hjust))-    where-      err = error "Maybe.fromColumns: mismatch between tag and data"---instance (EqTable a, context ~ Expr) => EqTable (MaybeTable context a) where-  eqTable = HMaybeTable-    { htag = hlabel (HIdentity Dict)-    , hjust = hlabel (eqTable @(Nullify context a))-    }---instance (OrdTable a, context ~ Expr) => OrdTable (MaybeTable context a) where-  ordTable = HMaybeTable-    { htag = hlabel (HIdentity Dict)-    , hjust = hlabel (ordTable @(Nullify context a))-    }---instance (ToExprs exprs a, context ~ Expr) =>-  ToExprs (MaybeTable context exprs) (Maybe a)----- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.-isNothingTable :: MaybeTable Expr a -> Expr Bool-isNothingTable (MaybeTable tag _) = isNull tag----- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.-isJustTable :: MaybeTable Expr a -> Expr Bool-isJustTable (MaybeTable tag _) = isNonNull tag----- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.-maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable Expr a -> b-maybeTable b f ma@(MaybeTable _ a) = bool (f (extract a)) b (isNothingTable ma)-{-# INLINABLE maybeTable #-}----- | The null table. Like 'Nothing'.-nothingTable :: Table Expr a => MaybeTable Expr a-nothingTable = MaybeTable null (pure undefined)----- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use--- 'pure'.-justTable :: a -> MaybeTable Expr a-justTable = MaybeTable mempty . pure----- | Project a single expression out of a 'MaybeTable'. You can think of this--- operator like the '$' operator, but it also has the ability to return--- @null@.-($?) :: forall a b. Sql DBType b-  => (a -> Expr b) -> MaybeTable Expr a -> Expr (N.Nullify b)-f $? ma@(MaybeTable _ a) = case nullable @b of-  Null -> boolExpr (f (extract a)) null (isNothingTable ma)-  NotNull -> boolExpr (nullify (f (extract a))) null (isNothingTable ma)-infixl 4 $?----- | Lift an aggregating function to operate on a 'MaybeTable'.--- @nothingTable@s and @justTable@s are grouped separately.-aggregateMaybeTable :: ()-  => (exprs -> aggregates)-  -> MaybeTable Expr exprs-  -> MaybeTable Aggregate aggregates-aggregateMaybeTable f (MaybeTable tag a) =-  MaybeTable (groupByExpr tag) (aggregateNullify f a)----- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you--- have a 'MaybeTable' that you are storing in a table and need to construct a--- 'TableSchema'.-nameMaybeTable-  :: Name (Maybe MaybeTag)-     -- ^ The name of the column to track whether a row is a 'justTable' or-     -- 'nothingTable'.-  -> a-     -- ^ Names of the columns in @a@.-  -> MaybeTable Name a-nameMaybeTable tag = MaybeTable tag . pure
− src/Rel8/Table/Name.hs 
@@ -1,79 +0,0 @@-{-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language MultiParamTypeClasses #-}-{-# language NamedFieldPuns #-}-{-# language ScopedTypeVariables #-}-{-# language TypeApplications #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}-{-# language ViewPatterns #-}--module Rel8.Table.Name-  ( namesFromLabels-  , namesFromLabelsWith-  , showLabels-  , showNames-  )-where---- base-import Data.Foldable ( fold )-import Data.Functor.Const ( Const( Const ), getConst )-import Data.List.NonEmpty ( NonEmpty, intersperse, nonEmpty )-import Data.Maybe ( fromMaybe )-import Prelude---- rel8-import Rel8.Schema.HTable ( htabulate, htabulateA, hfield, hspecs )-import Rel8.Schema.Name ( Name( Name ) )-import Rel8.Schema.Spec ( Spec(..) )-import Rel8.Table ( Table(..) )----- | Construct a table in the 'Name' context containing the names of all--- columns. Nested column names will be combined with @/@.------ See also: 'namesFromLabelsWith'.-namesFromLabels :: Table Name a => a-namesFromLabels = namesFromLabelsWith go-  where-    go = fold . intersperse "/"----- | Construct a table in the 'Name' context containing the names of all--- columns. The supplied function can be used to transform column names.------ This function can be used to generically derive the columns for a--- 'TableSchema'. For example,------ @--- myTableSchema :: TableSchema (MyTable Name)--- myTableSchema = TableSchema---   { columns = namesFromLabelsWith last---   }--- @------ will construct a 'TableSchema' where each columns names exactly corresponds--- to the name of the Haskell field.-namesFromLabelsWith :: Table Name a-  => (NonEmpty String -> String) -> a-namesFromLabelsWith f = fromColumns $ htabulate $ \field ->-  case hfield hspecs field of-    Spec {labels} -> Name (f (renderLabels labels))---showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]-showLabels _ = getConst $-  htabulateA @(Columns a) $ \field -> case hfield hspecs field of-    Spec {labels} -> Const (pure (renderLabels labels))---showNames :: forall a. Table Name a => a -> NonEmpty String-showNames (toColumns -> names) = getConst $-  htabulateA @(Columns a) $ \field -> case hfield names field of-    Name name -> Const (pure name)---renderLabels :: [String] -> NonEmpty String-renderLabels labels = fromMaybe (pure "anon") (nonEmpty labels )
− src/Rel8/Table/NonEmpty.hs 
@@ -1,143 +0,0 @@-{-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language MultiParamTypeClasses #-}-{-# language NamedFieldPuns #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}--module Rel8.Table.NonEmpty-  ( NonEmptyTable(..)-  , ($+)-  , nonEmptyTable-  , nameNonEmptyTable-  )-where---- base-import Data.Functor.Identity ( Identity( Identity ) )-import Data.Kind ( Type )-import Data.List.NonEmpty ( NonEmpty )-import Prelude hiding ( id )---- rel8-import Rel8.Expr ( Expr )-import Rel8.Expr.Array ( sappend1, snonEmptyOf )-import Rel8.Schema.Dict ( Dict( Dict ) )-import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )-import Rel8.Schema.HTable.Vectorize-  ( hvectorize, hunvectorize-  , happend-  , hproject, hcolumn-  )-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Name ( Name( Name ) )-import Rel8.Schema.Null ( Nullity( Null, NotNull ) )-import Rel8.Schema.Result ( vectorizer, unvectorizer )-import Rel8.Schema.Spec ( Spec(..) )-import Rel8.Table-  ( Table, Context, Columns, fromColumns, toColumns-  , FromExprs, fromResult, toResult-  , Transpose-  )-import Rel8.Table.Alternative ( AltTable, (<|>:) )-import Rel8.Table.Eq ( EqTable, eqTable )-import Rel8.Table.Ord ( OrdTable, ordTable )-import Rel8.Table.Projection-  ( Projectable, Projecting, Projection, project, apply-  )-import Rel8.Table.Serialize ( ToExprs )----- | A @NonEmptyTable@ value contains one or more instances of @a@. You--- construct @NonEmptyTable@s with 'Rel8.some' or 'nonEmptyAgg'.-type NonEmptyTable :: K.Context -> Type -> Type-newtype NonEmptyTable context a =-  NonEmptyTable (HNonEmptyTable (Columns a) (Context a))---instance Projectable (NonEmptyTable context) where-  project f (NonEmptyTable a) = NonEmptyTable (hproject (apply f) a)---instance (Table context a, context ~ context') =>-  Table context' (NonEmptyTable context a)- where-  type Columns (NonEmptyTable context a) = HNonEmptyTable (Columns a)-  type Context (NonEmptyTable context a) = Context a-  type FromExprs (NonEmptyTable context a) = NonEmpty (FromExprs a)-  type Transpose to (NonEmptyTable context a) =-    NonEmptyTable to (Transpose to a)--  fromColumns = NonEmptyTable-  toColumns (NonEmptyTable a) = a-  fromResult = fmap (fromResult @_ @a) . hunvectorize unvectorizer-  toResult = hvectorize vectorizer . fmap (toResult @_ @a)---instance (EqTable a, context ~ Expr) =>-  EqTable (NonEmptyTable context a)- where-  eqTable =-    hvectorize-      (\Spec {nullity} (Identity Dict) -> case nullity of-        Null -> Dict-        NotNull -> Dict)-      (Identity (eqTable @a))---instance (OrdTable a, context ~ Expr) =>-  OrdTable (NonEmptyTable context a)- where-  ordTable =-    hvectorize-      (\Spec {nullity} (Identity Dict) -> case nullity of-        Null -> Dict-        NotNull -> Dict)-      (Identity (ordTable @a))---instance (ToExprs exprs a, context ~ Expr) =>-  ToExprs (NonEmptyTable context exprs) (NonEmpty a)---instance context ~ Expr => AltTable (NonEmptyTable context) where-  (<|>:) = (<>)---instance (Table Expr a, context ~ Expr) => Semigroup (NonEmptyTable context a)- where-  NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $-    happend (const sappend1) as bs----- | Project a single expression out of a 'NonEmptyTable'.-($+) :: Projecting a (Expr b)-  => Projection a (Expr b) -> NonEmptyTable Expr a -> Expr (NonEmpty b)-f $+ NonEmptyTable a = hcolumn $ hproject (apply f) a-infixl 4 $+----- | Construct a @NonEmptyTable@ from a non-empty list of expressions.-nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable Expr a-nonEmptyTable =-  NonEmptyTable .-  hvectorize (\Spec {info} -> snonEmptyOf info) .-  fmap toColumns----- | Construct a 'NonEmptyTable' in the 'Name' context. This can be useful if--- you have a 'NonEmptyTable' that you are storing in a table and need to--- construct a 'TableSchema'.-nameNonEmptyTable-  :: Table Name a-  => a -- ^ The names of the columns of elements of the list.-  -> NonEmptyTable Name a-nameNonEmptyTable =-  NonEmptyTable .-  hvectorize (\_ (Identity (Name a)) -> Name a) .-  pure .-  toColumns
− src/Rel8/Table/Nullify.hs 
@@ -1,184 +0,0 @@-{-# language DataKinds #-}-{-# language FlexibleInstances #-}-{-# language LambdaCase #-}-{-# language MultiParamTypeClasses #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}--module Rel8.Table.Nullify-  ( Nullify-  , aggregateNullify-  , guard-  )-where---- base-import Control.Applicative ( liftA2 )-import Data.Functor.Identity ( runIdentity )-import Data.Kind ( Type )-import Prelude---- comonad-import Control.Comonad ( Comonad, duplicate, extract, ComonadApply, (<@>) )---- rel8-import Rel8.Aggregate ( Aggregate )-import Rel8.Expr ( Expr )-import Rel8.Kind.Context ( Reifiable, contextSing )-import Rel8.Schema.Context.Nullify-  ( Nullifiability( NAggregate, NExpr )-  , NonNullifiability-  , Nullifiable, nullifiability-  , nullifiableOrNot, absurd-  , guarder-  , nullifier-  , unnullifier-  )-import Rel8.Schema.Dict ( Dict( Dict ) )-import Rel8.Schema.HTable ( HTable )-import Rel8.Schema.HTable.Nullify-  ( HNullify, hnulls, hnullify, hunnullify-  , hguard-  , hproject-  )-import qualified Rel8.Schema.Kind as K-import qualified Rel8.Schema.Result as R-import Rel8.Table-  ( Table, Columns, Context, toColumns, fromColumns-  , FromExprs, fromResult, toResult-  , Transpose-  )-import Rel8.Table.Eq ( EqTable, eqTable )-import Rel8.Table.Ord ( OrdTable, ordTable )-import Rel8.Table.Projection ( Projectable, apply, project )---- semigroupoids-import Data.Functor.Apply ( Apply, (<.>), liftF2 )-import Data.Functor.Bind ( Bind, (>>-) )-import Data.Functor.Extend ( Extend, duplicated )---type Nullify :: K.Context -> Type -> Type-data Nullify context a-  = Table (Nullifiability context) a-  | Fields (NonNullifiability context) (HNullify (Columns a) (Context a))---instance Projectable (Nullify context) where-  project f = \case-    Table nullifiable a -> Table nullifiable (fromColumns (apply f (toColumns a)))-    Fields nonNullifiable a -> Fields nonNullifiable (hproject (apply f) a)---instance Nullifiable context => Functor (Nullify context) where-  fmap f = \case-    Table nullifiable a -> Table nullifiable (f a)-    Fields notNullifiable _ -> absurd nullifiability notNullifiable---instance Nullifiable context => Foldable (Nullify context) where-  foldMap f = \case-    Table _ a -> f a-    Fields notNullifiable _ -> absurd nullifiability notNullifiable---instance Nullifiable context => Traversable (Nullify context) where-  traverse f = \case-    Table nullifiable a -> Table nullifiable <$> f a-    Fields notNullifiable _ -> absurd nullifiability notNullifiable---instance Nullifiable context => Apply (Nullify context) where-  liftF2 f = \case-    Table nullifiable a -> \case-      Table _ b -> Table nullifiable (f a b)-      Fields notNullifiable _ -> absurd nullifiable notNullifiable-    Fields notNullifiable _ -> absurd nullifiability notNullifiable---instance Nullifiable context => Applicative (Nullify context) where-  pure = Table nullifiability-  liftA2 = liftF2---instance Nullifiable context => Bind (Nullify context) where-  Table _ a >>- f = f a-  Fields notNullifiable _ >>- _ = absurd nullifiability notNullifiable---instance Nullifiable context => Monad (Nullify context) where-  (>>=) = (>>-)---instance Nullifiable context => Extend (Nullify context) where-  duplicated = \case-    Table nullifiable a -> Table nullifiable (Table nullifiable a)-    Fields notNullifiable _ -> absurd nullifiability notNullifiable---instance Nullifiable context => Comonad (Nullify context) where-  extract = \case-    Table _ a -> a-    Fields notNullifiable _ -> absurd nullifiability notNullifiable-  duplicate = duplicated---instance Nullifiable context => ComonadApply (Nullify context) where-  (<@>) = (<.>)---instance (Table context a, Reifiable context, context ~ context') =>-  Table context' (Nullify context a)- where-  type Columns (Nullify context a) = HNullify (Columns a)-  type Context (Nullify context a) = Context a-  type FromExprs (Nullify context a) = Maybe (FromExprs a)-  type Transpose to (Nullify context a) = Nullify to (Transpose to a)--  fromColumns = case nullifiableOrNot contextSing of-    Left notNullifiable -> Fields notNullifiable-    Right nullifiable ->-      Table nullifiable .-      fromColumns .-      runIdentity .-      hunnullify (\spec -> pure . unnullifier nullifiable spec)--  toColumns = \case-    Table nullifiable a -> hnullify (nullifier nullifiable) (toColumns a)-    Fields _ a -> a--  fromResult = fmap (fromResult @_ @a) . hunnullify R.unnullifier--  toResult =-    maybe (hnulls (const R.null)) (hnullify R.nullifier) .-    fmap (toResult @_ @a)---instance (EqTable a, context ~ Expr) => EqTable (Nullify context a) where-  eqTable = hnullify (\_ Dict -> Dict) (eqTable @a)---instance (OrdTable a, context ~ Expr) => OrdTable (Nullify context a) where-  ordTable = hnullify (\_ Dict -> Dict) (ordTable @a)---aggregateNullify :: ()-  => (exprs -> aggregates)-  -> Nullify Expr exprs-  -> Nullify Aggregate aggregates-aggregateNullify f = \case-  Table _ a -> Table NAggregate (f a)-  Fields notNullifiable _ -> absurd NExpr notNullifiable---guard :: (Reifiable context, HTable t)-  => context tag-  -> (tag -> Bool)-  -> (Expr tag -> Expr Bool)-  -> HNullify t context-  -> HNullify t context-guard tag isNonNull isNonNullExpr =-  hguard (guarder contextSing tag isNonNull isNonNullExpr)
− src/Rel8/Table/Opaleye.hs 
@@ -1,166 +0,0 @@-{-# language BlockArguments #-}-{-# language DataKinds #-}-{-# language DisambiguateRecordFields #-}-{-# language FlexibleContexts #-}-{-# language NamedFieldPuns #-}-{-# language RankNTypes #-}-{-# language TypeFamilies #-}-{-# language ViewPatterns #-}--module Rel8.Table.Opaleye-  ( aggregator-  , attributes-  , binaryspec-  , distinctspec-  , exprs-  , exprsWithNames-  , table-  , tableFields-  , unpackspec-  , valuesspec-  , view-  , castTable-  )-where---- base-import Data.Functor.Const ( Const( Const ), getConst )-import Data.List.NonEmpty ( NonEmpty )-import Prelude hiding ( undefined )---- opaleye-import qualified Opaleye.Internal.Aggregate as Opaleye-import qualified Opaleye.Internal.Binary as Opaleye-import qualified Opaleye.Internal.Distinct as Opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye-import qualified Opaleye.Internal.PackMap as Opaleye-import qualified Opaleye.Internal.Unpackspec as Opaleye-import qualified Opaleye.Internal.Values as Opaleye-import qualified Opaleye.Internal.Table as Opaleye---- profunctors-import Data.Profunctor ( dimap, lmap )---- rel8-import Rel8.Aggregate ( Aggregate( Aggregate ), Aggregates )-import Rel8.Expr ( Expr )-import Rel8.Expr.Opaleye-  ( fromPrimExpr, toPrimExpr-  , traversePrimExpr-  , fromColumn, toColumn-  , scastExpr-  )-import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs, htabulate )-import Rel8.Schema.Name ( Name( Name ), Selects, ppColumn )-import Rel8.Schema.Spec ( Spec(..) )-import Rel8.Schema.Table ( TableSchema(..), ppTable )-import Rel8.Table ( Table, fromColumns, toColumns )-import Rel8.Table.Undefined ( undefined )---- semigroupoids-import Data.Functor.Apply ( WrappedApplicative(..) )---aggregator :: Aggregates aggregates exprs => Opaleye.Aggregator aggregates exprs-aggregator = Opaleye.Aggregator $ Opaleye.PackMap $ \f aggregates ->-  fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->-    WrapApplicative $ case hfield (toColumns aggregates) field of-      Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner)) ->-        inner f ()---attributes :: Selects names exprs => TableSchema names -> exprs-attributes schema@TableSchema {columns} = fromColumns $ htabulate $ \field ->-  case hfield (toColumns columns) field of-    Name column -> fromPrimExpr $ Opaleye.ConstExpr $-      Opaleye.OtherLit $-        show (ppTable schema) <> "." <> show (ppColumn column)---binaryspec :: Table Expr a => Opaleye.Binaryspec a a-binaryspec = Opaleye.Binaryspec $ Opaleye.PackMap $ \f (as, bs) ->-  fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->-    WrapApplicative $-      case (hfield (toColumns as) field, hfield (toColumns bs) field) of-        (a, b) -> fromPrimExpr <$> f (toPrimExpr a, toPrimExpr b)---distinctspec :: Table Expr a => Opaleye.Distinctspec a a-distinctspec =-  Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap $ \f ->-    fmap fromColumns .-    unwrapApplicative .-    htraverse-      (\a -> WrapApplicative $ fromPrimExpr <$> f (Nothing, toPrimExpr a)) .-    toColumns---exprs :: Table Expr a => a -> NonEmpty Opaleye.PrimExpr-exprs (toColumns -> as) = getConst $ htabulateA $ \field ->-  case hfield as field of-    expr -> Const (pure (toPrimExpr expr))---exprsWithNames :: Selects names exprs-  => names -> exprs -> NonEmpty (String, Opaleye.PrimExpr)-exprsWithNames names as = getConst $ htabulateA $ \field ->-  case (hfield (toColumns names) field, hfield (toColumns as) field) of-    (Name name, expr) -> Const (pure (name, toPrimExpr expr))---table :: Selects names exprs => TableSchema names -> Opaleye.Table exprs exprs-table (TableSchema name schema columns) =-  case schema of-    Nothing -> Opaleye.Table name (tableFields columns)-    Just schemaName -> Opaleye.TableWithSchema schemaName name (tableFields columns)---tableFields :: Selects names exprs-  => names -> Opaleye.TableFields exprs exprs-tableFields (toColumns -> names) = dimap toColumns fromColumns $-  unwrapApplicative $ htabulateA $ \field -> WrapApplicative $-    case hfield names field of-      name -> lmap (`hfield` field) (go name)-  where-    go :: Name a -> Opaleye.TableFields (Expr a) (Expr a)-    go (Name name) =-      dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $-        Opaleye.requiredTableField name---unpackspec :: Table Expr a => Opaleye.Unpackspec a a-unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->-  fmap fromColumns .-  unwrapApplicative .-  htraverse (WrapApplicative . traversePrimExpr f) .-  toColumns-{-# INLINABLE unpackspec #-}---valuesspec :: Table Expr a => Opaleye.ValuesspecSafe a a-valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec---view :: Selects names exprs => names -> exprs-view columns = fromColumns $ htabulate $ \field ->-  case hfield (toColumns columns) field of-    Name column -> fromPrimExpr $ Opaleye.BaseTableAttrExpr column---toPackMap :: Table Expr a-  => a -> Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () a-toPackMap as = Opaleye.PackMap $ \f () ->-  fmap fromColumns $-  unwrapApplicative .-  htraverse (WrapApplicative . traversePrimExpr f) $-  toColumns as----- | Transform a table by adding 'CAST' to all columns. This is most useful for--- finalising a SELECT or RETURNING statement, guaranteed that the output--- matches what is encoded in each columns TypeInformation.-castTable :: Table Expr a => a -> a-castTable (toColumns -> as) = fromColumns $ htabulate \field ->-  case hfield hspecs field of-    Spec {info} -> case hfield as field of-        expr -> scastExpr info expr
− src/Rel8/Table/Ord.hs 
@@ -1,154 +0,0 @@-{-# language AllowAmbiguousTypes #-}-{-# language DataKinds #-}-{-# language DefaultSignatures #-}-{-# language DisambiguateRecordFields #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-}-{-# language TypeFamilies #-}-{-# language TypeOperators #-}-{-# language UndecidableInstances #-}-{-# language ViewPatterns #-}--module Rel8.Table.Ord-  ( OrdTable( ordTable ), (<:), (<=:), (>:), (>=:), least, greatest-  )-where---- base-import Data.Functor.Const ( Const( Const ), getConst )-import Data.Kind ( Constraint, Type )-import GHC.Generics ( Rep )-import Prelude hiding ( seq )---- rel8-import Rel8.Expr ( Expr )-import Rel8.Expr.Bool ( (||.), (&&.), false, true )-import Rel8.Expr.Eq ( (==.) )-import Rel8.Expr.Ord ( (<.), (>.) )-import Rel8.FCF ( Eval, Exp )-import Rel8.Generic.Record ( Record )-import Rel8.Generic.Table.Record ( GTable, GColumns, gtable )-import Rel8.Schema.Dict ( Dict( Dict ) )-import Rel8.Schema.HTable ( htabulateA, hfield )-import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )-import Rel8.Schema.Null (Sql)-import Rel8.Table ( Columns, toColumns, TColumns )-import Rel8.Table.Bool ( bool )-import Rel8.Table.Eq ( EqTable )-import Rel8.Type.Ord ( DBOrd )----- | The class of 'Table's that can be ordered. Ordering on tables is defined--- by their lexicographic ordering of all columns, so this class means "all--- columns in a 'Table' have an instance of 'DBOrd'".-type OrdTable :: Type -> Constraint-class EqTable a => OrdTable a where-  ordTable :: Columns a (Dict (Sql DBOrd))--  default ordTable ::-    ( GTable TOrdTable TColumns (Rep (Record a))-    , Columns a ~ GColumns TColumns (Rep (Record a))-    )-    => Columns a (Dict (Sql DBOrd))-  ordTable = gtable @TOrdTable @TColumns @(Rep (Record a)) table-    where-      table (_ :: proxy x) = ordTable @x---data TOrdTable :: Type -> Exp Constraint-type instance Eval (TOrdTable a) = OrdTable a---instance Sql DBOrd a => OrdTable (Expr a) where-  ordTable = HIdentity Dict---instance (OrdTable a, OrdTable b) => OrdTable (a, b)---instance (OrdTable a, OrdTable b, OrdTable c) => OrdTable (a, b, c)---instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d) => OrdTable (a, b, c, d)---instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e) =>-  OrdTable (a, b, c, d, e)---instance-  ( OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e, OrdTable f-  )-  => OrdTable (a, b, c, d, e, f)---instance-  ( OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e, OrdTable f-  , OrdTable g-  )-  => OrdTable (a, b, c, d, e, f, g)----- | Test if one 'Table' sorts before another. Corresponds to comparing all--- columns with '<'.-(<:) :: forall a. OrdTable a => a -> a -> Expr Bool-(toColumns -> as) <: (toColumns -> bs) =-  foldr @[] go false $ getConst $ htabulateA $ \field ->-    case (hfield as field, hfield bs field) of-      (a, b) -> case hfield (ordTable @a) field of-        Dict -> Const [(a <. b, a ==. b)]-  where-    go (lt, eq) a = lt ||. (eq &&. a)-infix 4 <:----- | Test if one 'Table' sorts before, or is equal to, another. Corresponds to--- comparing all columns with '<='.-(<=:) :: forall a. OrdTable a => a -> a -> Expr Bool-(toColumns -> as) <=: (toColumns -> bs) =-  foldr @[] go true $ getConst $ htabulateA $ \field ->-    case (hfield as field, hfield bs field) of-      (a, b) -> case hfield (ordTable @a) field of-        Dict -> Const [(a <. b, a ==. b)]-  where-    go (lt, eq) a = lt ||. (eq &&. a)-infix 4 <=:----- | Test if one 'Table' sorts after another. Corresponds to comparing all--- columns with '>'.-(>:) :: forall a. OrdTable a => a -> a -> Expr Bool-(toColumns -> as) >: (toColumns -> bs) =-  foldr @[] go false $ getConst $ htabulateA $ \field ->-    case (hfield as field, hfield bs field) of-      (a, b) -> case hfield (ordTable @a) field of-        Dict -> Const [(a >. b, a ==. b)]-  where-    go (gt, eq) a = gt ||. (eq &&. a)-infix 4 >:----- | Test if one 'Table' sorts after another. Corresponds to comparing all--- columns with '>='.-(>=:) :: forall a. OrdTable a => a -> a -> Expr Bool-(toColumns -> as) >=: (toColumns -> bs) =-  foldr @[] go true $ getConst $ htabulateA $ \field ->-    case (hfield as field, hfield bs field) of-      (a, b) -> case hfield (ordTable @a) field of-        Dict -> Const [(a >. b, a ==. b)]-  where-    go (gt, eq) a = gt ||. (eq &&. a)-infix 4 >=:----- | Given two 'Table's, return the table that sorts before the other.-least :: OrdTable a => a -> a -> a-least a b = bool a b (a <: b)----- | Given two 'Table's, return the table that sorts after the other.-greatest :: OrdTable a => a -> a -> a-greatest a b = bool a b (a >: b)
− src/Rel8/Table/Order.hs 
@@ -1,50 +0,0 @@-{-# language DataKinds #-}-{-# language NamedFieldPuns #-}-{-# language ScopedTypeVariables #-}-{-# language TypeApplications #-}-{-# language TypeFamilies #-}--module Rel8.Table.Order-  ( ascTable-  , descTable-  )-where---- base-import Data.Functor.Const ( Const( Const ), getConst )-import Data.Functor.Contravariant ( (>$<), contramap )-import Prelude---- rel8-import Rel8.Expr.Order ( asc, desc, nullsFirst, nullsLast )-import Rel8.Order ( Order )-import Rel8.Schema.Dict ( Dict( Dict ) )-import Rel8.Schema.HTable (htabulateA, hfield, hspecs)-import Rel8.Schema.Null ( Nullity( Null, NotNull ) )-import Rel8.Schema.Spec ( Spec( Spec, nullity ) )-import Rel8.Table ( Columns, toColumns )-import Rel8.Table.Ord ( OrdTable, ordTable )----- | Construct an 'Order' for a 'Table' by sorting all columns into ascending--- orders (any nullable columns will be sorted with @NULLS FIRST@).-ascTable :: forall a. OrdTable a => Order a-ascTable = contramap toColumns $ getConst $-  htabulateA @(Columns a) $ \field -> case hfield hspecs field of-    Spec {nullity} -> case hfield (ordTable @a) field of-      Dict -> Const $ (`hfield` field) >$<-        case nullity of-          Null -> nullsFirst asc-          NotNull -> asc----- | Construct an 'Order' for a 'Table' by sorting all columns into descending--- orders (any nullable columns will be sorted with @NULLS LAST@).-descTable :: forall a. OrdTable a => Order a-descTable = contramap toColumns $ getConst $-  htabulateA @(Columns a) $ \field -> case hfield hspecs field of-    Spec {nullity} -> case hfield (ordTable @a) field of-      Dict -> Const $ (`hfield` field) >$<-        case nullity of-          Null -> nullsLast desc-          NotNull -> desc
− src/Rel8/Table/Projection.hs 
@@ -1,73 +0,0 @@-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language MonoLocalBinds #-}-{-# language MultiParamTypeClasses #-}-{-# language StandaloneKindSignatures #-}-{-# language UndecidableInstances #-}--module Rel8.Table.Projection-  ( Projection-  , Projectable( project )-  , Biprojectable( biproject )-  , Projecting-  , apply-  )-where---- base-import Data.Kind ( Constraint, Type )-import Prelude---- rel8-import Rel8.Schema.Field ( Field( Field ), fields )-import Rel8.Schema.HTable ( hfield, htabulate )-import Rel8.Table ( Columns, Context, Transpose, toColumns )-import Rel8.Table.Transpose ( Transposes )----- | The constraint @'Projecting' a b@ ensures that @'Projection' a b@ is a--- usable 'Projection'.-type Projecting :: Type -> Type -> Constraint-class-  ( Transposes (Context a) (Field a) a (Transpose (Field a) a)-  , Transposes (Context a) (Field a) b (Transpose (Field a) b)-  )-  => Projecting a b-instance-  ( Transposes (Context a) (Field a) a (Transpose (Field a) a)-  , Transposes (Context a) (Field a) b (Transpose (Field a) b)-  )-  => Projecting a b----- | A @'Projection' a b@s is a special type of function @a -> b@ whereby the--- resulting @b@ is guaranteed to be composed only from columns contained in--- @a@.-type Projection :: Type -> Type -> Type-type Projection a b = Transpose (Field a) a -> Transpose (Field a) b----- | @'Projectable' f@ means that @f@ is a kind of functor on 'Rel8.Table's--- that allows the mapping of a 'Projection' over its underlying columns.-type Projectable :: (Type -> Type) -> Constraint-class Projectable f where-  -- | Map a 'Projection' over @f@.-  project :: Projecting a b-    => Projection a b -> f a -> f b----- | @'Biprojectable' p@ means that @p@ is a kind of bifunctor on--- 'Rel8.Table's that allows the mapping of a pair of 'Projection's  over its--- underlying columns.-type Biprojectable :: (Type -> Type -> Type) -> Constraint-class Biprojectable p where-  -- | Map a pair of 'Projection's over @p@.-  biproject :: (Projecting a b, Projecting c d)-    => Projection a b -> Projection c d -> p a c -> p b d---apply :: Projecting a b-  => Projection a b -> Columns a context -> Columns b context-apply f a = case toColumns (f fields) of-  bs -> htabulate $ \field -> case hfield bs field of-    Field field' -> hfield a field'
− src/Rel8/Table/Rel8able.hs 
@@ -1,92 +0,0 @@-{-# language DataKinds #-}-{-# language FlexibleInstances #-}-{-# language MultiParamTypeClasses #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}--{-# options_ghc -fno-warn-orphans #-}--module Rel8.Table.Rel8able-  (-  )-where---- base-import Prelude ()---- rel8-import Rel8.Expr ( Expr )-import qualified Rel8.Kind.Algebra as K-import Rel8.Kind.Context ( Reifiable, contextSing )-import Rel8.Generic.Rel8able-  ( Rel8able, Algebra-  , GColumns, gfromColumns, gtoColumns-  , GFromExprs, gfromResult, gtoResult-  )-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.HTable ( HConstrainTable, hdicts )-import Rel8.Schema.Null ( Sql )-import Rel8.Schema.Result ( Result )-import Rel8.Table-  ( Table, Columns, Context, fromColumns, toColumns-  , FromExprs, fromResult, toResult-  , Transpose-  )-import Rel8.Table.ADT ( ADT )-import Rel8.Table.Eq ( EqTable, eqTable )-import Rel8.Table.Ord ( OrdTable, ordTable )-import Rel8.Table.Serialize ( ToExprs )-import Rel8.Type.Eq ( DBEq )-import Rel8.Type.Ord ( DBOrd )---instance (Rel8able t, Reifiable context, context ~ context') =>-  Table context' (t context)- where-  type Columns (t context) = GColumns t-  type Context (t context) = context-  type FromExprs (t context) = GFromExprs t-  type Transpose to (t context) = t to--  fromColumns = gfromColumns contextSing-  toColumns = gtoColumns contextSing-  fromResult = gfromResult @t-  toResult = gtoResult @t---instance-  ( context ~ Expr-  , Rel8able t-  , HConstrainTable (Columns (t context)) (Sql DBEq)-  )-  => EqTable (t context)- where-  eqTable = hdicts @(Columns (t context)) @(Sql DBEq)---instance-  ( context ~ Expr-  , Rel8able t-  , HConstrainTable (Columns (t context)) (Sql DBEq)-  , HConstrainTable (Columns (t context)) (Sql DBOrd)-  )-  => OrdTable (t context)- where-  ordTable = hdicts @(Columns (t context)) @(Sql DBOrd)---instance-  ( Rel8able t', t' ~ Choose (Algebra t) t-  , x ~ t' Expr-  , result ~ Result-  )-  => ToExprs x (t result)---type Choose :: K.Algebra -> K.Rel8able -> K.Rel8able-type family Choose algebra t where-  Choose 'K.Sum t = ADT t-  Choose 'K.Product t = t
− src/Rel8/Table/Serialize.hs 
@@ -1,148 +0,0 @@-{-# language AllowAmbiguousTypes #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language FunctionalDependencies #-}-{-# language NamedFieldPuns #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}--module Rel8.Table.Serialize-  ( Serializable, lit, litHTable, parse-  , ToExprs-  )-where---- base-import Data.Functor.Identity ( Identity( Identity ) )-import Data.Kind ( Constraint, Type )-import Data.List.NonEmpty ( NonEmpty )-import Prelude---- hasql-import qualified Hasql.Decoders as Hasql---- rel8-import Rel8.Expr ( Expr )-import Rel8.Expr.Serialize ( slitExpr, sparseValue )-import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )-import Rel8.Schema.Null ( NotNull, Sql )-import Rel8.Schema.Result ( Result )-import Rel8.Schema.Spec ( Spec(..) )-import Rel8.Table ( Table, fromColumns, FromExprs, fromResult, toResult )-import Rel8.Type ( DBType )---- semigroupoids-import Data.Functor.Apply ( WrappedApplicative(..) )----- | @ToExprs exprs a@ is evidence that the types @exprs@ and @a@ describe--- essentially the same type, but @exprs@ is in the 'Expr' context, and @a@ is--- a normal Haskell type.-type ToExprs :: Type -> Type -> Constraint-class Table Expr exprs => ToExprs exprs a---instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a---instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a]---instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a)---instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a)---instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>-  ToExprs x (a, b)---instance-  ( ToExprs exprs1 a-  , ToExprs exprs2 b-  , ToExprs exprs3 c-  , x ~ (exprs1, exprs2, exprs3)-  )-  => ToExprs x (a, b, c)---instance-  ( ToExprs exprs1 a-  , ToExprs exprs2 b-  , ToExprs exprs3 c-  , ToExprs exprs4 d-  , x ~ (exprs1, exprs2, exprs3, exprs4)-  )-  => ToExprs x (a, b, c, d)---instance-  ( ToExprs exprs1 a-  , ToExprs exprs2 b-  , ToExprs exprs3 c-  , ToExprs exprs4 d-  , ToExprs exprs5 e-  , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)-  )-  => ToExprs x (a, b, c, d, e)---instance-  ( ToExprs exprs1 a-  , ToExprs exprs2 b-  , ToExprs exprs3 c-  , ToExprs exprs4 d-  , ToExprs exprs5 e-  , ToExprs exprs6 f-  , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6)-  )-  => ToExprs x (a, b, c, d, e, f)---instance-  ( ToExprs exprs1 a-  , ToExprs exprs2 b-  , ToExprs exprs3 c-  , ToExprs exprs4 d-  , ToExprs exprs5 e-  , ToExprs exprs6 f-  , ToExprs exprs7 g-  , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6, exprs7)-  )-  => ToExprs x (a, b, c, d, e, f, g)----- | @Serializable@ witnesses the one-to-one correspondence between the type--- @sql@, which contains SQL expressions, and the type @haskell@, which--- contains the Haskell decoding of rows containing @sql@ SQL expressions.-type Serializable :: Type -> Type -> Constraint-class (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a-instance (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a-instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a----- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is--- capable of lifting single @Expr@s to full tables.-lit :: forall exprs a. Serializable exprs a => a -> exprs-lit = fromColumns . litHTable . toResult @_ @exprs---parse :: forall exprs a. Serializable exprs a => Hasql.Row a-parse = fromResult @_ @exprs <$> parseHTable---litHTable :: HTable t => t Result -> t Expr-litHTable as = htabulate $ \field ->-  case hfield hspecs field of-    Spec {nullity, info} -> case hfield as field of-      Identity value -> slitExpr nullity info value---parseHTable :: HTable t => Hasql.Row (t Result)-parseHTable = unwrapApplicative $ htabulateA $ \field ->-  WrapApplicative $ case hfield hspecs field of-    Spec {nullity, info} -> Identity <$> sparseValue nullity info
− src/Rel8/Table/These.hs 
@@ -1,346 +0,0 @@-{-# language DataKinds #-}-{-# language DeriveFunctor #-}-{-# language DerivingStrategies #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language MultiParamTypeClasses #-}-{-# language NamedFieldPuns #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TupleSections #-}-{-# language TypeApplications #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}--{-# options_ghc -fno-warn-orphans #-}--module Rel8.Table.These-  ( TheseTable(..)-  , theseTable, thisTable, thatTable, thoseTable-  , isThisTable, isThatTable, isThoseTable-  , hasHereTable, hasThereTable-  , justHereTable, justThereTable-  , aggregateTheseTable-  , nameTheseTable-  )-where---- base-import Data.Bifunctor ( Bifunctor, bimap )-import Data.Kind ( Type )-import Data.Maybe ( isJust )-import Prelude hiding ( undefined )---- rel8-import Rel8.Aggregate ( Aggregate )-import Rel8.Expr ( Expr )-import Rel8.Expr.Bool ( (&&.), not_ )-import Rel8.Expr.Null ( isNonNull )-import Rel8.Kind.Context ( Reifiable )-import Rel8.Schema.Context.Nullify ( Nullifiable )-import Rel8.Schema.Dict ( Dict( Dict ) )-import Rel8.Schema.HTable.Label ( hlabel, hrelabel, hunlabel )-import Rel8.Schema.HTable.Identity ( HIdentity(..) )-import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )-import Rel8.Schema.HTable.These ( HTheseTable(..) )-import qualified Rel8.Schema.Kind as K-import Rel8.Schema.Name ( Name )-import Rel8.Table-  ( Table, Columns, Context, fromColumns, toColumns-  , FromExprs, fromResult, toResult-  , Transpose-  )-import Rel8.Table.Eq ( EqTable, eqTable )-import Rel8.Table.Maybe-  ( MaybeTable(..)-  , maybeTable, justTable, nothingTable-  , isJustTable-  , aggregateMaybeTable-  , nameMaybeTable-  )-import Rel8.Table.Nullify ( Nullify, guard )-import Rel8.Table.Ord ( OrdTable, ordTable )-import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )-import Rel8.Table.Serialize ( ToExprs )-import Rel8.Table.Undefined ( undefined )-import Rel8.Type.Tag ( MaybeTag )---- semigroupoids-import Data.Functor.Apply ( Apply, (<.>) )-import Data.Functor.Bind ( Bind, (>>-) )---- these-import Data.These ( These( This, That, These ) )-import Data.These.Combinators ( justHere, justThere )----- | @TheseTable a b@ is a Rel8 table that contains either the table @a@, the--- table @b@, or both tables @a@ and @b@. You can construct @TheseTable@s using--- 'thisTable', 'thatTable' and 'thoseTable'. @TheseTable@s can be--- eliminated/pattern matched using 'theseTable'.------ @TheseTable@ is operationally the same as Haskell's 'These' type, but--- adapted to work with Rel8.-type TheseTable :: K.Context -> Type -> Type -> Type-data TheseTable context a b = TheseTable-  { here :: MaybeTable context a-  , there :: MaybeTable context b-  }-  deriving stock Functor---instance Biprojectable (TheseTable context) where-  biproject f g (TheseTable a b) = TheseTable (project f a) (project g b)---instance Nullifiable context => Bifunctor (TheseTable context) where-  bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)---instance Projectable (TheseTable context a) where-  project f (TheseTable a b) = TheseTable a (project f b)---instance (context ~ Expr, Table Expr a, Semigroup a) =>-  Apply (TheseTable context a)- where-  fs <.> as = TheseTable-    { here = here fs <> here as-    , there = there fs <.> there as-    }---instance (context ~ Expr, Table Expr a, Semigroup a) =>-  Applicative (TheseTable context a)- where-  pure = thatTable-  (<*>) = (<.>)---instance (context ~ Expr, Table Expr a, Semigroup a) =>-  Bind (TheseTable context a)- where-  TheseTable here1 ma >>- f = case ma >>- f' of-    mtb -> TheseTable-      { here = maybeTable here1 ((here1 <>) . fst) mtb-      , there = snd <$> mtb-      }-    where-      f' a = case f a of-        TheseTable here2 mb -> (here2,) <$> mb---instance (context ~ Expr, Table Expr a, Semigroup a) =>-  Monad (TheseTable context a)- where-  (>>=) = (>>-)---instance (context ~ Expr, Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>-  Semigroup (TheseTable context a b)- where-  a <> b = TheseTable-    { here = here a <> here b-    , there = there a <> there b-    }---instance-  ( Table context a, Table context b-  , Reifiable context, context ~ context'-  )-  => Table context' (TheseTable context a b)- where-  type Columns (TheseTable context a b) = HTheseTable (Columns a) (Columns b)-  type Context (TheseTable context a b) = Context a-  type FromExprs (TheseTable context a b) =-    These (FromExprs a) (FromExprs b)-  type Transpose to (TheseTable context a b) =-    TheseTable to (Transpose to a) (Transpose to b)--  toColumns TheseTable {here, there} = HTheseTable-    { hhereTag = hlabel $ HIdentity $ tag here-    , hhere =-        hlabel $ guard (tag here) isJust isNonNull $ toColumns $ just here-    , hthereTag = hlabel $ HIdentity $ tag there-    , hthere =-        hlabel $ guard (tag there) isJust isNonNull $ toColumns $ just there-    }--  fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable-    { here = MaybeTable-        { tag = unHIdentity $ hunlabel hhereTag-        , just = fromColumns $ hunlabel hhere-        }-    , there = MaybeTable-        { tag = unHIdentity $ hunlabel hthereTag-        , just = fromColumns $ hunlabel hthere-        }-    }--  toResult tables = HTheseTable-    { hhereTag = hrelabel hhereTag-    , hhere = hrelabel hhere-    , hthereTag = hrelabel hthereTag-    , hthere = hrelabel hthere-    }-    where-      HMaybeTable-        { htag = hhereTag-        , hjust = hhere-        } = toResult @_ @(MaybeTable context a) (justHere tables)-      HMaybeTable-        { htag = hthereTag-        , hjust = hthere-        } = toResult @_ @(MaybeTable context b) (justThere tables)--  fromResult HTheseTable {hhereTag, hhere, hthereTag, hthere} =-    case (here, there) of-      (Just a, Nothing) -> This a-      (Nothing, Just b) -> That b-      (Just a, Just b) -> These a b-      _ -> error "These.fromColumns: mismatch between tags and data"-    where-      here = fromResult @_ @(MaybeTable context a) mhere-      there = fromResult @_ @(MaybeTable context b) mthere-      mhere = HMaybeTable-        { htag = hrelabel hhereTag-        , hjust = hrelabel hhere-        }-      mthere = HMaybeTable-        { htag = hrelabel hthereTag-        , hjust = hrelabel hthere-        }---instance (EqTable a, EqTable b, context ~ Expr) =>-  EqTable (TheseTable context a b)- where-  eqTable = HTheseTable-    { hhereTag = hlabel (HIdentity Dict)-    , hhere = hlabel (eqTable @(Nullify context a))-    , hthereTag = hlabel (HIdentity Dict)-    , hthere = hlabel (eqTable @(Nullify context b))-    }---instance (OrdTable a, OrdTable b, context ~ Expr) =>-  OrdTable (TheseTable context a b)- where-  ordTable = HTheseTable-    { hhereTag = hlabel (HIdentity Dict)-    , hhere = hlabel (ordTable @(Nullify context a))-    , hthereTag = hlabel (HIdentity Dict)-    , hthere = hlabel (ordTable @(Nullify context b))-    }---instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable Expr exprs1 exprs2) =>-  ToExprs x (These a b)----- | Test if a 'TheseTable' was constructed with 'thisTable'.------ Corresponds to 'Data.These.Combinators.isThis'.-isThisTable :: TheseTable Expr a b -> Expr Bool-isThisTable a = hasHereTable a &&. not_ (hasThereTable a)----- | Test if a 'TheseTable' was constructed with 'thatTable'.------ Corresponds to 'Data.These.Combinators.isThat'.-isThatTable :: TheseTable Expr a b -> Expr Bool-isThatTable a = not_ (hasHereTable a) &&. hasThereTable a----- | Test if a 'TheseTable' was constructed with 'thoseTable'.------ Corresponds to 'Data.These.Combinators.isThese'.-isThoseTable :: TheseTable Expr a b -> Expr Bool-isThoseTable a = hasHereTable a &&. hasThereTable a----- | Test if the @a@ side of @TheseTable a b@ is present.------ Corresponds to 'Data.These.Combinators.hasHere'.-hasHereTable :: TheseTable Expr a b -> Expr Bool-hasHereTable TheseTable {here} = isJustTable here----- | Test if the @b@ table of @TheseTable a b@ is present.------ Corresponds to 'Data.These.Combinators.hasThere'.-hasThereTable :: TheseTable Expr a b -> Expr Bool-hasThereTable TheseTable {there} = isJustTable there----- | Attempt to project out the @a@ table of a @TheseTable a b@.------ Corresponds to 'Data.These.Combinators.justHere'.-justHereTable :: TheseTable context a b -> MaybeTable context a-justHereTable = here----- | Attempt to project out the @b@ table of a @TheseTable a b@.------ Corresponds to 'Data.These.Combinators.justThere'.-justThereTable :: TheseTable context a b -> MaybeTable context b-justThereTable = there----- | Construct a @TheseTable@. Corresponds to 'This'.-thisTable :: Table Expr b => a -> TheseTable Expr a b-thisTable a = TheseTable (justTable a) nothingTable----- | Construct a @TheseTable@. Corresponds to 'That'.-thatTable :: Table Expr a => b -> TheseTable Expr a b-thatTable b = TheseTable nothingTable (justTable b)----- | Construct a @TheseTable@. Corresponds to 'These'.-thoseTable :: a -> b -> TheseTable Expr a b-thoseTable a b = TheseTable (justTable a) (justTable b)----- | Pattern match on a 'TheseTable'. Corresponds to 'these'.-theseTable :: Table Expr c-  => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable Expr a b -> c-theseTable f g h TheseTable {here, there} =-  maybeTable-    (maybeTable undefined f here)-    (\b -> maybeTable (g b) (`h` b) here)-    there----- | Lift a pair of aggregating functions to operate on an 'TheseTable'.--- @thisTable@s, @thatTable@s and @thoseTable@s are grouped separately.-aggregateTheseTable :: ()-  => (exprs -> aggregates)-  -> (exprs' -> aggregates')-  -> TheseTable Expr exprs exprs'-  -> TheseTable Aggregate aggregates aggregates'-aggregateTheseTable f g (TheseTable here there) = TheseTable-  { here = aggregateMaybeTable f here-  , there = aggregateMaybeTable g there-  }----- | Construct a 'TheseTable' in the 'Name' context. This can be useful if you--- have a 'TheseTable' that you are storing in a table and need to construct a--- 'TableSchema'.-nameTheseTable :: ()-  => Name (Maybe MaybeTag)-     -- ^ The name of the column to track the presence of the @a@ table.-  -> Name (Maybe MaybeTag)-     -- ^ The name of the column to track the presence of the @b@ table.-  -> a-     -- ^ Names of the columns in the @a@ table.-  -> b-     -- ^ Names of the columns in the @b@ table.-  -> TheseTable Name a b-nameTheseTable here there a b =-  TheseTable-    { here = nameMaybeTable here a-    , there = nameMaybeTable there b-    }
− src/Rel8/Table/Transpose.hs 
@@ -1,46 +0,0 @@-{-# language DataKinds #-}-{-# language FlexibleInstances #-}-{-# language FunctionalDependencies #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}--module Rel8.Table.Transpose-  ( Transposes-  )-where---- base-import Data.Kind ( Constraint, Type )-import Prelude ()---- rel8-import qualified Rel8.Schema.Kind as K-import Rel8.Table ( Table, Transpose, Congruent )----- | @'Transposes' from to a b@ means that @a@ and @b@ are 'Table's, in the--- @from@ and @to@ contexts respectively, which share the same underlying--- structure. In other words, @b@ is a version of @a@ transposed from the--- @from@ context to the @to@ context (and vice versa).-type Transposes :: K.Context -> K.Context -> Type -> Type -> Constraint-class-  ( Table from a-  , Table to b-  , Congruent a b-  , b ~ Transpose to a-  , a ~ Transpose from b-  )-  => Transposes from to a b-    | a -> from-    , b -> to-    , a to -> b-    , b from -> a-instance-  ( Table from a-  , Table to b-  , Congruent a b-  , b ~ Transpose to a-  , a ~ Transpose from b-  )-  => Transposes from to a b
− src/Rel8/Table/Undefined.hs 
@@ -1,26 +0,0 @@-{-# language FlexibleContexts #-}-{-# language NamedFieldPuns #-}-{-# language TypeFamilies #-}--module Rel8.Table.Undefined-  ( undefined-  )-where---- base-import Prelude hiding ( undefined )---- rel8-import Rel8.Expr ( Expr )-import Rel8.Expr.Null ( snull, unsafeUnnullify )-import Rel8.Schema.HTable ( htabulate, hfield, hspecs )-import Rel8.Schema.Null ( Nullity( Null, NotNull ) )-import Rel8.Schema.Spec ( Spec(..) )-import Rel8.Table ( Table, fromColumns )---undefined :: Table Expr a => a-undefined = fromColumns $ htabulate $ \field -> case hfield hspecs field of-  Spec {nullity, info} -> case nullity of-    Null -> snull info-    NotNull -> unsafeUnnullify (snull info)
src/Rel8/Tabulate.hs view
@@ -2,7 +2,6 @@ {-# language MonoLocalBinds #-} {-# language ScopedTypeVariables #-} {-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-} {-# language TupleSections #-} {-# language UndecidableInstances #-} @@ -22,9 +21,13 @@      -- * Aggregation and Ordering   , aggregate+  , aggregate1   , distinct   , order +    -- * Materialize+  , materialize+     -- ** Magic 'Tabulation's     -- $magic   , count@@ -50,7 +53,7 @@ where  -- base-import Control.Applicative ( (<|>), empty, liftA2 )+import Control.Applicative ( (<|>), empty ) import Control.Monad ( liftM2 ) import Data.Bifunctor ( Bifunctor, bimap, first, second ) import Data.Foldable ( traverse_ )@@ -58,7 +61,7 @@ import Data.Functor.Contravariant ( Contravariant, (>$<), contramap ) import Data.Int ( Int64 ) import Data.Kind ( Type )-import Data.Maybe ( fromMaybe )+import Data.Maybe ( fromJust, fromMaybe ) import Prelude hiding ( lookup, zip, zipWith )  -- bifunctors@@ -68,10 +71,7 @@ import Control.Comonad ( extract )  -- opaleye-import qualified Opaleye.Aggregate as Opaleye-import qualified Opaleye.Internal.Order as Opaleye-import qualified Opaleye.Internal.QueryArr as Opaleye-import qualified Opaleye.Order as Opaleye ( orderBy )+import qualified Opaleye.Order as Opaleye ( orderBy, distinctOnExplicit )  -- profunctors import Data.Profunctor ( dimap, lmap )@@ -84,39 +84,41 @@ import qualified Data.Profunctor.Product as PP  -- rel8-import Rel8.Aggregate ( Aggregates )-import Rel8.Expr ( Expr )-import Rel8.Expr.Aggregate ( countStar )-import Rel8.Expr.Bool ( true )-import Rel8.Order ( Order( Order ) )-import Rel8.Query ( Query )-import qualified Rel8.Query.Exists as Q ( exists, present, absent )-import Rel8.Query.Filter ( where_ )-import Rel8.Query.Limit ( limit )-import Rel8.Query.List ( catNonEmptyTable )-import qualified Rel8.Query.Maybe as Q ( optional )-import Rel8.Query.Opaleye ( mapOpaleye, unsafePeekQuery )-import Rel8.Query.These ( alignBy )-import Rel8.Table ( Table, fromColumns, toColumns )-import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )-import Rel8.Table.Alternative+import Rel8.Internal.Aggregate (Aggregator' (Aggregator), Aggregator, toAggregator1)+import Rel8.Internal.Aggregate.Fold (Fallback (Fallback))+import Rel8.Internal.Expr ( Expr )+import Rel8.Internal.Expr.Aggregate (countStar)+import Rel8.Internal.Expr.Bool ( true )+import Rel8.Internal.Order ( Order( Order ) )+import Rel8.Internal.Query ( Query )+import qualified Rel8.Internal.Query.Aggregate as Q+import qualified Rel8.Internal.Query.Exists as Q ( exists, present, absent )+import Rel8.Internal.Query.Filter ( where_ )+import Rel8.Internal.Query.List ( catNonEmptyTable )+import qualified Rel8.Internal.Query.Materialize as Q+import qualified Rel8.Internal.Query.Maybe as Q ( optional )+import Rel8.Internal.Query.Opaleye ( mapOpaleye, unsafePeekQuery )+import Rel8.Internal.Query.Rebind ( rebind )+import Rel8.Internal.Query.These ( alignBy )+import Rel8.Internal.Table ( Table, fromColumns, toColumns )+import Rel8.Internal.Table.Aggregate (groupBy, listAgg, nonEmptyAgg)+import Rel8.Internal.Table.Alternative   ( AltTable, (<|>:)   , AlternativeTable, emptyTable   )-import Rel8.Table.Cols ( fromCols, toCols )-import Rel8.Table.Eq ( EqTable, (==:), eqTable )-import Rel8.Table.List ( ListTable( ListTable ) )-import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), maybeTable )-import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )-import Rel8.Table.Opaleye ( aggregator, unpackspec )-import Rel8.Table.Ord ( OrdTable )-import Rel8.Table.Order ( ascTable )-import Rel8.Table.Projection+import Rel8.Internal.Table.Eq (EqTable, (==:))+import Rel8.Internal.Table.List (ListTable)+import Rel8.Internal.Table.Maybe (MaybeTable (MaybeTable), fromMaybeTable)+import Rel8.Internal.Table.NonEmpty (NonEmptyTable)+import Rel8.Internal.Table.Opaleye ( unpackspec )+import Rel8.Internal.Table.Ord ( OrdTable )+import Rel8.Internal.Table.Order ( ascTable )+import Rel8.Internal.Table.Projection   ( Biprojectable, biproject   , Projectable, project   , apply   )-import Rel8.Table.These ( TheseTable( TheseTable ), theseTable )+import Rel8.Internal.Table.These ( TheseTable( TheseTable ), theseTable )  -- semigroupoids import Data.Functor.Apply ( Apply, liftF2 )@@ -236,7 +238,13 @@ -- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<|>:)@ is -- @unionWith (<>)@. instance EqTable k => AltTable (Tabulation k) where-  as <|>: bs = catNonEmptyTable `through` ((<>) `on` some) as bs+  tas <|>: tbs = do+    eas <- peek tas+    ebs <- peek tbs+    case (eas, ebs) of+      (Left as, Left bs) -> liftQuery $ as <|>: bs+      (Right as, Right bs) -> fromQuery $ as <|>: bs+      _ -> catNonEmptyTable `through` ((<>) `on` some) tas tbs   instance EqTable k => AlternativeTable (Tabulation k) where@@ -325,19 +333,23 @@     p = match (pure k)  --- | 'aggregate' aggregates the values within each key of a+-- | 'aggregate' produces a \"magic\" 'Tabulation' whereby the values within+-- each group of keys in the given 'Tabulation' is aggregated according to+-- the given aggregator, and every other possible key contains a single+-- \"fallback\" row is returned, composed of the identity elements of the+-- constituent aggregation functions.+aggregate :: (EqTable k, Table Expr i, Table Expr a)+  => Aggregator i a -> Tabulation k i -> Tabulation k a+aggregate aggregator@(Aggregator (Fallback fallback) _) =+  fmap (fromMaybeTable fallback) . optional . aggregate1 aggregator+++-- | 'aggregate1' aggregates the values within each key of a -- 'Tabulation'. There is an implicit @GROUP BY@ on all the key columns.-aggregate :: forall k aggregates exprs.-  ( EqTable k-  , Aggregates aggregates exprs-  )-  => Tabulation k aggregates -> Tabulation k exprs-aggregate (Tabulation f) = Tabulation $-  mapOpaleye (Opaleye.aggregate (keyed haggregator aggregator)) .-  fmap (first (fmap (hgroupBy (eqTable @k) . toColumns))) .-  f-  where-    haggregator = dimap fromColumns fromCols aggregator+aggregate1 :: (EqTable k, Table Expr i)+  => Aggregator' fold i a -> Tabulation k i -> Tabulation k a+aggregate1 aggregator (Tabulation f) =+  Tabulation $ Q.aggregateU (keyed unpackspec unpackspec) (keyed groupBy (toAggregator1 aggregator)) . f   -- | 'distinct' ensures a 'Tabulation' has at most one value for@@ -345,19 +357,8 @@ -- \"first\" value it encounters for each key, but note that \"first\" is -- undefined unless you first call 'order'. distinct :: EqTable k => Tabulation k a -> Tabulation k a-distinct (Tabulation f) = Tabulation $ \p ->-  -- workaround for https://github.com/tomjaguarpaw/haskell-opaleye/pull/518-  case fst (unsafePeekQuery (f p)) of-    Nothing -> limit 1 (f p)-    Just _ ->-      mapOpaleye-        (\q ->-          Opaleye.productQueryArr-            ( Opaleye.distinctOn (key unpackspec) fst-            . Opaleye.runSimpleQueryArr q-            )-        )-        (f p)+distinct (Tabulation f) = Tabulation $+  mapOpaleye (Opaleye.distinctOnExplicit (key unpackspec) fst) . f   -- | 'order' orders the /values/ of a 'Tabulation' within their@@ -415,11 +416,7 @@ -- The resulting 'Tabulation' is \"magic\" in that the value @0@ exists at -- every possible key that wasn't in the given 'Tabulation'. count :: EqTable k => Tabulation k a -> Tabulation k (Expr Int64)-count =-  fmap (maybeTable 0 id) .-  optional .-  aggregate .-  fmap (const countStar)+count = aggregate countStar . (true <$)   -- | 'optional' produces a \"magic\" 'Tabulation' whereby each@@ -446,11 +443,7 @@ -- 'Tabulation'. many :: (EqTable k, Table Expr a)   => Tabulation k a -> Tabulation k (ListTable Expr a)-many =-  fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .-  optional .-  aggregate .-  fmap (listAgg . toCols)+many = aggregate listAgg   -- | 'some' aggregates each entry with a particular key into a@@ -459,10 +452,7 @@ -- 'order' can be used to give this 'NonEmptyTable' a defined order. some :: (EqTable k, Table Expr a)   => Tabulation k a -> Tabulation k (NonEmptyTable Expr a)-some =-  fmap (\(NonEmptyTable a) -> NonEmptyTable a) .-  aggregate .-  fmap (nonEmptyAgg . toCols)+some = aggregate1 nonEmptyAgg   -- | 'exists' produces a \"magic\" 'Tabulation' which contains the@@ -516,8 +506,8 @@   -> Tabulation k a -> Tabulation k b -> Tabulation k c alignWith f (Tabulation as) (Tabulation bs) = Tabulation $ \p -> do   tkab <- liftF2 (alignBy condition) as bs p+  k <- traverse (rebind "key") $ recover $ bimap fst fst tkab   let-    k = recover $ bimap fst fst tkab     tab = bimap snd snd tkab   pure (k, f tab)   where@@ -537,7 +527,7 @@ -- -- Note that you can achieve the same effect with 'optional' and the -- 'Applicative' instance for 'Tabulation', i.e., this is just--- @\left right -> liftA2 (,) left (optional right). You can also+-- @\\left right -> liftA2 (,) left (optional right)@. You can also -- use @do@-notation. leftAlign :: EqTable k   => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable Expr b)@@ -550,7 +540,7 @@ -- -- Note that you can achieve the same effect with 'optional' and the -- 'Applicative' instance for 'Tabulation', i.e., this is just--- @\f left right -> liftA2 f left (optional right). You can also+-- @\\f left right -> liftA2 f left (optional right)@. You can also -- use @do@-notation. leftAlignWith :: EqTable k   => (a -> MaybeTable Expr b -> c)@@ -564,7 +554,7 @@ -- -- Note that you can achieve the same effect with 'optional' and the -- 'Applicative' instance for 'Tabulation', i.e., this is just--- @\left right -> liftA2 (flip (,)) right (optional left). You can+-- @\\left right -> liftA2 (flip (,)) right (optional left)@. You can -- also use @do@-notation. rightAlign :: EqTable k   => Tabulation k a -> Tabulation k b -> Tabulation k (MaybeTable Expr a, b)@@ -577,7 +567,7 @@ -- -- Note that you can achieve the same effect with 'optional' and the -- 'Applicative' instance for 'Tabulation', i.e., this is just--- @\f left right -> liftA2 (flip f) right (optional left). You can+-- @\\f left right -> liftA2 (flip f) right (optional left)@. You can -- also use @do@-notation. rightAlignWith :: EqTable k   => (MaybeTable Expr a -> b -> c)@@ -617,7 +607,7 @@ -- -- Note that you can achieve a similar effect with 'present' and the -- 'Applicative' instance of 'Tabulation', i.e., this is just--- @\left right -> left <* present right@. You can also use+-- @\\left right -> left <* present right@. You can also use -- @do@-notation. similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a similarity a b = a <* present b@@ -631,7 +621,28 @@ -- -- Note that you can achieve a similar effect with 'absent' and the -- 'Applicative' instance of 'Tabulation', i.e., this is just--- @\left right -> left <* absent right@. You can also use+-- @\\left right -> left <* absent right@. You can also use -- @do@-notation. difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a difference a b = a <* absent b+++-- | 'Q.materialize' for 'Tabulation's.+materialize :: (Table Expr k, Table Expr a)+  => Tabulation k a -> (Tabulation k a -> Query b) -> Query b+materialize tabulation f = case peek tabulation of+  Tabulation query -> do+    (_, equery) <- query mempty+    case equery of+      Left as -> Q.materialize as (f . liftQuery)+      Right kas -> Q.materialize kas (f . fromQuery)+++-- | 'Tabulation's can be produced with either 'fromQuery' or 'liftQuery', and+-- in some cases we might want to treat these differently. 'peek' uses+-- 'unsafePeekQuery' to determine which type of 'Tabulation' we have.+peek :: Tabulation k a -> Tabulation k (Either (Query a) (Query (k, a)))+peek (Tabulation f) = Tabulation $ \p ->+  pure $ (empty,) $ case unsafePeekQuery (f p) of+    (Nothing, _) -> Left $ fmap snd (f p)+    (Just _, _) -> Right $ fmap (first fromJust) (f p)
− src/Rel8/Type.hs 
@@ -1,288 +0,0 @@-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language MonoLocalBinds #-}-{-# language MultiWayIf #-}-{-# language StandaloneKindSignatures #-}-{-# language UndecidableInstances #-}--module Rel8.Type-  ( DBType (typeInformation)-  )-where---- aeson-import Data.Aeson ( Value )-import qualified Data.Aeson as Aeson---- base-import Data.Int ( Int16, Int32, Int64 )-import Data.List.NonEmpty ( NonEmpty )-import Data.Kind ( Constraint, Type )-import Prelude---- bytestring-import Data.ByteString ( ByteString )-import qualified Data.ByteString.Lazy as Lazy ( ByteString )-import qualified Data.ByteString.Lazy as ByteString ( fromStrict, toStrict )---- case-insensitive-import Data.CaseInsensitive ( CI )-import qualified Data.CaseInsensitive as CI---- hasql-import qualified Hasql.Decoders as Hasql---- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye-import qualified Opaleye.Internal.HaskellDB.Sql.Default as Opaleye ( quote )---- rel8-import Rel8.Schema.Null ( NotNull, Sql, nullable )-import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )-import Rel8.Type.Information ( TypeInformation(..), mapTypeInformation )---- scientific-import Data.Scientific ( Scientific )---- text-import Data.Text ( Text )-import qualified Data.Text as Text-import qualified Data.Text.Lazy as Lazy ( Text, unpack )-import qualified Data.Text.Lazy as Text ( fromStrict, toStrict )-import qualified Data.Text.Lazy.Encoding as Lazy ( decodeUtf8 )---- time-import Data.Time.Calendar ( Day )-import Data.Time.Clock ( UTCTime )-import Data.Time.LocalTime-  ( CalendarDiffTime( CalendarDiffTime )-  , LocalTime-  , TimeOfDay-  )-import Data.Time.Format ( formatTime, defaultTimeLocale )---- uuid-import Data.UUID ( UUID )-import qualified Data.UUID as UUID----- | Haskell types that can be represented as expressions in a database. There--- should be an instance of @DBType@ for all column types in your database--- schema (e.g., @int@, @timestamptz@, etc).--- --- Rel8 comes with stock instances for most default types in PostgreSQL, so you--- should only need to derive instances of this class for custom database--- types, such as types defined in PostgreSQL extensions, or custom domain--- types.-type DBType :: Type -> Constraint-class NotNull a => DBType a where-  typeInformation :: TypeInformation a----- | Corresponds to @bool@-instance DBType Bool where-  typeInformation = TypeInformation-    { encode = Opaleye.ConstExpr . Opaleye.BoolLit-    , decode = Hasql.bool-    , typeName = "bool"-    }----- | Corresponds to @char@-instance DBType Char where-  typeInformation = TypeInformation-    { encode = Opaleye.ConstExpr . Opaleye.StringLit . pure-    , decode = Hasql.char-    , typeName = "char"-    }----- | Corresponds to @int2@-instance DBType Int16 where-  typeInformation = TypeInformation-    { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger-    , decode = Hasql.int2-    , typeName = "int2"-    }----- | Corresponds to @int4@-instance DBType Int32 where-  typeInformation = TypeInformation-    { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger-    , decode = Hasql.int4-    , typeName = "int4"-    }----- | Corresponds to @int8@-instance DBType Int64 where-  typeInformation = TypeInformation-    { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger-    , decode = Hasql.int8-    , typeName = "int8"-    }----- | Corresponds to @float4@-instance DBType Float where-  typeInformation = TypeInformation-    { encode = \x -> Opaleye.ConstExpr-        if | x == (1 /0) -> Opaleye.OtherLit "'Infinity'"-           | isNaN x     -> Opaleye.OtherLit "'NaN'"-           | x == (-1/0) -> Opaleye.OtherLit "'-Infinity'"-           | otherwise   -> Opaleye.NumericLit $ realToFrac x-    , decode = Hasql.float4-    , typeName = "float4"-    }----- | Corresponds to @float8@-instance DBType Double where-  typeInformation = TypeInformation-    { encode = \x -> Opaleye.ConstExpr-        if | x == (1 /0) -> Opaleye.OtherLit "'Infinity'"-           | isNaN x     -> Opaleye.OtherLit "'NaN'"-           | x == (-1/0) -> Opaleye.OtherLit "'-Infinity'"-           | otherwise   -> Opaleye.NumericLit $ realToFrac x-    , decode = Hasql.float8-    , typeName = "float8"-    }----- | Corresponds to @numeric@-instance DBType Scientific where-  typeInformation = TypeInformation-    { encode = Opaleye.ConstExpr . Opaleye.NumericLit-    , decode = Hasql.numeric-    , typeName = "numeric"-    }----- | Corresponds to @timestamptz@-instance DBType UTCTime where-  typeInformation = TypeInformation-    { encode =-        Opaleye.ConstExpr . Opaleye.OtherLit .-        formatTime defaultTimeLocale "'%FT%T%QZ'"-    , decode = Hasql.timestamptz-    , typeName = "timestamptz"-    }----- | Corresponds to @date@-instance DBType Day where-  typeInformation = TypeInformation-    { encode =-        Opaleye.ConstExpr . Opaleye.OtherLit .-        formatTime defaultTimeLocale "'%F'"-    , decode = Hasql.date-    , typeName = "date"-    }----- | Corresponds to @timestamp@-instance DBType LocalTime where-  typeInformation = TypeInformation-    { encode =-        Opaleye.ConstExpr . Opaleye.OtherLit .-        formatTime defaultTimeLocale "'%FT%T%Q'"-    , decode = Hasql.timestamp-    , typeName = "timestamp"-    }----- | Corresponds to @time@-instance DBType TimeOfDay where-  typeInformation = TypeInformation-    { encode =-        Opaleye.ConstExpr . Opaleye.OtherLit .-        formatTime defaultTimeLocale "'%T%Q'"-    , decode = Hasql.time-    , typeName = "time"-    }----- | Corresponds to @interval@-instance DBType CalendarDiffTime where-  typeInformation = TypeInformation-    { encode =-        Opaleye.ConstExpr . Opaleye.OtherLit .-        formatTime defaultTimeLocale "'%bmon %0Es'"-    , decode = CalendarDiffTime 0 . realToFrac <$> Hasql.interval-    , typeName = "interval"-    }----- | Corresponds to @text@-instance DBType Text where-  typeInformation = TypeInformation-    { encode = Opaleye.ConstExpr . Opaleye.StringLit . Text.unpack-    , decode = Hasql.text-    , typeName = "text"-    }----- | Corresponds to @text@-instance DBType Lazy.Text where-  typeInformation =-    mapTypeInformation Text.fromStrict Text.toStrict typeInformation----- | Corresponds to @citext@-instance DBType (CI Text) where-  typeInformation = mapTypeInformation CI.mk CI.original typeInformation-    { typeName = "citext"-    }----- | Corresponds to @citext@-instance DBType (CI Lazy.Text) where-  typeInformation = mapTypeInformation CI.mk CI.original typeInformation-    { typeName = "citext"-    }----- | Corresponds to @bytea@-instance DBType ByteString where-  typeInformation = TypeInformation-    { encode = Opaleye.ConstExpr . Opaleye.ByteStringLit-    , decode = Hasql.bytea-    , typeName = "bytea"-    }----- | Corresponds to @bytea@-instance DBType Lazy.ByteString where-  typeInformation =-    mapTypeInformation ByteString.fromStrict ByteString.toStrict-      typeInformation----- | Corresponds to @uuid@-instance DBType UUID where-  typeInformation = TypeInformation-    { encode = Opaleye.ConstExpr . Opaleye.StringLit . UUID.toString-    , decode = Hasql.uuid-    , typeName = "uuid"-    }----- | Corresponds to @jsonb@-instance DBType Value where-  typeInformation = TypeInformation-    { encode =-        Opaleye.ConstExpr . Opaleye.OtherLit .-        Opaleye.quote .-        Lazy.unpack . Lazy.decodeUtf8 . Aeson.encode-    , decode = Hasql.jsonb-    , typeName = "jsonb"-    }---instance Sql DBType a => DBType [a] where-  typeInformation = listTypeInformation nullable typeInformation---instance Sql DBType a => DBType (NonEmpty a) where-  typeInformation = nonEmptyTypeInformation nullable typeInformation
− src/Rel8/Type/Array.hs 
@@ -1,100 +0,0 @@-{-# language GADTs #-}-{-# language LambdaCase #-}-{-# language NamedFieldPuns #-}-{-# language OverloadedStrings #-}-{-# language ViewPatterns #-}--module Rel8.Type.Array-  ( array, encodeArrayElement, extractArrayElement-  , listTypeInformation-  , nonEmptyTypeInformation-  )-where---- base-import Data.Foldable ( toList )-import Data.List.NonEmpty ( NonEmpty, nonEmpty )-import Prelude hiding ( null, repeat, zipWith )---- hasql-import qualified Hasql.Decoders as Hasql---- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye---- rel8-import Rel8.Schema.Null ( Unnullify, Nullity( Null, NotNull ) )-import Rel8.Type.Information ( TypeInformation(..), parseTypeInformation )---array :: Foldable f-  => TypeInformation a -> f Opaleye.PrimExpr -> Opaleye.PrimExpr-array info =-  Opaleye.CastExpr (arrayType info <> "[]") .-  Opaleye.ArrayExpr . map (encodeArrayElement info) . toList-{-# INLINABLE array #-}---listTypeInformation :: ()-  => Nullity a-  -> TypeInformation (Unnullify a)-  -> TypeInformation [a]-listTypeInformation nullity info@TypeInformation {encode, decode} =-  TypeInformation-    { decode = case nullity of-        Null ->-          Hasql.listArray (decodeArrayElement info (Hasql.nullable decode))-        NotNull ->-          Hasql.listArray (decodeArrayElement info (Hasql.nonNullable decode))-    , encode = case nullity of-        Null ->-          Opaleye.ArrayExpr .-          fmap (encodeArrayElement info . maybe null encode)-        NotNull ->-          Opaleye.ArrayExpr .-          fmap (encodeArrayElement info . encode)-    , typeName = arrayType info <> "[]"-    }-  where-    null = Opaleye.ConstExpr Opaleye.NullLit---nonEmptyTypeInformation :: ()-  => Nullity a-  -> TypeInformation (Unnullify a)-  -> TypeInformation (NonEmpty a)-nonEmptyTypeInformation nullity =-  parseTypeInformation parse toList . listTypeInformation nullity-  where-    parse = maybe (Left message) Right . nonEmpty-    message = "failed to decode NonEmptyList: got empty list"---isArray :: TypeInformation a -> Bool-isArray = \case-  (reverse . typeName -> ']' : '[' : _) -> True-  _ -> False---arrayType :: TypeInformation a -> String-arrayType info-  | isArray info = "record"-  | otherwise = typeName info---decodeArrayElement :: TypeInformation a -> Hasql.NullableOrNot Hasql.Value x -> Hasql.NullableOrNot Hasql.Value x-decodeArrayElement info-  | isArray info = Hasql.nonNullable . Hasql.composite . Hasql.field-  | otherwise = id---encodeArrayElement :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr-encodeArrayElement info-  | isArray info = Opaleye.UnExpr (Opaleye.UnOpOther "ROW")-  | otherwise = id---extractArrayElement :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr-extractArrayElement info-  | isArray info = flip Opaleye.CompositeExpr "f1"-  | otherwise = id
− src/Rel8/Type/Composite.hs 
@@ -1,135 +0,0 @@-{-# language AllowAmbiguousTypes #-}-{-# language BlockArguments #-}-{-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language GADTs #-}-{-# language NamedFieldPuns #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-}-{-# language UndecidableInstances #-}-{-# language UndecidableSuperClasses #-}-{-# language ViewPatterns #-}--module Rel8.Type.Composite-  ( Composite( Composite )-  , DBComposite( compositeFields, compositeTypeName )-  , compose, decompose-  )-where---- base-import Data.Functor.Const ( Const( Const ), getConst )-import Data.Functor.Identity ( Identity( Identity ) )-import Data.Kind ( Constraint, Type )-import Prelude---- hasql-import qualified Hasql.Decoders as Hasql---- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye---- rel8-import Rel8.Expr ( Expr )-import Rel8.Expr.Opaleye ( castExpr, fromPrimExpr, toPrimExpr )-import Rel8.Schema.HTable ( HTable, hfield, hspecs, htabulate, htabulateA )-import Rel8.Schema.Name ( Name( Name ) )-import Rel8.Schema.Null ( Nullity( Null, NotNull ) )-import Rel8.Schema.Result ( Result )-import Rel8.Schema.Spec ( Spec( Spec, nullity, info ) )-import Rel8.Table ( fromColumns, toColumns, fromResult, toResult )-import Rel8.Table.Eq ( EqTable )-import Rel8.Table.HKD ( HKD, HKDable )-import Rel8.Table.Ord ( OrdTable )-import Rel8.Table.Rel8able ()-import Rel8.Table.Serialize ( litHTable )-import Rel8.Type ( DBType, typeInformation )-import Rel8.Type.Eq ( DBEq )-import Rel8.Type.Information ( TypeInformation(..) )-import Rel8.Type.Ord ( DBOrd, DBMax, DBMin )---- semigroupoids-import Data.Functor.Apply ( WrappedApplicative(..) )----- | A deriving-via helper type for column types that store a Haskell product--- type in a single Postgres column using a Postgres composite type.------ Note that this must map to a specific extant type in your database's schema--- (created with @CREATE TYPE@). Use 'DBComposite' to specify the name of this--- Postgres type and the names of the individual fields (for projecting with--- 'decompose').-type Composite :: Type -> Type-newtype Composite a = Composite-  { unComposite :: a-  }---instance DBComposite a => DBType (Composite a) where-  typeInformation = TypeInformation-    { decode = Hasql.composite (Composite . fromResult @_ @(HKD a Expr) <$> decoder)-    , encode = encoder . litHTable . toResult @_ @(HKD a Expr) . unComposite-    , typeName = compositeTypeName @a-    }---instance (DBComposite a, EqTable (HKD a Expr)) => DBEq (Composite a)---instance (DBComposite a, OrdTable (HKD a Expr)) => DBOrd (Composite a)---instance (DBComposite a, OrdTable (HKD a Expr)) => DBMax (Composite a)---instance (DBComposite a, OrdTable (HKD a Expr)) => DBMin (Composite a)----- | 'DBComposite' is used to associate composite type metadata with a Haskell--- type.-type DBComposite :: Type -> Constraint-class (DBType a, HKDable a) => DBComposite a where-  -- | The names of all fields in the composite type that @a@ maps to.-  compositeFields :: HKD a Name--  -- | The name of the composite type that @a@ maps to.-  compositeTypeName :: String----- | Collapse a 'HKD' into a PostgreSQL composite type.------ 'HKD' values are represented in queries by having a column for each field in--- the corresponding Haskell type. 'compose' collapses these columns into a--- single column expression, by combining them into a PostgreSQL composite--- type.-compose :: DBComposite a => HKD a Expr -> Expr a-compose = castExpr . fromPrimExpr . encoder . toColumns----- | Expand a composite type into a 'HKD'.------ 'decompose' is the inverse of 'compose'.-decompose :: forall a. DBComposite a => Expr a -> HKD a Expr-decompose (toPrimExpr -> a) = fromColumns $ htabulate \field ->-  case hfield names field of-    Name name -> case hfield hspecs field of-      Spec {} -> fromPrimExpr $ Opaleye.CompositeExpr a name-  where-    names = toColumns (compositeFields @a)---decoder :: HTable t => Hasql.Composite (t Result)-decoder = unwrapApplicative $ htabulateA \field ->-  case hfield hspecs field of-    Spec {nullity, info} -> WrapApplicative $ Identity <$>-      case nullity of-        Null -> Hasql.field $ Hasql.nullable $ decode info-        NotNull -> Hasql.field $ Hasql.nonNullable $ decode info---encoder :: HTable t => t Expr -> Opaleye.PrimExpr-encoder a = Opaleye.FunExpr "ROW" exprs-  where-    exprs = getConst $ htabulateA \field -> case hfield a field of-      expr -> Const [toPrimExpr expr]
− src/Rel8/Type/Enum.hs 
@@ -1,138 +0,0 @@-{-# language AllowAmbiguousTypes #-}-{-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language LambdaCase #-}-{-# language RankNTypes #-}-{-# language ScopedTypeVariables #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeApplications #-}-{-# language TypeFamilies #-}-{-# language TypeOperators #-}-{-# language UndecidableInstances #-}--module Rel8.Type.Enum-  ( Enum( Enum )-  , DBEnum( enumValue, enumTypeName )-  , Enumable-  )-where---- base-import Control.Applicative ( (<|>) )-import Control.Arrow ( (&&&) )-import Data.Kind ( Constraint, Type )-import Data.Proxy ( Proxy( Proxy ) )-import GHC.Generics-  ( Generic, Rep, from, to-  , (:+:)( L1, R1 ), M1( M1 ), U1( U1 )-  , D, C, Meta( MetaCons )-  )-import GHC.TypeLits ( KnownSymbol, symbolVal )-import Prelude hiding ( Enum )---- hasql-import qualified Hasql.Decoders as Hasql---- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye---- rel8-import Rel8.Type ( DBType, typeInformation )-import Rel8.Type.Eq ( DBEq )-import Rel8.Type.Information ( TypeInformation(..) )-import Rel8.Type.Ord ( DBOrd, DBMax, DBMin )---- text-import Data.Text ( pack )----- | A deriving-via helper type for column types that store an \"enum\" type--- (in Haskell terms, a sum type where all constructors are nullary) using a--- Postgres @enum@ type.------ Note that this should map to a specific type in your database's schema--- (explicitly created with @CREATE TYPE ... AS ENUM@). Use 'DBEnum' to--- specify the name of this Postgres type and the names of the individual--- values. If left unspecified, the names of the values of the Postgres--- @enum@ are assumed to match exactly exactly the names of the constructors--- of the Haskell type (up to and including case sensitivity).-type Enum :: Type -> Type-newtype Enum a = Enum-  { unEnum :: a-  }---instance DBEnum a => DBType (Enum a) where-  typeInformation = TypeInformation-    { decode =-        Hasql.enum $-        flip lookup $-        map ((pack . enumValue &&& Enum) . to) $-        genumerate @(Rep a)-    , encode =-        Opaleye.ConstExpr .-        Opaleye.StringLit .-        enumValue @a .-        unEnum-    , typeName = enumTypeName @a-    }---instance DBEnum a => DBEq (Enum a)---instance DBEnum a => DBOrd (Enum a)---instance DBEnum a => DBMax (Enum a)---instance DBEnum a => DBMin (Enum a)----- | @DBEnum@ contains the necessary metadata to describe a PostgreSQL @enum@ type.-type DBEnum :: Type -> Constraint-class (DBType a, Enumable a) => DBEnum a where-  -- | Map Haskell values to the corresponding element of the @enum@ type. The-  -- default implementation of this method will use the exact name of the-  -- Haskell constructors.-  enumValue :: a -> String-  enumValue = gshow @(Rep a) . from--  -- | The name of the PostgreSQL @enum@ type that @a@ maps to.-  enumTypeName :: String----- | Types that are sum types, where each constructor is unary (that is, has no--- fields).-class (Generic a, GEnumable (Rep a)) => Enumable a-instance (Generic a, GEnumable (Rep a)) => Enumable a---type GEnumable :: (Type -> Type) -> Constraint-class GEnumable rep where-  genumerate :: [rep x]-  gshow :: rep x -> String---instance GEnumable rep => GEnumable (M1 D meta rep) where-  genumerate = M1 <$> genumerate-  gshow (M1 rep) = gshow rep---instance (GEnumable a, GEnumable b) => GEnumable (a :+: b) where-  genumerate = L1 <$> genumerate <|> R1 <$> genumerate-  gshow = \case-    L1 a -> gshow a-    R1 a -> gshow a---instance-  ( meta ~ 'MetaCons name _fixity _isRecord-  , KnownSymbol name-  )-  => GEnumable (M1 C meta U1)- where-  genumerate = [M1 U1]-  gshow (M1 U1) = symbolVal (Proxy @name)
− src/Rel8/Type/Eq.hs 
@@ -1,78 +0,0 @@-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language MonoLocalBinds #-}-{-# language MultiParamTypeClasses #-}-{-# language StandaloneKindSignatures #-}-{-# language UndecidableInstances #-}--module Rel8.Type.Eq-  ( DBEq-  )-where---- aeson-import Data.Aeson ( Value )---- base-import Data.List.NonEmpty ( NonEmpty )-import Data.Int ( Int16, Int32, Int64 )-import Data.Kind ( Constraint, Type )-import Prelude---- bytestring-import Data.ByteString ( ByteString )-import qualified Data.ByteString.Lazy as Lazy ( ByteString )---- case-insensitive-import Data.CaseInsensitive ( CI )---- rel8-import Rel8.Schema.Null ( Sql )-import Rel8.Type ( DBType )---- scientific-import Data.Scientific ( Scientific )---- text-import Data.Text ( Text )-import qualified Data.Text.Lazy as Lazy ( Text )---- time-import Data.Time.Calendar ( Day )-import Data.Time.Clock ( UTCTime )-import Data.Time.LocalTime ( CalendarDiffTime, LocalTime, TimeOfDay )---- uuid-import Data.UUID ( UUID )----- | Database types that can be compared for equality in queries. If a type is--- an instance of 'DBEq', it means we can compare expressions for equality--- using the SQL @=@ operator.-type DBEq :: Type -> Constraint-class DBType a => DBEq a---instance DBEq Bool-instance DBEq Char-instance DBEq Int16-instance DBEq Int32-instance DBEq Int64-instance DBEq Float-instance DBEq Double-instance DBEq Scientific-instance DBEq UTCTime-instance DBEq Day-instance DBEq LocalTime-instance DBEq TimeOfDay-instance DBEq CalendarDiffTime-instance DBEq Text-instance DBEq Lazy.Text-instance DBEq (CI Text)-instance DBEq (CI Lazy.Text)-instance DBEq ByteString-instance DBEq Lazy.ByteString-instance DBEq UUID-instance DBEq Value-instance Sql DBEq a => DBEq [a]-instance Sql DBEq a => DBEq (NonEmpty a)
− src/Rel8/Type/Information.hs 
@@ -1,67 +0,0 @@-{-# language GADTs #-}-{-# language NamedFieldPuns #-}-{-# language StandaloneKindSignatures #-}--module Rel8.Type.Information-  ( TypeInformation(..)-  , mapTypeInformation-  , parseTypeInformation-  )-where---- base-import Data.Bifunctor ( first )-import Data.Kind ( Type )-import Prelude---- hasql-import qualified Hasql.Decoders as Hasql---- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye---- text-import qualified Data.Text as Text----- | @TypeInformation@ describes how to encode and decode a Haskell type to and--- from database queries. The @typeName@ is the name of the type in the--- database, which is used to accurately type literals. -type TypeInformation :: Type -> Type-data TypeInformation a = TypeInformation-  { encode :: a -> Opaleye.PrimExpr-    -- ^ How to encode a single Haskell value as a SQL expression.-  , decode :: Hasql.Value a-    -- ^ How to deserialize a single result back to Haskell.-  , typeName :: String-    -- ^ The name of the SQL type.-  }----- | Simultaneously map over how a type is both encoded and decoded, while--- retaining the name of the type. This operation is useful if you want to--- essentially @newtype@ another 'Rel8.DBType'.--- --- The mapping is required to be total. If you have a partial mapping, see--- 'parseTypeInformation'.-mapTypeInformation :: ()-  => (a -> b) -> (b -> a)-  -> TypeInformation a -> TypeInformation b-mapTypeInformation = parseTypeInformation . fmap pure----- | Apply a parser to 'TypeInformation'.--- --- This can be used if the data stored in the database should only be subset of--- a given 'TypeInformation'. The parser is applied when deserializing rows--- returned - the encoder assumes that the input data is already in the--- appropriate form.-parseTypeInformation :: ()-  => (a -> Either String b) -> (b -> a)-  -> TypeInformation a -> TypeInformation b-parseTypeInformation to from TypeInformation {encode, decode, typeName} =-  TypeInformation-    { encode = encode . from-    , decode = Hasql.refine (first Text.pack . to) decode-    , typeName-    }
− src/Rel8/Type/JSONBEncoded.hs 
@@ -1,31 +0,0 @@-module Rel8.Type.JSONBEncoded ( JSONBEncoded(..) ) where---- aeson-import Data.Aeson ( FromJSON, ToJSON, parseJSON, toJSON )-import Data.Aeson.Types ( parseEither )---- base-import Data.Bifunctor ( first )-import Prelude---- hasql-import qualified Hasql.Decoders as Hasql---- rel8-import Rel8.Type ( DBType(..) )-import Rel8.Type.Information ( TypeInformation(..) )---- text-import Data.Text ( pack )----- | Like 'Rel8.JSONEncoded', but works for @jsonb@ columns.-newtype JSONBEncoded a = JSONBEncoded { fromJSONBEncoded :: a }---instance (FromJSON a, ToJSON a) => DBType (JSONBEncoded a) where-  typeInformation = TypeInformation-    { encode = encode typeInformation . toJSON . fromJSONBEncoded-    , decode = Hasql.refine (first pack . fmap JSONBEncoded . parseEither parseJSON) Hasql.jsonb-    , typeName = "jsonb"-    }
− src/Rel8/Type/JSONEncoded.hs 
@@ -1,25 +0,0 @@-module Rel8.Type.JSONEncoded ( JSONEncoded(..) ) where---- aeson-import Data.Aeson ( FromJSON, ToJSON, parseJSON, toJSON )-import Data.Aeson.Types ( parseEither )---- base-import Prelude---- rel8-import Rel8.Type ( DBType(..) )-import Rel8.Type.Information ( parseTypeInformation )----- | A deriving-via helper type for column types that store a Haskell value--- using a JSON encoding described by @aeson@'s 'ToJSON' and 'FromJSON' type--- classes.-newtype JSONEncoded a = JSONEncoded { fromJSONEncoded :: a }---instance (FromJSON a, ToJSON a) => DBType (JSONEncoded a) where-  typeInformation = parseTypeInformation f g typeInformation-    where-      f = fmap JSONEncoded . parseEither parseJSON-      g = toJSON . fromJSONEncoded
− src/Rel8/Type/Monoid.hs 
@@ -1,79 +0,0 @@-{-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language MultiParamTypeClasses #-}-{-# language OverloadedStrings #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}--module Rel8.Type.Monoid-  ( DBMonoid( memptyExpr )-  )-where---- base-import Data.Kind ( Constraint, Type )-import Prelude hiding ( null )---- bytestring-import Data.ByteString ( ByteString )-import qualified Data.ByteString.Lazy as Lazy ( ByteString )---- case-insensitive-import Data.CaseInsensitive ( CI )---- rel8-import {-# SOURCE #-} Rel8.Expr ( Expr )-import Rel8.Expr.Array ( sempty )-import Rel8.Expr.Serialize ( litExpr )-import Rel8.Schema.Null ( Sql )-import Rel8.Type ( DBType, typeInformation )-import Rel8.Type.Semigroup ( DBSemigroup )---- text-import Data.Text ( Text )-import qualified Data.Text.Lazy as Lazy ( Text )---- time-import Data.Time.LocalTime ( CalendarDiffTime( CalendarDiffTime ) )----- | The class of 'Rel8.DBType's that form a semigroup. This class is purely a--- Rel8 concept, and exists to mirror the 'Monoid' class.-type DBMonoid :: Type -> Constraint-class DBSemigroup a => DBMonoid a where-  -- The identity for '<>.'-  memptyExpr :: Expr a---instance Sql DBType a => DBMonoid [a] where-  memptyExpr = sempty typeInformation---instance DBMonoid CalendarDiffTime where-  memptyExpr = litExpr (CalendarDiffTime 0 0)---instance DBMonoid Text where-  memptyExpr = litExpr ""---instance DBMonoid Lazy.Text where-  memptyExpr = litExpr ""---instance DBMonoid (CI Text) where-  memptyExpr = litExpr ""---instance DBMonoid (CI Lazy.Text) where-  memptyExpr = litExpr ""---instance DBMonoid ByteString where-  memptyExpr = litExpr ""---instance DBMonoid Lazy.ByteString where-  memptyExpr = litExpr ""
− src/Rel8/Type/Num.hs 
@@ -1,58 +0,0 @@-{-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language MultiParamTypeClasses #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}--module Rel8.Type.Num-  ( DBNum, DBIntegral, DBFractional, DBFloating-  )-where---- base-import Data.Int ( Int16, Int32, Int64 )-import Data.Kind ( Constraint, Type )-import Prelude---- rel8-import Rel8.Type ( DBType )---- scientific-import Data.Scientific ( Scientific )----- | The class of database types that support the @+@, @*@, @-@ operators, and--- the @abs@, @negate@, @sign@ functions.-type DBNum :: Type -> Constraint-class DBType a => DBNum a-instance DBNum Int16-instance DBNum Int32-instance DBNum Int64-instance DBNum Float-instance DBNum Double-instance DBNum Scientific----- | The class of database types that can be coerced to from integral--- expressions. This is a Rel8 concept, and allows us to provide--- 'fromIntegral'.-type DBIntegral :: Type -> Constraint-class DBNum a => DBIntegral a-instance DBIntegral Int16-instance DBIntegral Int32-instance DBIntegral Int64----- | The class of database types that support the @/@ operator.-class DBNum a => DBFractional a-instance DBFractional Float-instance DBFractional Double-instance DBFractional Scientific----- | The class of database types that support the @/@ operator.-class DBFractional a => DBFloating a-instance DBFloating Float-instance DBFloating Double
− src/Rel8/Type/Ord.hs 
@@ -1,122 +0,0 @@-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language MonoLocalBinds #-}-{-# language MultiParamTypeClasses #-}-{-# language StandaloneKindSignatures #-}-{-# language UndecidableInstances #-}--module Rel8.Type.Ord-  ( DBOrd-  , DBMax, DBMin-  )-where---- base-import Data.Int ( Int16, Int32, Int64 )-import Data.Kind ( Constraint, Type )-import Data.List.NonEmpty ( NonEmpty )-import Prelude---- bytestring-import Data.ByteString ( ByteString )-import qualified Data.ByteString.Lazy as Lazy ( ByteString )---- case-insensitive-import Data.CaseInsensitive ( CI )---- rel8-import Rel8.Schema.Null ( Sql )-import Rel8.Type.Eq ( DBEq )---- scientific-import Data.Scientific ( Scientific )---- text-import Data.Text ( Text )-import qualified Data.Text.Lazy as Lazy ( Text )---- time-import Data.Time.Calendar ( Day )-import Data.Time.Clock ( UTCTime )-import Data.Time.LocalTime ( CalendarDiffTime, LocalTime, TimeOfDay )---- uuid-import Data.UUID ( UUID )----- | The class of database types that support the @<@, @<=@, @>@ and @>=@--- operators.-type DBOrd :: Type -> Constraint-class DBEq a => DBOrd a-instance DBOrd Bool-instance DBOrd Char-instance DBOrd Int16-instance DBOrd Int32-instance DBOrd Int64-instance DBOrd Float-instance DBOrd Double-instance DBOrd Scientific-instance DBOrd UTCTime-instance DBOrd Day-instance DBOrd LocalTime-instance DBOrd TimeOfDay-instance DBOrd CalendarDiffTime-instance DBOrd Text-instance DBOrd Lazy.Text-instance DBOrd (CI Text)-instance DBOrd (CI Lazy.Text)-instance DBOrd ByteString-instance DBOrd Lazy.ByteString-instance DBOrd UUID-instance Sql DBOrd a => DBOrd [a]-instance Sql DBOrd a => DBOrd (NonEmpty a)----- | The class of database types that support the @max@ aggregation function.-type DBMax :: Type -> Constraint-class DBOrd a => DBMax a-instance DBMax Char-instance DBMax Int16-instance DBMax Int32-instance DBMax Int64-instance DBMax Float-instance DBMax Double-instance DBMax Scientific-instance DBMax UTCTime-instance DBMax Day-instance DBMax LocalTime-instance DBMax TimeOfDay-instance DBMax CalendarDiffTime-instance DBMax Text-instance DBMax Lazy.Text-instance DBMax (CI Text)-instance DBMax (CI Lazy.Text)-instance DBMax ByteString-instance DBMax Lazy.ByteString-instance Sql DBMax a => DBMax [a]-instance Sql DBMax a => DBMax (NonEmpty a)----- | The class of database types that support the @min@ aggregation function.-type DBMin :: Type -> Constraint-class DBOrd a => DBMin a-instance DBMin Char-instance DBMin Int16-instance DBMin Int32-instance DBMin Int64-instance DBMin Float-instance DBMin Double-instance DBMin Scientific-instance DBMin UTCTime-instance DBMin Day-instance DBMin LocalTime-instance DBMin TimeOfDay-instance DBMin CalendarDiffTime-instance DBMin Text-instance DBMin Lazy.Text-instance DBMin (CI Text)-instance DBMin (CI Lazy.Text)-instance DBMin ByteString-instance DBMin Lazy.ByteString-instance Sql DBMin a => DBMin [a]-instance Sql DBMin a => DBMin (NonEmpty a)
− src/Rel8/Type/ReadShow.hs 
@@ -1,32 +0,0 @@-{-# language ScopedTypeVariables #-}-{-# language TypeApplications #-}-{-# language ViewPatterns #-}--module Rel8.Type.ReadShow ( ReadShow(..) ) where---- base-import Data.Proxy ( Proxy( Proxy ) )-import Data.Typeable ( Typeable, typeRep )-import Prelude -import Text.Read ( readMaybe )---- rel8-import Rel8.Type ( DBType( typeInformation ) )-import Rel8.Type.Information ( parseTypeInformation )---- text-import qualified Data.Text as Text----- | A deriving-via helper type for column types that store a Haskell value--- using a Haskell's 'Read' and 'Show' type classes.-newtype ReadShow a = ReadShow { fromReadShow :: a }---instance (Read a, Show a, Typeable a) => DBType (ReadShow a) where-  typeInformation = parseTypeInformation parser printer typeInformation-    where-      parser (Text.unpack -> t) = case readMaybe t of-        Just ok -> Right $ ReadShow ok-        Nothing -> Left $ "Could not read " <> t <> " as a " <> show (typeRep (Proxy @a))-      printer = Text.pack . show . fromReadShow
− src/Rel8/Type/Semigroup.hs 
@@ -1,87 +0,0 @@-{-# language BlockArguments #-}-{-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language MultiParamTypeClasses #-}-{-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}--module Rel8.Type.Semigroup-  ( DBSemigroup( (<>.))-  )-where---- base-import Data.Kind ( Constraint, Type )-import Data.List.NonEmpty ( NonEmpty )-import Prelude ()---- bytestring-import Data.ByteString ( ByteString )-import qualified Data.ByteString.Lazy as Lazy ( ByteString )---- case-insensitive-import Data.CaseInsensitive ( CI )---- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye---- rel8-import {-# SOURCE #-} Rel8.Expr ( Expr )-import Rel8.Expr.Array ( sappend, sappend1 )-import Rel8.Expr.Opaleye ( zipPrimExprsWith )-import Rel8.Schema.Null ( Sql )-import Rel8.Type ( DBType )---- text-import Data.Text ( Text )-import qualified Data.Text.Lazy as Lazy ( Text )---- time-import Data.Time.LocalTime ( CalendarDiffTime )----- | The class of 'Rel8.DBType's that form a semigroup. This class is purely a--- Rel8 concept, and exists to mirror the 'Semigroup' class.-type DBSemigroup :: Type -> Constraint-class DBType a => DBSemigroup a where-  -- | An associative operation.-  (<>.) :: Expr a -> Expr a -> Expr a-  infixr 6 <>.---instance Sql DBType a => DBSemigroup [a] where-  (<>.) = sappend---instance Sql DBType a => DBSemigroup (NonEmpty a) where-  (<>.) = sappend1---instance DBSemigroup CalendarDiffTime where-  (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:+))---instance DBSemigroup Text where-  (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))---instance DBSemigroup Lazy.Text where-  (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))---instance DBSemigroup (CI Text) where-  (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))---instance DBSemigroup (CI Lazy.Text) where-  (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))---instance DBSemigroup ByteString where-  (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))---instance DBSemigroup Lazy.ByteString where-  (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
− src/Rel8/Type/String.hs 
@@ -1,40 +0,0 @@-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language MultiParamTypeClasses #-}-{-# language StandaloneKindSignatures #-}-{-# language UndecidableInstances #-}--module Rel8.Type.String-  ( DBString-  )-where---- base-import Data.Kind ( Constraint, Type )-import Prelude ()---- bytestring-import Data.ByteString ( ByteString )-import qualified Data.ByteString.Lazy as Lazy ( ByteString )---- case-insensitive-import Data.CaseInsensitive ( CI )---- rel8-import Rel8.Type ( DBType )---- text-import Data.Text ( Text )-import qualified Data.Text.Lazy as Lazy ( Text )----- | The class of data types that support the @string_agg()@ aggregation--- function.-type DBString :: Type -> Constraint-class DBType a => DBString a-instance DBString Text-instance DBString Lazy.Text-instance DBString (CI Text)-instance DBString (CI Lazy.Text)-instance DBString ByteString-instance DBString Lazy.ByteString
− src/Rel8/Type/Sum.hs 
@@ -1,38 +0,0 @@-{-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language MultiParamTypeClasses #-}-{-# language TypeFamilies #-}-{-# language StandaloneKindSignatures #-}-{-# language UndecidableInstances #-}--module Rel8.Type.Sum-  ( DBSum-  )-where---- base-import Data.Int ( Int16, Int32, Int64 )-import Data.Kind ( Constraint, Type )-import Prelude---- rel8-import Rel8.Type ( DBType )---- scientific-import Data.Scientific ( Scientific )---- time-import Data.Time.LocalTime ( CalendarDiffTime )----- | The class of database types that support the @sum()@ aggregation function.-type DBSum :: Type -> Constraint-class DBType a => DBSum a-instance DBSum Int16-instance DBSum Int32-instance DBSum Int64-instance DBSum Float-instance DBSum Double-instance DBSum Scientific-instance DBSum CalendarDiffTime
− src/Rel8/Type/Tag.hs 
@@ -1,97 +0,0 @@-{-# language DataKinds #-}-{-# language DeriveAnyClass #-}-{-# language DerivingVia #-}-{-# language GeneralizedNewtypeDeriving #-}-{-# language StandaloneKindSignatures #-}--module Rel8.Type.Tag-  ( EitherTag( IsLeft, IsRight ), isLeft, isRight-  , MaybeTag( IsJust )-  , Tag( Tag )-  )-where---- base-import Data.Bool ( bool )-import Data.Kind ( Type )-import Data.Semigroup ( Min( Min ) )-import Prelude---- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye---- rel8-import Rel8.Expr ( Expr )-import Rel8.Expr.Eq ( (==.) )-import Rel8.Expr.Opaleye ( zipPrimExprsWith )-import Rel8.Expr.Serialize ( litExpr )-import Rel8.Type.Eq ( DBEq )-import Rel8.Type ( DBType, typeInformation )-import Rel8.Type.Information ( mapTypeInformation, parseTypeInformation )-import Rel8.Type.Monoid ( DBMonoid, memptyExpr )-import Rel8.Type.Ord ( DBOrd )-import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )---- text-import Data.Text ( Text )---type EitherTag :: Type-data EitherTag = IsLeft | IsRight-  deriving stock (Eq, Ord, Read, Show, Enum, Bounded)-  deriving (Semigroup, Monoid) via (Min EitherTag)-  deriving anyclass (DBEq, DBOrd)---instance DBType EitherTag where-  typeInformation = mapTypeInformation to from typeInformation-    where-      to = bool IsLeft IsRight-      from IsLeft = False-      from IsRight = True---instance DBSemigroup EitherTag where-  (<>.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpAnd)---instance DBMonoid EitherTag where-  memptyExpr = litExpr mempty---isLeft :: Expr EitherTag -> Expr Bool-isLeft = (litExpr IsLeft ==.)---isRight :: Expr EitherTag -> Expr Bool-isRight = (litExpr IsRight ==.)---type MaybeTag :: Type-data MaybeTag = IsJust-  deriving stock (Eq, Ord, Read, Show, Enum, Bounded)-  deriving (Semigroup, Monoid) via (Min MaybeTag)-  deriving anyclass (DBEq, DBOrd)---instance DBType MaybeTag where-  typeInformation = parseTypeInformation to from typeInformation-    where-      to False = Left "MaybeTag can't be false"-      to True = Right IsJust-      from _ = True---instance DBSemigroup MaybeTag where-  (<>.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpAnd)---instance DBMonoid MaybeTag where-  memptyExpr = litExpr mempty---newtype Tag = Tag Text-  deriving newtype-    ( Eq, Ord, Read, Show-    , DBType, DBEq, DBOrd-    )
tests/Main.hs view
@@ -1,10 +1,12 @@ {-# language BangPatterns #-} {-# language BlockArguments #-}+{-# language CPP #-} {-# language DeriveAnyClass #-} {-# language DeriveGeneric #-}-{-# language DerivingStrategies #-}+{-# language DerivingVia #-} {-# language FlexibleContexts #-} {-# language FlexibleInstances #-}+{-# language LambdaCase #-} {-# language MonoLocalBinds #-} {-# language NamedFieldPuns #-} {-# language OverloadedStrings #-}@@ -18,21 +20,32 @@   ) where +-- aeson+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Key as Aeson.Key+import qualified Data.Aeson.KeyMap as Aeson.KeyMap+ -- base import Control.Applicative ( empty, liftA2, liftA3 ) import Control.Exception ( bracket, throwIO )-import Control.Monad ( (>=>), void )+import Control.Monad ((>=>)) import Data.Bifunctor ( bimap )+import Data.Fixed (Fixed (MkFixed)) import Data.Foldable ( for_ )+import Data.Fixed (Centi)+import Data.Functor (void) import Data.Int ( Int32, Int64 )-import Data.List ( nub, sort )+import Data.List ( isInfixOf, nub, sort ) import Data.Maybe ( catMaybes )-import Data.String ( fromString )+import Data.Ratio ((%)) import Data.Word (Word32) import GHC.Generics ( Generic )+import Prelude hiding (truncate)  -- bytestring+import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy+import Data.ByteString ( ByteString )  -- case-insensitive import Data.CaseInsensitive ( mk )@@ -42,24 +55,39 @@ import qualified Data.Map.Strict as Map  -- hasql-import Hasql.Connection ( Connection, acquire, release )+import Hasql.Connection ( Connection, ConnectionError, acquire, release )+#if MIN_VERSION_hasql(1,9,0)+import qualified Hasql.Connection.Setting+import qualified Hasql.Connection.Setting.Connection+#endif import Hasql.Session ( sql, run )  -- hasql-transaction import Hasql.Transaction ( Transaction, condemn, statement )+import qualified Hasql.Transaction as Hasql import qualified Hasql.Transaction.Sessions as Hasql  -- hedgehog-import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )+import Hedgehog ( annotate, assert, failure, property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen ) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range +-- iproute+import qualified Data.IP+ -- mmorph import Control.Monad.Morph ( hoist )  -- rel8 import Rel8 ( Result ) import qualified Rel8+import qualified Rel8.Generic.Rel8able.Test as Rel8able+import qualified Rel8.Internal.Table.Verify as Verify+import Rel8.Range (+  Bound (Incl, Excl, Inf),+  Range (Empty, Range),+  Multirange (Multirange),+ )  -- scientific import Data.Scientific ( Scientific )@@ -71,7 +99,8 @@ import Test.Tasty.Hedgehog ( testProperty )  -- text-import Data.Text ( Text, pack, unpack )+import Data.Text ( Text, unpack )+import qualified Data.Text as T import qualified Data.Text.Lazy import Data.Text.Encoding ( decodeUtf8 ) @@ -87,7 +116,10 @@ -- uuid import qualified Data.UUID +-- vector+import qualified Data.Vector as Vector + main :: IO () main = defaultMain tests @@ -97,6 +129,7 @@   withResource startTestDatabase stopTestDatabase \getTestDatabase ->   testGroup "rel8"     [ testSelectTestTable getTestDatabase+    , testWithStatement getTestDatabase     , testWhere_ getTestDatabase     , testFilter getTestDatabase     , testLimit getTestDatabase@@ -112,7 +145,7 @@     , testDBType getTestDatabase     , testDBEq getTestDatabase     , testTableEquality getTestDatabase-    , testFromString getTestDatabase+    , testFromRational getTestDatabase     , testCatMaybeTable getTestDatabase     , testCatMaybe getTestDatabase     , testMaybeTable getTestDatabase@@ -127,19 +160,20 @@     , testSelectArray getTestDatabase     , testNestedMaybeTable getTestDatabase     , testEvaluate getTestDatabase+    , testSelectTruncated getTestDatabase+    , testShowCreateTable getTestDatabase     ]-   where-     startTestDatabase = do       db <- TmpPostgres.start >>= either throwIO return -      bracket (either (error . show) return =<< acquire (TmpPostgres.toConnectionString db)) release \conn -> void do+      bracket (either (error . show) return =<< acquireFromConnectionString (TmpPostgres.toConnectionString db)) release \conn -> void do         flip run conn do           sql "CREATE EXTENSION citext"           sql "CREATE TABLE test_table ( column1 text not null, column2 bool not null )"           sql "CREATE TABLE unique_table ( \"key\" text not null unique, \"value\" text not null )"           sql "CREATE SEQUENCE test_seq"+          sql "CREATE TYPE composite AS (\"bool\" bool, \"char\" text, \"array\" int4[])"        return db @@ -147,9 +181,119 @@   connect :: TmpPostgres.DB -> IO Connection-connect = acquire . TmpPostgres.toConnectionString >=> either (maybe empty (fail . unpack . decodeUtf8)) pure+connect = acquireFromConnectionString . TmpPostgres.toConnectionString >=> either (maybe empty (fail . unpack . decodeUtf8)) pure +acquireFromConnectionString :: ByteString -> IO (Either ConnectionError Connection)+acquireFromConnectionString connectionString =+#if MIN_VERSION_hasql(1,9,0)+  acquire +    [ Hasql.Connection.Setting.connection . Hasql.Connection.Setting.Connection.string . decodeUtf8 $ connectionString+    ]+#else+  acquire connectionString+#endif +testShowCreateTable :: IO TmpPostgres.DB -> TestTree+testShowCreateTable getTestDatabase = testGroup "CREATE TABLE"+  [ testTypeChecker "tableTest" Rel8able.tableTest Rel8able.genTableTest getTestDatabase+  , testTypeChecker "tablePair" Rel8able.tablePair Rel8able.genTablePair getTestDatabase+  , testTypeChecker "tableMaybe" Rel8able.tableMaybe Rel8able.genTableMaybe getTestDatabase+  , testTypeChecker "tableEither" Rel8able.tableEither Rel8able.genTableEither getTestDatabase+  , testTypeChecker "tableThese" Rel8able.tableThese Rel8able.genTableThese getTestDatabase+  , testTypeChecker "tableList" Rel8able.tableList Rel8able.genTableList getTestDatabase+  , testTypeChecker "tableNest" Rel8able.tableNest Rel8able.genTableNest getTestDatabase+  , testTypeChecker "nonRecord" Rel8able.nonRecord Rel8able.genNonRecord getTestDatabase+  , testTypeChecker "tableProduct" Rel8able.tableProduct Rel8able.genTableProduct getTestDatabase+  , testTypeChecker "tableType" Rel8able.tableType Rel8able.genTableType getTestDatabase+  , testWrongTable getTestDatabase+  , testDuplicateTable getTestDatabase+  , testCharMismatch getTestDatabase+  , testNumericMismatch getTestDatabase+  ]+  where+    -- confirms that the type checker works correctly for numeric modifiers+    testNumericMismatch = databasePropertyTest "numeric mismatch" \transaction -> transaction do+      lift $ Hasql.sql $ "create table \"tableNumeric\" ( foo numeric(1000, 4) not null );"+      typeErrors <- lift $ statement () $ Verify.getSchemaErrors+        [Verify.SomeTableSchema Rel8able.tableNumeric]+      case typeErrors of+        Nothing -> failure+        Just _ -> pure ()+      lift $ Hasql.sql $ "alter table \"tableNumeric\" alter column foo set data type numeric(1000, 2);"+      typeErrors <- lift $ statement () $ Verify.getSchemaErrors+        [Verify.SomeTableSchema Rel8able.tableNumeric]+      case typeErrors of+        Nothing -> pure ()+        Just _ -> failure++    -- tests that the type checker works correctly for bpchar modifiers+    testCharMismatch = databasePropertyTest "bpchar mismatch" \transaction -> transaction do+      lift $ Hasql.sql $ "create table \"tableChar\" ( foo bpchar(2) not null );"+      typeErrors <- lift $ statement () $ Verify.getSchemaErrors+        [Verify.SomeTableSchema Rel8able.tableChar]+      case typeErrors of+        Nothing -> failure+        Just _ -> pure ()+      lift $ Hasql.sql $ "alter table \"tableChar\" alter column foo set data type bpchar(1);"+      typeErrors <- lift $ statement () $ Verify.getSchemaErrors+        [Verify.SomeTableSchema Rel8able.tableChar]+      case typeErrors of+        Nothing -> pure ()+        Just a -> do+            annotate (unpack a)+            failure++    -- confirms that the type checker fails when no type errors are present in a+    -- table with duplicate column names+    testDuplicateTable = databasePropertyTest "duplicate columns" \transaction -> transaction do+      lift $ Hasql.sql $ B.pack $ Verify.showCreateTable Rel8able.tableDuplicate+      typeErrors <- lift $ statement () $ Verify.getSchemaErrors+        [Verify.SomeTableSchema Rel8able.tableDuplicate]+      case typeErrors of+        Nothing -> failure+        Just _ -> pure ()++    -- confirms that the type checker fails if the types mismatch+    testWrongTable = databasePropertyTest "type mismatch" \transaction -> transaction do+      lift $ Hasql.sql $ B.pack $ Verify.showCreateTable Rel8able.tableType+      typeErrors <- lift $ statement () $ Verify.getSchemaErrors+        [Verify.SomeTableSchema Rel8able.badTableType]+      case typeErrors of+        Nothing -> failure+        Just _ -> pure ()++    testTypeChecker ::+      ( Show (k Result), Rel8.Rel8able k, Rel8.Selects (k Rel8.Name) (k Rel8.Expr)+      , Rel8.Serializable (k Rel8.Expr) (k Rel8.Result))+      => TestName -> Rel8.TableSchema (k Rel8.Name) -> Gen (k Result) -> IO TmpPostgres.DB -> TestTree+    testTypeChecker testName tableSchema genRows = databasePropertyTest testName \transaction -> do+      rows <- forAll $ Gen.list (Range.linear 0 10) genRows++      transaction do+        lift $ Hasql.sql $ B.pack $ Verify.showCreateTable tableSchema+        typeErrors <- lift $ statement () $ Verify.getSchemaErrors [Verify.SomeTableSchema tableSchema]+        case typeErrors of+          Nothing -> pure ()+          Just typ -> do+            annotate (unpack typ)+            failure++        selected <- lift do+          statement () $ Rel8.run_ $ Rel8.insert Rel8.Insert+            { into = tableSchema+            , rows = Rel8.values $ map Rel8.lit rows+            , onConflict = Rel8.DoNothing Nothing+            , returning = Rel8.NoReturning+            }+          statement () $ Rel8.run $ Rel8.select do+            Rel8.each tableSchema++        -- not every type we use this with has an ord instance, and we're+        -- primarily checking the type checker here, not the parser/printer,+        -- so we this is only here as one additional check+        length selected === length rows++ databasePropertyTest   :: TestName   -> ((TestT Transaction () -> PropertyT IO ()) -> PropertyT IO ())@@ -180,7 +324,6 @@ testTableSchema =   Rel8.TableSchema     { name = "test_table"-    , schema = Nothing     , columns = TestTable         { testTableColumn1 = "column1"         , testTableColumn2 = "column2"@@ -194,14 +337,14 @@    transaction do     selected <- lift do-      statement () $ Rel8.insert Rel8.Insert+      statement () $ Rel8.run_ $ Rel8.insert Rel8.Insert         { into = testTableSchema         , rows = Rel8.values $ map Rel8.lit rows-        , onConflict = Rel8.DoNothing-        , returning = pure ()+        , onConflict = Rel8.DoNothing Nothing+        , returning = Rel8.NoReturning         } -      statement () $ Rel8.select do+      statement () $ Rel8.run $ Rel8.select do         Rel8.each testTableSchema      sort selected === sort rows@@ -221,7 +364,7 @@    transaction do     selected <- lift do-      statement () $ Rel8.select do+      statement () $ Rel8.run $ Rel8.select do         t <- Rel8.values $ Rel8.lit <$> rows         Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool         return t@@ -241,7 +384,7 @@     let expected = filter testTableColumn2 rows      selected <- lift do-      statement () $ Rel8.select do+      statement () $ Rel8.run $ Rel8.select do         Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)      sort selected === sort expected@@ -259,7 +402,7 @@    transaction do     selected <- lift do-      statement () $ Rel8.select do+      statement () $ Rel8.run $ Rel8.select do         Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)      diff (length selected) (<=) (fromIntegral n)@@ -280,7 +423,7 @@    transaction do     selected <- lift do-      statement () $ Rel8.select do+      statement () $ Rel8.run $ Rel8.select do         Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)      sort selected === sort (nub (left ++ right))@@ -292,7 +435,7 @@    transaction do     selected <- lift do-      statement () $ Rel8.select do+      statement () $ Rel8.run $ Rel8.select do         Rel8.distinct do           Rel8.values (Rel8.lit <$> rows) @@ -309,12 +452,12 @@    transaction do     exists <- lift do-      statement () $ Rel8.select do+      statement () $ Rel8.run1 $ Rel8.select do         Rel8.exists $ Rel8.values $ Rel8.lit <$> rows      case rows of-      [] -> exists === [False]-      _ -> exists === [True]+      [] -> exists === False+      _ -> exists === True   testOptional :: IO TmpPostgres.DB -> TestTree@@ -323,7 +466,7 @@    transaction do     selected <- lift do-      statement () $ Rel8.select do+      statement () $ Rel8.run $ Rel8.select do         Rel8.optional $ Rel8.values (Rel8.lit <$> rows)      case rows of@@ -336,8 +479,8 @@   (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool    transaction do-    [result] <- lift do-      statement () $ Rel8.select do+    result <- lift do+      statement () $ Rel8.run1 $ Rel8.select do         pure $ Rel8.lit x Rel8.&&. Rel8.lit y      result === (x && y)@@ -348,8 +491,8 @@   (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool    transaction do-    [result] <- lift do-      statement () $ Rel8.select $ pure $+    result <- lift do+      statement () $ Rel8.run1 $ Rel8.select $ pure $         Rel8.lit x Rel8.||. Rel8.lit y      result === (x || y)@@ -360,8 +503,8 @@   (u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool    transaction do-    [result] <- lift do-      statement () $ Rel8.select do+    result <- lift do+      statement () $ Rel8.run1 $ Rel8.select do         pure $ Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x      result === (u || v && w == x)@@ -372,8 +515,8 @@   x <- forAll Gen.bool    transaction do-    [result] <- lift do-      statement () $ Rel8.select do+    result <- lift do+      statement () $ Rel8.run1 $ Rel8.select do         pure $ Rel8.not_ $ Rel8.lit x      result === not x@@ -384,8 +527,8 @@   (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool    transaction do-    [result] <- lift do-      statement () $ Rel8.select do+    result <- lift do+      statement () $ Rel8.run1 $ Rel8.select do         pure $ Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)      result === if x then y else z@@ -400,53 +543,145 @@    transaction do     result <- lift do-      statement () $ Rel8.select do+      statement () $ Rel8.run $ Rel8.select do         liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))      sort result === sort (liftA2 (,) rows1 rows2)  +data Composite = Composite+  { bool :: !Bool+  , char :: !Text+  , array :: ![Int32]+  }+  deriving stock (Eq, Show, Generic)+  deriving (Rel8.DBType) via Rel8.Composite Composite+++instance Rel8.DBComposite Composite where+  compositeTypeName = "composite"+  compositeFields = Rel8.namesFromLabels++ testDBType :: IO TmpPostgres.DB -> TestTree testDBType getTestDatabase = testGroup "DBType instances"   [ dbTypeTest "Bool" Gen.bool   , dbTypeTest "ByteString" $ Gen.bytes (Range.linear 0 128)-  , dbTypeTest "CI Lazy Text" $ mk . Data.Text.Lazy.fromStrict <$> Gen.text (Range.linear 0 10) Gen.unicode-  , dbTypeTest "CI Text" $ mk <$> Gen.text (Range.linear 0 10) Gen.unicode+  , dbTypeTest "CalendarDiffTime" genCalendarDiffTime+  , dbTypeTest "Char" Gen.unicode+  , dbTypeTest "CI Lazy Text" $ mk . Data.Text.Lazy.fromStrict <$> genText+  , dbTypeTest "CI Text" $ mk <$> genText+  , dbTypeTest "Composite" genComposite   , dbTypeTest "Day" genDay-  , dbTypeTest "Double" $ (/10) . fromIntegral @Int @Double <$> Gen.integral (Range.linear (-100) 100)-  , dbTypeTest "Float" $ (/10) . fromIntegral @Int @Float <$> Gen.integral (Range.linear (-100) 100)+  , dbTypeTest "Double" $ (/ 10) . fromIntegral @Int @Double <$> Gen.integral (Range.linear (-100) 100)+  , dbTypeTest "Fixed" $ toEnum @Centi <$> Gen.integral (Range.linear (-10000) 10000)+  , dbTypeTest "Float" $ (/ 10) . fromIntegral @Int @Float <$> Gen.integral (Range.linear (-100) 100)   , dbTypeTest "Int32" $ Gen.integral @_ @Int32 Range.linearBounded   , dbTypeTest "Int64" $ Gen.integral @_ @Int64 Range.linearBounded   , dbTypeTest "Lazy ByteString" $ Data.ByteString.Lazy.fromStrict <$> Gen.bytes (Range.linear 0 128)-  , dbTypeTest "Lazy Text" $ Data.Text.Lazy.fromStrict <$> Gen.text (Range.linear 0 10) Gen.unicode+  , dbTypeTest "Lazy Text" $ Data.Text.Lazy.fromStrict <$> genText   , dbTypeTest "LocalTime" genLocalTime-  , dbTypeTest "Scientific" $ (/10) . fromIntegral @Int @Scientific <$> Gen.integral (Range.linear (-100) 100)-  , dbTypeTest "Text" $ Gen.text (Range.linear 0 10) Gen.unicode+  , dbTypeTest "Scientific" $ genScientific+  , dbTypeTest "Text" genText   , dbTypeTest "TimeOfDay" genTimeOfDay   , dbTypeTest "UTCTime" $ UTCTime <$> genDay <*> genDiffTime   , dbTypeTest "UUID" $ Data.UUID.fromWords <$> genWord32 <*> genWord32 <*> genWord32 <*> genWord32+  , dbTypeTest "INet" genIPRange+  , dbTypeTest "Value" genValue+  , dbTypeTest "JSONEncoded" genJSONEncoded+  , dbTypeTest "JSONBEncoded" genJSONBEncoded+  , dbTypeTest "Object" genObject+  , dbTypeTest "Range" genRange+  , dbTypeTest "Multirange" genMultirange   ]    where-    dbTypeTest :: (Eq a, Show a, Rel8.DBType a) => TestName -> Gen a -> TestTree+    dbTypeTest :: (Eq a, Show a, Rel8.DBType a, Rel8.ToExprs (Rel8.Expr a) a) => TestName -> Gen a -> TestTree     dbTypeTest name generator = testGroup name       [ databasePropertyTest name (t generator) getTestDatabase       , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase       ] -    t :: forall a b. (Eq a, Show a, Rel8.Sql Rel8.DBType a)+    t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBType a, Rel8.ToExprs (Rel8.Expr a) a)       => Gen a-      -> (TestT Transaction () -> PropertyT IO b)-      -> PropertyT IO b+      -> (TestT Transaction () -> PropertyT IO ())+      -> PropertyT IO ()     t generator transaction = do       x <- forAll generator+      y <- forAll generator+      xss <- forAll $ Gen.list (Range.linear 0 10) (Gen.list (Range.linear 0 10) generator)+      xsss <- forAll $ Gen.list (Range.linear 0 10) (Gen.list (Range.linear 0 10) (Gen.list (Range.linear 0 10) generator))        transaction do-        [res] <- lift do-          statement () $ Rel8.select do+        res <- lift do+          statement () $ Rel8.run1 $ Rel8.select do             pure (Rel8.litExpr x)         diff res (==) x+        res' <- lift do+          statement () $ Rel8.run1 $ Rel8.select $ Rel8.many $ Rel8.many do+            Rel8.values [Rel8.litExpr x, Rel8.litExpr y]+        diff res' (==) [[x, y]]+        res3 <- lift do+          statement () $ Rel8.run1 $ Rel8.select $ Rel8.many $ Rel8.many $ Rel8.many do+            Rel8.values [Rel8.litExpr x, Rel8.litExpr y]+        diff res3 (==) [[[x, y]]]+        res'' <- lift do+          statement () $ Rel8.run $ Rel8.select do+            xs <- Rel8.catListTable (Rel8.listTable [Rel8.listTable [Rel8.litExpr x, Rel8.litExpr y]])+            Rel8.catListTable xs+        diff res'' (==) [x, y]+        res''' <- lift do+          statement () $ Rel8.run $ Rel8.select do+            xss' <- Rel8.catListTable (Rel8.listTable [Rel8.listTable [Rel8.listTable [Rel8.litExpr x, Rel8.litExpr y]]])+            xs <- Rel8.catListTable xss'+            Rel8.catListTable xs+        diff res''' (==) [x, y]+        res'''' <- lift do+          statement () $ Rel8.run1 $ Rel8.select $+            Rel8.aggregate Rel8.listCatExpr $+              Rel8.values $ map Rel8.litExpr xss+        diff res'''' (==) (concat xss)+        res''''' <- lift do+          statement () $ Rel8.run1 $ Rel8.select $+            Rel8.aggregate Rel8.listCatExpr $+              Rel8.values $ map Rel8.litExpr xsss+        diff res''''' (==) (concat xsss) +      transaction do+        res <- lift do+          statement x $ Rel8.prepared Rel8.run1 $+            Rel8.select @(Rel8.Expr _) .+            pure+        diff res (==) x++        res' <- lift do+          statement [x, y] $ Rel8.prepared Rel8.run1 $+            Rel8.select @(Rel8.ListTable Rel8.Expr (Rel8.Expr _)) .+            Rel8.many . Rel8.catListTable+        diff res' (==) [x, y]++        res'' <- lift do+          statement [[x, y]] $ Rel8.prepared Rel8.run1 $+            Rel8.select @(Rel8.ListTable Rel8.Expr (Rel8.ListTable Rel8.Expr (Rel8.Expr _))) .+            Rel8.many . Rel8.many . (Rel8.catListTable >=> Rel8.catListTable)+        diff res'' (==) [[x, y]]++        res''' <- lift do+          statement [[[x, y]]] $ Rel8.prepared Rel8.run1 $+            Rel8.select @(Rel8.ListTable Rel8.Expr (Rel8.ListTable Rel8.Expr (Rel8.ListTable Rel8.Expr (Rel8.Expr _)))) .+            Rel8.many . Rel8.many . Rel8.many . (Rel8.catListTable >=> Rel8.catListTable >=> Rel8.catListTable)+        diff res''' (==) [[[x, y]]]++    genScientific :: Gen Scientific+    genScientific = (/ 10) . fromIntegral @Int @Scientific <$> Gen.integral (Range.linear (-100) 100)++    genComposite :: Gen Composite+    genComposite = do+      bool <- Gen.bool+      char <- genText+      array <- Gen.list (Range.linear 0 10) (Gen.int32 (Range.linear (-10000) 10000))+      pure Composite {..}+     genDay :: Gen Day     genDay = do       year <- Gen.integral (Range.linear 1970 3000)@@ -454,6 +689,14 @@       day <- Gen.integral (Range.linear 1 31)       Gen.just $ pure $ fromGregorianValid year month day +    genCalendarDiffTime :: Gen CalendarDiffTime+    genCalendarDiffTime = do+      -- hardcoded to 0 because Hasql's 'interval' decoder needs to return a+      -- CalendarDiffTime for this to be properly round-trippable+      months <- pure 0 -- Gen.integral (Range.linear 0 120)+      diffTime <- secondsToNominalDiffTime . MkFixed . (* 1000000) <$> Gen.integral (Range.linear 0 2147483647999999)+      pure $ CalendarDiffTime months diffTime+     genDiffTime :: Gen DiffTime     genDiffTime = secondsToDiffTime <$> Gen.integral (Range.linear 0 86401) @@ -469,13 +712,126 @@     genWord32 :: Gen Word32     genWord32 = Gen.integral Range.linearBounded +    genIPRange :: Gen (Data.IP.IPRange)+    genIPRange =+      Gen.choice+        [ Data.IP.IPv4Range <$> (Data.IP.makeAddrRange <$> genIPv4 <*> genIP4Mask)+        , Data.IP.IPv6Range <$> (Data.IP.makeAddrRange <$> genIPv6 <*> genIP6Mask)+        ]+      where+        genIP4Mask :: Gen Int+        genIP4Mask = Gen.integral (Range.linearFrom 0 0 32) +        genIPv4 :: Gen Data.IP.IPv4+        genIPv4 = Data.IP.toIPv4w <$> genWord32++        genIP6Mask :: Gen Int+        genIP6Mask = Gen.integral (Range.linearFrom 0 0 128)++        genIPv6 :: Gen (Data.IP.IPv6)+        genIPv6 = Data.IP.toIPv6w <$> ((,,,) <$> genWord32 <*> genWord32 <*> genWord32 <*> genWord32)++    genKey :: Gen Aeson.Key+    genKey = Aeson.Key.fromText <$> genText++    genValue :: Gen Aeson.Value+    genValue = Gen.recursive Gen.choice+     [ pure Aeson.Null+     , Aeson.Bool <$> Gen.bool+     , Aeson.Number <$> genScientific+     , Aeson.String <$> genText+     ]+     [ Aeson.Object <$> genObject+     , Aeson.Array . Vector.fromList <$> Gen.list (Range.linear 0 10) genValue+     ]++    genJSONEncoded = Rel8.JSONEncoded <$> genValue+    genJSONBEncoded = Rel8.JSONBEncoded <$> genValue++    genObject :: Gen Aeson.Object+    genObject = Aeson.KeyMap.fromMap <$> Gen.map (Range.linear 0 10) ((,) <$> genKey <*> genValue)++    genRange :: Gen (Range Scientific)+    genRange =+      Gen.choice+        [ pure Empty+        , do+            (lower, upper) <- genBounds+            pure (Range lower upper)+        ]++    genBound :: Gen a -> Gen (Bound a)+    genBound a =+      Gen.choice+        [ Incl <$> a+        , Excl <$> a+        , pure Inf+        ]++    genNum :: Gen Scientific+    genNum = genNumFrom (-1000)++    genNumFrom :: Scientific -> Gen Scientific+    genNumFrom x = (/ 10) . fromIntegral @Int @Scientific <$> Gen.integral (Range.linear i 10000)+      where+        i = round (x * 10)++    genBounds :: Gen (Bound Scientific, Bound Scientific)+    genBounds = do+      lower <- genBound genNum+      upper <- genUpperFrom lower+      pure (lower, upper)++    genUpperFrom :: Bound Scientific -> Gen (Bound Scientific)+    genUpperFrom = \case+      Inf -> genBound genNum+      Incl x -> genBoundGT x+      Excl x -> genBoundGT x+      where+        genBoundGT x+          | x' < 1000 = genBound $ genNumFrom x'+          | otherwise = pure Inf+          where+            x' = x + 0.1++    genMultirange :: Gen (Multirange Scientific)+    genMultirange = Multirange <$> do+      n <- Gen.integral (Range.linear @Int 0 10)+      if n == 0+        then pure []+        else do+          (lower, upper) <- genBounds+          ranges <- go (n - 1) upper+          pure (Range lower upper : ranges)+      where+        go n bound+          | n == 0 = pure []+          | otherwise = case bound of+              Inf -> pure []+              Incl x -> next x+              Excl x -> next x+          where+            next x+              | x' >= 1000 = pure []+              | otherwise = do+                  lower <-+                    Gen.choice+                      [ Incl <$> genNumFrom x'+                      , Excl <$> genNumFrom x'+                      ]+                  upper <- genUpperFrom lower+                  ranges <- go (n - 1) upper+                  pure (Range lower upper : ranges)+              where+                x' = x + 0.1++ testDBEq :: IO TmpPostgres.DB -> TestTree testDBEq getTestDatabase = testGroup "DBEq instances"   [ dbEqTest "Bool" Gen.bool   , dbEqTest "Int32" $ Gen.integral @_ @Int32 Range.linearBounded   , dbEqTest "Int64" $ Gen.integral @_ @Int64 Range.linearBounded-  , dbEqTest "Text" $ Gen.text (Range.linear 0 10) Gen.unicode+  , dbEqTest "Text" $ genText   ]    where@@ -493,33 +849,57 @@       (x, y) <- forAll (liftA2 (,) generator generator)        transaction do-        [res] <- lift do-          statement () $ Rel8.select do+        res <- lift do+          statement () $ Rel8.run1 $ Rel8.select do             pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y         res === (x == y)  +genText :: Gen Text+genText = removeNull <$> Gen.text (Range.linear 0 10) Gen.unicode+  where+    -- | Postgres doesn't support the NULL character (not to be confused with a NULL value) inside strings.+    removeNull :: Text -> Text+    removeNull = T.filter (/= '\0')+++ testTableEquality :: IO TmpPostgres.DB -> TestTree testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do    (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable     transaction do-     [eq] <- lift do-       statement () $ Rel8.select do+     eq <- lift do+       statement () $ Rel8.run1 $ Rel8.select do          pure $ Rel8.lit x Rel8.==: Rel8.lit y       eq === (x == y)  -testFromString :: IO TmpPostgres.DB -> TestTree-testFromString = databasePropertyTest "FromString" \transaction -> do-  str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode+testFromRational :: IO TmpPostgres.DB -> TestTree+testFromRational = databasePropertyTest "fromRational" \transaction -> do+  numerator <- forAll $ Gen.int64 Range.linearBounded+  denominator <- forAll $ Gen.int64 $ Range.linear 1 maxBound +  let+    rational = toInteger numerator % toInteger denominator+    double = fromRational @Double rational+   transaction do-    [result] <- lift do-      statement () $ Rel8.select do-        pure $ fromString str-    result === pack str+    result <- lift do+      statement () $ Rel8.run1 $ Rel8.select do+        pure $ fromRational rational+    diff result (~=) double+  where+    wholeDigits x = fromIntegral $ length $ show $ round @_ @Integer x+    -- A Double gives us between 15-17 decimal digits of precision.+    -- It's tempting to say that two numbers are equal if they differ by less than 1e15.+    -- But this doesn't hold.+    -- The precision is split between the whole numer part and the decimal part of the number.+    -- For instance, a number between 10 and 99 only has around 13 digits of precision in its decimal part.+    -- Postgres and Haskell show differing amounts of digits in these cases,+    a ~= b = abs (a - b) < 10 ** (-15 + wholeDigits a)+    infix 4 ~=   testCatMaybeTable :: IO TmpPostgres.DB -> TestTree@@ -528,7 +908,7 @@    transaction do     selected <- lift do-      statement () $ Rel8.select do+      statement () $ Rel8.run $ Rel8.select do         testTable <- Rel8.values $ Rel8.lit <$> rows         Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable) @@ -541,7 +921,7 @@    transaction do     selected <- lift do-      statement () $ Rel8.select do+      statement () $ Rel8.run $ Rel8.select do         Rel8.catNull =<< Rel8.values (map Rel8.lit rows)      sort selected === sort (catMaybes rows)@@ -553,7 +933,7 @@    transaction do     selected <- lift do-      statement () $ Rel8.select do+      statement () $ Rel8.run $ Rel8.select do         Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))      case rows of@@ -577,8 +957,8 @@    transaction do     selected <- lift do-      statement () $ Rel8.select do-        Rel8.aggregate $ Rel8.aggregateMaybeTable Rel8.sum <$> Rel8.values (Rel8.lit <$> rows)+      statement () $ Rel8.run $ Rel8.select do+        Rel8.aggregate1 (Rel8.aggregateMaybeTable Rel8.sum) $ Rel8.values (Rel8.lit <$> rows)      sort selected === aggregate rows @@ -605,7 +985,7 @@    transaction do     selected <- lift do-      statement () $ Rel8.select do+      statement () $ Rel8.run $ Rel8.select do         Rel8.values (Rel8.lit <$> rows)      sort selected === sort rows@@ -618,7 +998,7 @@    transaction do     selected <- lift do-      statement () $ Rel8.select do+      statement () $ Rel8.run $ Rel8.select do         as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))         bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))         pure $ liftA2 (,) as bs@@ -631,7 +1011,7 @@   where     genRows :: PropertyT IO [TestTable Result]     genRows = forAll do-      Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)+      Gen.list (Range.linear 0 10) $ liftA2 TestTable genText (pure True)   genTestTable :: Gen (TestTable Result)@@ -647,14 +1027,14 @@    transaction do     selected <- lift do-      statement () $ Rel8.insert Rel8.Insert+      statement () $ Rel8.run_ $ Rel8.insert Rel8.Insert         { into = testTableSchema         , rows = Rel8.values $ map Rel8.lit $ Map.keys rows-        , onConflict = Rel8.DoNothing-        , returning = pure ()+        , onConflict = Rel8.DoNothing Nothing+        , returning = Rel8.NoReturning         } -      statement () $ Rel8.update Rel8.Update+      statement () $ Rel8.run_ $ Rel8.update Rel8.Update         { target = testTableSchema         , from = pure ()         , set = \_ r ->@@ -672,10 +1052,10 @@               r               updates         , updateWhere = \_ _ -> Rel8.lit True-        , returning = pure ()+        , returning = Rel8.NoReturning         } -      statement () $ Rel8.select do+      statement () $ Rel8.run $ Rel8.select do         Rel8.each testTableSchema      sort selected === sort (Map.elems rows)@@ -691,21 +1071,21 @@    transaction do     (deleted, selected) <- lift do-      statement () $ Rel8.insert Rel8.Insert+      statement () $ Rel8.run_ $ Rel8.insert Rel8.Insert         { into = testTableSchema         , rows = Rel8.values $ map Rel8.lit rows-        , onConflict = Rel8.DoNothing-        , returning = pure ()+        , onConflict = Rel8.DoNothing Nothing+        , returning = Rel8.NoReturning         } -      deleted <- statement () $ Rel8.delete Rel8.Delete+      deleted <- statement () $ Rel8.run $ Rel8.delete Rel8.Delete           { from = testTableSchema           , using = pure ()           , deleteWhere = const testTableColumn2-          , returning = Rel8.Projection id+          , returning = Rel8.Returning id           } -      selected <- statement () $ Rel8.select do+      selected <- statement () $ Rel8.run $ Rel8.select do         Rel8.each testTableSchema        pure (deleted, selected)@@ -713,6 +1093,80 @@     sort (deleted <> selected) === sort rows  +testWithStatement :: IO TmpPostgres.DB -> TestTree+testWithStatement genTestDatabase =+  testGroup "WITH"+    [ selectUnionInsert genTestDatabase+    , rowsAffectedNoReturning genTestDatabase+    , rowsAffectedReturing genTestDatabase+    , pureQuery genTestDatabase+    ]+  where+    selectUnionInsert = +      databasePropertyTest "Can UNION results of SELECT with results of INSERT" \transaction -> do+        rows <- forAll $ Gen.list (Range.linear 0 50) genTestTable++        transaction do+          rows' <- lift do+            statement () $ Rel8.run $ do+              values <- Rel8.select $ Rel8.values $ map Rel8.lit rows++              inserted <- Rel8.insert $ Rel8.Insert+                { into = testTableSchema+                , rows = values+                , onConflict = Rel8.DoNothing Nothing+                , returning = Rel8.Returning id+                }++              pure $ values <> inserted++          sort rows' === sort (rows <> rows)++    rowsAffectedNoReturning = +      databasePropertyTest "Can read rows affected from INSERT without RETURNING" \transaction -> do+        rows <- forAll $ Gen.list (Range.linear 0 50) genTestTable++        transaction do+          affected <- lift do+            statement () $ Rel8.runN $ do+              Rel8.insert $ Rel8.Insert+                { into = testTableSchema+                , rows = Rel8.values $ map Rel8.lit rows+                , onConflict = Rel8.DoNothing Nothing+                , returning = Rel8.NoReturning+                }++          length rows === fromIntegral affected++    rowsAffectedReturing = +      databasePropertyTest "Can read rows affected from INSERT with RETURNING" \transaction -> do+        rows <- forAll $ Gen.list (Range.linear 0 50) genTestTable++        transaction do+          affected <- lift do+            statement () $ Rel8.runN $ void $ do+              Rel8.insert $ Rel8.Insert+                { into = testTableSchema+                , rows = Rel8.values $ map Rel8.lit rows+                , onConflict = Rel8.DoNothing Nothing+                , returning = Rel8.Returning id+                }++          length rows === fromIntegral affected++    pureQuery = +      databasePropertyTest "Can read pure Query" \transaction -> do+        rows <- forAll $ Gen.list (Range.linear 0 50) genTestTable++        transaction do+          rows' <- lift do+            statement () $ Rel8.run $ pure do+              Rel8.values $ map Rel8.lit rows++          sort rows === sort rows'+++ data UniqueTable f = UniqueTable   { uniqueTableKey :: Rel8.Column f Text   , uniqueTableValue :: Rel8.Column f Text@@ -730,7 +1184,6 @@ uniqueTableSchema =   Rel8.TableSchema     { name = "unique_table"-    , schema = Nothing     , columns = UniqueTable         { uniqueTableKey = "key"         , uniqueTableValue = "value"@@ -752,25 +1205,30 @@    transaction do     selected <- lift do-      statement () $ Rel8.insert Rel8.Insert+      statement () $ Rel8.run_ $ Rel8.insert Rel8.Insert         { into = uniqueTableSchema         , rows = Rel8.values $ Rel8.lit <$> as-        , onConflict = Rel8.DoNothing-        , returning = pure ()+        , onConflict = Rel8.DoNothing Nothing+        , returning = Rel8.NoReturning         } -      statement () $ Rel8.insert Rel8.Insert+      statement () $ Rel8.run_ $ Rel8.insert Rel8.Insert         { into = uniqueTableSchema         , rows = Rel8.values $ Rel8.lit <$> bs         , onConflict = Rel8.DoUpdate Rel8.Upsert-            { index = uniqueTableKey+            { conflict =+                Rel8.OnIndex+                  Rel8.Index+                    { columns = uniqueTableKey+                    , predicate = Nothing+                    }             , set = \UniqueTable {uniqueTableValue} old -> old {uniqueTableValue}             , updateWhere = \_ _ -> Rel8.true             }-        , returning = pure ()+        , returning = Rel8.NoReturning         } -      statement () $ Rel8.select do+      statement () $ Rel8.run $ Rel8.select do         Rel8.each uniqueTableSchema      fromUniqueTables selected === fromUniqueTables bs <> fromUniqueTables as@@ -794,7 +1252,7 @@    transaction do     selected <- lift do-      statement () $ Rel8.select do+      statement () $ Rel8.run $ Rel8.select do         Rel8.values $ map Rel8.lit rows      sort selected === sort rows@@ -806,13 +1264,13 @@    transaction do     selected <- lift do-      statement () $ Rel8.select do+      statement () $ Rel8.run1 $ Rel8.select do         Rel8.many $ Rel8.values (map Rel8.lit rows) -    selected === [foldMap pure rows]+    selected === rows      selected' <- lift do-      statement () $ Rel8.select do+      statement () $ Rel8.run $ Rel8.select do         a <- Rel8.catListTable =<< do           Rel8.many $ Rel8.values (map Rel8.lit rows)         b <- Rel8.catListTable =<< do@@ -841,11 +1299,11 @@    transaction do     selected <- lift do-      statement () $ Rel8.select do+      statement () $ Rel8.run1 $ Rel8.select do         x <- Rel8.values [Rel8.lit example]         pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x) -    selected === [True]+    selected === True   testEvaluate :: IO TmpPostgres.DB -> TestTree@@ -853,7 +1311,7 @@    transaction do     selected <- lift do-      statement () $ Rel8.select do+      statement () $ Rel8.run $ Rel8.select do         x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])         y <- Rel8.evaluate (Rel8.nextval "test_seq")         pure (x, (y, y))@@ -865,7 +1323,7 @@       ]      selected' <- lift do-      statement () $ Rel8.select do+      statement () $ Rel8.run $ Rel8.select do         x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])         y <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])         z <- Rel8.evaluate (Rel8.nextval "test_seq")@@ -887,3 +1345,53 @@     normalize :: [(x, (Int64, Int64))] -> [(x, (Int64, Int64))]     normalize [] = []     normalize xs@((_, (i, _)) : _) = map (fmap (\(a, b) -> (a - i, b - i))) xs+++-- Field name is 42 chars+data LongLabelTable f = LongLabelTable+  { aFieldNameDefinitelyLongerThanThirtyCharsA :: Rel8.Column f Text+  , aFieldNameDefinitelyLongerThanThirtyCharsB :: Rel8.Column f Text+  }+  deriving stock Generic+  deriving anyclass Rel8.Rel8able++deriving stock instance Eq (LongLabelTable Result)+deriving stock instance Ord (LongLabelTable Result)+deriving stock instance Show (LongLabelTable Result)+++-- Field name is 51 chars, nested with the 42 above, we'll get more than 63,+-- triggering truncation.+data NestedForLargerThan63 f = NestedForLargerThan63+  { aFieldNameDefinitelyLongerThanThirtyCharsNestedWith :: LongLabelTable f+  }+  deriving stock Generic+  deriving anyclass Rel8.Rel8able++deriving stock instance Eq (NestedForLargerThan63 Result)+deriving stock instance Ord (NestedForLargerThan63 Result)+deriving stock instance Show (NestedForLargerThan63 Result)+++testSelectTruncated :: IO TmpPostgres.DB -> TestTree+testSelectTruncated = databasePropertyTest "select truncates long column aliases" \transaction -> do+  rows <- forAll $ Gen.list (Range.linear 0 10) ((,) <$> genText <*> genText)++  let q = Rel8.values $ map (\(tA, tB) -> NestedForLargerThan63 (LongLabelTable (Rel8.lit tA) (Rel8.lit tB))) rows+      sqlText = Rel8.showStatement (Rel8.select q)+  annotate sqlText++  -- Check that long names do not exist+  assert $ not $ "aFieldNameDefinitelyLongerThanThirtyCharsA" `isInfixOf` sqlText+  assert $ not $ "aFieldNameDefinitelyLongerThanThirtyCharsB" `isInfixOf` sqlText++  -- Find the short names+  assert $ "aFieldNameDefinitelyLongerThanThirtyCharsNestedWith/aFieldN_1_1" `isInfixOf` sqlText+  assert $ "aFieldNameDefinitelyLongerThanThirtyCharsNestedWith/aFieldN_2_1" `isInfixOf` sqlText++  transaction do+    selected <- lift do+      statement () $ Rel8.run $ Rel8.select q+    sort (map (((,) <$> aFieldNameDefinitelyLongerThanThirtyCharsA <*>  aFieldNameDefinitelyLongerThanThirtyCharsB)+      . aFieldNameDefinitelyLongerThanThirtyCharsNestedWith) selected)+      === sort rows
tests/Rel8/Generic/Rel8able/Test.hs view
@@ -1,3 +1,4 @@+{-# language ScopedTypeVariables #-} {-# language DataKinds #-} {-# language DeriveAnyClass #-} {-# language DeriveGeneric #-}@@ -5,7 +6,13 @@ {-# language DuplicateRecordFields #-} {-# language FlexibleInstances #-} {-# language MultiParamTypeClasses #-}+{-# language OverloadedStrings #-}+{-# language StandaloneDeriving #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-} {-# language TypeFamilies #-}+{-# language TypeOperators #-}+{-# language RecordWildCards #-} {-# language UndecidableInstances #-}  {-# options_ghc -O0 #-}@@ -15,97 +22,284 @@   ) where +-- aeson+import Data.Aeson ( Value(..) )+import qualified Data.Aeson.KeyMap as Aeson+ -- base+import Data.Fixed ( Fixed ( MkFixed ), E2 )+import Data.Foldable ( fold )+import Data.Int ( Int16, Int32, Int64 )+import Data.Functor.Identity ( Identity(..) )+import qualified Data.List.NonEmpty as NonEmpty import GHC.Generics ( Generic ) import Prelude+import Control.Applicative ( liftA3 ) +-- bytestring+import Data.ByteString ( ByteString )+import qualified Data.ByteString.Lazy as LB++-- case-insensitive+import Data.CaseInsensitive ( CI )+import qualified Data.CaseInsensitive as CI++-- containers+import qualified Data.Map as Map++-- hedgehog+import qualified Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+ -- rel8-import Rel8+import Rel8 (+  Column,+  DBType,+  Expr,+  HADT,+  HEither,+  HKD,+  HList,+  HMaybe,+  HNonEmpty,+  HThese,+  KRel8able,+  Lift,+  Name,+  QualifiedName,+  Rel8able,+  Result,+  TableSchema (TableSchema),+  ToExprs,+  namesFromLabelsWith,+ )+import qualified Rel8 +-- scientific+import Data.Scientific ( Scientific, fromFloatDigits )++-- time+import Data.Time.Calendar (Day)+import Data.Time.Clock (UTCTime(..), secondsToDiffTime, secondsToNominalDiffTime)+import Data.Time.LocalTime+  ( CalendarDiffTime (CalendarDiffTime)+  , LocalTime(..)+  , TimeOfDay(..)+  )+ -- text import Data.Text ( Text )+import qualified Data.Text.Lazy as LT +-- these+import Data.These +-- uuid+import Data.UUID ( UUID )+import qualified Data.UUID as UUID++-- vector+import qualified Data.Vector as Vector+++makeSchema :: forall f. Rel8able f => QualifiedName -> TableSchema (f Name)+makeSchema name = TableSchema+  { name = name+  , columns = namesFromLabelsWith @(f Name) (fold . NonEmpty.intersperse "/")+  }+++data TableDuplicate f = TableDuplicate+  { foo :: TablePair f+  , bar :: TablePair f+  }+  deriving stock Generic+  deriving anyclass Rel8able++tableDuplicate :: TableSchema (TableDuplicate Name)+tableDuplicate = TableSchema+  { name = "tableDuplicate"+  , columns = namesFromLabelsWith NonEmpty.last+  }++ data TableTest f = TableTest   { foo :: Column f Bool   , bar :: Column f (Maybe Bool)   }   deriving stock Generic   deriving anyclass Rel8able+deriving stock instance f ~ Result => Show (TableTest f)+deriving stock instance f ~ Result => Eq (TableTest f)+deriving stock instance f ~ Result => Ord (TableTest f) +tableTest :: TableSchema (TableTest Name)+tableTest = makeSchema "tableTest" +genTableTest :: Hedgehog.MonadGen m => m (TableTest Result)+genTableTest = TableTest <$> Gen.bool <*> Gen.maybe Gen.bool++ data TablePair f = TablePair   { foo :: Column f Bool   , bars :: (Column f Text, Column f Text)   }   deriving stock Generic   deriving anyclass Rel8able+deriving stock instance f ~ Result => Show (TablePair f)+deriving stock instance f ~ Result => Eq (TablePair f)+deriving stock instance f ~ Result => Ord (TablePair f) +tablePair :: TableSchema (TablePair Name)+tablePair = makeSchema "tablePair" +genTablePair :: Hedgehog.MonadGen m => m (TablePair Result)+genTablePair = TablePair+  <$> Gen.bool+  <*> liftA2 (,) (Gen.text (Range.linear 0 10) Gen.alphaNum) (Gen.text (Range.linear 0 10) Gen.alphaNum)++ data TableMaybe f = TableMaybe   { foo :: Column f [Maybe Bool]   , bars :: HMaybe f (TablePair f, TablePair f)   }   deriving stock Generic   deriving anyclass Rel8able+deriving stock instance f ~ Result => Show (TableMaybe f)+deriving stock instance f ~ Result => Eq (TableMaybe f)+deriving stock instance f ~ Result => Ord (TableMaybe f) +tableMaybe :: TableSchema (TableMaybe Name)+tableMaybe = makeSchema "tableMaybe" +genTableMaybe :: Hedgehog.MonadGen m => m (TableMaybe Result)+genTableMaybe = TableMaybe+  <$> Gen.list (Range.linear 0 10) (Gen.maybe Gen.bool)+  <*> Gen.maybe (liftA2 (,) genTablePair genTablePair)++ data TableEither f = TableEither   { foo :: Column f Bool   , bars :: HEither f (HMaybe f (TablePair f, TablePair f)) (Column f Char)   }   deriving stock Generic   deriving anyclass Rel8able+deriving stock instance f ~ Result => Show (TableEither f)+deriving stock instance f ~ Result => Eq (TableEither f)+deriving stock instance f ~ Result => Ord (TableEither f) +tableEither :: TableSchema (TableEither Name)+tableEither = makeSchema "tableEither" +genTableEither :: Hedgehog.MonadGen m => m (TableEither Result)+genTableEither = TableEither+  <$> Gen.bool+  <*> Gen.either (Gen.maybe $ liftA2 (,) genTablePair genTablePair) Gen.alphaNum++ data TableThese f = TableThese   { foo :: Column f Bool   , bars :: HThese f (TableMaybe f) (TableEither f)   }   deriving stock Generic   deriving anyclass Rel8able+deriving stock instance f ~ Result => Show (TableThese f)+deriving stock instance f ~ Result => Eq (TableThese f)+deriving stock instance f ~ Result => Ord (TableThese f) +tableThese :: TableSchema (TableThese Name)+tableThese = makeSchema "tableThese" +genTableThese :: Hedgehog.MonadGen m => m (TableThese Result)+genTableThese = TableThese+  <$> Gen.bool+  <*> Gen.choice+    [ This <$> genTableMaybe+    , That <$> genTableEither+    , These <$> genTableMaybe <*> genTableEither+    ]++ data TableList f = TableList   { foo :: Column f Bool   , bars :: HList f (TableThese f)   }   deriving stock Generic   deriving anyclass Rel8able+deriving stock instance f ~ Result => Show (TableList f)+deriving stock instance f ~ Result => Eq (TableList f)+deriving stock instance f ~ Result => Ord (TableList f) +tableList :: TableSchema (TableList Name)+tableList = makeSchema "tableList" +genTableList :: Hedgehog.MonadGen m => m (TableList Result)+genTableList = TableList+  <$> Gen.bool+  <*> Gen.list (Range.linear 0 10) genTableThese++ data TableNonEmpty f = TableNonEmpty   { foo :: Column f Bool   , bars :: HNonEmpty f (TableList f, TableMaybe f)   }   deriving stock Generic   deriving anyclass Rel8able+deriving stock instance f ~ Result => Show (TableNonEmpty f)+deriving stock instance f ~ Result => Eq (TableNonEmpty f)+deriving stock instance f ~ Result => Ord (TableNonEmpty f) +tableNonEmpty :: TableSchema (TableNonEmpty Name)+tableNonEmpty = makeSchema "tableNonEmpty" +genTableNonEmpty :: Hedgehog.MonadGen m => m (TableNonEmpty Result)+genTableNonEmpty = TableNonEmpty+  <$> Gen.bool+  <*> Gen.nonEmpty (Range.linear 0 10) (liftA2 (,) genTableList genTableMaybe)++ data TableNest f = TableNest   { foo :: Column f Bool   , bars :: HList f (HMaybe f (TablePair f))   }   deriving stock Generic   deriving anyclass Rel8able+deriving stock instance f ~ Result => Show (TableNest f)+deriving stock instance f ~ Result => Eq (TableNest f)+deriving stock instance f ~ Result => Ord (TableNest f) +tableNest :: TableSchema (TableNest Name)+tableNest = makeSchema "tableNest" +genTableNest :: Hedgehog.MonadGen m => m (TableNest Result)+genTableNest = TableNest+  <$> Gen.bool+  <*> Gen.list (Range.linear 0 10) (Gen.maybe genTablePair)++ data S3Object = S3Object   { bucketName :: Text   , objectKey :: Text   }-  deriving stock Generic+  deriving stock (Generic, Show, Eq, Ord)   instance x ~ HKD S3Object Expr => ToExprs x S3Object   data HKDSum = HKDSumA Text | HKDSumB Bool Char | HKDSumC-  deriving stock Generic+  deriving stock (Generic, Show, Eq, Ord)   instance x ~ HKD HKDSum Expr => ToExprs x HKDSum +genHKDSum :: Hedgehog.MonadGen m => m HKDSum+genHKDSum = Gen.choice+  [ HKDSumA <$> Gen.text (Range.linear 0 10) Gen.alpha+  , HKDSumB <$> Gen.bool <*> Gen.alpha+  , pure HKDSumC+  ]  data HKDTest f = HKDTest   { s3Object :: Lift f S3Object@@ -113,7 +307,14 @@   }   deriving stock Generic   deriving anyclass Rel8able+deriving stock instance f ~ Result => Show (HKDTest f)+deriving stock instance f ~ Result => Eq (HKDTest f)+deriving stock instance f ~ Result => Ord (HKDTest f) +genHKDTest :: Hedgehog.MonadGen m => m (HKDTest Result)+genHKDTest = HKDTest+  <$> liftA2 S3Object (Gen.text (Range.linear 0 10) Gen.alpha) (Gen.text (Range.linear 0 10) Gen.alpha)+  <*> genHKDSum  data NonRecord f = NonRecord   (Column f Bool)@@ -128,22 +329,63 @@   (Column f Char)   deriving stock Generic   deriving anyclass Rel8able+deriving stock instance f ~ Result => Show (NonRecord f)+deriving stock instance f ~ Result => Eq (NonRecord f)+deriving stock instance f ~ Result => Ord (NonRecord f) +nonRecord :: TableSchema (NonRecord Name)+nonRecord = makeSchema "nonRecord" +genNonRecord :: Hedgehog.MonadGen m => m (NonRecord Result)+genNonRecord = NonRecord+  <$> Gen.bool+  <*> Gen.alpha+  <*> Gen.alpha+  <*> Gen.alpha+  <*> Gen.alpha+  <*> Gen.alpha+  <*> Gen.alpha+  <*> Gen.alpha+  <*> Gen.alpha+  <*> Gen.alpha++ data TableSum f   = TableSumA (Column f Bool) (Column f Text)   | TableSumB   | TableSumC (Column f Text)   deriving stock Generic+deriving stock instance f ~ Result => Show (TableSum f)+deriving stock instance f ~ Result => Eq (TableSum f)+deriving stock instance f ~ Result => Ord (TableSum f)  +genTableSum :: Hedgehog.MonadGen m => m (HADT Result TableSum)+genTableSum = Gen.choice+  [ TableSumA <$> Gen.bool <*> Gen.text (Range.linear 0 10) Gen.alpha+  , pure TableSumB+  , TableSumC <$> Gen.text (Range.linear 0 10) Gen.alpha+  ]++ data BarbieSum f   = BarbieSumA (f Bool) (f Text)   | BarbieSumB   | BarbieSumC (f Text)   deriving stock Generic+deriving stock instance f ~ Result => Show (BarbieSum f)+deriving stock instance f ~ Result => Eq (BarbieSum f)+deriving stock instance f ~ Result => Ord (BarbieSum f)  +genBarbieSum :: Hedgehog.MonadGen m => m (BarbieSum Result)+genBarbieSum = Gen.choice+  [ BarbieSumA <$> fmap Identity Gen.bool <*> fmap Identity (Gen.text (Range.linear 0 10) Gen.alpha)+  , pure BarbieSumB+  , BarbieSumC <$> fmap Identity (Gen.text (Range.linear 0 10) Gen.alpha)+  ]++ data TableProduct f = TableProduct   { sum :: HADT f BarbieSum   , list :: TableList f@@ -151,8 +393,32 @@   }   deriving stock Generic   deriving anyclass Rel8able+deriving stock instance f ~ Result => Show (TableProduct f)+deriving stock instance f ~ Result => Eq (TableProduct f)+deriving stock instance f ~ Result => Ord (TableProduct f) +tableProduct :: TableSchema (TableProduct Name)+tableProduct = makeSchema "tableProduct" +genTableProduct :: Hedgehog.MonadGen m => m (TableProduct Result)+genTableProduct = TableProduct+  <$> genBarbieSum+  <*> genTableList+  <*> Gen.list (Range.linear 0 10) (liftA3 (,,) genTableSum genHKDSum genHKDTest)++-- tableProduct :: TableProduct Name+-- tableProduct = makeSchema "tableProduct"++-- genTableProduct :: Hedgehog.MonadGen m => m (TableProduct Result)+-- genTableProduct = TableProduct+--   <$> Gen.choice+--     [ BarbieSumA <$> Gen.bool <*> Gen.text (Range.linear 0 10) Gen.alpha+--     , BarbieSumB+--     , BarbieSumC <$> Gen.text (Range.linear 0 10) Gen.alpha+--     ]+--   <*> genTableList+--   <*> Gen.list (Range.linear 0 10) (liftA3 (,,) genTableSum)+ data TableTestB f = TableTestB   { foo :: f Bool   , bar :: f (Maybe Bool)@@ -171,9 +437,118 @@   deriving anyclass Rel8able  - newtype IdRecord a f = IdRecord { recordId :: Column f a }   deriving stock Generic   instance DBType a => Rel8able (IdRecord a)+++type Nest :: KRel8able -> KRel8able -> KRel8able+data Nest t u f = Nest+  { foo :: t f+  , bar :: u f+  }+  deriving stock Generic+  deriving anyclass Rel8able+++data TableType f = TableType+  { bool                :: Column f Bool+  , char                :: Column f Char+  , int16               :: Column f Int16+  , int32               :: Column f Int32+  , int64               :: Column f Int64+  , float               :: Column f Float+  , double              :: Column f Double+  , scientific          :: Column f Scientific+  , fixed               :: Column f (Fixed E2)+  , utctime             :: Column f UTCTime+  , day                 :: Column f Day+  , localtime           :: Column f LocalTime+  , timeofday           :: Column f TimeOfDay+  , calendardifftime    :: Column f CalendarDiffTime+  , text                :: Column f Text+  , lazytext            :: Column f LT.Text+  , citext              :: Column f (CI Text)+  , cilazytext          :: Column f (CI LT.Text)+  , bytestring          :: Column f ByteString+  , lazybytestring      :: Column f LB.ByteString+  , uuid                :: Column f UUID+  , value               :: Column f Value+  } deriving stock (Generic)+deriving anyclass instance Rel8able TableType+deriving stock instance f ~ Result => Show (TableType f)+deriving stock instance f ~ Result => Eq (TableType f)+-- deriving stock instance f ~ Result => Ord (TableType f)++tableType :: TableSchema (TableType Name)+tableType = makeSchema "tableType"++badTableType :: TableSchema (TableProduct Name)+badTableType = makeSchema "tableType"++genTableType :: Hedgehog.MonadGen m => m (TableType Result)+genTableType = do+  bool <- Gen.bool+  char <- Gen.alpha+  int16 <- Gen.int16 range+  int32 <- Gen.int32 range+  int64 <- Gen.int64 range+  float <- Gen.float linearFrac+  double <- Gen.double linearFrac+  scientific <- fromFloatDigits @Double <$> Gen.realFloat linearFrac+  utctime <- UTCTime <$> (toEnum <$> Gen.integral range) <*> fmap secondsToDiffTime (Gen.integral range)+  day <- toEnum <$> Gen.integral range+  localtime <- LocalTime <$> (toEnum <$> Gen.integral range) <*> timeOfDay+  timeofday <- timeOfDay+  text <- Gen.text range Gen.alpha+  lazytext <- LT.fromStrict <$> Gen.text range Gen.alpha+  citext <- CI.mk <$> Gen.text range Gen.alpha+  cilazytext <- CI.mk <$> LT.fromStrict <$> Gen.text range Gen.alpha+  bytestring <- Gen.bytes range+  lazybytestring <- LB.fromStrict <$> Gen.bytes range+  uuid <- UUID.fromWords <$> Gen.word32 range <*> Gen.word32 range <*> Gen.word32 range <*> Gen.word32 range+  fixed <- MkFixed <$> Gen.integral range+  value <- Gen.choice+    [ Object <$> Aeson.fromMapText <$> Map.fromList <$> Gen.list range (liftA2 (,) (Gen.text range Gen.alpha) (pure Null))+    , Array <$> Vector.fromList <$> Gen.list range (pure Null)+    , String <$> Gen.text range Gen.alpha+    , Number <$> fromFloatDigits @Double <$> Gen.realFloat linearFrac+    , Bool <$> Gen.bool+    , pure Null+    ]+  calendardifftime <- CalendarDiffTime <$> Gen.integral range <*> (secondsToNominalDiffTime <$> Gen.realFrac_ linearFrac)+  pure TableType {..}+  where+    timeOfDay :: Hedgehog.MonadGen m => m TimeOfDay+    timeOfDay = TimeOfDay <$> Gen.integral range <*> Gen.integral range <*> Gen.realFrac_ linearFrac++    range :: Integral a => Range.Range a+    range = Range.linear 0 10++    linearFrac :: (Fractional a, Ord a) => Range.Range a+    linearFrac = Range.linearFrac 0 10++data TableNumeric f = TableNumeric+  { foo :: Column f (Fixed E2)+  } deriving stock (Generic)+deriving anyclass instance Rel8able TableNumeric+deriving stock instance f ~ Result => Show (TableNumeric f)+deriving stock instance f ~ Result => Eq (TableNumeric f)++tableNumeric :: TableSchema (TableNumeric Name)+tableNumeric = makeSchema "tableNumeric"+++data TableChar f = TableChar+  { foo :: Column f Char+  } deriving stock (Generic)+deriving anyclass instance Rel8able TableChar+deriving stock instance f ~ Result => Show (TableChar f)+deriving stock instance f ~ Result => Eq (TableChar f)++tableChar :: TableSchema (TableChar Name)+tableChar = makeSchema "tableChar"++
+ tests/Rel8/TH/Rel8able/Test.hs view
@@ -0,0 +1,137 @@+{-# language ScopedTypeVariables #-}+{-# language DataKinds #-}+{-# language DeriveAnyClass #-}+{-# language DeriveGeneric #-}+{-# language DerivingStrategies #-}+{-# language DuplicateRecordFields #-}+{-# language FlexibleInstances #-}+{-# language MultiParamTypeClasses #-}+{-# language OverloadedStrings #-}+{-# language StandaloneDeriving #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language TypeOperators #-}+{-# language RecordWildCards #-}+{-# language UndecidableInstances #-}+{-# LANGUAGE TemplateHaskell #-}++module Rel8.TH.Rel8able.Test where++-- base+import Data.Fixed ( Fixed ( MkFixed ), E2 )+import Prelude++-- rel8+import Rel8 (+  Column,+  HEither,+  HList,+  HMaybe,+  HNonEmpty,+  HThese, + )+import Rel8.TH++-- text+import Data.Text ( Text )++data TableTest f = TableTest+  { foo :: Column f Bool+  , bar :: Column f (Maybe Bool)+  }++deriveRel8able ''TableTest++data TablePair f = TablePair+  { foo :: Column f Bool+  , bars :: (Column f Text, Column f Text)+  }+  +deriveRel8able ''TablePair++data TableDuplicate f = TableDuplicate+  { foo :: TablePair f+  , bar :: TablePair f+  }++deriveRel8able ''TableDuplicate ++data TableMaybe f = TableMaybe+  { foo :: Column f [Maybe Bool]+  , bars :: HMaybe f (TablePair f, TablePair f)+  }+  +deriveRel8able ''TableMaybe++data TableEither f = TableEither+  { foo :: Column f Bool+  , bars :: HEither f (HMaybe f (TablePair f, TablePair f)) (Column f Char)+  }+  +deriveRel8able ''TableEither++data TableThese f = TableThese+  { foo :: Column f Bool+  , bars :: HThese f (TableMaybe f) (TableEither f)+  }+  +deriveRel8able ''TableThese+++data TableList f = TableList+  { foo :: Column f Bool+  , bars :: HList f (TableThese f)+  }+  +deriveRel8able ''TableList+++data TableNonEmpty f = TableNonEmpty+  { foo :: Column f Bool+  , bars :: HNonEmpty f (TableList f, TableMaybe f)+  }+  +deriveRel8able ''TableNonEmpty++data TableNest f = TableNest+  { foo :: Column f Bool+  , bars :: HList f (HMaybe f (TablePair f))+  }+  +deriveRel8able ''TableNest+++data TableTestB f = TableTestB+  { foo :: f Bool+  , bar :: f (Maybe Bool)+  }++deriveRel8able ''TableTestB++data NestedTableTestB f = NestedTableTestB+  { foo :: f Bool+  , bar :: f (Maybe Bool)+  , baz :: Column f Char+  , nest :: TableTestB f+  }+  +deriveRel8able ''NestedTableTestB++data TableNumeric f = TableNumeric+  { foo :: Column f (Fixed E2)+  }+  +deriveRel8able ''TableNumeric+++data TableChar f = TableChar+  { foo :: Column f Char+  } +deriveRel8able ''TableChar+++newtype IdRecord a f = IdRecord { recordId :: Column f a }++-- Our TH deriving code currently doesn't support type args other than f+-- deriveRel8able ''IdRecord