packages feed

rel8 1.2.2.0 → 1.7.0.0

raw patch · 126 files changed

Files

Changelog.md view
@@ -1,3 +1,284 @@++<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`).++- Support hasql-1.9++- Add `elem` and `elem1` to `Rel8.Array` for testing if an element is contained in `[]` and `NonEmpty` `Expr`s.++## 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
rel8.cabal view
@@ -1,6 +1,6 @@ cabal-version:       2.0 name:                rel8-version:             1.2.2.0+version:             1.7.0.0 synopsis:            Hey! Hey! Can u rel8? license:             BSD3 license-file:        LICENSE@@ -20,14 +20,19 @@ library   build-depends:       aeson-    , base ^>= 4.14 || ^>=4.15 || ^>=4.16+    , attoparsec+    , base >= 4.16 && < 4.22+    , base16 >= 1.0+    , base-compat >= 0.11 && < 0.15     , bifunctors     , bytestring     , case-insensitive     , comonad+    , containers     , contravariant-    , hasql ^>= 1.4.5.1 || ^>= 1.5.0.0-    , opaleye ^>= 0.8.0.0+    , hasql >= 1.8 && < 1.10+    , iproute ^>= 1.7+    , opaleye ^>= 0.10.2.1     , pretty     , profunctors     , product-profunctors@@ -37,7 +42,11 @@     , text     , these     , time+    , transformers+    , utf8-string     , uuid+    , vector+   default-language:     Haskell2010   ghc-options:@@ -46,17 +55,28 @@     -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+   hs-source-dirs:     src   exposed-modules:     Rel8+    Rel8.Array+    Rel8.Decoder+    Rel8.Encoder     Rel8.Expr.Num     Rel8.Expr.Text     Rel8.Expr.Time+    Rel8.Table.Verify     Rel8.Tabulate    other-modules:     Rel8.Aggregate+    Rel8.Aggregate.Fold+    Rel8.Aggregate.Function      Rel8.Column     Rel8.Column.ADT@@ -65,6 +85,7 @@     Rel8.Column.List     Rel8.Column.Maybe     Rel8.Column.NonEmpty+    Rel8.Column.Null     Rel8.Column.These      Rel8.Expr@@ -74,12 +95,18 @@     Rel8.Expr.Default     Rel8.Expr.Eq     Rel8.Expr.Function+    Rel8.Expr.List+    Rel8.Expr.NonEmpty     Rel8.Expr.Null     Rel8.Expr.Opaleye     Rel8.Expr.Ord     Rel8.Expr.Order+    Rel8.Expr.Read     Rel8.Expr.Sequence     Rel8.Expr.Serialize+    Rel8.Expr.Show+    Rel8.Expr.Subscript+    Rel8.Expr.Window      Rel8.FCF @@ -106,9 +133,12 @@     Rel8.Query.Evaluate     Rel8.Query.Exists     Rel8.Query.Filter+    Rel8.Query.Function     Rel8.Query.Indexed     Rel8.Query.Limit     Rel8.Query.List+    Rel8.Query.Loop+    Rel8.Query.Materialize     Rel8.Query.Maybe     Rel8.Query.Null     Rel8.Query.Opaleye@@ -118,9 +148,11 @@     Rel8.Query.SQL     Rel8.Query.These     Rel8.Query.Values+    Rel8.Query.Window      Rel8.Schema.Context.Nullify     Rel8.Schema.Dict+    Rel8.Schema.Escape     Rel8.Schema.Field     Rel8.Schema.HTable     Rel8.Schema.HTable.Either@@ -137,14 +169,19 @@     Rel8.Schema.Kind     Rel8.Schema.Name     Rel8.Schema.Null+    Rel8.Schema.QualifiedName     Rel8.Schema.Result     Rel8.Schema.Spec     Rel8.Schema.Table +    Rel8.Statement     Rel8.Statement.Delete     Rel8.Statement.Insert     Rel8.Statement.OnConflict+    Rel8.Statement.Prepared     Rel8.Statement.Returning+    Rel8.Statement.Rows+    Rel8.Statement.Run     Rel8.Statement.Select     Rel8.Statement.Set     Rel8.Statement.SQL@@ -156,6 +193,7 @@     Rel8.Table     Rel8.Table.ADT     Rel8.Table.Aggregate+    Rel8.Table.Aggregate.Maybe     Rel8.Table.Alternative     Rel8.Table.Bool     Rel8.Table.Cols@@ -166,6 +204,7 @@     Rel8.Table.Maybe     Rel8.Table.Name     Rel8.Table.NonEmpty+    Rel8.Table.Null     Rel8.Table.Nullify     Rel8.Table.Opaleye     Rel8.Table.Ord@@ -176,44 +215,63 @@     Rel8.Table.These     Rel8.Table.Transpose     Rel8.Table.Undefined+    Rel8.Table.Window      Rel8.Type     Rel8.Type.Array+    Rel8.Type.Builder.ByteString+    Rel8.Type.Builder.Fold+    Rel8.Type.Builder.Time     Rel8.Type.Composite+    Rel8.Type.Decimal+    Rel8.Type.Decoder     Rel8.Type.Eq+    Rel8.Type.Encoder     Rel8.Type.Enum     Rel8.Type.Information     Rel8.Type.JSONEncoded     Rel8.Type.JSONBEncoded     Rel8.Type.Monoid+    Rel8.Type.Name+    Rel8.Type.Nullable     Rel8.Type.Num     Rel8.Type.Ord+    Rel8.Type.Parser+    Rel8.Type.Parser.ByteString+    Rel8.Type.Parser.Time     Rel8.Type.ReadShow     Rel8.Type.Semigroup     Rel8.Type.String     Rel8.Type.Sum     Rel8.Type.Tag +    Rel8.Window++ 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.6     , mmorph+    , iproute     , rel8     , 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@@ -226,3 +284,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@@ -283,8 +378,14 @@     -- ** @.. RETURNING@   , Returning(..) +    -- ** @WITH@+  , Statement+  , showStatement+  , showPreparedStatement+     -- ** @CREATE VIEW@   , createView+  , createOrReplaceView      -- ** Sequences   , nextval@@ -296,6 +397,8 @@  -- rel8 import Rel8.Aggregate+import Rel8.Aggregate.Fold+import Rel8.Aggregate.Function import Rel8.Column import Rel8.Column.ADT import Rel8.Column.Either@@ -303,19 +406,23 @@ import Rel8.Column.List import Rel8.Column.Maybe import Rel8.Column.NonEmpty+import Rel8.Column.Null import Rel8.Column.These import Rel8.Expr import Rel8.Expr.Aggregate+import Rel8.Expr.Array 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.Opaleye (unsafeCastExpr, unsafeCoerceExpr, unsafeLiteral, unsafePrimExpr) import Rel8.Expr.Ord import Rel8.Expr.Order import Rel8.Expr.Serialize import Rel8.Expr.Sequence+import Rel8.Expr.Text ( like, ilike )+import Rel8.Expr.Window import Rel8.Generic.Rel8able ( KRel8able, Rel8able ) import Rel8.Order import Rel8.Query@@ -326,9 +433,12 @@ import Rel8.Query.Evaluate import Rel8.Query.Exists import Rel8.Query.Filter+import Rel8.Query.Function import Rel8.Query.Indexed import Rel8.Query.Limit import Rel8.Query.List+import Rel8.Query.Loop+import Rel8.Query.Materialize import Rel8.Query.Maybe import Rel8.Query.Null import Rel8.Query.Order@@ -337,16 +447,21 @@ import Rel8.Query.Set import Rel8.Query.These import Rel8.Query.Values+import Rel8.Query.Window import Rel8.Schema.Field import Rel8.Schema.HTable import Rel8.Schema.Name import Rel8.Schema.Null hiding ( nullable )+import Rel8.Schema.QualifiedName import Rel8.Schema.Result ( Result ) import Rel8.Schema.Table+import Rel8.Statement import Rel8.Statement.Delete import Rel8.Statement.Insert import Rel8.Statement.OnConflict+import Rel8.Statement.Prepared import Rel8.Statement.Returning+import Rel8.Statement.Run import Rel8.Statement.Select import Rel8.Statement.SQL import Rel8.Statement.Update@@ -354,6 +469,7 @@ import Rel8.Table import Rel8.Table.ADT import Rel8.Table.Aggregate+import Rel8.Table.Aggregate.Maybe import Rel8.Table.Alternative import Rel8.Table.Bool import Rel8.Table.Either@@ -363,6 +479,7 @@ import Rel8.Table.Maybe import Rel8.Table.Name import Rel8.Table.NonEmpty+import Rel8.Table.Null import Rel8.Table.Opaleye ( castTable ) import Rel8.Table.Ord import Rel8.Table.Order@@ -371,6 +488,7 @@ import Rel8.Table.Serialize import Rel8.Table.These import Rel8.Table.Transpose+import Rel8.Table.Window import Rel8.Type import Rel8.Type.Composite import Rel8.Type.Eq@@ -379,16 +497,230 @@ import Rel8.Type.JSONBEncoded import Rel8.Type.JSONEncoded import Rel8.Type.Monoid+import Rel8.Type.Name 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.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 :: f Int32, employerName :: f Text}+--   deriving stock Generic+--   deriving anyclass Rel8able+--+-- data Potato f = Potato { size :: f Int32, grower :: 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 view
@@ -1,91 +1,197 @@ {-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language MultiParamTypeClasses #-}-{-# language NamedFieldPuns #-}-{-# language RankNTypes #-}+{-# language GADTs #-}+{-# language KindSignatures #-}+{-# language ScopedTypeVariables #-} {-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}  module Rel8.Aggregate-  ( Aggregate(..), zipOutputs-  , Aggregator(..), unsafeMakeAggregate-  , Aggregates+  ( Aggregator' (Aggregator)+  , Aggregator+  , Aggregator1+  , toAggregator+  , toAggregator1+  , filterWhereExplicit+  , unsafeMakeAggregator   ) where  -- base-import Control.Applicative ( liftA2 )-import Data.Functor.Identity ( Identity( Identity ) )-import Data.Kind ( Constraint, Type )+import Control.Applicative (liftA2)+import Data.Kind (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+import qualified Opaleye.Aggregate as Opaleye+import qualified Opaleye.Internal.MaybeFields as Opaleye+import qualified Opaleye.Internal.Operators 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+-- product-profunctor+import Data.Profunctor.Product+  ( ProductProfunctor, purePP, (****)+  , SumProfunctor, (+++!)   )-import Rel8.Table.Transpose ( Transposes )-import Rel8.Type ( DBType ) +-- profunctors+import Data.Profunctor (Profunctor, dimap) --- | 'Aggregate' is a special context used by 'Rel8.aggregate'.-type Aggregate :: K.Context-newtype Aggregate a = Aggregate (Opaleye.Aggregator () (Expr a))+-- rel8+import Rel8.Expr (Expr)+import Rel8.Expr.Opaleye (toPrimExpr, toColumn)+import Rel8.Aggregate.Fold (Fallback (Empty, Fallback), Fold (Full, Semi)) +-- semigroupoids+import Data.Functor.Apply (Apply, liftF2) -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+-- | 'Aggregator'' is the most general form of \"aggregator\", of which+-- 'Aggregator' and 'Aggregator1' are special cases. 'Aggregator''s are+-- comprised of aggregation functions and/or @GROUP BY@ clauses.+--+-- Aggregation functions operating on individual 'Rel8.Expr's such as+-- 'Rel8.sum' can be combined into 'Aggregator's operating on larger types+-- using the 'Applicative', 'Profunctor' and 'ProductProfunctor' interfaces.+-- Working with 'Profunctor's can sometimes be awkward so for every 'Rel8.sum'+-- we also provide a 'Rel8.sumOn' which bundles an 'Data.Profunctor.lmap'. For+-- complex aggregations, we recommend using these functions along with+-- @ApplicativeDo@, @BlockArguments@, @OverloadedRecordDot@ and+-- @RecordWildCards@:+--+-- @+--+-- data Input f = Input+--   { orderId :: Column f OrderId+--   , customerId :: Column f CustomerId+--   , productId :: Column f ProductId+--   , quantity :: Column f Int64+--   , price :: Column f Scientific+--   }+--   deriving (Generic, Rel8able)+--+--+-- totalPrice :: Input Expr -> Expr Scientific+-- totalPrice input = fromIntegral input.quantity * input.price+--+--+-- data Result f = Result+--   { customerId :: Column f CustomerId+--   , totalOrders :: Column f Int64+--   , productsOrdered :: Column f Int64+--   , totalPrice :: Column f Scientific+--   }+--   deriving (Generic, Rel8able)+--+--+-- allResults :: Query (Result Expr)+-- allResults =+--   aggregate+--     do+--       customerId <- groupByOn (.customerId)+--       totalOrders <- countDistinctOn (.orderId)+--       productsOrdered <- countDistinctOn (.productId)+--       totalPrice <- sumOn totalPrice+--       pure Result {..}+--     do+--       order <- each orderSchema+--       orderLine <- each orderLineSchema+--       where_ $ order.id ==. orderLine.orderId+--       pure+--         Input+--           { orderId = order.id+--           , customerId = order.customerId+--           , productId = orderLine.productId+--           , quantity = orderLine.quantity+--           , price = orderLine.price+--           }+-- @+type Aggregator' :: Fold -> Type -> Type -> Type+data Aggregator' fold i a = Aggregator !(Fallback fold a) !(Opaleye.Aggregator i 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+instance Profunctor (Aggregator' fold) where+  dimap f g (Aggregator fallback a) =+    Aggregator (fmap g fallback) (dimap f g a)  -zipOutputs :: ()-  => (Expr a -> Expr b -> Expr c) -> Aggregate a -> Aggregate b -> Aggregate c-zipOutputs f (Aggregate a) (Aggregate b) = Aggregate (liftA2 f a b)+instance ProductProfunctor (Aggregator' fold) where+  purePP = pure+  (****) = (<*>)  -type Aggregator :: Type-data Aggregator = Aggregator-  { operation :: Opaleye.AggrOp-  , ordering :: [Opaleye.OrderExpr]-  , distinction :: Opaleye.AggrDistinct-  }+instance SumProfunctor (Aggregator' fold) where+  Aggregator fallback a +++! Aggregator fallback' b =+    flip Aggregator (a +++! b) $ case fallback of+      Empty -> case fallback' of+        Empty -> Empty+        Fallback x -> Fallback (Right x)+      Fallback x -> Fallback (Left x)  -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)+instance Functor (Aggregator' fold i) where+  fmap = dimap id+++instance Apply (Aggregator' fold i) where+  liftF2 f (Aggregator fallback a) (Aggregator fallback' b) =+    Aggregator (liftF2 f fallback fallback') (liftA2 f a b)+++instance Applicative (Aggregator' fold i) where+  pure a = Aggregator (pure a) (pure a)+  liftA2 = liftF2+++-- | An 'Aggregator' takes a 'Rel8.Query' producing a collection of rows of+-- type @a@ and transforms it into a 'Rel8.Query' producing a single row of+-- type @b@. If the given 'Rel8.Query' produces an empty collection of rows,+-- then the single row in the resulting 'Rel8.Query' contains the identity+-- values of the aggregation functions comprising the 'Aggregator' (i.e.,+-- @0@ for 'Rel8.sum', 'Rel8.false' for 'Rel8.or', etc.).+--+-- 'Aggregator' is a special form of 'Aggregator'' parameterised by 'Full'.+type Aggregator :: Type -> Type -> Type+type Aggregator = Aggregator' 'Full+++-- | An 'Aggregator1' takes a collection of rows of type @a@, groups them, and+-- transforms each group into a single row of type @b@. This corresponds to+-- aggregators using @GROUP BY@ in SQL. If given an empty collection of rows,+-- 'Aggregator1' will have no groups and will therefore also return an empty+-- collection of rows.+--+-- 'Aggregator1' is a special form of 'Aggregator'' parameterised by 'Semi'.+type Aggregator1 :: Type -> Type -> Type+type Aggregator1 = Aggregator' 'Semi+++-- | 'toAggregator1' turns an 'Aggregator' into an 'Aggregator1'.+toAggregator1 :: Aggregator' fold i a -> Aggregator1 i a+toAggregator1 (Aggregator _ a) = Aggregator Empty a+++-- | Given a value to fall back on if given an empty collection of rows,+-- 'toAggregator' turns an 'Aggregator1' into an 'Aggregator'.+toAggregator :: a -> Aggregator' fold i a -> Aggregator' fold' i a+toAggregator fallback (Aggregator _ a) = Aggregator (Fallback fallback) a+++filterWhereExplicit :: ()+  => Opaleye.IfPP a a+  -> (i -> Expr Bool)+  -> Aggregator i a+  -> Aggregator' fold i a+filterWhereExplicit ifPP f (Aggregator (Fallback fallback) aggregator) =+  Aggregator (Fallback fallback) aggregator'   where-    tuplize Aggregator {operation, ordering, distinction} =-      (operation, ordering, distinction)+    aggregator' =+      Opaleye.fromMaybeFieldsExplicit ifPP fallback+        <$> Opaleye.filterWhere (toColumn . toPrimExpr . f) aggregator+++unsafeMakeAggregator :: forall (i :: Type) (o :: Type) (fold :: Fold) i' o'.  ()+  => (i -> i')+  -> (o' -> o)+  -> Fallback fold o+  -> Opaleye.Aggregator i' o'+  -> Aggregator' fold i o+unsafeMakeAggregator input output fallback =+  Aggregator fallback . dimap input output
− 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/Aggregate/Fold.hs view
@@ -0,0 +1,52 @@+{-# language DataKinds #-}+{-# language GADTs #-}+{-# language LambdaCase #-}+{-# language StandaloneKindSignatures #-}++module Rel8.Aggregate.Fold+  ( Fallback (Empty, Fallback)+  , Fold (Semi, Full)+  )+where++-- base+import Control.Applicative (liftA2)+import Data.Kind (Type)+import Prelude++-- semigroupoids+import Data.Functor.Apply (Apply, liftF2)+++-- | 'Fold' is a kind that parameterises aggregations. Aggregations+-- parameterised by 'Semi' are analogous to 'Data.Semigroup.Foldable.foldMap1'+-- (i.e, they can only produce results on a non-empty 'Rel8.Query') whereas+-- aggregations parameterised by 'Full' are analagous to 'foldMap' (given a+-- non-empty) query, they return the identity values of the aggregation+-- functions.+type Fold :: Type+data Fold = Semi | Full+++type Fallback :: Fold -> Type -> Type+data Fallback fold a where+  Fallback :: !a -> Fallback fold a+  Empty :: Fallback 'Semi a+++instance Functor (Fallback fold) where+  fmap f = \case+    Fallback a -> Fallback (f a)+    Empty -> Empty+++instance Apply (Fallback fold) where+  liftF2 f (Fallback a) (Fallback b) = Fallback (f a b)+  liftF2 _ (Fallback _) Empty = Empty+  liftF2 _ Empty (Fallback _) = Empty+  liftF2 _ Empty Empty = Empty+++instance Applicative (Fallback fold) where+  pure = Fallback+  liftA2 = liftF2
+ src/Rel8/Aggregate/Function.hs view
@@ -0,0 +1,45 @@+{-# language FlexibleContexts #-}+{-# language MonoLocalBinds #-}++module Rel8.Aggregate.Function (+  aggregateFunction,+  rawAggregateFunction,+) where++-- base+import Prelude++-- opaleye+import qualified Opaleye.Internal.Aggregate as Opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye++-- rel8+import Rel8.Aggregate (Aggregator1, unsafeMakeAggregator)+import Rel8.Aggregate.Fold (Fallback (Empty))+import Rel8.Expr (Expr)+import Rel8.Expr.Opaleye (castExpr, fromColumn, fromPrimExpr)+import Rel8.Schema.Null (Sql)+import Rel8.Schema.QualifiedName (QualifiedName, showQualifiedName)+import Rel8.Table (Table)+import Rel8.Table.Opaleye (unpackspec)+import Rel8.Type (DBType)+++-- | 'aggregateFunction' allows the use use of custom aggregation functions+-- or PostgreSQL aggregation functions which are not otherwise supported by+-- Rel8.+aggregateFunction ::+  (Table Expr i, Sql DBType a) =>+  QualifiedName ->+  Aggregator1 i (Expr a)+aggregateFunction name = castExpr <$> rawAggregateFunction name+++rawAggregateFunction :: Table Expr i => QualifiedName -> Aggregator1 i (Expr a)+rawAggregateFunction name =+  unsafeMakeAggregator+    id+    (fromPrimExpr . fromColumn)+    Empty+    (Opaleye.makeAggrExplicit unpackspec+      (Opaleye.AggrOther (showQualifiedName name)))
+ src/Rel8/Array.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE OverloadedStrings #-}++module Rel8.Array+  (+    -- ** @ListTable@+    ListTable+  , head, headExpr+  , index, indexExpr+  , last, lastExpr+  , length, lengthExpr+  , elem++    -- ** @NonEmptyTable@+  , NonEmptyTable+  , head1, head1Expr+  , index1, index1Expr+  , last1, last1Expr+  , length1, length1Expr+  , elem1++    -- ** Unsafe+  , unsafeSubscript+  , unsafeSubscripts+  )+where++-- base+import Data.List.NonEmpty (NonEmpty)+import Prelude hiding (elem, head, last, length)++-- rel8+import Rel8.Expr (Expr)+import Rel8.Expr.Array (listOf, nonEmptyOf)+import Rel8.Expr.Function (rawBinaryOperator)+import Rel8.Expr.List+import Rel8.Expr.NonEmpty+import Rel8.Expr.Subscript+import Rel8.Schema.Null (Sql)+import Rel8.Table.List+import Rel8.Table.NonEmpty+import Rel8.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 = (<@) . listOf . pure+  where+    (<@) = rawBinaryOperator "<@"+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 = (<@) . nonEmptyOf . pure+  where+    (<@) = rawBinaryOperator "<@"+infix 4 `elem1`
+ src/Rel8/Column/Null.hs view
@@ -0,0 +1,26 @@+{-# language DataKinds #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeFamilyDependencies #-}++module Rel8.Column.Null+  ( HNull+  )+where++-- base+import Data.Kind ( Type )+import Prelude++-- rel8+import qualified Rel8.Schema.Kind as K+import Rel8.Schema.Result ( Result )+import Rel8.Table.Null ( NullTable )+++-- | Nest a 'Null' value within a 'Rel8able'. @HNull f a@ will produce a+-- 'NullTable' @a@ in the 'Expr' context, and a @'Maybe' a@ in the 'Result'+-- context.+type HNull :: K.Context -> Type -> Type+type family HNull context = maybe | maybe -> context where+  HNull Result = Maybe+  HNull context = NullTable context
+ src/Rel8/Decoder.hs view
@@ -0,0 +1,6 @@+module Rel8.Decoder (+  Decoder (..),+  Parser,+  parseDecoder,+) where+import Rel8.Type.Decoder
+ src/Rel8/Encoder.hs view
@@ -0,0 +1,4 @@+module Rel8.Encoder (+  Encoder (..),+) where+import Rel8.Type.Encoder
src/Rel8/Expr.hs view
@@ -3,6 +3,7 @@ {-# language FlexibleContexts #-} {-# language FlexibleInstances #-} {-# language MultiParamTypeClasses #-}+{-# language OverloadedStrings #-} {-# language ScopedTypeVariables #-} {-# language StandaloneKindSignatures #-} {-# language TypeApplications #-}@@ -16,6 +17,7 @@  -- base import Data.Functor.Identity ( Identity( Identity ) )+import Data.Ratio (denominator, numerator) import Data.String ( IsString, fromString ) import Prelude hiding ( null ) @@ -23,7 +25,7 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye  -- rel8-import Rel8.Expr.Function ( function, nullaryFunction )+import Rel8.Expr.Function (function) import Rel8.Expr.Null ( liftOpNull, nullify ) import Rel8.Expr.Opaleye   ( castExpr@@ -45,7 +47,10 @@ import Rel8.Type.Num ( DBFloating, DBFractional, DBNum ) import Rel8.Type.Semigroup ( DBSemigroup, (<>.) ) +-- scientific+import Data.Scientific (fromRationalRepetendLimited) + -- | Typed SQL expressions. type Expr :: K.Context newtype Expr a = Expr Opaleye.PrimExpr@@ -88,17 +93,24 @@ instance Sql DBFractional a => Fractional (Expr a) where   (/) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:/)) -  fromRational =-    castExpr . Expr . Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac+  fromRational = castExpr . Expr . toScientific+    where+      toScientific r = case fromRationalRepetendLimited 20 r of+        Right (s, Nothing) -> Opaleye.ConstExpr (Opaleye.NumericLit s)+        _ -> Opaleye.BinExpr (Opaleye.:/) (int n) (int d)+          where+            int = Opaleye.ConstExpr . Opaleye.NumericLit . fromInteger+            n = numerator r+            d = denominator r   instance Sql DBFloating a => Floating (Expr a) where-  pi = nullaryFunction "PI"+  pi = function "pi" ()   exp = function "exp"   log = function "ln"   sqrt = function "sqrt"   (**) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:^))-  logBase = function "log"+  logBase a b = function "log" (a, b)   sin = function "sin"   cos = function "cos"   tan = function "tan"
src/Rel8/Expr/Aggregate.hs view
@@ -1,189 +1,495 @@ {-# language DataKinds #-}+{-# language DisambiguateRecordFields #-} {-# language FlexibleContexts #-}+{-# language NamedFieldPuns #-}+{-# language OverloadedStrings #-} {-# language ScopedTypeVariables #-}+{-# language TypeApplications #-} {-# 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+  ( count, countOn, countStar+  , countDistinct, countDistinctOn+  , countWhere, countWhereOn+  , and, andOn, or, orOn+  , min, minOn, max, maxOn+  , sum, sumOn, sumWhere+  , avg, avgOn+  , stringAgg, stringAggOn+  , mode, modeOn+  , percentile, percentileOn+  , percentileContinuous, percentileContinuousOn+  , hypotheticalRank+  , hypotheticalDenseRank+  , hypotheticalPercentRank+  , hypotheticalCumeDist+  , groupByExpr, groupByExprOn+  , distinctAggregate+  , filterWhereExplicit+  , listAggExpr, listAggExprOn, nonEmptyAggExpr, nonEmptyAggExprOn+  , listCatExpr, listCatExprOn, nonEmptyCatExpr, nonEmptyCatExprOn   , slistAggExpr, snonEmptyAggExpr+  , slistCatExpr, snonEmptyCatExpr   ) where  -- base+import Data.Functor.Contravariant ((>$<)) import Data.Int ( Int64 ) import Data.List.NonEmpty ( NonEmpty )-import Prelude hiding ( and, max, min, null, or, sum )+import Data.String (IsString)+import Prelude hiding (and, max, min, null, or, show, sum)  -- opaleye+import qualified Opaleye.Aggregate as Opaleye+import qualified Opaleye.Internal.Aggregate as Opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye+import qualified Opaleye.Internal.Operators as Opaleye +-- profunctors+import Data.Profunctor (dimap, lmap)+ -- rel8-import Rel8.Aggregate ( Aggregate, Aggregator(..), unsafeMakeAggregate )+import Rel8.Aggregate+  ( Aggregator' (Aggregator)+  , Aggregator1+  , filterWhereExplicit+  , unsafeMakeAggregator+  )+import Rel8.Aggregate.Fold (Fallback (Empty, Fallback)) import Rel8.Expr ( Expr )-import Rel8.Expr.Bool ( caseExpr )+import Rel8.Expr.Array (sempty)+import Rel8.Expr.Bool (false, true)+import Rel8.Expr.Eq ((/=.)) import Rel8.Expr.Opaleye   ( castExpr-  , fromPrimExpr+  , fromColumn   , fromPrimExpr+  , toColumn   , toPrimExpr+  , unsafeCastExpr   )-import Rel8.Expr.Null ( null )-import Rel8.Expr.Serialize ( litExpr )+import Rel8.Expr.Order (asc)+import Rel8.Expr.Read (sread)+import Rel8.Expr.Show (show)+import qualified Rel8.Expr.Text as Text+import Rel8.Order (Order (Order)) import Rel8.Schema.Null ( Sql, Unnullify )+import Rel8.Table.Opaleye (fromOrder, unpackspec)+import Rel8.Table.Order (ascTable) import Rel8.Type ( DBType, typeInformation )-import Rel8.Type.Array ( encodeArrayElement )+import Rel8.Type.Array (arrayTypeName, quoteArrayElement) import Rel8.Type.Eq ( DBEq )-import Rel8.Type.Information ( TypeInformation )-import Rel8.Type.Num ( DBNum )-import Rel8.Type.Ord ( DBMax, DBMin )+import Rel8.Type.Information (TypeInformation)+import Rel8.Type.Num (DBFractional, DBNum)+import Rel8.Type.Ord (DBMax, DBMin, DBOrd) 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 :: Aggregator' fold (Expr a) (Expr Int64)+count =+  unsafeMakeAggregator+    (toColumn . toPrimExpr)+    (fromPrimExpr . fromColumn)+    (Fallback 0)+    Opaleye.count  --- | Count the number of distinct occurances of a single column. Corresponds to+-- | Applies 'count' to the column selected by the given function.+countOn :: (i -> Expr a) -> Aggregator' fold i (Expr Int64)+countOn f = lmap f count+++-- | Count the number of distinct occurrences 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-    }+countDistinct :: Sql DBEq a+  => Aggregator' fold (Expr a) (Expr Int64)+countDistinct = distinctAggregate count  +-- | Applies 'countDistinct' to the column selected by the given function.+countDistinctOn :: Sql DBEq a+  => (i -> Expr a) -> Aggregator' fold i (Expr Int64)+countDistinctOn f = lmap f countDistinct++ -- | Corresponds to @COUNT(*)@.-countStar :: Aggregate Int64-countStar = count (litExpr True)+countStar :: Aggregator' fold i (Expr Int64)+countStar = lmap (const true) count   -- | 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)+countWhere :: Aggregator' fold (Expr Bool) (Expr Int64)+countWhere = filterWhereExplicit ifPP id countStar  +-- | Applies 'countWhere' to the column selected by the given function.+countWhereOn :: (i -> Expr Bool) -> Aggregator' fold i (Expr Int64)+countWhereOn f = lmap f countWhere++ -- | Corresponds to @bool_and@.-and :: Expr Bool -> Aggregate Bool-and = unsafeMakeAggregate toPrimExpr fromPrimExpr $-  Just Aggregator-    { operation = Opaleye.AggrBoolAnd-    , ordering = []-    , distinction = Opaleye.AggrAll-    }+and :: Aggregator' fold (Expr Bool) (Expr Bool)+and =+  unsafeMakeAggregator+    (toColumn . toPrimExpr)+    (fromPrimExpr . fromColumn)+    (Fallback true)+    Opaleye.boolAnd  +-- | Applies 'and' to the column selected by the given function.+andOn :: (i -> Expr Bool) -> Aggregator' fold i (Expr Bool)+andOn f = lmap f and++ -- | Corresponds to @bool_or@.-or :: Expr Bool -> Aggregate Bool-or = unsafeMakeAggregate toPrimExpr fromPrimExpr $-  Just Aggregator-    { operation = Opaleye.AggrBoolOr-    , ordering = []-    , distinction = Opaleye.AggrAll-    }+or :: Aggregator' fold (Expr Bool) (Expr Bool)+or =+  unsafeMakeAggregator+    (toColumn . toPrimExpr)+    (fromPrimExpr . fromColumn)+    (Fallback false)+    Opaleye.boolOr  --- | 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-    }+-- | Applies 'or' to the column selected by the given function.+orOn :: (i -> Expr Bool) -> Aggregator' fold i (Expr Bool)+orOn f = lmap f or   -- | 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-    }+max :: Sql DBMax a => Aggregator1 (Expr a) (Expr a)+max =+  unsafeMakeAggregator+    (toColumn . toPrimExpr)+    (fromPrimExpr . fromColumn)+    Empty+    Opaleye.unsafeMax ++-- | Applies 'max' to the column selected by the given function.+maxOn :: Sql DBMax a => (i -> Expr a) -> Aggregator1 i (Expr a)+maxOn f = lmap f max+++-- | Produce an aggregation for @Expr a@ using the @min@ function.+min :: Sql DBMin a => Aggregator1 (Expr a) (Expr a)+min =+  unsafeMakeAggregator+    (toColumn . toPrimExpr)+    (fromPrimExpr . fromColumn)+    Empty+    Opaleye.unsafeMin+++-- | Applies 'min' to the column selected by the given function.+minOn :: Sql DBMin a => (i -> Expr a) -> Aggregator1 i (Expr a)+minOn f = lmap f min++ -- | 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+-- this, and will add explicit casts 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-    }+sum :: (Sql DBNum a, Sql DBSum a) => Aggregator' fold (Expr a) (Expr a)+sum =+  unsafeMakeAggregator+    (toColumn . toPrimExpr)+    (fromPrimExpr . fromColumn)+    (Fallback 0)+    Opaleye.unsafeSum  --- | Take the sum of all expressions that satisfy a predicate.+-- | Applies 'sum' to the column selected by the given fucntion.+sumOn :: (Sql DBNum a, Sql DBSum a)+  => (i -> Expr a) -> Aggregator' fold i (Expr a)+sumOn f = lmap f sum+++-- | 'sumWhere' is a combination of 'Rel8.filterWhere' and 'sumOn'. sumWhere :: (Sql DBNum a, Sql DBSum a)-  => Expr Bool -> Expr a -> Aggregate a-sumWhere condition a = sum (caseExpr [(condition, a)] 0)+  => (i -> Expr Bool) -> (i -> Expr a) -> Aggregator' fold i (Expr a)+sumWhere condition = filterWhereExplicit ifPP condition . sumOn  +-- | Corresponds to @avg@. Note that in SQL, @avg@ is type changing - for+-- example, the @avg@ of @integer@ returns a @numeric@. Rel8 doesn't support+-- this, and will add explicit casts back to the original input type. If you+-- need a fractional result on an integral column, you should cast your input+-- to 'Double' or 'Data.Scientific.Scientific' before calling 'avg'.+avg :: Sql DBSum a => Aggregator1 (Expr a) (Expr a)+avg =+  unsafeMakeAggregator+    (toColumn . toPrimExpr)+    (fromPrimExpr . fromColumn)+    Empty+    Opaleye.unsafeAvg+++-- | Applies 'avg' to the column selected by the given fucntion.+avgOn :: Sql DBSum a => (i -> Expr a) -> Aggregator1 i (Expr a)+avgOn f = lmap f avg++ -- | Corresponds to @string_agg()@.-stringAgg :: Sql DBString a-  => Expr db -> Expr a -> Aggregate a+stringAgg :: (Sql IsString a, Sql DBString a)+  => Expr a -> Aggregator' fold (Expr a) (Expr a) stringAgg delimiter =-  unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $-    Just Aggregator-      { operation = Opaleye.AggrStringAggr (toPrimExpr delimiter)-      , ordering = []-      , distinction = Opaleye.AggrAll-      }+  unsafeMakeAggregator+    (toColumn . toPrimExpr)+    (castExpr . fromPrimExpr . fromColumn)+    (Fallback "")+    (Opaleye.stringAgg (toColumn (toPrimExpr delimiter)))  +-- | Applies 'stringAgg' to the column selected by the given function.+stringAggOn :: (Sql IsString a, Sql DBString a)+  => Expr a -> (i -> Expr a) -> Aggregator' fold i (Expr a)+stringAggOn delimiter f = lmap f (stringAgg delimiter)+++-- | Corresponds to @mode() WITHIN GROUP (ORDER BY _)@.+mode :: Sql DBOrd a => Aggregator1 (Expr a) (Expr a)+mode =+  unsafeMakeAggregator+    id+    (fromPrimExpr . fromColumn)+    Empty+    (Opaleye.withinGroup ((\(Order o) -> o) ascTable)+      (Opaleye.makeAggrExplicit (pure ()) (Opaleye.AggrOther "mode")))+++-- | Applies 'mode' to the column selected by the given function.+modeOn :: Sql DBOrd a => (i -> Expr a) -> Aggregator1 i (Expr a)+modeOn f = lmap f mode+++-- | Corresponds to @percentile_disc(_) WITHIN GROUP (ORDER BY _)@.+percentile :: Sql DBOrd a => Expr Double -> Aggregator1 (Expr a) (Expr a)+percentile fraction = +  unsafeMakeAggregator+    (\a -> (fraction, a))+    (castExpr . fromPrimExpr . fromColumn)+    Empty+    (Opaleye.withinGroup ((\(Order o) -> o) (snd >$< ascTable))+      (Opaleye.makeAggrExplicit+        (lmap fst unpackspec)+        (Opaleye.AggrOther "percentile_disc")))+++-- | Applies 'percentile' to the column selected by the given function.+percentileOn ::+  Sql DBOrd a =>+  Expr Double ->+  (i -> Expr a) ->+  Aggregator1 i (Expr a)+percentileOn fraction f = lmap f (percentile fraction)+++-- | Corresponds to @percentile_cont(_) WITHIN GROUP (ORDER BY _)@.+percentileContinuous ::+  Sql DBFractional a =>+  Expr Double ->+  Aggregator1 (Expr a) (Expr a)+percentileContinuous fraction = +  unsafeMakeAggregator+    (\a -> (fraction, a))+    (castExpr . fromPrimExpr . fromColumn)+    Empty+    (Opaleye.withinGroup ((\(Order o) -> o) (unsafeCastExpr @Double . snd >$< asc))+      (Opaleye.makeAggrExplicit+        (lmap fst unpackspec)+        (Opaleye.AggrOther "percentile_disc")))++++-- | Applies 'percentileContinuous' to the column selected by the given+-- function.+percentileContinuousOn ::+  Sql DBFractional a =>+  Expr Double ->+  (i -> Expr a) ->+  Aggregator1 i (Expr a)+percentileContinuousOn fraction f = lmap f (percentileContinuous fraction)+++-- | Corresponds to @rank(_) WITHIN GROUP (ORDER BY _)@.+hypotheticalRank ::+  Order a ->+  a ->+  Aggregator' fold a (Expr Int64)+hypotheticalRank (Order order) args = +  unsafeMakeAggregator+    (\a -> (args, a))+    (castExpr . fromPrimExpr . fromColumn)+    (Fallback 1)+    (Opaleye.withinGroup (snd >$< order)+      (Opaleye.makeAggrExplicit+        (fromOrder (fst >$< order))+        (Opaleye.AggrOther "rank")))+++-- | Corresponds to @dense_rank(_) WITHIN GROUP (ORDER BY _)@.+hypotheticalDenseRank ::+  Order a ->+  a ->+  Aggregator' fold a (Expr Int64)+hypotheticalDenseRank (Order order) args = +  unsafeMakeAggregator+    (const args)+    (castExpr . fromPrimExpr . fromColumn)+    (Fallback 1)+    (Opaleye.withinGroup order+      (Opaleye.makeAggrExplicit (fromOrder order)+        (Opaleye.AggrOther "dense_rank")))+++-- | Corresponds to @percent_rank(_) WITHIN GROUP (ORDER BY _)@.+hypotheticalPercentRank ::+  Order a ->+  a ->+  Aggregator' fold a (Expr Double)+hypotheticalPercentRank (Order order) args = +  unsafeMakeAggregator+    (const args)+    (castExpr . fromPrimExpr . fromColumn)+    (Fallback 0)+    (Opaleye.withinGroup order+      (Opaleye.makeAggrExplicit (fromOrder order)+        (Opaleye.AggrOther "percent_rank")))+++-- | Corresponds to @cume_dist(_) WITHIN GROUP (ORDER BY _)@.+hypotheticalCumeDist ::+  Order a ->+  a ->+  Aggregator' fold a (Expr Double)+hypotheticalCumeDist (Order order) args = +  unsafeMakeAggregator+    (const args)+    (castExpr . fromPrimExpr . fromColumn)+    (Fallback 1)+    (Opaleye.withinGroup order+      (Opaleye.makeAggrExplicit (fromOrder order)+        (Opaleye.AggrOther "cume_dist")))++ -- | Aggregate a value by grouping by it.-groupByExpr :: Sql DBEq a => Expr a -> Aggregate a-groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Nothing+groupByExpr :: Sql DBEq a => Aggregator1 (Expr a) (Expr a)+groupByExpr =+  unsafeMakeAggregator+    (toColumn . toPrimExpr)+    (fromPrimExpr . fromColumn)+    Empty+    Opaleye.groupBy  +-- | Applies 'groupByExpr' to the column selected by the given function.+groupByExprOn :: Sql DBEq a => (i -> Expr a) -> Aggregator1 i (Expr a)+groupByExprOn f = lmap f groupByExpr++ -- | Collect expressions values as a list.-listAggExpr :: Sql DBType a => Expr a -> Aggregate [a]+listAggExpr :: Sql DBType a => Aggregator' fold (Expr a) (Expr [a]) listAggExpr = slistAggExpr typeInformation  +-- | Applies 'listAggExpr' to the column selected by the given function.+listAggExprOn :: Sql DBType a => (i -> Expr a) -> Aggregator' fold i (Expr [a])+listAggExprOn f = lmap f listAggExpr++ -- | Collect expressions values as a non-empty list.-nonEmptyAggExpr :: Sql DBType a => Expr a -> Aggregate (NonEmpty a)+nonEmptyAggExpr :: Sql DBType a => Aggregator1 (Expr a) (Expr (NonEmpty a)) nonEmptyAggExpr = snonEmptyAggExpr typeInformation  +-- | Applies 'nonEmptyAggExpr' to the column selected by the given function.+nonEmptyAggExprOn :: Sql DBType a+  => (i -> Expr a) -> Aggregator1 i (Expr (NonEmpty a))+nonEmptyAggExprOn f = lmap f nonEmptyAggExpr+++-- | Concatenate lists into a single list.+listCatExpr :: Sql DBType a => Aggregator' fold (Expr [a]) (Expr [a])+listCatExpr = slistCatExpr typeInformation+++-- | Applies 'listCatExpr' to the column selected by the given function.+listCatExprOn :: Sql DBType a+  => (i -> Expr [a]) -> Aggregator' fold i (Expr [a])+listCatExprOn f = lmap f listCatExpr+++-- | Concatenate non-empty lists into a single non-empty list.+nonEmptyCatExpr :: Sql DBType a+  => Aggregator1 (Expr (NonEmpty a)) (Expr (NonEmpty a))+nonEmptyCatExpr = snonEmptyCatExpr typeInformation+++-- | Applies 'nonEmptyCatExpr' to the column selected by the given function.+nonEmptyCatExprOn :: Sql DBType a+  => (i -> Expr (NonEmpty a)) -> Aggregator1 i (Expr (NonEmpty a))+nonEmptyCatExprOn f = lmap f nonEmptyCatExpr+++-- | 'distinctAggregate' modifies an 'Aggregator' to consider only distinct+-- values of each particular column. Note that this "distinction" only happens+-- within each column individually, not across all columns simultaneously.+distinctAggregate :: Aggregator' fold i a -> Aggregator' fold i a+distinctAggregate (Aggregator fallback a) =+  Aggregator fallback (Opaleye.distinctAggregator a)++ 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+  => TypeInformation (Unnullify a) -> Aggregator' fold (Expr a) (Expr [a])+slistAggExpr info =+  unsafeMakeAggregator+    (toColumn . quoteArrayElement info . toPrimExpr)+    (fromPrimExpr . fromColumn)+    (Fallback (sempty info))+    Opaleye.arrayAgg   snonEmptyAggExpr :: ()-  => TypeInformation (Unnullify a) -> Expr a -> Aggregate (NonEmpty a)-snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just-  Aggregator-    { operation = Opaleye.AggrArr-    , ordering = []-    , distinction = Opaleye.AggrAll-    }+  => TypeInformation (Unnullify a) -> Aggregator1 (Expr a) (Expr (NonEmpty a))+snonEmptyAggExpr info =+  unsafeMakeAggregator+    (toColumn . quoteArrayElement info . toPrimExpr)+    (fromPrimExpr . fromColumn)+    Empty+    Opaleye.arrayAgg+++slistCatExpr :: ()+  => TypeInformation (Unnullify a) -> Aggregator' fold (Expr [a]) (Expr [a])+slistCatExpr info = dimap (unbracket . show) (sread name . bracket) agg   where-    to = encodeArrayElement info . toPrimExpr+    bracket a = "{" <> a <> "}"+    unbracket a = Text.substr a 2 (Just (Text.length a - 2))+    agg = filterWhereExplicit ifPP (/=. "") (stringAgg ",")+    name = arrayTypeName info+++snonEmptyCatExpr :: ()+  => TypeInformation (Unnullify a)+  -> Aggregator1 (Expr (NonEmpty a)) (Expr (NonEmpty a))+snonEmptyCatExpr info = dimap (unbracket . show) (sread name . bracket) agg+  where+    bracket a = "{" <> a <> "}"+    unbracket a = Text.substr a 2 (Just (Text.length a - 2))+    agg = filterWhereExplicit ifPP (/=. "") (stringAgg ",")+    name = arrayTypeName info+++ifPP :: Opaleye.IfPP (Expr a) (Expr a)+ifPP = dimap from to Opaleye.ifPPField+  where+    from = toColumn . toPrimExpr+    to = fromPrimExpr . fromColumn
src/Rel8/Expr/Array.hs view
@@ -12,7 +12,7 @@ where  -- base-import Data.List.NonEmpty ( NonEmpty )+import Data.List.NonEmpty (NonEmpty) import Prelude  -- opaleye@@ -20,14 +20,11 @@  -- rel8 import {-# SOURCE #-} Rel8.Expr ( Expr )-import Rel8.Expr.Opaleye-  ( fromPrimExpr, toPrimExpr-  , zipPrimExprsWith-  )+import Rel8.Expr.Opaleye (fromPrimExpr, toPrimExpr, zipPrimExprsWith) import Rel8.Type ( DBType, typeInformation )-import Rel8.Type.Array ( array )+import Rel8.Type.Array (array) import Rel8.Type.Information ( TypeInformation(..) )-import Rel8.Schema.Null ( Unnullify, Sql )+import Rel8.Schema.Null (Unnullify, Sql)   sappend :: Expr [a] -> Expr [a] -> Expr [a]
src/Rel8/Expr/Default.hs view
@@ -24,8 +24,13 @@ -- @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+-- 3. @DEFAULT@ values cannot be transformed. For example, the innocuous Rel8 -- code @unsafeDefault + 1@ will crash, despite type checking.+--+-- Also note, PostgreSQL's syntax rules mean that @DEFAULT@ can only appear in+-- @INSERT@ expressions whose rows are specified using @VALUES@. This means+-- that if the @rows@ field of your 'Rel8.Insert' record doesn\'t look like+-- @values [..]@, then @unsafeDefault@ won't work. -- -- Given all these caveats, we suggest avoiding the use of default values where -- possible, instead being explicit. A common scenario where default values are
src/Rel8/Expr/Eq.hs view
@@ -55,9 +55,9 @@ -- | 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 '/=?'.+-- @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
src/Rel8/Expr/Function.hs view
@@ -1,14 +1,19 @@ {-# language FlexibleContexts #-} {-# language FlexibleInstances #-} {-# language MultiParamTypeClasses #-}+{-# language RecordWildCards #-} {-# language StandaloneKindSignatures #-} {-# language TypeFamilies #-}+{-# language TypeOperators #-} {-# language UndecidableInstances #-}  module Rel8.Expr.Function-  ( Function, function-  , nullaryFunction+  ( Arguments+  , function+  , primFunction+  , rawFunction   , binaryOperator+  , rawBinaryOperator   ) where @@ -20,44 +25,69 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye  -- rel8-import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )+import {-# SOURCE #-} Rel8.Expr (Expr) import Rel8.Expr.Opaleye   ( castExpr   , fromPrimExpr, toPrimExpr, zipPrimExprsWith   )+import Rel8.Schema.HTable (hfoldMap) import Rel8.Schema.Null ( Sql )+import Rel8.Schema.QualifiedName+  ( QualifiedName (..)+  , showQualifiedName+  , showQualifiedOperator+  +  )+import Rel8.Table (Table, toColumns) 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+-- | This type class is basically @'Table' 'Expr'@, where each column of the+-- 'Table' is an argument to the function, but it also has an additional+-- instance for @()@ for calling functions with no arguments.+type Arguments :: Type -> Constraint+class Arguments a where+  arguments :: a -> [Opaleye.PrimExpr]  -instance (arg ~ Expr a, Sql DBType b) => Function arg (Expr b) where-  applyArgument f a = castExpr $ fromPrimExpr $ f [toPrimExpr a]+instance Table Expr a => Arguments a where+  arguments = hfoldMap (pure . toPrimExpr) . toColumns  -instance (arg ~ Expr a, Function args res) => Function arg (args -> res) where-  applyArgument f a = applyArgument (f . (toPrimExpr a :))+instance {-# OVERLAPS #-} Arguments () where+  arguments _ = []  --- | 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+-- | @'function' name arguments@ runs the PostgreSQL function @name@ with+-- the arguments @arguments@ returning an @'Expr' a@.+function :: (Arguments arguments, Sql DBType a)+  => QualifiedName -> arguments -> Expr a+function qualified = castExpr . rawFunction qualified  --- | Construct a function call for functions with no arguments.-nullaryFunction :: Sql DBType a => String -> Expr a-nullaryFunction name = castExpr $ Expr (Opaleye.FunExpr name [])+-- | A less safe version of 'function' that does not wrap the return value in+-- a cast.+rawFunction :: Arguments arguments => QualifiedName -> arguments -> Expr a+rawFunction qualified = fromPrimExpr . primFunction qualified  +primFunction :: Arguments arguments+  => QualifiedName -> arguments -> Opaleye.PrimExpr+primFunction qualified = Opaleye.FunExpr name . arguments+  where+    name = showQualifiedName qualified++ -- | 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+binaryOperator :: Sql DBType c => QualifiedName -> Expr a -> Expr b -> Expr c+binaryOperator operator a b = castExpr $ rawBinaryOperator operator a b+++-- | A less safe version of 'binaryOperator' that does not wrap the return+-- value in a cast.+rawBinaryOperator :: QualifiedName -> Expr a -> Expr b -> Expr c+rawBinaryOperator operator a b =+  zipPrimExprsWith (Opaleye.BinExpr (Opaleye.OpOther name)) a b+  where+    name = showQualifiedOperator operator
+ src/Rel8/Expr/List.hs view
@@ -0,0 +1,52 @@+{-# language FlexibleContexts #-}+{-# language MonoLocalBinds #-}++module Rel8.Expr.List (+  headExpr,+  indexExpr,+  lastExpr,+  sheadExpr,+  sindexExpr,+  slastExpr,+  lengthExpr,+) where++-- base+import Data.Int (Int32)+import Prelude++-- rel8+import Rel8.Expr (Expr)+import Rel8.Expr.Opaleye (mapPrimExpr, toPrimExpr)+import Rel8.Schema.Null (Nullify, Sql, Unnullify)+import Rel8.Type (DBType, typeInformation)+import Rel8.Type.Information (TypeInformation)+import qualified Rel8.Type.Array as Prim+++headExpr :: Sql DBType a => Expr [a] -> Expr (Nullify a)+headExpr = sheadExpr typeInformation+++indexExpr :: Sql DBType a => Expr Int32 -> Expr [a] -> Expr (Nullify a)+indexExpr = sindexExpr typeInformation+++lastExpr :: Sql DBType a => Expr [a] -> Expr (Nullify a)+lastExpr = slastExpr typeInformation+++sheadExpr :: TypeInformation (Unnullify a) -> Expr [a] -> Expr (Nullify a)+sheadExpr info = mapPrimExpr (Prim.head info)+++sindexExpr :: TypeInformation (Unnullify a) -> Expr Int32 -> Expr [a] -> Expr (Nullify a)+sindexExpr info i = mapPrimExpr (Prim.index info (toPrimExpr i))+++slastExpr :: TypeInformation (Unnullify a) -> Expr [a] -> Expr (Nullify a)+slastExpr info = mapPrimExpr (Prim.last info)+++lengthExpr :: Expr [a] -> Expr Int32+lengthExpr = mapPrimExpr (Prim.length)
+ src/Rel8/Expr/NonEmpty.hs view
@@ -0,0 +1,53 @@+{-# language FlexibleContexts #-}+{-# language MonoLocalBinds #-}++module Rel8.Expr.NonEmpty (+  head1Expr,+  index1Expr,+  last1Expr,+  shead1Expr,+  sindex1Expr,+  slast1Expr,+  length1Expr,+) where++-- base+import Data.Int (Int32)+import Data.List.NonEmpty (NonEmpty)+import Prelude++-- rel8+import Rel8.Expr (Expr)+import Rel8.Expr.Opaleye (mapPrimExpr, toPrimExpr)+import Rel8.Schema.Null (Nullify, Sql, Unnullify)+import Rel8.Type (DBType, typeInformation)+import Rel8.Type.Information (TypeInformation)+import qualified Rel8.Type.Array as Prim+++head1Expr :: Sql DBType a => Expr (NonEmpty a) -> Expr a+head1Expr = shead1Expr typeInformation+++index1Expr :: Sql DBType a => Expr Int32 -> Expr (NonEmpty a) -> Expr (Nullify a)+index1Expr = sindex1Expr typeInformation+++last1Expr :: Sql DBType a => Expr (NonEmpty a) -> Expr a+last1Expr = slast1Expr typeInformation+++shead1Expr :: TypeInformation (Unnullify a) -> Expr (NonEmpty a) -> Expr a+shead1Expr info = mapPrimExpr (Prim.head info)+++sindex1Expr :: TypeInformation (Unnullify a) -> Expr Int32 -> Expr (NonEmpty a) -> Expr (Nullify a)+sindex1Expr info i = mapPrimExpr (Prim.index info (toPrimExpr i))+++slast1Expr :: TypeInformation (Unnullify a) -> Expr (NonEmpty a) -> Expr a+slast1Expr info = mapPrimExpr (Prim.last info)+++length1Expr :: Expr (NonEmpty a) -> Expr Int32+length1Expr = mapPrimExpr (Prim.length)
src/Rel8/Expr/Null.hs view
@@ -35,6 +35,10 @@ nullify (Expr a) = Expr a  +-- | Assume that a nullable column's value is non-null. If the column is+-- actually @null@, this will lead to runtime errors when you try to decode+-- the value into Haskell, so you should prefer to use 'Rel8.nullable'+-- unless you know what you're doing. unsafeUnnullify :: Expr (Maybe a) -> Expr a unsafeUnnullify (Expr a) = Expr a
src/Rel8/Expr/Num.hs view
@@ -1,21 +1,28 @@ {-# 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.Eq ( (==.) )+import Rel8.Expr.Function (function) import Rel8.Expr.Opaleye ( castExpr ) import Rel8.Schema.Null ( Homonullable, Sql )+import Rel8.Table.Bool ( bool ) import Rel8.Type.Num ( DBFractional, DBIntegral, DBNum )  @@ -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 view
@@ -1,6 +1,7 @@ {-# language FlexibleContexts #-} {-# language NamedFieldPuns #-} {-# language ScopedTypeVariables #-}+{-# language TypeApplications #-} {-# language TypeFamilies #-}  {-# options_ghc -fno-warn-redundant-constraints #-}@@ -8,9 +9,11 @@ module Rel8.Expr.Opaleye   ( castExpr, unsafeCastExpr   , scastExpr, sunsafeCastExpr+  , unsafeCoerceExpr+  , unsafePrimExpr   , unsafeLiteral   , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith, traversePrimExpr-  , toColumn, fromColumn+  , toColumn, fromColumn, traverseFieldP   ) where @@ -26,33 +29,54 @@ import Rel8.Schema.Null ( Unnullify, Sql ) import Rel8.Type ( DBType, typeInformation ) import Rel8.Type.Information ( TypeInformation(..) )+import Rel8.Type.Name (TypeName, showTypeName) +-- profunctors+import Data.Profunctor ( Profunctor, dimap ) + 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+unsafeCastExpr :: forall b a. Sql DBType b => Expr a -> Expr b+unsafeCastExpr = case typeInformation @(Unnullify b) of+  TypeInformation {typeName} -> sunsafeCastExpr typeName  +-- | Change the type of an 'Expr', without a cast. Even more unsafe than+-- 'unsafeCastExpr'. Only use this if you are certain that the @typeName@s of+-- @a@ and @b@ refer to exactly the same PostgreSQL type.+unsafeCoerceExpr :: Expr a -> Expr b+unsafeCoerceExpr (Expr a) = Expr a+++-- | Import a raw 'Opaleye.PrimExpr' from @opaleye@, without a cast.+--+-- This is an escape hatch, and can be used if Rel8 cannot adequately express+-- the expression you need. If you find yourself using this function, please+-- let us know, as it may indicate that something is missing from Rel8!+unsafePrimExpr :: Opaleye.PrimExpr -> Expr a+unsafePrimExpr = fromPrimExpr++ scastExpr :: TypeInformation (Unnullify a) -> Expr a -> Expr a-scastExpr = sunsafeCastExpr+scastExpr TypeInformation {typeName} = sunsafeCastExpr typeName   sunsafeCastExpr :: ()-  => TypeInformation (Unnullify b) -> Expr a -> Expr b-sunsafeCastExpr TypeInformation {typeName} =-  fromPrimExpr . Opaleye.CastExpr typeName . toPrimExpr+  => TypeName -> Expr a -> Expr b+sunsafeCastExpr name =+  fromPrimExpr . Opaleye.CastExpr (showTypeName name) . 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!+-- This is an escape hatch, and can be used if Rel8 cannot adequately express+-- the expression 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 @@ -80,9 +104,15 @@ traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr  -toColumn :: Opaleye.PrimExpr -> Opaleye.Column b+traverseFieldP :: Profunctor p+  => p (Opaleye.Field_ n x) (Opaleye.Field_ m y)+  -> p (Expr a) (Expr b)+traverseFieldP =  dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn)+++toColumn :: Opaleye.PrimExpr -> Opaleye.Field_ n b toColumn = Opaleye.Column  -fromColumn :: Opaleye.Column b -> Opaleye.PrimExpr+fromColumn :: Opaleye.Field_ n b -> Opaleye.PrimExpr fromColumn (Opaleye.Column a) = a
src/Rel8/Expr/Order.hs view
@@ -59,7 +59,7 @@     g orderOp = orderOp { Opaleye.orderNulls = Opaleye.NullsFirst }  --- | Transform an ordering so that @null@ values appear first. This corresponds+-- | Transform an ordering so that @null@ values appear last. This corresponds -- to @NULLS LAST@ in SQL. nullsLast :: Order (Expr a) -> Order (Expr (Maybe a)) nullsLast (Order (Opaleye.Order f)) =
+ src/Rel8/Expr/Read.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MonoLocalBinds #-}++module Rel8.Expr.Read+  ( read+  , sread+  )+where++-- base+import Prelude ()++-- rel8+import Rel8.Expr (Expr)+import Rel8.Expr.Opaleye (unsafeCastExpr, sunsafeCastExpr)+import Rel8.Schema.Null (Sql)+import Rel8.Type (DBType)+import Rel8.Type.Name (TypeName)++-- text+import Data.Text (Text)+++read :: Sql DBType a => Expr Text -> Expr a+read = unsafeCastExpr+++sread :: TypeName -> Expr Text -> Expr a+sread = sunsafeCastExpr
src/Rel8/Expr/Sequence.hs view
@@ -7,15 +7,19 @@ import Data.Int ( Int64 ) import Prelude +-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye+ -- rel8 import Rel8.Expr ( Expr )-import Rel8.Expr.Function ( function )-import Rel8.Expr.Serialize ( litExpr )---- text-import Data.Text ( pack )+import Rel8.Expr.Opaleye (fromPrimExpr)+import Rel8.Schema.QualifiedName (QualifiedName, showQualifiedName)   -- | See https://www.postgresql.org/docs/current/functions-sequence.html-nextval :: String -> Expr Int64-nextval = function "nextval" . litExpr . pack+nextval :: QualifiedName -> Expr Int64+nextval name =+  fromPrimExpr $+    Opaleye.FunExpr "nextval"+      [ Opaleye.ConstExpr (Opaleye.StringLit (showQualifiedName name))+      ]
src/Rel8/Expr/Serialize.hs view
@@ -1,3 +1,4 @@+{-# language DisambiguateRecordFields #-} {-# language FlexibleContexts #-} {-# language NamedFieldPuns #-} {-# language TypeFamilies #-}@@ -23,6 +24,8 @@ import Rel8.Expr.Opaleye ( scastExpr ) import Rel8.Schema.Null ( Unnullify, Nullity( Null, NotNull ), Sql, nullable ) import Rel8.Type ( DBType, typeInformation )+import Rel8.Type.Decoder (Decoder (..))+import Rel8.Type.Encoder (Encoder (..)) import Rel8.Type.Information ( TypeInformation(..) )  @@ -35,15 +38,15 @@   slitExpr :: Nullity a -> TypeInformation (Unnullify a) -> a -> Expr a-slitExpr nullity info@TypeInformation {encode} =+slitExpr nullity info@TypeInformation {encode = Encoder {quote}} =   scastExpr info . Expr . encoder   where     encoder = case nullity of-      Null -> maybe (Opaleye.ConstExpr Opaleye.NullLit) encode-      NotNull -> encode+      Null -> maybe (Opaleye.ConstExpr Opaleye.NullLit) quote+      NotNull -> quote   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+sparseValue nullity TypeInformation {decode = Decoder {binary}} = case nullity of+  Null -> Hasql.column $ Hasql.nullable binary+  NotNull -> Hasql.column $ Hasql.nonNullable binary
+ src/Rel8/Expr/Show.hs view
@@ -0,0 +1,18 @@+module Rel8.Expr.Show+  ( show+  )+where++-- base+import Prelude ()++-- rel8+import Rel8.Expr (Expr)+import Rel8.Expr.Opaleye (unsafeCastExpr)++-- text+import Data.Text (Text)+++show :: Expr a -> Expr Text+show = unsafeCastExpr
+ src/Rel8/Expr/Subscript.hs view
@@ -0,0 +1,65 @@+{-# language FlexibleContexts #-}+{-# language MonoLocalBinds #-}++module Rel8.Expr.Subscript+  ( unsafeSubscript+  , unsafeSubscripts+  )+where++-- base+import Data.Foldable (foldl')+import Prelude++-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye++-- rel8+import Rel8.Expr (Expr)+import Rel8.Expr.Opaleye (fromPrimExpr, toPrimExpr)+import Rel8.Schema.HTable (hfoldMap)+import Rel8.Schema.Null (Sql, Unnullify)+import Rel8.Table (Table, toColumns)+import Rel8.Type (DBType, typeInformation)+import Rel8.Type.Array (extractArrayElement)+import Rel8.Type.Information (TypeInformation)+++-- | @'unsafeSubscript' a i@ will generate the SQL @a[i]@.+--+-- Note that this function is not type checked and the generated SQL has no+-- casts. This is only intended an escape hatch to be used if Rel8 cannot+-- otherwise express the expression you need. If you find yourself using this+-- function, please let us know, as it may indicate that something is missing+-- from Rel8!+unsafeSubscript :: Sql DBType b => Expr a -> Expr i -> Expr b+unsafeSubscript = sunsafeSubscript typeInformation+++-- | @'unsafeSubscripts' a (i, j)@ will generate the SQL @a[i][j]@.+--+-- Note that this function is not type checked and the generated SQL has no+-- casts. This is only intended an escape hatch to be used if Rel8 cannot+-- otherwise express the expression you need. If you find yourself using this+-- function, please let us know, as it may indicate that something is missing+-- from Rel8!+unsafeSubscripts :: (Table Expr i, Sql DBType b) => Expr a -> i -> Expr b+unsafeSubscripts = sunsafeSubscripts typeInformation+++sunsafeSubscript :: TypeInformation (Unnullify b) -> Expr a -> Expr i -> Expr b+sunsafeSubscript info array i =+  fromPrimExpr . extractArrayElement info $+    Opaleye.ArrayIndex (toPrimExpr array) (toPrimExpr i)+++sunsafeSubscripts :: Table Expr i => TypeInformation (Unnullify b) -> Expr a -> i -> Expr b+sunsafeSubscripts info array i =+  fromPrimExpr $ extractArrayElement info $ primSubscripts array indices+  where+    indices = hfoldMap (pure . toPrimExpr) $ toColumns i+++primSubscripts :: Expr a -> [Opaleye.PrimExpr] -> Opaleye.PrimExpr+primSubscripts array indices =+  foldl' Opaleye.ArrayIndex (toPrimExpr array) indices
src/Rel8/Expr/Text.hs view
@@ -1,4 +1,5 @@ {-# language DataKinds #-}+{-# language OverloadedStrings #-}  module Rel8.Expr.Text   (@@ -17,6 +18,9 @@   , pgClientEncoding, quoteIdent, quoteLiteral, quoteNullable, regexpReplace   , regexpSplitToArray, repeat, replace, reverse, right, rpad, rtrim   , splitPart, strpos, substr, translate++    -- * @LIKE@ and @ILIKE@+  , like, ilike   ) where @@ -24,14 +28,18 @@ import Data.Bool ( Bool ) import Data.Int ( Int32 ) import Data.Maybe ( Maybe( Nothing, Just ) )-import Prelude ()+import Prelude ( flip )  -- bytestring import Data.ByteString ( ByteString ) +-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye+ -- rel8 import Rel8.Expr ( Expr )-import Rel8.Expr.Function ( binaryOperator, function, nullaryFunction )+import Rel8.Expr.Function (binaryOperator, function)+import Rel8.Expr.Opaleye (zipPrimExprsWith)  -- text import Data.Text (Text)@@ -49,10 +57,10 @@   -- | Matches regular expression, case sensitive--- --- Corresponds to the @~.@ operator.+--+-- Corresponds to the @~@ operator. (~.) :: Expr Text -> Expr Text -> Expr Bool-(~.) = binaryOperator "~."+(~.) = binaryOperator "~" infix 2 ~.  @@ -117,7 +125,7 @@  -- | Corresponds to the @btrim@ function. btrim :: Expr Text -> Maybe (Expr Text) -> Expr Text-btrim a (Just b) = function "btrim" a b+btrim a (Just b) = function "btrim" (a, b) btrim a Nothing = function "btrim" a  @@ -128,27 +136,27 @@  -- | Corresponds to the @convert@ function. convert :: Expr ByteString -> Expr Text -> Expr Text -> Expr ByteString-convert = function "convert"+convert a b c = function "convert" (a, b, c)   -- | Corresponds to the @convert_from@ function. convertFrom :: Expr ByteString -> Expr Text -> Expr Text-convertFrom = function "convert_from"+convertFrom a b = function "convert_from" (a, b)   -- | Corresponds to the @convert_to@ function. convertTo :: Expr Text -> Expr Text -> Expr ByteString-convertTo = function "convert_to"+convertTo a b = function "convert_to" (a, b)   -- | Corresponds to the @decode@ function. decode :: Expr Text -> Expr Text -> Expr ByteString-decode = function "decode"+decode a b = function "decode" (a, b)   -- | Corresponds to the @encode@ function. encode :: Expr ByteString -> Expr Text -> Expr Text-encode = function "encode"+encode a b = function "encode" (a, b)   -- | Corresponds to the @initcap@ function.@@ -158,7 +166,7 @@  -- | Corresponds to the @left@ function. left :: Expr Text -> Expr Int32 -> Expr Text-left = function "left"+left a b = function "left" (a, b)   -- | Corresponds to the @length@ function.@@ -168,18 +176,18 @@  -- | Corresponds to the @length@ function. lengthEncoding :: Expr ByteString -> Expr Text -> Expr Int32-lengthEncoding = function "length"+lengthEncoding a b = function "length" (a, b)   -- | 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+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 (Just b) = function "ltrim" (a, b) ltrim a Nothing = function "ltrim" a  @@ -190,7 +198,7 @@  -- | Corresponds to the @pg_client_encoding()@ expression. pgClientEncoding :: Expr Text-pgClientEncoding = nullaryFunction "pg_client_encoding"+pgClientEncoding = function "pg_client_encoding" ()   -- | Corresponds to the @quote_ident@ function.@@ -211,25 +219,25 @@ -- | 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+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+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"+repeat a b = function "repeat" (a, b)   -- | Corresponds to the @replace@ function. replace :: Expr Text -> Expr Text -> Expr Text -> Expr Text-replace = function "replace"+replace a b c = function "replace" (a, b, c)   -- | Corresponds to the @reverse@ function.@@ -239,37 +247,55 @@  -- | Corresponds to the @right@ function. right :: Expr Text -> Expr Int32 -> Expr Text-right = function "right"+right a b = function "right" (a, b)   -- | 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+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 (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"+splitPart a b c = function "split_part" (a, b, c)   -- | Corresponds to the @strpos@ function. strpos :: Expr Text -> Expr Text -> Expr Int32-strpos = function "strpos"+strpos a b = function "strpos" (a, b)   -- | 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+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"+translate a b c = function "translate" (a, b, c)+++-- | @like x y@ corresponds to the expression @y LIKE x@.+--+-- Note that the arguments to @like@ are swapped. This is to aid currying, so+-- you can write expressions like+-- @filter (like "Rel%" . packageName) =<< each haskellPackages@+like :: Expr Text -> Expr Text -> Expr Bool+like = flip (zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpLike))+++-- | @ilike x y@ corresponds to the expression @y ILIKE x@.+--+-- Note that the arguments to @ilike@ are swapped. This is to aid currying, so+-- you can write expressions like+-- @filter (ilike "Rel%" . packageName) =<< each haskellPackages@+ilike :: Expr Text -> Expr Text -> Expr Bool+ilike = flip (zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpILike))
src/Rel8/Expr/Time.hs view
@@ -1,3 +1,5 @@+{-# language OverloadedStrings #-}+ module Rel8.Expr.Time   ( -- * Working with @Day@     today@@ -30,7 +32,7 @@  -- rel8 import Rel8.Expr ( Expr )-import Rel8.Expr.Function ( binaryOperator, nullaryFunction )+import Rel8.Expr.Function (binaryOperator, function) import Rel8.Expr.Opaleye ( castExpr, unsafeCastExpr, unsafeLiteral )  -- time@@ -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/Expr/Window.hs view
@@ -0,0 +1,149 @@+module Rel8.Expr.Window+  ( cumulative+  , rowNumber+  , rank+  , denseRank+  , percentRank+  , cumeDist+  , ntile+  , lagExpr, lagExprOn+  , leadExpr, leadExprOn+  , firstValueExpr, firstValueExprOn+  , lastValueExpr, lastValueExprOn+  , nthValueExpr, nthValueExprOn+  )+where++-- base+import Data.Int ( Int32, Int64 )+import Prelude++-- opaleye+import qualified Opaleye.Internal.Aggregate as Opaleye+import qualified Opaleye.Internal.PackMap as Opaleye+import qualified Opaleye.Internal.Window as Opaleye+import qualified Opaleye.Window as Opaleye++-- profunctors+import Data.Profunctor (dimap, lmap)++-- rel8+import Rel8.Aggregate (Aggregator' (Aggregator))+import Rel8.Expr ( Expr )+import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr, toColumn, toPrimExpr )+import Rel8.Schema.Null ( Nullify )+import Rel8.Window ( Window( Window ) )+++-- | 'cumulative' allows the use of aggregation functions in 'Window'+-- expressions. In particular, @'cumulative' 'Rel8.sum'@+-- (when combined with 'Rel8.Window.orderPartitionBy') gives a running total,+-- also known as a \"cumulative sum\", hence the name @cumulative@.+cumulative :: Aggregator' fold i a -> Window i a+cumulative f =+  fromWindowFunction $ Opaleye.aggregatorWindowFunction (fromAggregate f) id+++-- | [@row_number()@](https://www.postgresql.org/docs/current/functions-window.html)+rowNumber :: Window i (Expr Int64)+rowNumber = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.rowNumber+++-- | [@rank()@](https://www.postgresql.org/docs/current/functions-window.html)+rank :: Window i (Expr Int64)+rank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.rank+++-- | [@dense_rank()@](https://www.postgresql.org/docs/current/functions-window.html)+denseRank :: Window i (Expr Int64)+denseRank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.denseRank+++-- | [@percent_rank()@](https://www.postgresql.org/docs/current/functions-window.html)+percentRank :: Window i (Expr Double)+percentRank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.percentRank+++-- | [@cume_dist()@](https://www.postgresql.org/docs/current/functions-window.html)+cumeDist :: Window i (Expr Double)+cumeDist = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.cumeDist+++-- | [@ntile(num_buckets)@](https://www.postgresql.org/docs/current/functions-window.html)+ntile :: Expr Int32 -> Window i (Expr Int32)+ntile buckets = fromWindowFunction $ fromPrimExpr . fromColumn <$>+  Opaleye.ntile (toColumn (toPrimExpr buckets))+++-- | [@lag(value, offset, default)@](https://www.postgresql.org/docs/current/functions-window.html)+lagExpr :: Expr Int32 -> Expr a -> Window (Expr a) (Expr a)+lagExpr offset def =+  fromWindowFunction $+    dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $+      Opaleye.lag (toColumn (toPrimExpr offset)) (toColumn (toPrimExpr def))+++-- | Applies 'lag' to the column selected by the given function.+lagExprOn :: Expr Int32 -> Expr a -> (i -> Expr a) -> Window i (Expr a)+lagExprOn offset def f = lmap f (lagExpr offset def)+++-- | [@lead(value, offset, default)@](https://www.postgresql.org/docs/current/functions-window.html)+leadExpr :: Expr Int32 -> Expr a -> Window (Expr a) (Expr a)+leadExpr offset def =+  fromWindowFunction $+    dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $+      Opaleye.lead (toColumn (toPrimExpr offset)) (toColumn (toPrimExpr def))+++-- | Applies 'lead' to the column selected by the given function.+leadExprOn :: Expr Int32 -> Expr a -> (i -> Expr a) -> Window i (Expr a)+leadExprOn offset def f = lmap f (leadExpr offset def)+++-- | [@first_value(value)@](https://www.postgresql.org/docs/current/functions-window.html)+firstValueExpr :: Window (Expr a) (Expr a)+firstValueExpr =+  fromWindowFunction $+    dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn)+      Opaleye.firstValue+++-- | Applies 'firstValue' to the column selected by the given function.+firstValueExprOn :: (i -> Expr a) -> Window i (Expr a)+firstValueExprOn f = lmap f firstValueExpr+++-- | [@last_value(value)@](https://www.postgresql.org/docs/current/functions-window.html)+lastValueExpr :: Window (Expr a) (Expr a)+lastValueExpr =+  fromWindowFunction $+    dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn)+      Opaleye.lastValue+++-- | Applies 'lastValue' to the column selected by the given function.+lastValueExprOn :: (i -> Expr a) -> Window i (Expr a)+lastValueExprOn f = lmap f lastValueExpr+++-- | [@nth_value(value, n)@](https://www.postgresql.org/docs/current/functions-window.html)+nthValueExpr :: Expr Int32 -> Window (Expr a) (Expr (Nullify a))+nthValueExpr n =+  fromWindowFunction $+    dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $+      Opaleye.nthValue (toColumn (toPrimExpr n))+++-- | [@nth_value(value, n)@](https://www.postgresql.org/docs/current/functions-window.html)+nthValueExprOn :: Expr Int32 -> (i -> Expr a) -> Window i (Expr (Nullify a))+nthValueExprOn n f = lmap f (nthValueExpr n)+++fromAggregate :: Aggregator' fold i a -> Opaleye.Aggregator i a+fromAggregate (Aggregator _ a) = a+++fromWindowFunction :: Opaleye.WindowFunction i a -> Window i a+fromWindowFunction (Opaleye.WindowFunction (Opaleye.PackMap w)) =+  Window $ Opaleye.Windows $ Opaleye.PackMap $ \f -> w $ \o -> f (o, mempty)
src/Rel8/Generic/Construction.hs view
@@ -7,6 +7,7 @@ {-# language StandaloneKindSignatures #-} {-# language TypeApplications #-} {-# language TypeFamilies #-}+{-# language TypeOperators #-} {-# language UndecidableInstances #-} {-# language ViewPatterns #-} @@ -15,23 +16,21 @@   , GGBuild, ggbuild   , GGConstructable   , GGConstruct, ggconstruct-  , GGDeconstruct, ggdeconstruct+  , GGDeconstruct, ggdeconstruct, ggdeconstructA   , GGName, ggname-  , GGAggregate, ggaggregate   ) where  -- base import Data.Bifunctor ( first )+import Data.Functor ((<&>)) 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 )@@ -39,10 +38,10 @@ import Rel8.Generic.Construction.ADT   ( GConstructorADT, GMakeableADT, gmakeADT   , GConstructableADT-  , GBuildADT, gbuildADT, gunbuildADT+  , GBuildADT, gbuildADT   , GConstructADT, gconstructADT, gdeconstructADT   , RepresentableConstructors, GConstructors, gcindex, gctabulate-  , RepresentableFields, gfindex, gftabulate+  , RepresentableFields, gftabulate   ) import Rel8.Generic.Construction.Record   ( GConstructor@@ -55,7 +54,6 @@   , 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@@ -69,11 +67,14 @@ import Rel8.Table.Bool ( case_ ) import Rel8.Type.Tag ( Tag ) +-- semigroupoids+import Data.Functor.Apply (Apply)+import Data.Semigroup.Traversable (sequence1, traverse1) + 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))))@@ -137,7 +138,6 @@ 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))))@@ -148,20 +148,16 @@ 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 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))     )@@ -249,6 +245,43 @@             case_ cases' r  +ggdeconstructA :: forall algebra rep a f r. (GGConstructable algebra rep, Apply f, Table Expr r)+  => (a -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)+  -> GGDeconstruct algebra rep a (f r)+ggdeconstructA gtoColumns = case algebraSing @algebra of+  SProduct -> \build ->+    gindex @Id @(Eval (rep Expr)) @(f r) build .+    gdeconstruct+      @(TTable Expr)+      @TColumns+      @Id+      @Expr+      @(Eval (rep Expr))+      (const fromColumns) .+    gtoColumns+  SSum ->+    gctabulate @Id @(Eval (rep Expr)) @(f r) @(a -> f 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+        fcases = traverse1 sequence1 cases+      in+        fcases+          <&> \((_, 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@@ -281,72 +314,3 @@       (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 view
@@ -77,10 +77,10 @@  type NoConstructor :: Symbol -> Symbol -> ErrorMessage type NoConstructor datatype constructor =-  ( 'Text "The type `" ':<>:-    'Text datatype ':<>:-    'Text "` has no constructor `" ':<>:-    'Text constructor ':<>:+  ( 'Text "The type `" ' :<>:+    'Text datatype ' :<>:+    'Text "` has no constructor `" ' :<>:+    'Text constructor ' :<>:     'Text "`."   )
src/Rel8/Generic/Construction/Record.hs view
@@ -63,8 +63,8 @@ type family GConstructor rep where   GConstructor (M1 D _ (M1 C ('MetaCons name _ _) _)) = name   GConstructor (M1 D ('MetaData name _ _ _) _) = TypeError (-    'Text "`" ':<>:-    'Text name ':<>:+    'Text "`" ' :<>:+    'Text name ' :<>:     'Text "` does not appear to have exactly 1 constructor"    )
src/Rel8/Generic/Record.hs view
@@ -142,6 +142,7 @@   uncount = id  +type Record :: Type -> Type newtype Record a = Record   { unrecord :: a   }
src/Rel8/Generic/Rel8able.hs view
@@ -33,7 +33,6 @@ import Prelude  -- rel8-import Rel8.Aggregate ( Aggregate ) import Rel8.Expr ( Expr ) import Rel8.FCF ( Exp, Eval ) import Rel8.Generic.Record ( Record(..) )@@ -63,6 +62,11 @@ -- 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 == a" (where a is a+  -- KRel8able), which occurs when we have polymorphic Rel8ables+  -- (e.g., newtype T t f = T { x :: t a })+  (a :: KRel8able) == (a :: KRel8able) = 'True+   -- 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 })@@ -141,7 +145,7 @@ -- [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+-- project. To do this, enable the @DeriveAnyClass@ and @DeriveGeneric@ language -- extensions: -- -- @@@ -164,40 +168,40 @@   type GColumns t = G.GColumns TColumns (GRep t Expr)   type GFromExprs t = t Result +  {-# NOINLINE gfromColumns #-} -- See Note [Generics and Inlining]   default gfromColumns :: forall context.-    ( SRel8able t Aggregate-    , SRel8able t Expr+    ( 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 +  {-# NOINLINE gtoColumns #-} -- See Note [Generics and Inlining]   default gtoColumns :: forall context.-    ( SRel8able t Aggregate-    , SRel8able t Expr+    ( 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 +  {-# NOINLINE gfromResult #-} -- See Note [Generics and Inlining]   default gfromResult :: (SSerialize t, GFromExprs t ~ t Result)     => GColumns t Result -> GFromExprs t   gfromResult = sfromResult +  {-# NOINLINE gtoResult #-} -- See Note [Generics and Inlining]   default gtoResult :: (SSerialize t, GFromExprs t ~ t Result)     => GFromExprs t -> GColumns t Result   gtoResult = stoResult@@ -274,3 +278,11 @@     (\(_ :: proxy x) -> serialize @_ @x) .   from .   Record++-- Note [Generics and Inlining]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- We want to make sure that Generics derived functions (by default)+-- do not expose their unfoldings. These are always unoptimised code and can+-- therefore be quite large, and bloat our interfaces.+-- By marking these as NOINLINE we can considerably speed up our compile times.+-- If users do want these INLINEd, they can locally override the default using a pragma.
src/Rel8/Kind/Context.hs view
@@ -14,7 +14,6 @@ import Prelude ()  -- rel8-import Rel8.Aggregate ( Aggregate ) import Rel8.Expr ( Expr ) import Rel8.Schema.Field ( Field ) import Rel8.Schema.Kind ( Context )@@ -24,7 +23,6 @@  type SContext :: Context -> Type data SContext context where-  SAggregate :: SContext Aggregate   SExpr :: SContext Expr   SField :: SContext (Field table)   SName :: SContext Name@@ -34,10 +32,6 @@ type Reifiable :: Context -> Constraint class Reifiable context where   contextSing :: SContext context---instance Reifiable Aggregate where-  contextSing = SAggregate   instance Reifiable Expr where
src/Rel8/Order.hs view
@@ -4,7 +4,6 @@  module Rel8.Order   ( Order(..)-  , toOrderExprs   ) where @@ -17,8 +16,7 @@ import Data.Functor.Contravariant.Divisible ( Decidable, Divisible )  -- opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye-import qualified Opaleye.Internal.Order as Opaleye+import qualified Opaleye.Order as Opaleye   -- | An ordering expression for @a@. Primitive orderings are defined with@@ -30,8 +28,3 @@ 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 view
@@ -1,4 +1,6 @@+{-# language FlexibleContexts #-} {-# language StandaloneKindSignatures #-}+{-# language UndecidableInstances #-}  module Rel8.Query   ( Query( Query )@@ -15,15 +17,16 @@ -- 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.PrimQuery as Opaleye hiding (lateral) import qualified Opaleye.Internal.QueryArr as Opaleye import qualified Opaleye.Internal.Tag as Opaleye  -- rel8+import Rel8.Expr ( Expr ) import Rel8.Query.Set ( unionAll ) import Rel8.Query.Opaleye ( fromOpaleye ) import Rel8.Query.Values ( values )-import Rel8.Table ( fromColumns, toColumns )+import Rel8.Table ( Table, fromColumns, toColumns ) import Rel8.Table.Alternative   ( AltTable, (<|>:)   , AlternativeTable, emptyTable@@ -175,14 +178,14 @@   instance Monad Query where-  Query q >>= f = Query $ \dummies -> Opaleye.QueryArr $ \(_, tag) ->+  Query q >>= f = Query $ \dummies -> Opaleye.stateQueryArr $ \_ tag ->     let-      Opaleye.QueryArr qa = q dummies-      ((m, a), query, tag') = qa ((), tag)+      qa = q dummies+      ((m, a), query, tag') = Opaleye.runStateQueryArr qa () tag       Query q' = f a       (dummies', query', tag'') =         ( dummy : dummies-        , \lateral -> Opaleye.Rebind True bindings . query lateral+        , query <> Opaleye.aRebind bindings         , Opaleye.next tag'         )         where@@ -190,11 +193,11 @@             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'')+      qa' = Opaleye.lateral $ \_ -> q' dummies'+      ((m'@(Any needsDummies), b), query'', tag''') = Opaleye.runStateQueryArr qa' () tag''       query'''-        | needsDummies = \lateral -> query'' lateral . query' lateral-        | otherwise = \lateral -> query'' lateral . query lateral+        | needsDummies = query' <> query''+        | otherwise = query <> query''       m'' = m <> m'     in       ((m'', b), query''', tag''')@@ -208,3 +211,13 @@ -- | 'emptyTable' = 'values' @[]@. instance AlternativeTable Query where   emptyTable = values []+++-- | '<>' = 'unionAll'.+instance Table Expr a => Semigroup (Query a) where+  (<>) = (<|>:)+++-- | 'mempty' = @'values' []@.+instance Table Expr a => Monoid (Query a) where+  mempty = emptyTable
src/Rel8/Query/Aggregate.hs view
@@ -1,37 +1,59 @@ {-# language FlexibleContexts #-} {-# language MonoLocalBinds #-}+{-# language ScopedTypeVariables #-}  module Rel8.Query.Aggregate   ( aggregate+  , aggregate1+  , aggregateU   , countRows   ) where  -- base+import Control.Applicative (liftA2) import Data.Int ( Int64 ) import Prelude  -- opaleye+import qualified Opaleye.Adaptors as Opaleye import qualified Opaleye.Aggregate as Opaleye  -- rel8-import Rel8.Aggregate ( Aggregates )+import Rel8.Aggregate (Aggregator' (Aggregator), Aggregator)+import Rel8.Aggregate.Fold (Fallback (Fallback)) import Rel8.Expr ( Expr ) import Rel8.Expr.Aggregate ( countStar )+import Rel8.Expr.Bool (true) import Rel8.Query ( Query ) import Rel8.Query.Maybe ( optional ) import Rel8.Query.Opaleye ( mapOpaleye )-import Rel8.Table.Opaleye ( aggregator )-import Rel8.Table.Maybe ( maybeTable )+import Rel8.Table (Table)+import Rel8.Table.Maybe (fromMaybeTable)+import Rel8.Table.Opaleye (unpackspec)  --- | Apply an aggregation to all rows returned by a 'Query'.-aggregate :: Aggregates aggregates exprs => Query aggregates -> Query exprs-aggregate = mapOpaleye (Opaleye.aggregate aggregator)+-- | Apply an 'Aggregator' to all rows returned by a 'Query'. If the 'Query'+-- is empty, then a single \"fallback\" row is returned, composed of the+-- identity elements of the constituent aggregation functions.+aggregate :: (Table Expr i, Table Expr a) => Aggregator i a -> Query i -> Query a+aggregate aggregator@(Aggregator (Fallback fallback) _) =+  fmap (fromMaybeTable fallback) . optional . aggregate1 aggregator  +-- | Apply an 'Rel8.Aggregator1' to all rows returned by a 'Query'. If+-- the 'Query' is empty, then zero rows are returned.+aggregate1 :: Table Expr i => Aggregator' fold i a -> Query i -> Query a+aggregate1 = aggregateU unpackspec+++aggregateU :: Opaleye.Unpackspec i i -> Aggregator' fold i a -> Query i -> Query a+aggregateU unpack (Aggregator _ aggregator) =+  mapOpaleye (Opaleye.aggregateExplicit unpack 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)+countRows = aggregate countStar . (true <$)
src/Rel8/Query/Distinct.hs view
@@ -1,5 +1,3 @@-{-# options_ghc -fno-warn-redundant-constraints #-}- module Rel8.Query.Distinct   ( distinct   , distinctOn@@ -8,38 +6,35 @@ where  -- base-import Prelude+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+import qualified Opaleye.Distinct as Opaleye+import qualified Opaleye.Order 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 )+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)+distinct = mapOpaleye (Opaleye.distinctExplicit unpackspec 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))+distinctOn proj = mapOpaleye (Opaleye.distinctOnExplicit unpackspec proj)   -- | 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))+distinctOnBy proj (Order order) = mapOpaleye (Opaleye.distinctOnByExplicit unpackspec proj order)
src/Rel8/Query/Exists.hs view
@@ -12,7 +12,7 @@  -- opaleye import qualified Opaleye.Exists as Opaleye-import qualified Opaleye.Operators as Opaleye hiding ( exists )+import qualified Opaleye.Operators as Opaleye  -- rel8 import Rel8.Expr ( Expr )
+ src/Rel8/Query/Function.hs view
@@ -0,0 +1,32 @@+{-# language FlexibleContexts #-}+{-# language MonoLocalBinds #-}++module Rel8.Query.Function+  ( queryFunction+  )+where++-- base+import Prelude++-- opaleye+import qualified Opaleye.Internal.Operators as Opaleye++-- rel8+import Rel8.Expr (Expr)+import Rel8.Expr.Function (Arguments, primFunction)+import Rel8.Query (Query)+import Rel8.Query.Opaleye (fromOpaleye)+import Rel8.Schema.QualifiedName (QualifiedName)+import Rel8.Table (Table)+import Rel8.Table.Opaleye (castTable, relExprPP)+++-- | Select each row from a function that returns a relation. This is+-- equivalent to @FROM function(input)@.+queryFunction :: (Arguments input, Table Expr output)+  => QualifiedName -> input -> Query output+queryFunction name input = fmap castTable $ fromOpaleye $+  Opaleye.relationValuedExprExplicit relExprPP (const expr)+  where+    expr = primFunction name input
src/Rel8/Query/Indexed.hs view
@@ -4,31 +4,18 @@ where  -- base+import Control.Applicative ( liftA2 ) 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.Expr.Window ( rowNumber ) import Rel8.Query ( Query )-import Rel8.Query.Opaleye ( mapOpaleye )+import Rel8.Query.Window ( window )+import Rel8.Table.Window ( currentRow )   -- | 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'')+indexed = window (liftA2 (,) (subtract 1 <$> rowNumber) currentRow)
src/Rel8/Query/List.hs view
@@ -11,6 +11,7 @@ where  -- base+import Control.Monad ((>=>)) import Data.Functor.Identity ( runIdentity ) import Data.List.NonEmpty ( NonEmpty ) import Prelude@@ -23,21 +24,18 @@ 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.Query.Aggregate (aggregate, aggregate1)+import Rel8.Query.Rebind (hrebind, rebind)+import Rel8.Schema.HTable (HTable, hfield, hspecs, htabulate) import Rel8.Schema.HTable.Vectorize ( hunvectorize )-import Rel8.Schema.Null ( Sql, Unnullify )+import Rel8.Schema.Null ( Sql ) import Rel8.Schema.Spec ( Spec( Spec, info ) )-import Rel8.Table ( Table, fromColumns )-import Rel8.Table.Cols ( toCols )+import Rel8.Table (Table, fromColumns, toColumns) 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 ( DBType ) import Rel8.Type.Array ( extractArrayElement )-import Rel8.Type.Information ( TypeInformation )   -- | Aggregate a 'Query' into a 'ListTable'. If the supplied query returns 0@@ -48,11 +46,7 @@ -- @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)+many = aggregate listAgg   -- | Aggregate a 'Query' into a 'NonEmptyTable'. If the supplied query returns@@ -64,20 +58,17 @@ -- @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)+some = aggregate1 nonEmptyAgg   -- | 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+manyExpr = aggregate listAggExpr   -- | A version of 'many' specialised to single expressions. someExpr :: Sql DBType a => Query (Expr a) -> Query (Expr (NonEmpty a))-someExpr = aggregate . fmap nonEmptyAggExpr+someExpr = aggregate1 nonEmptyAggExpr   -- | Expand a 'ListTable' into a 'Query', where each row in the query is an@@ -86,8 +77,8 @@ -- @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+  fmap fromColumns $ (hrebind "unnest" >=> hextract) $ runIdentity $+    hunvectorize (\_ -> pure . unnest) as   -- | Expand a 'NonEmptyTable' into a 'Query', where each row in the query is an@@ -96,8 +87,8 @@ -- @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+  fmap fromColumns $ (hrebind "unnest" >=> hextract) $ runIdentity $+    hunvectorize (\_ -> pure . unnest) as   -- | Expand an expression that contains a list into a 'Query', where each row@@ -105,7 +96,7 @@ -- -- @catList@ is an inverse to 'manyExpr'. catList :: Sql DBType a => Expr [a] -> Query (Expr a)-catList = rebind "unnest" . sunnest typeInformation+catList = rebind "unnest" . unnest >=> extract   -- | Expand an expression that contains a non-empty list into a 'Query', where@@ -113,10 +104,21 @@ -- -- @catNonEmpty@ is an inverse to 'someExpr'. catNonEmpty :: Sql DBType a => Expr (NonEmpty a) -> Query (Expr a)-catNonEmpty = rebind "unnest" . sunnest typeInformation+catNonEmpty = rebind "unnest" . unnest >=> extract  -sunnest :: TypeInformation (Unnullify a) -> Expr (list a) -> Expr a-sunnest info = mapPrimExpr $-  extractArrayElement info .-  Opaleye.UnExpr (Opaleye.UnOpOther "UNNEST")+unnest :: Expr (list a) -> Expr a+unnest = mapPrimExpr $ Opaleye.UnExpr (Opaleye.UnOpOther "UNNEST")+++extract :: Table Expr a => a -> Query a+extract = fmap fromColumns . hextract . toColumns+++hextract :: HTable t => t Expr -> Query (t Expr)+hextract = hrebind "extract" . go+  where+    go as = htabulate $ \field ->+      case hfield as field of+        a -> case hfield hspecs field of+          Spec {info} -> mapPrimExpr (extractArrayElement info) a
+ src/Rel8/Query/Loop.hs view
@@ -0,0 +1,73 @@+{-# language FlexibleContexts #-}++module Rel8.Query.Loop+  ( loop+  , loopDistinct+  ) where++-- base+import Prelude++-- opaleye+import Opaleye.With (withRecursiveExplicit, withRecursiveDistinctExplicit)++-- rel8+import Rel8.Expr ( Expr )+import Rel8.Query ( Query )+import Rel8.Query.Opaleye ( fromOpaleye, toOpaleye )+import Rel8.Table ( Table )+import Rel8.Table.Opaleye ( binaryspec )+++-- | 'loop' allows the construction of recursive queries, using Postgres'+-- [@WITH RECURSIVE@](https://www.postgresql.org/docs/current/queries-with.html#QUERIES-WITH-RECURSIVE)+-- under the hood. The first argument to 'loop' is what the Postgres+-- documentation refers to as the \"non-recursive term\" and the second+-- argument is the \"recursive term\", which is defined in terms of the result+-- of the \"non-recursive term\". 'loop' uses @UNION ALL@ to combine the+-- recursive and non-recursive terms.+--+-- Denotionally, @'loop' s f@ is the smallest set of rows @r@ such+-- that+--+-- @+-- r == s \`'Rel8.unionAll'\` (r >>= f)+-- @+--+-- Operationally, @'loop' s f@ takes each row in an initial set @s@ and+-- supplies it to @f@, resulting in a new generation of rows which are added+-- to the result set. Each row from this new generation is then fed back to+-- @f@, and this process is repeated until a generation comes along for which+-- @f@ returns an empty set for each row therein.+loop :: Table Expr a => Query a -> (a -> Query a) -> Query a+loop base recurse =+  fromOpaleye $ withRecursiveExplicit binaryspec base' recurse'+  where+    base' = toOpaleye base+    recurse' = toOpaleye . recurse+++-- | 'loopDistinct' is like 'loop' but uses @UNION@ instead of @UNION ALL@ to+-- combine the recursive and non-recursive terms.+--+-- Denotationally, @'loopDistinct' s f@ is the smallest set of rows+-- @r@ such that+--+-- @+-- r == s \`'Rel8.union'\` (r >>= f)+-- @+--+-- Operationally, @'loopDistinct' s f@ takes each /distinct/ row in an+-- initial set @s@ and supplies it to @f@, resulting in a new generation of+-- rows. Any rows returned by @f@ that already exist in the result set are not+-- considered part of this new generation by 'loopDistinct' (in contrast to+-- 'loop'). This new generation is then added to the result set, and each row+-- therein is then fed back to @f@, and this process is repeated until a+-- generation comes along for which @f@ returns no rows that don't already+-- exist in the result set.+loopDistinct :: Table Expr a => Query a -> (a -> Query a) -> Query a+loopDistinct base recurse =+  fromOpaleye $ withRecursiveDistinctExplicit binaryspec base' recurse'+  where+    base' = toOpaleye base+    recurse' = toOpaleye . recurse
+ src/Rel8/Query/Materialize.hs view
@@ -0,0 +1,40 @@+{-# language FlexibleContexts #-}++module Rel8.Query.Materialize+  ( materialize+  )+where++-- base+import Prelude++-- opaleye+import Opaleye.With ( withMaterializedExplicit )++-- rel8+import Rel8.Expr ( Expr )+import Rel8.Query ( Query )+import Rel8.Query.Opaleye ( fromOpaleye, toOpaleye )+import Rel8.Table ( Table )+import Rel8.Table.Opaleye ( unpackspec )+++-- | 'materialize' takes a 'Query' and fully evaluates it and caches the+-- results thereof, and passes to a continuation a new 'Query' that simply+-- looks up these cached results. It's usually best not to use this and to let+-- the Postgres optimizer decide for itself what's best, but if you know what+-- you're doing this can sometimes help to nudge it in a particular direction.+--+-- 'materialize' is currently implemented in terms of Postgres'+-- [@WITH](https://www.postgresql.org/docs/current/queries-with.html) syntax,+-- specifically the @WITH _ AS MATERIALIZED (_)@ form introduced in PostgreSQL+-- 12. This means that 'materialize' can only be used with PostgreSQL 12 or+-- newer.+materialize :: Table Expr a => Query a -> (Query a -> Query b) -> Query b+materialize query f =+  fromOpaleye $+    withMaterializedExplicit unpackspec+      (toOpaleye query')+      (toOpaleye . f . fromOpaleye)+  where+    query' = query
src/Rel8/Query/Maybe.hs view
@@ -21,11 +21,10 @@ -- 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 )+import Rel8.Table.Maybe (MaybeTable(..), isJustTable, makeMaybeTable)   -- | Convert a query that might return zero rows to a query that always returns@@ -34,10 +33,7 @@ -- 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-  }+optional = mapOpaleye $ Opaleye.optionalInternal makeMaybeTable   -- | Filter out 'MaybeTable's, returning only the tables that are not-null.
src/Rel8/Query/Null.hs view
@@ -1,5 +1,8 @@+{-# language FlexibleContexts #-}+ module Rel8.Query.Null   ( catNull+  , catNullTable   ) where @@ -9,6 +12,8 @@ -- rel8 import Rel8.Expr ( Expr ) import Rel8.Expr.Null ( isNonNull, unsafeUnnullify )+import Rel8.Table ( Table )+import Rel8.Table.Null ( NullTable, isNonNullTable, unsafeUnnullifyTable ) import Rel8.Query ( Query ) import Rel8.Query.Filter ( where_ ) @@ -21,3 +26,13 @@ catNull a = do   where_ $ isNonNull a   pure $ unsafeUnnullify a+++-- | Filter a 'Query' that might return @nullTable@ to a 'Query' without any+-- @nullTable@s.+--+-- Corresponds to 'Data.Maybe.catMaybes'.+catNullTable :: Table Expr a => NullTable Expr a -> Query a+catNullTable a = do+  where_ $ isNonNullTable a+  pure $ unsafeUnnullifyTable a
src/Rel8/Query/Opaleye.hs view
@@ -41,30 +41,30 @@  unsafePeekQuery :: Query a -> a unsafePeekQuery (Query q) = case q mempty of-  Opaleye.QueryArr f -> case f ((), Opaleye.start) of+  f -> case Opaleye.runStateQueryArr 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) ->+mapping f q = Opaleye.stateQueryArr $ \_ tag ->   let-    ((m, _), _, _) = qa ((), tag)-    Opaleye.QueryArr qa' = (m,) <$> f (snd <$> q)+    ((m, _), _, _) = Opaleye.runStateQueryArr q () tag+    q' = (m,) <$> f (snd <$> q)   in-    qa' ((), tag)+    Opaleye.runStateQueryArr q' () 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) ->+zipping f q q' =+  Opaleye.stateQueryArr $ \_ tag ->     let-      ((m, _), _, _) = qa ((), tag)-      ((m', _), _, _) = qa' ((), tag)+      ((m, _), _, _) = Opaleye.runStateQueryArr q () tag+      ((m', _), _, _) = Opaleye.runStateQueryArr q' () tag       m'' = m <> m'-      Opaleye.QueryArr qa'' = (m'',) <$> f (snd <$> q) (snd <$> q')+      q'' = (m'',) <$> f (snd <$> q) (snd <$> q')     in-      qa'' ((), tag)+      Opaleye.runStateQueryArr q'' () tag
src/Rel8/Query/Rebind.hs view
@@ -2,34 +2,35 @@  module Rel8.Query.Rebind   ( rebind+  , hrebind   ) where  -- base import Prelude+import Control.Arrow ((<<<))  -- 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+import qualified Opaleye.Internal.Rebind as Opaleye  -- rel8 import Rel8.Expr ( Expr )-import Rel8.Query ( Query( Query ) )+import Rel8.Query ( Query )+import Rel8.Query.Limit (offset)+import Rel8.Schema.HTable (HTable) import Rel8.Table ( Table )+import Rel8.Table.Cols (Cols (Cols)) import Rel8.Table.Opaleye ( unpackspec )+import Rel8.Query.Opaleye (fromOpaleye)   -- | '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')+rebind prefix a = offset 0 $+  fromOpaleye (Opaleye.rebindExplicitPrefix prefix unpackspec <<< pure a)+++hrebind :: HTable t => String -> t Expr -> Query (t Expr)+hrebind prefix = fmap (\(Cols a) -> a) . rebind prefix . Cols
src/Rel8/Query/SQL.hs view
@@ -9,13 +9,19 @@ -- base import Prelude +-- opaleye+import qualified Opaleye.Internal.Tag as Opaleye+ -- rel8 import Rel8.Expr ( Expr ) import Rel8.Query ( Query ) import Rel8.Statement.Select ( ppSelect ) import Rel8.Table ( Table ) +-- transformers+import Control.Monad.Trans.State.Strict (evalState) + -- | Convert a 'Query' to a 'String' containing a @SELECT@ statement. showQuery :: Table Expr a => Query a -> String-showQuery = show . ppSelect+showQuery = show . (`evalState` Opaleye.start) . ppSelect
src/Rel8/Query/Set.hs view
@@ -23,36 +23,36 @@   -- | 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@.+-- duplicates.  @union a b@ is the same as the SQL statement @a 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 a b@ is the same as the SQL statement @a 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@.+-- b@ is the same as the SQL statement @a 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@.+-- a b@ is the same as the SQL statement @a 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@.+-- the same as the SQL statement @a 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@.+-- is the same as the SQL statement @a EXCEPT ALL b@. exceptAll :: EqTable a => Query a -> Query a -> Query a exceptAll = zipOpaleyeWith (Opaleye.exceptAllExplicit binaryspec)
src/Rel8/Query/These.hs view
@@ -48,11 +48,11 @@ 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''')+alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.stateQueryArr $ \_ t -> case t of+  tag -> (tab, join', tag''')     where-      (ma, left', tag') = Opaleye.runSimpleQueryArr (pure <$> left) ((), tag)-      (mb, right', tag'') = Opaleye.runSimpleQueryArr (pure <$> right) ((), tag')+      (ma, left', tag') = Opaleye.runStateQueryArr (pure <$> left) () tag+      (mb, right', tag'') = Opaleye.runStateQueryArr (pure <$> right) () tag'       MaybeTable hasHere a = ma       MaybeTable hasThere b = mb       (hasHere', lbindings) = Opaleye.run $ do@@ -60,15 +60,15 @@       (hasThere', rbindings) = Opaleye.run $ do         traversePrimExpr (Opaleye.extractAttr "hasThere" tag'') hasThere       tag''' = Opaleye.next tag''-      join lateral = Opaleye.Join Opaleye.FullJoin on left'' right''+      join = 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')+          left'' = (Opaleye.NonLateral, Opaleye.toPrimQuery (left' <> Opaleye.aRebind lbindings))+          right'' = (Opaleye.NonLateral, Opaleye.toPrimQuery (right' <> Opaleye.aRebind rbindings))       ma' = MaybeTable hasHere' a       mb' = MaybeTable hasThere' b       tab = TheseTable {here = ma', there = mb'}-      join' lateral input = Opaleye.times lateral input (join lateral)+      join' = Opaleye.aProduct join   keepHereTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)
+ src/Rel8/Query/Window.hs view
@@ -0,0 +1,26 @@+module Rel8.Query.Window+  ( window+  )+where++-- base+import Prelude ()++-- opaleye+import qualified Opaleye.Window as Opaleye++-- rel8+import Rel8.Query ( Query )+import Rel8.Query.Opaleye ( mapOpaleye )+import Rel8.Window ( Window( Window ) )+++-- | 'window' runs a query composed of expressions containing+-- [window functions](https://www.postgresql.org/docs/current/tutorial-window.html).+-- 'window' is similar to 'Rel8.aggregate', with the main difference being+-- that in a window query, each input row corresponds to one output row,+-- whereas aggregation queries fold the entire input query down into a single+-- row. To put this into a Haskell context, 'Rel8.aggregate' is to 'foldl' as+-- 'window' is to 'scanl'.+window :: Window a b -> Query a -> Query b+window (Window a) = mapOpaleye (Opaleye.runWindows a)
src/Rel8/Schema/Context/Nullify.hs view
@@ -10,7 +10,6 @@   ( Nullifiability(..), NonNullifiability(..), nullifiableOrNot, absurd   , Nullifiable, nullifiability   , guarder, nullifier, unnullifier-  , sguard, snullify   ) where @@ -24,7 +23,6 @@ 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 )@@ -40,7 +38,6 @@  type Nullifiability :: K.Context -> Type data Nullifiability context where-  NAggregate :: Nullifiability Aggregate   NExpr :: Nullifiability Expr   NName :: Nullifiability Name @@ -50,10 +47,6 @@   nullifiability :: Nullifiability context  -instance Nullifiable Aggregate where-  nullifiability = NAggregate-- instance Nullifiable Expr where   nullifiability = NExpr @@ -72,7 +65,6 @@   => SContext context   -> Either (NonNullifiability context) (Nullifiability context) nullifiableOrNot = \case-  SAggregate -> Right NAggregate   SExpr -> Right NExpr   SField -> Left NField   SName -> Right NName@@ -81,7 +73,6 @@  absurd :: Nullifiability context -> NonNullifiability context -> a absurd = \case-  NAggregate -> \case   NExpr -> \case   NName -> \case @@ -94,7 +85,6 @@   -> 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@@ -108,8 +98,6 @@   -> 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 @@ -120,8 +108,6 @@   -> 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
+ src/Rel8/Schema/Escape.hs view
@@ -0,0 +1,20 @@+{-# language LambdaCase #-}++module Rel8.Schema.Escape+  ( escape+  )+where++-- base+import Prelude++-- pretty+import Text.PrettyPrint (Doc, doubleQuotes, text)+++escape :: String -> Doc+escape = doubleQuotes . text . concatMap go+  where+    go = \case+      '"' -> "\"\""+      c -> [c]
src/Rel8/Schema/HTable.hs view
@@ -15,14 +15,17 @@  module Rel8.Schema.HTable   ( HTable (HField, HConstrainTable)-  , hfield, htabulate, htraverse, hdicts, hspecs-  , hmap, htabulateA+  , hfield, htabulate, hdicts, hspecs+  , hfoldMap, hmap, htabulateA, htabulateP+  , htraverse, htraverse_, htraverseP, htraversePWithField   ) where  -- base-import Data.Kind ( Constraint, Type )+import Data.Functor (void) import Data.Functor.Compose ( Compose( Compose ), getCompose )+import Data.Functor.Const ( Const( Const ), getConst )+import Data.Kind ( Constraint, Type ) import Data.Proxy ( Proxy ) import GHC.Generics   ( (:*:)( (:*:) )@@ -32,6 +35,12 @@   ) import Prelude +-- profunctors+import Data.Profunctor ( rmap, Profunctor (lmap) )++-- product-profunctors+import Data.Profunctor.Product ( ProductProfunctor ((****)) )+ -- rel8 import Rel8.Schema.Dict ( Dict ) import Rel8.Schema.Spec ( Spec )@@ -39,8 +48,7 @@ import qualified Rel8.Schema.Kind as K  -- semigroupoids-import Data.Functor.Apply ( Apply, (<.>) )-+import Data.Functor.Apply (Apply, (<.>), liftF2)  -- | A @HTable@ is a functor-indexed/higher-kinded data type that is -- representable ('htabulate'/'hfield'), constrainable ('hdicts'), and@@ -114,15 +122,62 @@   {-# INLINABLE hspecs #-}  +hfoldMap :: (HTable t, Semigroup s)+  => (forall a. context a -> s) -> t context -> s+hfoldMap f a = getConst $ htraverse (Const . f) a++ hmap :: HTable t   => (forall a. context a -> context' a) -> t context -> t context' hmap f a = htabulate $ \field -> f (hfield a field)  +newtype Ap f a = Ap+  { getAp :: f a+  }+++instance (Apply f, Semigroup a) => Semigroup (Ap f a) where+  Ap a <> Ap b = Ap (liftF2 (<>) a b)+++htraverse_ :: (HTable t, Apply f)+  => (forall a. context a -> f b) -> t context -> f ()+htraverse_ f a = getAp $ hfoldMap (Ap . void . f) a++ 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 #-}+++htabulateP :: (HTable t, ProductProfunctor p)+  => (forall a. HField t a -> p i (context a)) -> p i (t context)+htabulateP f = unApplyP $ htraverse (ApplyP . getCompose) $ htabulate $ Compose . f+{-# INLINABLE htabulateP #-}+++newtype ApplyP p a b = ApplyP { unApplyP :: p a b }+++instance Profunctor p => Functor (ApplyP p a) where+  fmap f = ApplyP . rmap f . unApplyP+++instance ProductProfunctor p => Apply (ApplyP p a) where+  ApplyP f <.> ApplyP x = ApplyP (rmap id f **** x)+++htraverseP :: (HTable t, ProductProfunctor p)+  => (forall a. p (f a) (g a)) -> p (t f) (t g)+htraverseP f = htraversePWithField (const f)+++htraversePWithField :: (HTable t, ProductProfunctor p)+  => (forall a. HField t a -> p (f a) (g a)) -> p (t f) (t g)+htraversePWithField f =+  htabulateP $ \field -> lmap (flip hfield field) (f field)   type GHField :: K.HTable -> Type -> Type
src/Rel8/Schema/HTable/Nullify.hs view
@@ -32,9 +32,17 @@ import GHC.Generics ( Generic ) import Prelude hiding ( null ) +-- profunctors+import Data.Profunctor (lmap, rmap)++-- product-profunctors+import Data.Profunctor.Product (ProductProfunctor)+ -- rel8 import Rel8.FCF ( Eval, Exp )-import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs )+import Rel8.Schema.HTable+  ( HTable, hfield, hspecs, htabulate, htabulateA, htabulateP+  ) import Rel8.Schema.HTable.MapTable   ( HMapTable, HMapTableField( HMapTableField )   , MapSpec, mapInfo@@ -90,13 +98,11 @@ {-# 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)+hnullify :: (HTable t, ProductProfunctor p)+  => (forall a. Spec a -> p (context a) (context (Type.Nullify a)))+  -> p (t context) (HNullify t context)+hnullify nullifier = rmap HNullify $ htabulateP $ \(HMapTableField field) ->+  lmap (`hfield` field) (nullifier (hfield hspecs field)) {-# INLINABLE hnullify #-}
src/Rel8/Schema/HTable/Vectorize.hs view
@@ -2,13 +2,15 @@ {-# language ConstraintKinds #-} {-# language DataKinds #-} {-# language DeriveAnyClass #-}+{-# language DeriveFunctor #-} {-# language DeriveGeneric #-}-{-# language DerivingStrategies #-}+{-# language DerivingVia #-} {-# language FlexibleContexts #-} {-# language FlexibleInstances #-} {-# language GADTs #-} {-# language LambdaCase #-} {-# language MultiParamTypeClasses #-}+{-# language NamedFieldPuns #-} {-# language RankNTypes #-} {-# language RecordWildCards #-} {-# language ScopedTypeVariables #-}@@ -19,24 +21,37 @@  module Rel8.Schema.HTable.Vectorize   ( HVectorize-  , hvectorize, hunvectorize+  , hvectorize, hvectorizeA, hunvectorize+  , hnullify   , happend, hempty   , hproject+  , htraverseVectorP   , hcolumn+  , First (..)   ) where  -- base-import Data.Kind ( Type )+import Data.Kind ( Constraint, Type ) import Data.List.NonEmpty ( NonEmpty )+import qualified Data.Semigroup as Base import GHC.Generics (Generic) import Prelude +-- product-profunctors+import Data.Profunctor.Product (ProductProfunctor)++-- profunctors+import Data.Profunctor (dimap)+ -- 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+  ( HField, HTable, hfield, htabulate, htabulateA, hspecs+  , htraversePWithField+  ) import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) ) import Rel8.Schema.HTable.MapTable   ( HMapTable( HMapTable ), HMapTableField( HMapTableField )@@ -44,15 +59,21 @@   , Precompose( Precompose )   ) import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject )-import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )+import Rel8.Schema.HTable.Nullify (HNullify (HNullify))+import Rel8.Schema.Null (Nullify, 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(..) )+import Data.Align (Semialign, alignWith)+import Data.Zip (Unzip, Zip, Zippy(..), zipWith) +-- semigroupoids+import Data.Functor.Apply (Apply) ++type Vector :: (Type -> Type) -> Constraint class Vector list where   listNotNull :: proxy a -> Dict NotNull (list a)   vectorTypeInformation :: ()@@ -103,6 +124,16 @@ {-# INLINABLE hvectorize #-}  +hvectorizeA :: (HTable t, Apply f, Vector list)+  => (forall a. Spec a -> HField t a -> f (context' (list a)))+  -> f (HVectorize list t context')+hvectorizeA vectorizer = fmap HVectorize $+  htabulateA $ \(HMapTableField field) ->+    case hfield hspecs field of+      spec -> vectorizer spec field+{-# INLINABLE hvectorizeA #-}++ hunvectorize :: (HTable t, Zip f, Vector list)   => (forall a. Spec a -> context (list a) -> f (context' a))   -> HVectorize list t context@@ -138,5 +169,37 @@ hproject f (HVectorize a) = HVectorize (HMapTable.hproject f a)  +htraverseVectorP :: (HTable t, ProductProfunctor p)+  => (forall a. HField t a -> p (f (list a)) (g (list' a)))+  -> p (HVectorize list t f) (HVectorize list' t g)+htraverseVectorP f =+  dimap (\(HVectorize (HMapTable a)) -> a) (HVectorize . HMapTable) $+    htraversePWithField $ \field ->+      dimap (\(Precompose a) -> a) Precompose (f field)++ hcolumn :: HVectorize list (HIdentity a) context -> context (list a) hcolumn (HVectorize (HMapTable (HIdentity (Precompose a)))) = a+++hnullify :: forall t list context. (HTable t, Vector list)+  => (forall a. Spec a -> context (list a) -> context (Nullify a))+  -> HVectorize list t context+  -> HNullify t context+hnullify f (HVectorize table) = HNullify $+  htabulate $ \(HMapTableField field) -> case hfield hspecs field of+    spec -> case hfield table (HMapTableField field) of+      a -> f spec a+++newtype First a b = First {getFirst :: a}+  deriving stock Functor+  deriving (Semigroup) via (Base.First a)+++instance Semialign (First a) where+  alignWith _ (First a) _ = First a+++instance Zip (First a) where+  zipWith _ (First a) _ = First a
− 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 view
@@ -7,6 +7,7 @@ {-# language RankNTypes #-} {-# language StandaloneKindSignatures #-} {-# language TypeFamilies #-}+{-# language TypeOperators #-} {-# language UndecidableInstances #-} {-# language UndecidableSuperClasses #-}
+ src/Rel8/Schema/QualifiedName.hs view
@@ -0,0 +1,62 @@+{-# language DerivingStrategies #-}+{-# language DuplicateRecordFields #-}+{-# language RecordWildCards #-}+{-# language StandaloneKindSignatures #-}+{-# language StrictData #-}++module Rel8.Schema.QualifiedName+  ( QualifiedName (..)+  , ppQualifiedName+  , showQualifiedName+  , showQualifiedOperator+  )+where++-- base+import Data.Kind (Type)+import Data.String (IsString, fromString)+import Prelude++-- pretty+import Text.PrettyPrint (Doc, parens, text)++-- rel8+import Rel8.Schema.Escape (escape)+++-- | A name of an object (such as a table, view, function or sequence)+-- qualified by an optional schema. In the absence of an explicit schema,+-- the connection's @search_path@ will be used implicitly.+type QualifiedName :: Type+data QualifiedName = QualifiedName+  { name :: String+    -- ^ The name of the object.+  , schema :: Maybe String+    -- ^ The schema that this object belongs to. If 'Nothing', whatever is on+    -- the connection's @search_path@ will be used.+   }+  deriving stock (Eq, Ord, Show)+++-- | Constructs 'QualifiedName's with 'schema' set to 'Nothing'.+instance IsString QualifiedName where+  fromString name = QualifiedName {schema = Nothing, ..}+++ppQualifiedName :: QualifiedName -> Doc+ppQualifiedName QualifiedName {schema = mschema, ..} = case mschema of+  Nothing -> name'+  Just schema -> escape schema <> text "." <> name'+  where+    name' = escape name+++showQualifiedName :: QualifiedName -> String+showQualifiedName = show . ppQualifiedName+++showQualifiedOperator :: QualifiedName -> String+showQualifiedOperator QualifiedName {schema = mschema, ..} = case mschema of+  Nothing -> name+  Just schema ->+    show $ text "OPERATOR" <> parens (escape schema <> text "." <> text name)
src/Rel8/Schema/Table.hs view
@@ -1,7 +1,9 @@ {-# language DeriveFunctor #-} {-# language DerivingStrategies #-}-{-# language DisambiguateRecordFields #-}+{-# language DuplicateRecordFields #-} {-# language NamedFieldPuns #-}+{-# language StandaloneKindSignatures #-}+{-# language StrictData #-}  module Rel8.Schema.Table   ( TableSchema(..)@@ -10,37 +12,32 @@ where  -- base+import Data.Kind ( Type ) 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.Schema.QualifiedName (QualifiedName, ppQualifiedName) + -- | 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.+type TableSchema :: Type -> Type data TableSchema names = TableSchema-  { name :: String+  { name :: QualifiedName     -- ^ 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.+    -- ^ The columns of the table. Typically you would use a 'Rel8.Rel8able'+    -- data type here, parameterized by the 'Rel8.Name' context.   }   deriving stock Functor   ppTable :: TableSchema a -> Doc-ppTable TableSchema {name, schema} = Opaleye.ppTable Opaleye.SqlTable-  { sqlTableSchemaName = schema-  , sqlTableName = name-  }+ppTable TableSchema {name} = ppQualifiedName name
+ src/Rel8/Statement.hs view
@@ -0,0 +1,319 @@+{-# language DeriveFunctor #-}+{-# language DerivingVia #-}+{-# language FlexibleContexts #-}+{-# language GADTs #-}+{-# language LambdaCase #-}+{-# language NamedFieldPuns #-}+{-# language RankNTypes #-}+{-# language RecordWildCards #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}++module Rel8.Statement+  ( Statement+  , statementReturning+  , statementNoReturning+  , ppDecodeStatement+  )+where++-- base+import Control.Applicative (liftA2)+import Control.Monad (ap, liftM2)+import Data.Foldable (fold, toList)+import Data.Int (Int64)+import Data.Kind (Type)+import Data.List.NonEmpty (NonEmpty, intersperse)+import Data.Monoid (Endo (Endo))+import Data.String (fromString)+import Prelude++-- hasql+import qualified Hasql.Decoders as Hasql++-- opaleye+import qualified Opaleye.Internal.Tag as Opaleye++-- pretty+import Text.PrettyPrint+  ( Doc+  , (<+>)+  , ($$)+  , comma+  , hcat+  , parens+  , punctuate+  , text+  , vcat+  )++-- rel8+import Rel8.Expr (Expr)+import Rel8.Expr.Bool (false)+import Rel8.Query (Query)+import Rel8.Query.Aggregate (countRows)+import Rel8.Query.Each (each)+import Rel8.Schema.Escape (escape)+import Rel8.Schema.Table (TableSchema (..))+import Rel8.Statement.Rows (Rows (..))+import Rel8.Table (Table)+import Rel8.Table.Cols (fromCols)+import Rel8.Table.Name (namesFromLabelsWithA, showNames)+import Rel8.Table.Serialize (parse)++-- semigroupoids+import Data.Functor.Apply (Apply, WrappedApplicative (..))+import Data.Functor.Bind (Bind, (>>-))++-- transformers+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.State.Strict (State, evalState)+import Control.Monad.Trans.Writer.CPS (WriterT, runWriterT, tell)+++type Binding :: Type+data Binding = Binding+  { relation :: !String+  , columns :: !(Maybe (NonEmpty String))+  , doc :: !Doc+  , returning :: !Returning+  }+++type Result :: Type -> Type+data Result a = Unmodified !a | Modified !a+++instance Functor Result where+  fmap f = \case+    Unmodified a -> Modified (f a)+    Modified a -> Modified (f a)+++getResult :: Result a -> a+getResult = \case+  Unmodified a -> a+  Modified a -> a+++type Returning :: Type+data Returning where+  NoReturning :: Returning+  Returning :: Query (Expr Int64) -> Returning +++-- | 'Statement' represents a single PostgreSQL statement. Most commonly,+-- this is constructed using 'Rel8.select', 'Rel8.insert', 'Rel8.update'+-- or 'Rel8.delete'.+--+-- However, in addition to @SELECT@, @INSERT@, @UPDATE@ and @DELETE@,+-- PostgreSQL also supports compositions thereof via its statement-level+-- @WITH@ syntax (with some caveats). Each such \"sub-statement\" can+-- reference the results of previous sub-statements. 'Statement' provides a+-- 'Monad' instance that captures this \"binding\" pattern.+--+-- The caveat with this is that the [side-effects of these sub-statements+-- are not visible to other sub-statements](https://www.postgresql.org/docs/current/queries-with.html#QUERIES-WITH-MODIFYING);+-- only the explicit results of previous sub-statements (from @SELECT@s or+-- @RETURNING@ clauses) are visible. So, for example, an @INSERT@ into a table+-- followed immediately by a @SELECT@ therefrom will not return the inserted+-- rows. However, it is possible to return the inserted rows using+-- @RETURNING@, 'Rel8.unionAll'ing this with the result of a @SELECT@+-- from the same table will produce the desired result.+--+-- An example of where this can be useful is if you want to delete rows from+-- a table and simultaneously log their deletion in a log table.+--+-- @+-- deleteFoo :: (Foo Expr -> Expr Bool) -> Statement ()+-- deleteFoo predicate = do+--   foos <-+--     delete Delete+--       { from = fooSchema+--       , using = pure ()+--       , deleteWhere = \\_ -> predicate+--       , returning = Returning id+--       }+--   insert Insert+--     { into = deletedFooSchema+--     , rows = do+--         Foo {..} <- foos+--         let+--           deletedAt = 'Rel8.Expr.Time.now'+--         pure DeletedFoo {..}+--     , onConflict = Abort+--     , returning = NoReturning+--     }+-- @+newtype Statement a =+  Statement (WriterT (Endo [Binding]) (State Opaleye.Tag) (Result a))+  deriving stock (Functor)+  deriving (Apply) via WrappedApplicative Statement+++instance Applicative Statement where+  pure = Statement . pure . Modified+  (<*>) = ap+  liftA2 = liftM2+++instance Bind Statement where+  Statement m >>- f = Statement $ do+    result <- m+    case f (getResult result) of+      Statement m' -> m'+++instance Monad Statement where+  (>>=) = (>>-)+++statementNoReturning :: State Opaleye.Tag Doc -> Statement ()+statementNoReturning pp = Statement $ do+  binding <- lift $ do+    doc <- pp+    tag <- Opaleye.fresh+    let+      relation = Opaleye.tagWith tag "statement"+      columns = Nothing+      returning = NoReturning+      binding = Binding {..}+    pure binding+  tell (Endo (binding :))+  pure $ Unmodified ()+++statementReturning :: Table Expr a +  => State Opaleye.Tag Doc -> Statement (Query a)+statementReturning pp = Statement $ do+  (binding, query) <- lift $ do+    doc <- pp+    tag <- Opaleye.fresh+    let+      relation = Opaleye.tagWith tag "statement"+      symbol labels = do+        subtag <- Opaleye.fresh+        let+          suffix = Opaleye.tagWith tag (Opaleye.tagWith subtag "")+        pure $ take (63 - length suffix) label ++ suffix+        where+          label = fold (intersperse "/" labels)+      names = namesFromLabelsWithA symbol `evalState` Opaleye.start+      columns = Just $ showNames names+      query =+        fromCols <$> each+          TableSchema+            { name = fromString relation+            , columns = names+            }+      returning = Returning (countRows query)+      binding = Binding {..}+    pure (binding, query)+  tell (Endo (binding :))+  pure $ Unmodified query+++ppDecodeStatement :: ()+  => (forall x. Table Expr x => Query x -> State Opaleye.Tag Doc)+  -> Rows exprs a -> Statement exprs -> (Doc, Hasql.Result a)+ppDecodeStatement ppSelect rows (Statement m) = evalState go Opaleye.start+  where+    go = do+      (result, Endo dlist) <- runWriterT m+      let+        bindings' = dlist []+      case unsnoc bindings' of+        Nothing -> case rows of+          Void -> do+            doc <- ppSelect (pure false)+            pure (doc, Hasql.noResult)+          RowsAffected -> do+            doc <- ppSelect (pure false)+            pure (doc, 0 <$ Hasql.noResult)+          Single @exprs @a -> do+            doc <- ppSelect (getResult result)+            pure (doc, Hasql.singleRow (parse @exprs @a))+          Maybe @exprs @a -> do+            doc <- ppSelect (getResult result)+            pure (doc, Hasql.rowMaybe (parse @exprs @a))+          List @exprs @a -> do+            doc <- ppSelect (getResult result)+            pure (doc, Hasql.rowList (parse @exprs @a))+          Vector @exprs @a -> do+            doc <- ppSelect (getResult result)+            pure (doc, Hasql.rowVector (parse @exprs @a))+        Just (bindings, binding@Binding {doc = after}) -> case rows of+          Void -> pure (doc, Hasql.noResult)+            where+              doc = ppWith bindings after+          RowsAffected -> do+            case result of+              Unmodified _ -> pure (doc, Hasql.rowsAffected)+                where+                  doc = ppWith bindings after+              Modified _ -> case returning binding of+                NoReturning -> pure (doc, Hasql.rowsAffected)+                  where+                    doc = ppWith bindings after +                Returning query -> do+                  doc <- ppWith bindings' <$> ppSelect query+                  pure (doc, Hasql.singleRow parse)+          Single @exprs @a -> do+            case result of+              Unmodified _ -> pure (doc, Hasql.singleRow (parse @exprs @a))+                where+                  doc = ppWith bindings after+              Modified query -> do+                doc <- ppWith bindings' <$> ppSelect query+                pure (doc, Hasql.singleRow (parse @exprs @a))+          Maybe @exprs @a -> do+            case result of+              Unmodified _ -> pure (doc, Hasql.rowMaybe (parse @exprs @a))+                where+                  doc = ppWith bindings after+              Modified query -> do+                doc <- ppWith bindings' <$> ppSelect query+                pure (doc, Hasql.rowMaybe (parse @exprs @a))+          List @exprs @a -> do+            case result of+              Unmodified _ -> pure (doc, Hasql.rowList (parse @exprs @a))+                where+                  doc = ppWith bindings after+              Modified query -> do+                doc <- ppWith bindings' <$> ppSelect query+                pure (doc, Hasql.rowList (parse @exprs @a))+          Vector @exprs @a -> do+            case result of+              Unmodified _ -> pure (doc, Hasql.rowVector (parse @exprs @a))+                where+                  doc = ppWith bindings after+              Modified query -> do+                doc <- ppWith bindings' <$> ppSelect query+                pure (doc, Hasql.rowVector (parse @exprs @a))+++ppWith :: [Binding] -> Doc -> Doc+ppWith bindings after = pre $$ after+  where+    pre = case bindings of+      [] -> mempty+      _ ->+        text "WITH" <+>+        vcat (punctuate comma (map go bindings))+    go binding@Binding {doc = before} =+      ppAlias binding $$+      text "AS" <+>+      parens before+++ppAlias :: Binding -> Doc+ppAlias Binding {relation, columns = mcolumns} = case mcolumns of+  Nothing -> escape relation+  Just columns -> +    escape relation <+>+    parens (hcat (punctuate comma (escape <$> toList columns)))+++unsnoc :: [a] -> Maybe ([a], a)+unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing
src/Rel8/Statement/Delete.hs view
@@ -1,7 +1,7 @@ {-# language DuplicateRecordFields #-}+{-# language FlexibleContexts #-} {-# language GADTs #-} {-# language NamedFieldPuns #-}-{-# language RankNTypes #-} {-# language RecordWildCards #-} {-# language StandaloneKindSignatures #-} {-# language StrictData #-}@@ -17,9 +17,8 @@ import Data.Kind ( Type ) import Prelude --- hasql-import qualified Hasql.Encoders as Hasql-import qualified Hasql.Statement as Hasql+-- opaleye+import qualified Opaleye.Internal.Tag as Opaleye  -- pretty import Text.PrettyPrint ( Doc, (<+>), ($$), text )@@ -29,13 +28,13 @@ 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 (Statement)+import Rel8.Statement.Returning (Returning, ppReturning, runReturning) import Rel8.Statement.Using ( ppUsing ) import Rel8.Statement.Where ( ppWhere ) --- text-import qualified Data.Text as Text-import Data.Text.Encoding ( encodeUtf8 )+-- transformers+import Control.Monad.Trans.State.Strict (State)   -- | The constituent parts of a @DELETE@ statement.@@ -55,25 +54,21 @@     -> 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+-- | Build a @DELETE@ 'Statement'.+delete :: Delete a -> Statement a+delete statement@Delete {returning} =+  runReturning (ppDelete statement) 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+ppDelete :: Delete a -> State Opaleye.Tag Doc+ppDelete Delete {..} = do+  musing <- ppUsing using+  pure $ case musing 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
src/Rel8/Statement/Insert.hs view
@@ -19,12 +19,9 @@ 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+import qualified Opaleye.Internal.Tag as Opaleye  -- pretty import Text.PrettyPrint ( Doc, (<+>), ($$), parens, text )@@ -33,15 +30,15 @@ import Rel8.Query ( Query ) import Rel8.Schema.Name ( Name, Selects, ppColumn ) import Rel8.Schema.Table ( TableSchema(..), ppTable )+import Rel8.Statement (Statement) import Rel8.Statement.OnConflict ( OnConflict, ppOnConflict )-import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning )+import Rel8.Statement.Returning (Returning, ppReturning, runReturning) 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 )+-- transformers+import Control.Monad.Trans.State.Strict (State)   -- | The constituent parts of a SQL @INSERT@ statement.@@ -62,28 +59,24 @@     -> Insert a  -ppInsert :: Insert a -> Doc-ppInsert Insert {..} =-  text "INSERT INTO" <+>-  ppInto into $$-  ppRows rows $$-  ppOnConflict into onConflict $$-  ppReturning into returning+-- | Build an @INSERT@ 'Statement'.+insert :: Insert a -> Statement a+insert statement@Insert {returning} =+  runReturning (ppInsert statement) returning  +ppInsert :: Insert a -> State Opaleye.Tag Doc+ppInsert Insert {..} = do+  rows' <- ppRows rows+  pure $+    text "INSERT INTO" <+>+    ppInto into $$+    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 view
@@ -3,9 +3,11 @@ {-# language GADTs #-} {-# language LambdaCase #-} {-# language NamedFieldPuns #-}+{-# language OverloadedStrings #-} {-# language RecordWildCards #-} {-# language StandaloneKindSignatures #-} {-# language StrictData #-}+{-# language TypeOperators #-}  module Rel8.Statement.OnConflict   ( OnConflict(..)@@ -21,12 +23,14 @@  -- opaleye import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye+import qualified Opaleye.Internal.Sql as Opaleye  -- pretty import Text.PrettyPrint ( Doc, (<+>), ($$), parens, text )  -- rel8 import Rel8.Expr ( Expr )+import Rel8.Expr.Opaleye (toPrimExpr) import Rel8.Schema.Name ( Name, Selects, ppColumn ) import Rel8.Schema.Table ( TableSchema(..) ) import Rel8.Statement.Set ( ppSet )@@ -34,7 +38,7 @@ import Rel8.Table ( Table, toColumns ) import Rel8.Table.Cols ( Cols( Cols ) ) import Rel8.Table.Name ( showNames )-import Rel8.Table.Opaleye ( attributes )+import Rel8.Table.Opaleye (attributes, view) import Rel8.Table.Projection ( Projecting, Projection, apply )  @@ -60,15 +64,20 @@ -- 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.+-- Upsert in Postgres a \"conflict target\" to be specified — this is the+-- @UNIQUE@ index from conflicts with which we would like to recover. Indexes+-- are specified by listing the columns that comprise them along with an+-- optional predicate in the case of partial indexes. 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+      -- ^ The set of columns comprising the @UNIQUE@ index that forms our+      -- conflict target, projected from the set of columns for the whole+      -- table+    , predicate :: Maybe (exprs -> Expr Bool)+      -- ^ An optional predicate used to specify a+      -- [partial index](https://www.postgresql.org/docs/current/indexes-partial.html).     , set :: excluded -> exprs -> exprs       -- ^ How to update each selected row.     , updateWhere :: excluded -> exprs -> Expr Bool@@ -87,20 +96,27 @@ ppUpsert :: TableSchema names -> Upsert names -> Doc ppUpsert schema@TableSchema {columns} Upsert {..} =   text "ON CONFLICT" <+>-  ppIndex schema index <+>+  ppIndex columns index <+> foldMap (ppPredicate columns) predicate <+>   text "DO UPDATE" $$   ppSet schema (set excluded) $$   ppWhere schema (updateWhere excluded)   where     excluded = attributes TableSchema-      { schema = Nothing-      , name = "excluded"+      { name = "excluded"       , columns       }   ppIndex :: (Table Name names, Projecting names index)-  => TableSchema names -> Projection names index -> Doc-ppIndex TableSchema {columns} index =+  => names -> Projection names index -> Doc+ppIndex columns index =   parens $ Opaleye.commaV ppColumn $ toList $     showNames $ Cols $ apply index $ toColumns columns+++ppPredicate :: Selects names exprs+  => names -> (exprs -> Expr Bool) -> Doc+ppPredicate schema where_ = text "WHERE" <+> ppExpr condition+  where+    ppExpr = Opaleye.ppSqlExpr . Opaleye.sqlExpr . toPrimExpr+    condition = where_ (view schema)
+ src/Rel8/Statement/Prepared.hs view
@@ -0,0 +1,87 @@+{-# language AllowAmbiguousTypes #-}+{-# language BlockArguments #-}+{-# language FlexibleContexts #-}+{-# language MonoLocalBinds #-}+{-# language NamedFieldPuns #-}+{-# language ScopedTypeVariables #-}+{-# language TypeApplications #-}++module Rel8.Statement.Prepared (+  input,+  prepared,+) where++-- base+import Data.Functor.Const (Const (Const), getConst)+import Data.Functor.Contravariant (contramap, (>$<))+import Data.Functor.Identity (runIdentity)+import Prelude++-- hasql+import qualified Hasql.Encoders as Hasql+import qualified Hasql.Statement as Hasql++-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye++-- rel8+import Rel8.Expr (Expr)+import Rel8.Expr.Opaleye (fromPrimExpr, scastExpr)+import Rel8.Schema.HTable (hfield, hspecs, htabulateA)+import Rel8.Schema.Null (Nullity (Null, NotNull))+import Rel8.Schema.Spec (Spec (..))+import Rel8.Statement (Statement)+import Rel8.Table (Table, fromColumns, toResult)+import Rel8.Table.Serialize (Serializable)+import Rel8.Type.Encoder (binary)+import Rel8.Type.Information (encode)++-- transformers+import Control.Monad.Trans.State.Strict (evalState, state)+++{-| Given a 'Rel8.run' function that converts a 'Statement' to a+'Hasql.Statement', return a 'Rel8.run'-like function which instead takes a+/parameterized/ 'Statement' and converts it to a /preparable/+'Hasql.Statement'.++The parameters @i@ are sent to the database directly via PostgreSQL's binary+format. For large amounts of data this can be significantly more efficient+than embedding the values in the statement with 'Rel8.lit'.+-}+prepared :: forall a b i o.+  Serializable a i =>+  (Statement b -> Hasql.Statement () o) ->+  (a -> Statement b) ->+  Hasql.Statement i o+prepared run mkStatement = Hasql.Statement sql (encoder @a) decode True+  where+    Hasql.Statement sql _ decode _ = run $ mkStatement input+++encoder :: forall a i. Serializable a i => Hasql.Params i+encoder =+  contramap (toResult @_ @a) $+    getConst $+      htabulateA \field ->+        case hfield hspecs field of+          Spec {nullity, info} -> Const $+            runIdentity . (`hfield` field) >$<+              case nullity of+                Null -> Hasql.param $ Hasql.nullable build+                NotNull -> Hasql.param $ Hasql.nonNullable build+              where+                build = binary (encode info)+++input :: Table Expr a => a+input =+  fromColumns $+    flip (evalState @Word) 1 do+      htabulateA \field -> do+        n <- state (\n -> (n, n + 1))+        pure+          case hfield hspecs field of+            Spec {info} ->+              scastExpr info $ fromPrimExpr $+                Opaleye.ConstExpr $ Opaleye.OtherLit $ '$' : show n
src/Rel8/Statement/Returning.hs view
@@ -1,3 +1,5 @@+{-# language DataKinds #-}+{-# language FlexibleContexts #-} {-# language GADTs #-} {-# language LambdaCase #-} {-# language NamedFieldPuns #-}@@ -8,120 +10,68 @@ {-# language TypeApplications #-}  module Rel8.Statement.Returning-  ( Returning( NumberOfRowsAffected, Projection )-  , decodeReturning+  ( Returning( NoReturning, Returning )+  , runReturning   , 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+import qualified Opaleye.Internal.Tag as Opaleye  -- 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(..) )+import Rel8.Statement (Statement, statementNoReturning, statementReturning)+import Rel8.Table (Table) import Rel8.Table.Opaleye ( castTable, exprs, view )-import Rel8.Table.Serialize ( Serializable, parse ) --- semigropuoids-import Data.Functor.Apply ( Apply, (<.>) )+-- transformers+import Control.Monad.Trans.State.Strict (State)  --- | 'Rel8.Insert', 'Rel8.Update' and 'Rel8.Delete' all support returning either--- the number of rows affected, or the actual rows modified.+-- | 'Rel8.Insert', 'Rel8.Update' and 'Rel8.Delete' all support an optional+-- @RETURNING@ clause. 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+  -- | No @RETURNING@ clause+  NoReturning :: Returning names () -  -- | 'Projection' allows you to project out of the affected rows, which can+  -- | 'Returning' 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+  Returning :: (Selects names exprs, Table Expr a) => (exprs -> a) -> Returning names (Query a)   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+projections TableSchema {columns} = \case+  NoReturning -> Nothing+  Returning f -> Just (exprs (castTable (f (view columns))))  -decodeReturning :: Returning names a -> Hasql.Result a-decodeReturning = runReturning-  (<$> Hasql.rowsAffected)-  (\decoder withRows -> withRows <$> Hasql.rowList decoder)+runReturning ::+  State Opaleye.Tag Doc ->+  Returning names a ->+  Statement a+runReturning pp = \case+  NoReturning -> statementNoReturning pp+  Returning _ -> statementReturning pp   ppReturning :: TableSchema names -> Returning names a -> Doc
+ src/Rel8/Statement/Rows.hs view
@@ -0,0 +1,30 @@+{-# language DataKinds #-}+{-# language GADTs #-}+{-# language StandaloneKindSignatures #-}++module Rel8.Statement.Rows+  ( Rows (..)    +  )+where++-- base+import Data.Int (Int64)+import Data.Kind (Type)+import Prelude++-- rel8+import Rel8.Query (Query)+import Rel8.Table.Serialize (Serializable)++-- vector+import Data.Vector (Vector)+++type Rows :: Type -> Type -> Type+data Rows returning result where+  Void :: Rows returning ()+  RowsAffected :: Rows () Int64+  Single :: Serializable exprs a => Rows (Query exprs) a+  Maybe :: Serializable exprs a => Rows (Query exprs) (Maybe a)+  List :: Serializable exprs a => Rows (Query exprs) [a]+  Vector :: Serializable exprs a => Rows (Query exprs) (Vector a)
+ src/Rel8/Statement/Run.hs view
@@ -0,0 +1,107 @@+module Rel8.Statement.Run+  ( run_+  , runN+  , run1+  , runMaybe+  , run+  , runVector+  )+where++-- base+import Data.Int (Int64)+import Prelude++-- hasql+import qualified Hasql.Encoders as Hasql+import qualified Hasql.Statement as Hasql++-- rel8+import Rel8.Query (Query)+import Rel8.Statement (Statement, ppDecodeStatement)+import Rel8.Statement.Rows (Rows (..))+import Rel8.Statement.Select (ppSelect)+import Rel8.Table.Serialize (Serializable)++-- text+import qualified Data.Text as Text+import Data.Text.Encoding (encodeUtf8)++-- vector+import Data.Vector (Vector)+++makeRun :: Rows exprs a -> Statement exprs -> Hasql.Statement () a+makeRun rows statement = Hasql.Statement bytes params decode prepare+  where+    bytes = encodeUtf8 $ Text.pack sql+    params = Hasql.noParams+    prepare = False+    sql = show doc+    (doc, decode) = ppDecodeStatement ppSelect rows statement+++-- | Convert a 'Statement' to a runnable 'Hasql.Statement', disregarding the+-- results of that statement (if any).+--+-- @+-- run_ :: Rel8.'Statement' exprs -> Hasql.'Hasql.Statement' () ()+-- @+run_ :: Statement exprs -> Hasql.Statement () ()+run_ = makeRun Void+++-- | Convert a 'Statement' to a runnable 'Hasql.Statement', returning the+-- number of rows affected by that statement (for 'Rel8.insert's,+-- 'Rel8.update's or Rel8.delete's with 'Rel8.NoReturning').+--+-- @+-- runN :: Rel8.'Statement' () -> Hasql.'Hasql.Statement' () 'Int64'+-- @+runN :: Statement () -> Hasql.Statement () Int64+runN = makeRun RowsAffected+++-- | Convert a 'Statement' to a runnable 'Hasql.Statement', processing the+-- result of the statement as a single row. If the statement returns a number+-- of rows other than 1, a runtime exception is thrown.+--+-- @+-- run1 :: 'Serializable' exprs a => Rel8.'Statement' ('Query' exprs) -> Hasql.'Hasql.Statement' () a+-- @+run1 :: Serializable exprs a => Statement (Query exprs) -> Hasql.Statement () a+run1 = makeRun Single+++-- | Convert a 'Statement' to a runnable 'Hasql.Statement', processing the+-- result of the statement as 'Maybe' a single row. If the statement returns+-- a number of rows other than 0 or 1, a runtime exception is thrown.+--+-- @+-- runMaybe :: 'Serializable' exprs a => Rel8.'Statement' ('Query' exprs) -> Hasql.'Hasql.Statement' () ('Maybe' a)+-- @+runMaybe :: Serializable exprs a+  => Statement (Query exprs) -> Hasql.Statement () (Maybe a)+runMaybe = makeRun Maybe+++-- | Convert a 'Statement' to a runnable 'Hasql.Statement', processing the+-- result of the statement as a list of rows.+--+-- @+-- run :: 'Serializable' exprs a => Rel8.'Statement' ('Query' exprs) -> Hasql.'Hasql.Statement' () [a]+-- @+run :: Serializable exprs a+  => Statement (Query exprs) -> Hasql.Statement () [a]+run = makeRun List+++-- | Convert a 'Statement' to a runnable 'Hasql.Statement', processing the+-- result of the statement as a 'Vector' of rows.+--+-- @+-- runVector :: 'Serializable' exprs a => Rel8.'Statement' ('Query' exprs) -> Hasql.'Hasql.Statement' () ('Vector' a)+-- @+runVector :: Serializable exprs a+  => Statement (Query exprs) -> Hasql.Statement () (Vector a)+runVector = makeRun Vector
src/Rel8/Statement/SQL.hs view
@@ -1,29 +1,56 @@+{-# language FlexibleContexts #-}+ module Rel8.Statement.SQL   ( showDelete   , showInsert   , showUpdate+  , showStatement+  , showPreparedStatement   ) where  -- base import Prelude +-- opaleye+import qualified Opaleye.Internal.Tag as Opaleye+ -- rel8+import Rel8.Expr (Expr)+import Rel8.Statement (Statement, ppDecodeStatement) import Rel8.Statement.Delete ( Delete, ppDelete ) import Rel8.Statement.Insert ( Insert, ppInsert )+import Rel8.Statement.Prepared (input)+import Rel8.Statement.Rows (Rows (Void))+import Rel8.Statement.Select (ppSelect) import Rel8.Statement.Update ( Update, ppUpdate )+import Rel8.Table (Table) +-- transformers+import Control.Monad.Trans.State.Strict (evalState) + -- | Convert a 'Delete' to a 'String' containing a @DELETE@ statement. showDelete :: Delete a -> String-showDelete = show . ppDelete+showDelete = show . (`evalState` Opaleye.start) . ppDelete   -- | Convert an 'Insert' to a 'String' containing an @INSERT@ statement. showInsert :: Insert a -> String-showInsert = show . ppInsert+showInsert = show . (`evalState` Opaleye.start) . ppInsert   -- | Convert an 'Update' to a 'String' containing an @UPDATE@ statement. showUpdate :: Update a -> String-showUpdate = show . ppUpdate+showUpdate = show . (`evalState` Opaleye.start) . ppUpdate+++-- | Convert a 'Statement' to a 'String' containing an SQL statement.+showStatement :: Statement a -> String+showStatement = show . fst . ppDecodeStatement ppSelect Void+++-- | Convert a parameterized 'Statement' to a 'String' containing an SQL+-- statement.+showPreparedStatement :: Table Expr i => (i -> Statement a) -> String+showPreparedStatement = showStatement . ($ input)
src/Rel8/Statement/Select.hs view
@@ -1,14 +1,15 @@+{-# language DataKinds #-} {-# language DeriveTraversable #-} {-# language DerivingStrategies #-} {-# language FlexibleContexts #-} {-# language MonoLocalBinds #-} {-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-} {-# language TypeApplications #-}  module Rel8.Statement.Select   ( select   , ppSelect-   , Optimized(..)   , ppPrimSelect   , ppRows@@ -17,15 +18,10 @@  -- base import Data.Foldable ( toList )-import Data.List.NonEmpty ( NonEmpty( (:|) ) )+import Data.Kind ( Type ) 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@@ -47,52 +43,43 @@ import Rel8.Query ( Query ) import Rel8.Query.Opaleye ( toOpaleye ) import Rel8.Schema.Name ( Selects )+import Rel8.Statement (Statement, statementReturning) 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 )+-- transformers+import Control.Monad.Trans.State.Strict (State)  --- | 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+-- | Build a @SELECT@ 'Statement'.+select :: Table Expr a => Query a -> Statement (Query a)+select query = statementReturning (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) ()+ppSelect :: Table Expr a => Query a -> State Opaleye.Tag Doc+ppSelect query = do+  (exprs, primQuery) <- Opaleye.runSimpleSelect (toOpaleye query)+  let     (exprs', primQuery') = case optimize primQuery of       Empty -> (undefined, Opaleye.Product (pure (pure Opaleye.Unit)) never)       Unit -> (exprs, Opaleye.Unit)       Optimized pq -> (exprs, pq)+  pure $ Opaleye.ppSql $ primSelectWith names (toCols exprs') primQuery'+  where+    names = namesFromLabels     never = pure (toPrimExpr false)  -ppRows :: Table Expr a => Query a -> Doc+ppRows :: Table Expr a => Query a -> State Opaleye.Tag 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) :| []) [])+  Optimized (Opaleye.Values symbols rows)     | eqSymbols symbols (toList (T.exprs a)) ->-        Opaleye.ppValues_ (map Opaleye.sqlExpr <$> toList rows)+        pure $ Opaleye.ppValues_ (map Opaleye.sqlExpr <$> toList rows)   _ -> ppSelect query   where     (a, primQuery, _) = Opaleye.runSimpleQueryArrStart (toOpaleye query) ()@@ -109,15 +96,15 @@       = 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) ()+ppPrimSelect :: Query a -> State Opaleye.Tag (Optimized Doc, a)+ppPrimSelect query = do+  (a, primQuery) <- Opaleye.runSimpleSelect (toOpaleye query)+  pure $ (Opaleye.ppSql . primSelect <$> optimize primQuery, a)  +type Optimized :: Type -> Type data Optimized a = Empty | Unit | Optimized a-  deriving stock (Functor, Foldable, Traversable)+  deriving stock (Functor, Foldable, Traversable, Show)   optimize :: Opaleye.PrimQuery' a -> Optimized (Opaleye.PrimQuery' Void)
src/Rel8/Statement/Update.hs view
@@ -1,4 +1,5 @@ {-# language DuplicateRecordFields #-}+{-# language FlexibleContexts #-} {-# language GADTs #-} {-# language NamedFieldPuns #-} {-# language RecordWildCards #-}@@ -16,9 +17,8 @@ import Data.Kind ( Type ) import Prelude --- hasql-import qualified Hasql.Encoders as Hasql-import qualified Hasql.Statement as Hasql+-- opaleye+import qualified Opaleye.Internal.Tag as Opaleye  -- pretty import Text.PrettyPrint ( Doc, (<+>), ($$), text )@@ -28,14 +28,14 @@ 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 (Statement)+import Rel8.Statement.Returning (Returning, ppReturning, runReturning) 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 )+-- transformers+import Control.Monad.Trans.State.Strict (State)   -- | The constituent parts of an @UPDATE@ statement.@@ -57,27 +57,23 @@     -> 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+-- | Build an @UPDATE@ 'Statement'.+update :: Update a -> Statement a+update statement@Update {returning} =+  runReturning (ppUpdate statement) 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+ppUpdate :: Update a -> State Opaleye.Tag Doc+ppUpdate Update {..} = do+  mfrom <- ppFrom from+  pure $ case mfrom 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
src/Rel8/Statement/Using.hs view
@@ -1,3 +1,5 @@+{-# language OverloadedStrings #-}+ module Rel8.Statement.Using   ( ppFrom   , ppUsing@@ -7,6 +9,9 @@ -- base import Prelude +-- opaleye+import qualified Opaleye.Internal.Tag as Opaleye+ -- pretty import Text.PrettyPrint ( Doc, (<+>), parens, text ) @@ -15,22 +20,26 @@ import Rel8.Schema.Table ( TableSchema(..), ppTable ) import Rel8.Statement.Select ( Optimized(..), ppPrimSelect ) +-- transformers+import Control.Monad.Trans.State.Strict (State) -ppFrom :: Query a -> Maybe (Doc, a)++ppFrom :: Query a -> State Opaleye.Tag (Maybe (Doc, a)) ppFrom = ppJoin "FROM"  -ppUsing :: Query a -> Maybe (Doc, a)+ppUsing :: Query a -> State Opaleye.Tag (Maybe (Doc, a)) ppUsing = ppJoin "USING"  -ppJoin :: String -> Query a -> Maybe (Doc, a)+ppJoin :: String -> Query a -> State Opaleye.Tag (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)+  (ofrom, a) <- ppPrimSelect join+  pure $ 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+    alias = TableSchema {name = "T1", columns = ()}
src/Rel8/Statement/View.hs view
@@ -3,6 +3,7 @@  module Rel8.Statement.View   ( createView+  , createOrReplaceView   ) where @@ -14,6 +15,12 @@ import qualified Hasql.Encoders as Hasql import qualified Hasql.Statement as Hasql +-- opaleye+import qualified Opaleye.Internal.Tag as Opaleye++-- pretty+import Text.PrettyPrint ( Doc, (<+>), ($$), text )+ -- rel8 import Rel8.Query ( Query ) import Rel8.Schema.Name ( Selects )@@ -21,33 +28,57 @@ 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 ) +-- transformers+import Control.Monad.Trans.State.Strict (evalState) ++data CreateView = Create | CreateOrReplace++ -- | 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+createView =+  createViewGeneric Create+++-- | Given a 'TableSchema' and 'Query', @createOrReplaceView@ runs a+-- @CREATE OR REPLACE VIEW@ statement that will save the given query+-- as a view, replacing the current view definition if it exists and+-- adheres to the restrictions in place for replacing a view in+-- PostgreSQL.+createOrReplaceView :: Selects names exprs+  => TableSchema names -> Query exprs -> Hasql.Statement () ()+createOrReplaceView =+  createViewGeneric CreateOrReplace+++createViewGeneric :: Selects names exprs+  => CreateView -> TableSchema names -> Query exprs -> Hasql.Statement () ()+createViewGeneric replace 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+    doc = ppCreateView schema query replace   ppCreateView :: Selects names exprs-  => TableSchema names -> Query exprs -> Doc-ppCreateView schema query =-  text "CREATE VIEW" <+>+  => TableSchema names -> Query exprs -> CreateView -> Doc+ppCreateView schema query replace =+  createOrReplace replace <+>   ppInto schema $$   text "AS" <+>-  ppSelect query+  evalState (ppSelect query) Opaleye.start+  where+    createOrReplace Create = text "CREATE VIEW"+    createOrReplace CreateOrReplace = text "CREATE OR REPLACE VIEW"
src/Rel8/Table.hs view
@@ -8,6 +8,7 @@ {-# language StandaloneKindSignatures #-} {-# language TypeApplications #-} {-# language TypeFamilies #-}+{-# language TypeOperators #-} {-# language UndecidableInstances #-}  module Rel8.Table
src/Rel8/Table/ADT.hs view
@@ -18,9 +18,8 @@   , BuildADT, buildADT   , ConstructableADT   , ConstructADT, constructADT-  , DeconstructADT, deconstructADT+  , DeconstructADT, deconstructADT, deconstructAADT   , NameADT, nameADT-  , AggregateADT, aggregateADT   , ADTRep   ) where@@ -32,7 +31,6 @@ import Prelude  -- rel8-import Rel8.Aggregate ( Aggregate ) import Rel8.Expr ( Expr ) import Rel8.FCF ( Eval, Exp ) import Rel8.Generic.Construction@@ -40,9 +38,8 @@   , GGBuild, ggbuild   , GGConstructable   , GGConstruct, ggconstruct-  , GGDeconstruct, ggdeconstruct+  , GGDeconstruct, ggdeconstruct, ggdeconstructA   , GGName, ggname-  , GGAggregate, ggaggregate   ) import Rel8.Generic.Record ( Record( Record ), unrecord ) import Rel8.Generic.Rel8able@@ -59,7 +56,10 @@ import Rel8.Schema.Result ( Result ) import Rel8.Table ( Table, TColumns ) +-- semigroupoids+import Data.Functor.Apply (Apply) + type ADT :: K.Rel8able -> K.Rel8able newtype ADT t context = ADT (GColumnsADT t context) @@ -146,23 +146,18 @@   ggdeconstruct @'K.Sum @(ADTRep t) @(ADT t Expr) @r (\(ADT a) -> a)  +deconstructAADT :: forall t f r. (ConstructableADT t, Apply f, Table Expr r)+  => DeconstructADT t (f r)+deconstructAADT =+  ggdeconstructA @'K.Sum @(ADTRep t) @(ADT t Expr) @f @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)
src/Rel8/Table/Aggregate.hs view
@@ -1,54 +1,96 @@+{-# language BlockArguments #-} {-# language FlexibleContexts #-} {-# language NamedFieldPuns #-} {-# language ScopedTypeVariables #-} {-# language TypeApplications #-} {-# language TypeFamilies #-}-{-# language ViewPatterns #-}  module Rel8.Table.Aggregate-  ( groupBy, hgroupBy-  , listAgg, nonEmptyAgg+  ( groupBy, groupByOn+  , listAgg, listAggOn, nonEmptyAgg, nonEmptyAggOn+  , listCat, listCatOn, nonEmptyCat, nonEmptyCatOn+  , filterWhere+  , orderAggregateBy   ) where  -- base-import Data.Functor.Identity ( Identity( Identity ) ) import Prelude +-- opaleye+import qualified Opaleye.Internal.Aggregate as Opaleye++-- profunctors+import Data.Profunctor (dimap, lmap)+ -- rel8-import Rel8.Aggregate ( Aggregate, Aggregates )+import Rel8.Aggregate (Aggregator,  Aggregator' (Aggregator), Aggregator1) import Rel8.Expr ( Expr ) import Rel8.Expr.Aggregate-  ( groupByExpr+  ( filterWhereExplicit+  , groupByExprOn   , slistAggExpr+  , slistCatExpr   , snonEmptyAggExpr+  , snonEmptyCatExpr   )+import Rel8.Order (Order (Order)) import Rel8.Schema.Dict ( Dict( Dict ) )-import Rel8.Schema.HTable ( HTable, hfield, htabulate )-import Rel8.Schema.HTable.Vectorize ( hvectorize )+import Rel8.Schema.HTable (HTable, hfield, hspecs, htabulateA)+import Rel8.Schema.HTable.Vectorize (htraverseVectorP, hvectorizeA) import Rel8.Schema.Null ( Sql ) import Rel8.Schema.Spec ( Spec( Spec, info ) )-import Rel8.Table ( toColumns, fromColumns )+import Rel8.Table (Table, toColumns, fromColumns) import Rel8.Table.Eq ( EqTable, eqTable ) import Rel8.Table.List ( ListTable ) import Rel8.Table.NonEmpty ( NonEmptyTable )+import Rel8.Table.Opaleye (ifPP) 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+--+-- For example, if we have a table of items, we could group the items by the+-- order they belong to:+--+-- @+-- itemsByOrder :: Query (OrderId Expr, ListTable Expr (Item Expr))+-- itemsByOrder =+--   aggregate+--     do+--       orderId <- groupByOn (.orderId)+--       items <- listAgg+--       pure (orderId, items)+--     do+--       each itemSchema+-- @+groupBy :: forall a. EqTable a => Aggregator1 a a+groupBy = dimap toColumns fromColumns (hgroupBy (eqTable @a))  -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+-- | Applies 'groupBy' to the columns selected by the given function.+groupByOn :: EqTable a => (i -> a) -> Aggregator1 i a+groupByOn f = lmap f groupBy  +hgroupBy :: HTable t => t (Dict (Sql DBEq)) -> Aggregator1 (t Expr) (t Expr)+hgroupBy eqs = htabulateA $ \field -> case hfield eqs field of+  Dict -> groupByExprOn (`hfield` field)+++-- | 'filterWhere' allows an 'Aggregator' to filter out rows from the input+-- query before considering them for aggregation. Note that because the+-- predicate supplied to 'filterWhere' could return 'Rel8.false' for every+-- row, 'filterWhere' needs an 'Aggregator' as opposed to an 'Aggregator1', so+-- that it can return a default value in such a case. For a variant of+-- 'filterWhere' that can work with 'Aggregator1's, see+-- 'Rel8.filterWhereOptional'.+filterWhere :: Table Expr a+  => (i -> Expr Bool) -> Aggregator i a -> Aggregator' fold i a+filterWhere = filterWhereExplicit ifPP++ -- | 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@@ -62,19 +104,67 @@ -- ordersWithItems :: Query (Order Expr, ListTable Expr (Item Expr)) -- ordersWithItems = do --   order <- each orderSchema---   items <- aggregate $ listAgg <$> itemsFromOrder order+--   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)+listAgg :: Table Expr a => Aggregator' fold a (ListTable Expr a)+listAgg =+  fromColumns <$>+  hvectorizeA \Spec {info} field ->+    lmap ((`hfield` field) . toColumns) $ slistAggExpr info  +-- | Applies 'listAgg' to the columns selected by the given function.+listAggOn :: Table Expr a => (i -> a) -> Aggregator' fold i (ListTable Expr a)+listAggOn f = lmap f listAgg++ -- | 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)+nonEmptyAgg :: Table Expr a => Aggregator1 a (NonEmptyTable Expr a)+nonEmptyAgg =+  fromColumns <$>+  hvectorizeA \Spec {info} field ->+    lmap ((`hfield` field) . toColumns) $ snonEmptyAggExpr info+++-- | Applies 'nonEmptyAgg' to the columns selected by the given function.+nonEmptyAggOn :: Table Expr a+  => (i -> a) -> Aggregator1 i (NonEmptyTable Expr a)+nonEmptyAggOn f = lmap f nonEmptyAgg+++-- | Concatenate lists into a single list.+listCat :: Table Expr a+  => Aggregator' fold (ListTable Expr a) (ListTable Expr a)+listCat = dimap toColumns fromColumns $+  htraverseVectorP (\field -> case hfield hspecs field of+    Spec {info} -> slistCatExpr info)+++-- | Applies 'listCat' to the list selected by the given function.+listCatOn :: Table Expr a+  => (i -> ListTable Expr a) -> Aggregator' fold i (ListTable Expr a)+listCatOn f = lmap f listCat+++-- | Concatenate non-empty lists into a single non-empty list.+nonEmptyCat :: Table Expr a+  => Aggregator1 (NonEmptyTable Expr a) (NonEmptyTable Expr a)+nonEmptyCat = dimap toColumns fromColumns $+  htraverseVectorP (\field -> case hfield hspecs field of+    Spec {info} -> snonEmptyCatExpr info)+++-- | Applies 'nonEmptyCat' to the non-empty list selected by the given+-- function.+nonEmptyCatOn :: Table Expr a+  => (i -> NonEmptyTable Expr a) -> Aggregator1 i (NonEmptyTable Expr a)+nonEmptyCatOn f = lmap f nonEmptyCat+++-- | Order the values within each aggregation in an `Aggregator` using the+-- given ordering. This is only relevant for aggregations that depend on the+-- order they get their elements, like `Rel8.listAgg` and `Rel8.stringAgg`.+orderAggregateBy :: Order i -> Aggregator' fold i a -> Aggregator' fold i a+orderAggregateBy (Order order) (Aggregator fallback aggregator) =+  Aggregator fallback $ Opaleye.orderAggregate order aggregator
+ src/Rel8/Table/Aggregate/Maybe.hs view
@@ -0,0 +1,89 @@+{-# language FlexibleContexts #-}++module Rel8.Table.Aggregate.Maybe+  ( filterWhereOptional+  , optionalAggregate+  , aggregateJustTable+  , aggregateJustTable1+  , aggregateMaybeTable+  )+where++-- base+import Prelude++-- opaleye+import qualified Opaleye.Internal.Aggregate as Opaleye++-- profunctors+import Data.Profunctor (lmap)++-- rel8+import Rel8.Aggregate+  ( Aggregator' (Aggregator)+  , Aggregator, toAggregator+  , Aggregator1, toAggregator1+  )+import Rel8.Aggregate.Fold (Fallback (Fallback))+import Rel8.Expr (Expr)+import Rel8.Expr.Aggregate (groupByExprOn)+import Rel8.Expr.Opaleye (toColumn, toPrimExpr)+import Rel8.Table (Table)+import Rel8.Table.Aggregate (filterWhere)+import Rel8.Table.Maybe+  ( MaybeTable (MaybeTable, just, tag), justTable, nothingTable+  , isJustTable+  , makeMaybeTable+  )+import Rel8.Table.Nullify (aggregateNullify, unsafeUnnullifyTable)+++-- | A variant of 'filterWhere' that can be used with an 'Aggregator1'+-- (upgrading it to an 'Aggregator' in the process). It returns+-- 'nothingTable' in the case where the predicate matches zero rows.+filterWhereOptional :: Table Expr a+  => (i -> Expr Bool) -> Aggregator' fold i a -> Aggregator' fold' i (MaybeTable Expr a)+filterWhereOptional f (Aggregator _ aggregator) =+  Aggregator (Fallback nothingTable) $+    Opaleye.filterWhereInternal makeMaybeTable (toColumn . toPrimExpr . f) aggregator+++-- | 'optionalAggregate' upgrades an 'Aggregator1' into an 'Aggregator' by+-- having it return 'nothingTable' when aggregating over an empty collection+-- of rows.+optionalAggregate :: Table Expr a+  => Aggregator' fold i a -> Aggregator' fold' i (MaybeTable Expr a)+optionalAggregate = toAggregator nothingTable . fmap justTable+++-- | Lift an 'Aggregator' to operate on a 'MaybeTable'. If the input query has+-- @'justTable' i@s, they are folded into a single @a@ by the given aggregator+-- — in the case where the input query is all 'nothingTable's, the+-- 'Aggregator'\'s fallback @a@ is returned.+aggregateJustTable :: Table Expr a+  => Aggregator i a+  -> Aggregator' fold (MaybeTable Expr i) a+aggregateJustTable =+  filterWhere isJustTable . lmap (unsafeUnnullifyTable . just)+++-- | Lift an 'Aggregator1' to operate on a 'MaybeTable'. If the input query+-- has @'justTable' i@s, they are folded into a single @'justTable' a@ by the+-- given aggregator — in the case where the input query is all+-- 'nothingTable's, a single 'nothingTable' row is returned.+aggregateJustTable1 :: Table Expr a+  => Aggregator' fold i a+  -> Aggregator' fold' (MaybeTable Expr i) (MaybeTable Expr a)+aggregateJustTable1 =+  filterWhereOptional isJustTable . lmap (unsafeUnnullifyTable . just)+++-- | Lift an aggregator to operate on a 'MaybeTable'. @nothingTable@s and+-- @justTable@s are grouped separately.+aggregateMaybeTable :: ()+  => Aggregator' fold i a+  -> Aggregator1 (MaybeTable Expr i) (MaybeTable Expr a)+aggregateMaybeTable aggregator =+  MaybeTable+    <$> groupByExprOn tag+    <*> lmap just (toAggregator1 (aggregateNullify aggregator))
src/Rel8/Table/Cols.hs view
@@ -3,6 +3,7 @@ {-# language MultiParamTypeClasses #-} {-# language StandaloneKindSignatures #-} {-# language TypeFamilies #-}+{-# language TypeOperators #-} {-# language UndecidableInstances #-}  module Rel8.Table.Cols
src/Rel8/Table/Either.hs view
@@ -1,3 +1,4 @@+{-# language ApplicativeDo #-} {-# language DataKinds #-} {-# language DeriveFunctor #-} {-# language DerivingStrategies #-}@@ -10,6 +11,7 @@ {-# language StandaloneKindSignatures #-} {-# language TypeApplications #-} {-# language TypeFamilies #-}+{-# language TypeOperators #-} {-# language UndecidableInstances #-}  {-# options_ghc -fno-warn-orphans #-}@@ -18,6 +20,8 @@   ( EitherTable(..)   , eitherTable, leftTable, rightTable   , isLeftTable, isRightTable+  , aggregateLeftTable, aggregateLeftTable1+  , aggregateRightTable, aggregateRightTable1   , aggregateEitherTable   , nameEitherTable   )@@ -32,10 +36,13 @@ -- comonad import Control.Comonad ( extract ) +-- profunctors+import Data.Profunctor (lmap)+ -- rel8-import Rel8.Aggregate ( Aggregate )+import Rel8.Aggregate (Aggregator, Aggregator', Aggregator1, toAggregator1) import Rel8.Expr ( Expr )-import Rel8.Expr.Aggregate ( groupByExpr )+import Rel8.Expr.Aggregate (groupByExprOn) import Rel8.Expr.Serialize ( litExpr ) import Rel8.Kind.Context ( Reifiable ) import Rel8.Schema.Context.Nullify ( Nullifiable )@@ -50,9 +57,14 @@   , FromExprs, fromResult, toResult   , Transpose   )+import Rel8.Table.Aggregate (filterWhere)+import Rel8.Table.Aggregate.Maybe (filterWhereOptional) import Rel8.Table.Bool ( bool ) import Rel8.Table.Eq ( EqTable, eqTable )-import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )+import Rel8.Table.Maybe (MaybeTable)+import Rel8.Table.Nullify+  ( Nullify, aggregateNullify, guard, unsafeUnnullifyTable+  ) import Rel8.Table.Ord ( OrdTable, ordTable ) import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project ) import Rel8.Table.Serialize ( ToExprs )@@ -214,18 +226,61 @@ 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.+-- | Lift an 'Aggregator' to operate on an 'EitherTable'. If the input query has+-- @'leftTable' a@s, they are folded into a single @c@ by the given aggregator+-- — in the case where the input query is all 'rightTable's, the+-- 'Aggregator'\'s fallback @c@ is returned.+aggregateLeftTable :: Table Expr c+  => Aggregator a c+  -> Aggregator' fold (EitherTable Expr a b) c+aggregateLeftTable =+  filterWhere isLeftTable . lmap (unsafeUnnullifyTable . left)+++-- | Lift an 'Aggregator1' to operate on an 'EitherTable'. If the input query+-- has @'leftTable' a@s, they are folded into a single @'Rel8.justTable' c@+-- by the given aggregator — in the case where the input query is all+-- 'rightTable's, a single 'nothingTable' row is returned.+aggregateLeftTable1 :: Table Expr c+  => Aggregator' fold a c+  -> Aggregator' fold' (EitherTable Expr a b) (MaybeTable Expr c)+aggregateLeftTable1 =+  filterWhereOptional isLeftTable . lmap (unsafeUnnullifyTable . left)+++-- | Lift an 'Aggregator' to operate on an 'EitherTable'. If the input query has+-- @'rightTable' b@s, they are folded into a single @c@ by the given aggregator+-- — in the case where the input query is all 'rightTable's, the+-- 'Aggregator'\'s fallback @c@ is returned.+aggregateRightTable :: Table Expr c+  => Aggregator b c+  -> Aggregator' fold (EitherTable Expr a b) c+aggregateRightTable =+  filterWhere isRightTable . lmap (unsafeUnnullifyTable . right)+++-- | Lift an 'Aggregator1' to operate on an 'EitherTable'. If the input query+-- has @'rightTable' b@s, they are folded into a single @'Rel8.justTable' c@+-- by the given aggregator — in the case where the input query is all+-- 'leftTable's, a single 'nothingTable' row is returned.+aggregateRightTable1 :: Table Expr c+  => Aggregator' fold a c+  -> Aggregator' fold' (EitherTable Expr a b) (MaybeTable Expr c)+aggregateRightTable1 =+  filterWhereOptional isLeftTable . lmap (unsafeUnnullifyTable . left)+++-- | Lift a pair aggregators 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-  }+  => Aggregator' fold i a+  -> Aggregator' fold' i' b+  -> Aggregator1 (EitherTable Expr i i') (EitherTable Expr a b)+aggregateEitherTable a b =+  EitherTable+    <$> groupByExprOn tag+    <*> lmap left (toAggregator1 (aggregateNullify a))+    <*> lmap right (toAggregator1 (aggregateNullify b))   -- | Construct a 'EitherTable' in the 'Name' context. This can be useful if you
src/Rel8/Table/HKD.hs view
@@ -8,6 +8,7 @@ {-# language StandaloneKindSignatures #-} {-# language TypeApplications #-} {-# language TypeFamilies #-}+{-# language TypeOperators #-} {-# language UndecidableInstances #-} {-# language UndecidableSuperClasses #-} @@ -18,9 +19,8 @@   , BuildHKD, buildHKD   , ConstructableHKD   , ConstructHKD, constructHKD-  , DeconstructHKD, deconstructHKD+  , DeconstructHKD, deconstructHKD, deconstructAHKD   , NameHKD, nameHKD-  , AggregateHKD, aggregateHKD   , HKDRep   ) where@@ -32,7 +32,6 @@ import Prelude  -- rel8-import Rel8.Aggregate ( Aggregate ) import Rel8.Column ( TColumn ) import Rel8.Expr ( Expr ) import Rel8.FCF ( Eval, Exp )@@ -42,9 +41,8 @@   , GGBuild, ggbuild   , GGConstructable   , GGConstruct, ggconstruct-  , GGDeconstruct, ggdeconstruct+  , GGDeconstruct, ggdeconstruct, ggdeconstructA   , GGName, ggname-  , GGAggregate, ggaggregate   ) import Rel8.Generic.Map ( GMap ) import Rel8.Generic.Record@@ -71,7 +69,10 @@   , TSerialize   ) +-- semigroupoids+import Data.Functor.Apply (Apply) + type GColumnsHKD :: Type -> K.HTable type GColumnsHKD a =   Eval (GGColumns (GAlgebra (Rep a)) TColumns (GRecord (GMap (TColumn Expr) (Rep a))))@@ -157,6 +158,7 @@   => HKDable a  +type Top_ :: Constraint class Top_ instance Top_ @@ -203,23 +205,17 @@ deconstructHKD = ggdeconstruct @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) @r (\(HKD a) -> a)  +deconstructAHKD :: forall a f r. (ConstructableHKD a, Apply f, Table Expr r)+  => DeconstructHKD a (f r)+deconstructAHKD = ggdeconstructA @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) @f @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)
src/Rel8/Table/List.hs view
@@ -7,6 +7,7 @@ {-# language StandaloneKindSignatures #-} {-# language TypeApplications #-} {-# language TypeFamilies #-}+{-# language TypeOperators #-} {-# language UndecidableInstances #-}  module Rel8.Table.List@@ -14,23 +15,31 @@   , ($*)   , listTable   , nameListTable+  , head+  , index+  , last+  , length   ) where  -- base-import Data.Functor.Identity ( Identity( Identity ) )+import Data.Functor.Identity (Identity (Identity))+import Data.Int (Int32) import Data.Kind ( Type )-import Prelude+import Prelude hiding (head, last, length)  -- rel8 import Rel8.Expr ( Expr ) import Rel8.Expr.Array ( sappend, sempty, slistOf )+import Rel8.Expr.List (lengthExpr, sheadExpr, sindexExpr, slastExpr) import Rel8.Schema.Dict ( Dict( Dict ) ) import Rel8.Schema.HTable.List ( HListTable ) import Rel8.Schema.HTable.Vectorize   ( hvectorize, hunvectorize+  , hnullify   , happend, hempty   , hproject, hcolumn+  , First (..)   ) import qualified Rel8.Schema.Kind as K import Rel8.Schema.Name ( Name( Name ) )@@ -47,6 +56,7 @@   , AlternativeTable, emptyTable   ) import Rel8.Table.Eq ( EqTable, eqTable )+import Rel8.Table.Null (NullTable) import Rel8.Table.Ord ( OrdTable, ordTable ) import Rel8.Table.Projection   ( Projectable, Projecting, Projection, project, apply@@ -146,4 +156,38 @@   ListTable .   hvectorize (\_ (Identity (Name a)) -> Name a) .   pure .+  toColumns+++-- | Get the first element of a 'ListTable' (or 'Rel8.nullTable' if empty).+head :: Table Expr a => ListTable Expr a -> NullTable Expr a+head =+  fromColumns .+  hnullify (\Spec {info} -> sheadExpr info) .+  toColumns+++-- | @'index' i as@ extracts a single element from @as@, returning+-- 'Rel8.nullTable' if @i@ is out of range. Note that although PostgreSQL+-- array indexes are 1-based (by default), this function is always 0-based.+index :: Table Expr a => Expr Int32 -> ListTable Expr a -> NullTable Expr a+index i =+  fromColumns .+  hnullify (\Spec {info} -> sindexExpr info i) .+  toColumns+++-- | Get the last element of a 'ListTable' (or 'Rel8.nullTable' if empty).+last :: Table Expr a => ListTable Expr a -> NullTable Expr a+last =+  fromColumns .+  hnullify (\Spec {info} -> slastExpr info) .+  toColumns+++-- | Get the length of a 'ListTable'+length :: Table Expr a => ListTable Expr a -> Expr Int32+length =+  getFirst .+  hunvectorize (\_ -> First . lengthExpr) .   toColumns
src/Rel8/Table/Maybe.hs view
@@ -9,15 +9,18 @@ {-# language StandaloneKindSignatures #-} {-# language TypeApplications #-} {-# language TypeFamilies #-}+{-# language TypeOperators #-} {-# language UndecidableInstances #-}  module Rel8.Table.Maybe   ( MaybeTable(..)   , maybeTable, nothingTable, justTable   , isNothingTable, isJustTable+  , fromMaybeTable   , ($?)-  , aggregateMaybeTable   , nameMaybeTable+  , makeMaybeTable+  , unsafeFromJustTable   ) where @@ -31,12 +34,15 @@ -- comonad import Control.Comonad ( extract ) +-- opaleye+import qualified Opaleye.Field as Opaleye+import qualified Opaleye.SqlTypes as Opaleye+ -- 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.Expr.Opaleye (fromColumn, fromPrimExpr) import Rel8.Kind.Context ( Reifiable ) import Rel8.Schema.Dict ( Dict( Dict ) ) import qualified Rel8.Schema.Kind as K@@ -59,7 +65,7 @@ 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.Nullify (Nullify, guard, unsafeUnnullifyTable) import Rel8.Table.Serialize ( ToExprs ) import Rel8.Table.Undefined ( undefined ) import Rel8.Type ( DBType )@@ -206,6 +212,15 @@ justTable = MaybeTable mempty . pure  +-- | 'Data.Maybe.fromMaybe' for 'MaybeTable's.+fromMaybeTable :: Table Expr a => a -> MaybeTable Expr a -> a+fromMaybeTable fallback = maybeTable fallback id+++unsafeFromJustTable :: MaybeTable Expr a -> a+unsafeFromJustTable (MaybeTable _ just) = unsafeUnnullifyTable just++ -- | 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@.@@ -217,16 +232,6 @@ 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'.@@ -238,3 +243,10 @@      -- ^ Names of the columns in @a@.   -> MaybeTable Name a nameMaybeTable tag = MaybeTable tag . pure+++makeMaybeTable :: Opaleye.FieldNullable Opaleye.SqlBool -> a -> MaybeTable Expr a+makeMaybeTable tag a = MaybeTable+  { tag = fromPrimExpr $ fromColumn tag+  , just = pure a+  }
src/Rel8/Table/Name.hs view
@@ -12,6 +12,7 @@ module Rel8.Table.Name   ( namesFromLabels   , namesFromLabelsWith+  , namesFromLabelsWithA   , showLabels   , showNames   )@@ -20,17 +21,21 @@ -- base import Data.Foldable ( fold ) import Data.Functor.Const ( Const( Const ), getConst )+import Data.Functor.Identity (runIdentity) 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.HTable (htabulateA, hfield, hspecs) import Rel8.Schema.Name ( Name( Name ) ) import Rel8.Schema.Spec ( Spec(..) ) import Rel8.Table ( Table(..) ) +-- semigroupoids+import Data.Functor.Apply (Apply) + -- | Construct a table in the 'Name' context containing the names of all -- columns. Nested column names will be combined with @/@. --@@ -58,9 +63,14 @@ -- to the name of the Haskell field. namesFromLabelsWith :: Table Name a   => (NonEmpty String -> String) -> a-namesFromLabelsWith f = fromColumns $ htabulate $ \field ->+namesFromLabelsWith = runIdentity . namesFromLabelsWithA . (pure .)+++namesFromLabelsWithA :: (Apply f, Table Name a)+  => (NonEmpty String -> f String) -> f a+namesFromLabelsWithA f = fmap fromColumns $ htabulateA $ \field ->   case hfield hspecs field of-    Spec {labels} -> Name (f (renderLabels labels))+    Spec {labels} -> Name <$> f (renderLabels labels)   showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]
src/Rel8/Table/NonEmpty.hs view
@@ -7,6 +7,7 @@ {-# language StandaloneKindSignatures #-} {-# language TypeApplications #-} {-# language TypeFamilies #-}+{-# language TypeOperators #-} {-# language UndecidableInstances #-}  module Rel8.Table.NonEmpty@@ -14,11 +15,16 @@   , ($+)   , nonEmptyTable   , nameNonEmptyTable+  , head1+  , index1+  , last1+  , length1   ) where  -- base-import Data.Functor.Identity ( Identity( Identity ) )+import Data.Functor.Identity (Identity (Identity), runIdentity)+import Data.Int (Int32) import Data.Kind ( Type ) import Data.List.NonEmpty ( NonEmpty ) import Prelude hiding ( id )@@ -26,12 +32,15 @@ -- rel8 import Rel8.Expr ( Expr ) import Rel8.Expr.Array ( sappend1, snonEmptyOf )+import Rel8.Expr.NonEmpty (length1Expr, shead1Expr, sindex1Expr, slast1Expr) import Rel8.Schema.Dict ( Dict( Dict ) ) import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable ) import Rel8.Schema.HTable.Vectorize   ( hvectorize, hunvectorize+  , hnullify   , happend   , hproject, hcolumn+  , First (..)   ) import qualified Rel8.Schema.Kind as K import Rel8.Schema.Name ( Name( Name ) )@@ -45,6 +54,7 @@   ) import Rel8.Table.Alternative ( AltTable, (<|>:) ) import Rel8.Table.Eq ( EqTable, eqTable )+import Rel8.Table.Null (NullTable) import Rel8.Table.Ord ( OrdTable, ordTable ) import Rel8.Table.Projection   ( Projectable, Projecting, Projection, project, apply@@ -140,4 +150,40 @@   NonEmptyTable .   hvectorize (\_ (Identity (Name a)) -> Name a) .   pure .+  toColumns+++-- | Get the first element of a 'NonEmptyTable'.+head1 :: Table Expr a => NonEmptyTable Expr a -> a+head1 =+  fromColumns .+  runIdentity .+  hunvectorize (\Spec {info} -> Identity . shead1Expr info) .+  toColumns+++-- | @'index1' i as@ extracts a single element from @as@, returning+-- 'Rel8.nullTable' if @i@ is out of range. Note that although PostgreSQL+-- array indexes are 1-based (by default), this function is always 0-based.+index1 :: Table Expr a => Expr Int32 -> NonEmptyTable Expr a -> NullTable Expr a+index1 i =+  fromColumns .+  hnullify (\Spec {info} -> sindex1Expr info i) .+  toColumns+++-- | Get the last element of a 'NonEmptyTable'.+last1 :: Table Expr a => NonEmptyTable Expr a -> a+last1 =+  fromColumns .+  runIdentity .+  hunvectorize (\Spec {info} -> Identity . slast1Expr info) .+  toColumns+++-- | Get the length of a 'NonEmptyTable'+length1 :: Table Expr a => NonEmptyTable Expr a -> Expr Int32+length1 =+  getFirst .+  hunvectorize (\_ -> First . length1Expr) .   toColumns
+ src/Rel8/Table/Null.hs view
@@ -0,0 +1,149 @@+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language MultiParamTypeClasses #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language TypeOperators #-}+{-# language UndecidableInstances #-}++module Rel8.Table.Null+  ( NullTable(..)+  , nullableTable, nullTable, nullifyTable, unsafeUnnullifyTable+  , isNullTable, isNonNullTable+  , nameNullTable+  , toMaybeTable, toNullTable+  )+where++-- base+import Data.Kind ( Type )+import Prelude hiding ( null, undefined )++-- comonad+import Control.Comonad ( extract )++-- rel8+import Rel8.Expr ( Expr )+import Rel8.Expr.Bool ( not_ )+import Rel8.Kind.Context ( Reifiable )+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.Alternative+  ( AltTable, (<|>:)+  , AlternativeTable, emptyTable+  )+import Rel8.Table.Bool ( bool )+import Rel8.Table.Eq ( EqTable, eqTable )+import Rel8.Table.Maybe ( MaybeTable, justTable, maybeTable, nothingTable )+import Rel8.Table.Nullify ( Nullify, isNull )+import Rel8.Table.Ord ( OrdTable, ordTable )+import Rel8.Table.Projection ( Projectable, project )+import Rel8.Table.Serialize ( ToExprs )+import Rel8.Table.Undefined ( undefined )+++-- | @NullTable t@ is the table @t@, but where all the columns in @t@ have the+-- possibility of being 'Rel8.null'. This is very similar to+-- 'Rel8.MaybeTable', except that it does not use an extra tag field, so it+-- cannot distinguish between @Nothing@ and @Just Nothing@ if nested. In other+-- words, if all of the columns of the @t@ passed to @NullTable@ are already+-- nullable, then @NullTable@ has no effect.+type NullTable :: K.Context -> Type -> Type+newtype NullTable context a = NullTable (Nullify context a)+++instance Projectable (NullTable context) where+  project f (NullTable a) = NullTable (project f a)+++instance context ~ Expr => AltTable (NullTable context) where+  ma <|>: mb = bool ma mb (isNullTable ma)+++instance context ~ Expr => AlternativeTable (NullTable context) where+  emptyTable = nullTable+++instance (Table context a, Reifiable context, context ~ context') =>+  Table context' (NullTable context a)+ where+  type Columns (NullTable context a) = Columns (Nullify context a)+  type Context (NullTable context a) = Context (Nullify context a)+  type FromExprs (NullTable context a) = FromExprs (Nullify context a)+  type Transpose to (NullTable context a) = NullTable to (Transpose to a)++  toColumns (NullTable a) = toColumns a+  fromColumns = NullTable . fromColumns++  toResult = toResult @_ @(Nullify context a)+  fromResult = fromResult @_ @(Nullify context a)+++instance (EqTable a, context ~ Expr) => EqTable (NullTable context a) where+  eqTable = eqTable @(Nullify context a)+++instance (OrdTable a, context ~ Expr) => OrdTable (NullTable context a) where+  ordTable = ordTable @(Nullify context a)+++instance (ToExprs exprs a, context ~ Expr) =>+  ToExprs (NullTable context exprs) (Maybe a)+++-- | Check if any of the non-nullable fields of @a@ are 'Rel8.null' under the+-- 'NullTable'. Returns 'Rel8.false' if @a@ has no non-nullable fields.+isNullTable :: Table Expr a => NullTable Expr a -> Expr Bool+isNullTable (NullTable a) = isNull a+++-- | The inverse of 'isNullTable'.+isNonNullTable :: Table Expr a => NullTable Expr a -> Expr Bool+isNonNullTable = not_ . isNullTable+++-- | Like 'Rel8.nullable'.+nullableTable :: (Table Expr a, Table Expr b)+  => b -> (a -> b) -> NullTable Expr a -> b+nullableTable b f ma@(NullTable a) = bool (f (extract a)) b (isNullTable ma)+++-- | The null table. Like 'Rel8.null'.+nullTable :: Table Expr a => NullTable Expr a+nullTable = NullTable (pure undefined)+++-- | Lift any table into 'NullTable'. Like 'Rel8.nullify'.+nullifyTable :: a -> NullTable Expr a+nullifyTable = NullTable . pure+++-- | Assume that a 'NullTable' is non-null. Like 'Rel8.unsafeUnnullify'.+unsafeUnnullifyTable :: NullTable Expr a -> a+unsafeUnnullifyTable (NullTable a) = extract a+++-- | Construct a 'NullTable' in the 'Name' context. This can be useful if you+-- have a 'NullTable' that you are storing in a table and need to construct a+-- 'TableSchema'.+nameNullTable :: a -> NullTable Name a+nameNullTable = NullTable . pure+++-- | Convert a 'NullTable' to a 'MaybeTable'.+toMaybeTable :: Table Expr a => NullTable Expr a -> MaybeTable Expr a+toMaybeTable = nullableTable nothingTable justTable+++-- | Convert a 'MaybeTable' to a 'NullTable'. Note that if the underlying @a@+-- has no non-nullable fields, this is a lossy conversion.+toNullTable :: Table Expr a => MaybeTable Expr a -> NullTable Expr a+toNullTable = maybeTable nullTable nullifyTable
src/Rel8/Table/Nullify.hs view
@@ -1,22 +1,28 @@ {-# language DataKinds #-}+{-# language FlexibleContexts #-} {-# language FlexibleInstances #-} {-# language LambdaCase #-} {-# language MultiParamTypeClasses #-}+{-# language NamedFieldPuns #-} {-# language ScopedTypeVariables #-} {-# language StandaloneKindSignatures #-} {-# language TypeApplications #-} {-# language TypeFamilies #-}+{-# language TypeOperators #-} {-# language UndecidableInstances #-}  module Rel8.Table.Nullify   ( Nullify   , aggregateNullify   , guard+  , isNull+  , unsafeUnnullifyTable   ) where  -- base import Control.Applicative ( liftA2 )+import Data.Functor.Const ( Const( Const ), getConst ) import Data.Functor.Identity ( runIdentity ) import Data.Kind ( Type ) import Prelude@@ -24,12 +30,17 @@ -- comonad import Control.Comonad ( Comonad, duplicate, extract, ComonadApply, (<@>) ) +-- profunctors+import Data.Profunctor (dimap)+ -- rel8-import Rel8.Aggregate ( Aggregate )+import Rel8.Aggregate (Aggregator') import Rel8.Expr ( Expr )+import Rel8.Expr.Bool ( (||.), false )+import qualified Rel8.Expr.Null as Expr import Rel8.Kind.Context ( Reifiable, contextSing ) import Rel8.Schema.Context.Nullify-  ( Nullifiability( NAggregate, NExpr )+  ( Nullifiability( NExpr )   , NonNullifiability   , Nullifiable, nullifiability   , nullifiableOrNot, absurd@@ -45,12 +56,14 @@   , hproject   ) import qualified Rel8.Schema.Kind as K+import Rel8.Schema.Null ( Nullity( NotNull, Null ) ) import qualified Rel8.Schema.Result as R import Rel8.Table   ( Table, Columns, Context, toColumns, fromColumns   , FromExprs, fromResult, toResult   , Transpose   )+import Rel8.Schema.Spec ( Spec( Spec, nullity ) ) import Rel8.Table.Eq ( EqTable, eqTable ) import Rel8.Table.Ord ( OrdTable, ordTable ) import Rel8.Table.Projection ( Projectable, apply, project )@@ -166,12 +179,12 @@   aggregateNullify :: ()-  => (exprs -> aggregates)-  -> Nullify Expr exprs-  -> Nullify Aggregate aggregates-aggregateNullify f = \case-  Table _ a -> Table NAggregate (f a)-  Fields notNullifiable _ -> absurd NExpr notNullifiable+  => Aggregator' fold i a+  -> Aggregator' fold (Nullify Expr i) (Nullify Expr a)+aggregateNullify = dimap from to+  where+    from = unsafeUnnullifyTable+    to = Table NExpr   guard :: (Reifiable context, HTable t)@@ -182,3 +195,28 @@   -> HNullify t context guard tag isNonNull isNonNullExpr =   hguard (guarder contextSing tag isNonNull isNonNullExpr)+++isNull :: forall a. Table Expr a => Nullify Expr a -> Expr Bool+isNull =+  maybe false getAny .+  getConst .+  hunnullify (\Spec {nullity} a -> Const $ case nullity of+    NotNull -> Just $ Any $ Expr.isNull a+    Null -> Nothing) .+  toColumns+++unsafeUnnullifyTable :: Nullify Expr a -> a+unsafeUnnullifyTable = \case+  Table _ a -> a+  Fields notNullifiable _ -> absurd NExpr notNullifiable+++newtype Any = Any+  { getAny :: Expr Bool+  }+++instance Semigroup Any where+  Any a <> Any b = Any (a ||. b)
src/Rel8/Table/Opaleye.hs view
@@ -7,66 +7,67 @@ {-# language TypeFamilies #-} {-# language ViewPatterns #-} +{-# options_ghc -Wno-deprecations #-}+ module Rel8.Table.Opaleye-  ( aggregator-  , attributes+  ( attributes   , binaryspec   , distinctspec   , exprs   , exprsWithNames+  , ifPP+  , relExprPP   , table   , tableFields   , unpackspec   , valuesspec   , view   , castTable+  , fromOrder   ) where  -- base+import Data.Foldable (traverse_) import Data.Functor.Const ( Const( Const ), getConst ) import Data.List.NonEmpty ( NonEmpty )-import Prelude hiding ( undefined )+import Prelude  -- 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.Adaptors as Opaleye+import qualified Opaleye.Field as Opaleye ( Field_ ) import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye+import qualified Opaleye.Internal.Operators as Opaleye+import qualified Opaleye.Internal.Order 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+import qualified Opaleye.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+  , scastExpr, traverseFieldP   )-import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs, htabulate )+import Rel8.Schema.HTable+  ( htabulateA, hfield, hspecs, htabulate+  , htraverseP, htraversePWithField+  ) import Rel8.Schema.Name ( Name( Name ), Selects, ppColumn )+import Rel8.Schema.QualifiedName (QualifiedName (QualifiedName)) import Rel8.Schema.Spec ( Spec(..) ) import Rel8.Schema.Table ( TableSchema(..), ppTable ) import Rel8.Table ( Table, fromColumns, toColumns )-import Rel8.Table.Undefined ( undefined )+import Rel8.Type.Information ( typeName )+import Rel8.Type.Name (showTypeName)  -- 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 ()+import Data.Profunctor.Product ( ProductProfunctor )   attributes :: Selects names exprs => TableSchema names -> exprs@@ -77,22 +78,19 @@         show (ppTable schema) <> "." <> show (ppColumn column)  +fromOpaleyespec :: (ProductProfunctor p, Table Expr a)+  => p (Opaleye.Field_ n x) (Opaleye.Field_ n x)+  -> p a a+fromOpaleyespec x =+  dimap toColumns fromColumns (htraverseP (traverseFieldP x))++ 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)+binaryspec = fromOpaleyespec Opaleye.binaryspecField   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+distinctspec = fromOpaleyespec Opaleye.distinctspecField   exprs :: Table Expr a => a -> NonEmpty Opaleye.PrimExpr@@ -108,11 +106,19 @@     (Name name, expr) -> Const (pure (name, toPrimExpr expr))  +ifPP :: Table Expr a => Opaleye.IfPP a a+ifPP = fromOpaleyespec Opaleye.ifPPField+++relExprPP :: Table Expr a => Opaleye.RelExprPP a a+relExprPP = fromOpaleyespec Opaleye.relExprColumn++ table :: Selects names exprs => TableSchema names -> Opaleye.Table exprs exprs-table (TableSchema name schema columns) =+table (TableSchema (QualifiedName name schema) columns) =   case schema of-    Nothing -> Opaleye.Table name (tableFields columns)-    Just schemaName -> Opaleye.TableWithSchema schemaName name (tableFields columns)+    Nothing -> Opaleye.table name (tableFields columns)+    Just schemaName -> Opaleye.tableWithSchema schemaName name (tableFields columns)   tableFields :: Selects names exprs@@ -124,21 +130,20 @@   where     go :: Name a -> Opaleye.TableFields (Expr a) (Expr a)     go (Name name) =-      dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $+      traverseFieldP $         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+unpackspec = fromOpaleyespec Opaleye.unpackspecField {-# INLINABLE unpackspec #-}  -valuesspec :: Table Expr a => Opaleye.ValuesspecSafe a a-valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec+valuesspec :: Table Expr a => Opaleye.Valuesspec a a+valuesspec = dimap toColumns fromColumns $+  htraversePWithField (traverseFieldP . Opaleye.valuesspecFieldType . typeName)+  where+    typeName = showTypeName . Rel8.Type.Information.typeName . info . hfield hspecs   view :: Selects names exprs => names -> exprs@@ -147,15 +152,6 @@     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.@@ -164,3 +160,9 @@   case hfield hspecs field of     Spec {info} -> case hfield as field of         expr -> scastExpr info expr+++fromOrder :: Opaleye.Order a -> Opaleye.Unpackspec a a+fromOrder (Opaleye.Order o) =+  Opaleye.Unpackspec $ Opaleye.PackMap $ \f a ->+    a <$ traverse_ (f . snd) (o a)
src/Rel8/Table/Ord.hs view
@@ -146,9 +146,9 @@  -- | 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)+least a b = bool b a (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)+greatest a b = bool b a (a >: b)
src/Rel8/Table/Rel8able.hs view
@@ -5,6 +5,7 @@ {-# language StandaloneKindSignatures #-} {-# language TypeApplications #-} {-# language TypeFamilies #-}+{-# language TypeOperators #-} {-# language UndecidableInstances #-}  {-# options_ghc -fno-warn-orphans #-}@@ -16,6 +17,9 @@  -- base import Prelude ()++-- base-compat+import Data.Type.Equality.Compat  -- rel8 import Rel8.Expr ( Expr )
src/Rel8/Table/Serialize.hs view
@@ -7,6 +7,7 @@ {-# language StandaloneKindSignatures #-} {-# language TypeApplications #-} {-# language TypeFamilies #-}+{-# language TypeOperators #-} {-# language UndecidableInstances #-}  module Rel8.Table.Serialize
src/Rel8/Table/These.hs view
@@ -10,6 +10,7 @@ {-# language TupleSections #-} {-# language TypeApplications #-} {-# language TypeFamilies #-}+{-# language TypeOperators #-} {-# language UndecidableInstances #-}  {-# options_ghc -fno-warn-orphans #-}@@ -20,22 +21,32 @@   , isThisTable, isThatTable, isThoseTable   , hasHereTable, hasThereTable   , justHereTable, justThereTable+  , alignMaybeTable+  , aggregateThisTable, aggregateThisTable1+  , aggregateThatTable, aggregateThatTable1+  , aggregateThoseTable, aggregateThoseTable1+  , aggregateHereTable, aggregateHereTable1+  , aggregateThereTable, aggregateThereTable1   , aggregateTheseTable   , nameTheseTable   ) where  -- base+import Control.Arrow ((&&&)) import Data.Bifunctor ( Bifunctor, bimap ) import Data.Kind ( Type ) import Data.Maybe ( isJust )-import Prelude hiding ( undefined )+import Prelude hiding ( null, undefined ) +-- profunctors+import Data.Profunctor (lmap)+ -- rel8-import Rel8.Aggregate ( Aggregate )+import Rel8.Aggregate (Aggregator, Aggregator', Aggregator1) import Rel8.Expr ( Expr )-import Rel8.Expr.Bool ( (&&.), not_ )-import Rel8.Expr.Null ( isNonNull )+import Rel8.Expr.Bool ( (&&.), (||.), boolExpr, not_ )+import Rel8.Expr.Null ( null, isNonNull ) import Rel8.Kind.Context ( Reifiable ) import Rel8.Schema.Context.Nullify ( Nullifiable ) import Rel8.Schema.Dict ( Dict( Dict ) )@@ -50,13 +61,19 @@   , FromExprs, fromResult, toResult   , Transpose   )+import Rel8.Table.Aggregate (filterWhere)+import Rel8.Table.Aggregate.Maybe+  ( aggregateJustTable, aggregateJustTable1+  , aggregateMaybeTable+  , filterWhereOptional+  ) import Rel8.Table.Eq ( EqTable, eqTable ) import Rel8.Table.Maybe   ( MaybeTable(..)   , maybeTable, justTable, nothingTable   , isJustTable-  , aggregateMaybeTable   , nameMaybeTable+  , unsafeFromJustTable   ) import Rel8.Table.Nullify ( Nullify, guard ) import Rel8.Table.Ord ( OrdTable, ordTable )@@ -288,6 +305,16 @@ justThereTable = there  +-- | Construct a @TheseTable@ from two 'MaybeTable's.+alignMaybeTable :: ()+  => MaybeTable Expr a+  -> MaybeTable Expr b+  -> MaybeTable Expr (TheseTable Expr a b)+alignMaybeTable a b = MaybeTable tag (pure (TheseTable a b))+  where+    tag = boolExpr null mempty (isJustTable a ||. isJustTable b)++ -- | Construct a @TheseTable@. Corresponds to 'This'. thisTable :: Table Expr b => a -> TheseTable Expr a b thisTable a = TheseTable (justTable a) nothingTable@@ -313,17 +340,126 @@     there  --- | Lift a pair of aggregating functions to operate on an 'TheseTable'.--- @thisTable@s, @thatTable@s and @thoseTable@s are grouped separately.+-- | Lift an 'Aggregator' to operate on a 'TheseTable'. If the input query has+-- @'thisTable' a@s, they are folded into a single @c@ by the given aggregator+-- — in the case where the input query is all 'thatTable's or 'thoseTable's,+-- the 'Aggregator'\'s fallback @c@ is returned.+aggregateThisTable :: Table Expr c+  => Aggregator a c+  -> Aggregator' fold (TheseTable Expr a b) c+aggregateThisTable =+  filterWhere isThisTable . lmap (unsafeFromJustTable . here)+++-- | Lift an 'Aggregator1' to operate on a 'TheseTable'. If the input query+-- has @'thisTable' a@s, they are folded into a single @'Rel8.justTable' c@+-- by the given aggregator — in the case where the input query is all+-- 'thatTable's or 'thoseTable's, a single 'nothingTable' row is returned.+aggregateThisTable1 :: Table Expr c+  => Aggregator' fold a c+  -> Aggregator' fold' (TheseTable Expr a b) (MaybeTable Expr c)+aggregateThisTable1 =+  filterWhereOptional isThisTable . lmap (unsafeFromJustTable . here)+++-- | Lift an 'Aggregator' to operate on a 'TheseTable'. If the input query has+-- @'thatTable' b@s, they are folded into a single @c@ by the given aggregator+-- — in the case where the input query is all 'thisTable's or 'thoseTable's,+-- the 'Aggregator'\'s fallback @c@ is returned.+aggregateThatTable :: Table Expr c+  => Aggregator b c+  -> Aggregator' fold (TheseTable Expr a b) c+aggregateThatTable =+  filterWhere isThatTable . lmap (unsafeFromJustTable . there)+++-- | Lift an 'Aggregator1' to operate on a 'TheseTable'. If the input query+-- has @'thatTable' b@s, they are folded into a single @'Rel8.justTable' c@+-- by the given aggregator — in the case where the input query is all+-- 'thisTable's or 'thoseTable's, a single 'nothingTable' row is returned.+aggregateThatTable1 :: Table Expr c+  => Aggregator' fold b c+  -> Aggregator' fold' (TheseTable Expr a b) (MaybeTable Expr c)+aggregateThatTable1 =+  filterWhereOptional isThatTable . lmap (unsafeFromJustTable . there)+++-- | Lift an 'Aggregator' to operate on a 'ThoseTable'. If the input query has+-- @'thoseTable' a b@s, they are folded into a single @c@ by the given+-- aggregator — in the case where the input query is all 'thisTable's or+-- 'thatTable's, the 'Aggregator'\'s fallback @c@ is returned.+aggregateThoseTable :: Table Expr c+  => Aggregator (a, b) c+  -> Aggregator' fold (TheseTable Expr a b) c+aggregateThoseTable =+  filterWhere isThoseTable+    . lmap (unsafeFromJustTable . here &&& unsafeFromJustTable . there)+++-- | Lift an 'Aggregator1' to operate on a 'TheseTable'. If the input query+-- has @'thoseTable' a b@s, they are folded into a single @'Rel8.justTable' c@+-- by the given aggregator — in the case where the input query is all+-- 'thisTable's or 'thatTable's, a single 'nothingTable' row is returned.+aggregateThoseTable1 :: Table Expr c+  => Aggregator' fold (a, b) c+  -> Aggregator' fold' (TheseTable Expr a b) (MaybeTable Expr c)+aggregateThoseTable1 =+  filterWhereOptional isThoseTable+    . lmap (unsafeFromJustTable . here &&& unsafeFromJustTable . there)+++-- | Lift an 'Aggregator' to operate on a 'TheseTable'. If the input query has+-- @'thisTable' a@s or @'thoseTable' a _@s, the @a@s are folded into a single+-- @c@ by the given aggregator — in the case where the input query is all+-- 'thatTable's, the 'Aggregator'\'s fallback @c@ is returned.+aggregateHereTable :: Table Expr c+  => Aggregator a c+  -> Aggregator' fold (TheseTable Expr a b) c+aggregateHereTable = lmap here . aggregateJustTable+++-- | Lift an 'Aggregator1' to operate on an 'TheseTable'. If the input query+-- has @'thisTable' a@s or @'thoseTable' a _@s, the @a@s are folded into a+-- single @'Rel8.justTable' c@ by the given aggregator — in the case where+-- the input query is all 'thatTable's, a single 'nothingTable' row is+-- returned.+aggregateHereTable1 :: Table Expr c+  => Aggregator' fold a c+  -> Aggregator' fold' (TheseTable Expr a b) (MaybeTable Expr c)+aggregateHereTable1 = lmap here . aggregateJustTable1+++-- | Lift an 'Aggregator' to operate on a 'TheseTable'. If the input query has+-- @'thatTable' b@s or @'thoseTable' _ b@s, the @b@s are folded into a single+-- @c@ by the given aggregator — in the case where the input query is all+-- 'thisTable's, the 'Aggregator'\'s fallback @c@ is returned.+aggregateThereTable :: Table Expr c+  => Aggregator b c+  -> Aggregator' fold (TheseTable Expr a b) c+aggregateThereTable = lmap there . aggregateJustTable+++-- | Lift an 'Aggregator1' to operate on an 'TheseTable'. If the input query+-- has @'thatTable' b@s or @'thoseTable' _ b@s, the @b@s are folded into a+-- single @'Rel8.justTable' c@ by the given aggregator — in the case where+-- the input query is all 'thisTable's, a single 'nothingTable' row is+-- returned.+aggregateThereTable1 :: Table Expr c+  => Aggregator' fold b c+  -> Aggregator' fold' (TheseTable Expr a b) (MaybeTable Expr c)+aggregateThereTable1 = lmap there . aggregateJustTable1+++-- | Lift a pair aggregators to operate on a 'TheseTable'. 'thisTable's,+-- 'thatTable's are '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-  }+  => Aggregator' fold i a+  -> Aggregator' fold' i' b+  -> Aggregator1 (TheseTable Expr i i') (TheseTable Expr a b)+aggregateTheseTable a b =+  TheseTable+    <$> lmap here (aggregateMaybeTable a)+    <*> lmap there (aggregateMaybeTable b)   -- | Construct a 'TheseTable' in the 'Name' context. This can be useful if you
src/Rel8/Table/Transpose.hs view
@@ -3,6 +3,7 @@ {-# language FunctionalDependencies #-} {-# language StandaloneKindSignatures #-} {-# language TypeFamilies #-}+{-# language TypeOperators #-} {-# language UndecidableInstances #-}  module Rel8.Table.Transpose@@ -13,6 +14,9 @@ -- base import Data.Kind ( Constraint, Type ) import Prelude ()++-- base-compat+import Data.Type.Equality.Compat  -- rel8 import qualified Rel8.Schema.Kind as K
+ src/Rel8/Table/Verify.hs view
@@ -0,0 +1,644 @@++{-# language BlockArguments #-}+{-# language LambdaCase #-}+{-# language RecordWildCards #-}+{-# language RankNTypes #-}+{-# language DuplicateRecordFields #-}+{-# language DerivingStrategies #-}+{-# language OverloadedRecordDot #-}+{-# language TypeApplications #-}+{-# language NamedFieldPuns #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneDeriving #-}+{-# language DeriveAnyClass #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language DeriveGeneric #-}+{-# language GeneralizedNewtypeDeriving #-}+{-# language OverloadedStrings #-}+{-# language GADTs #-}++module Rel8.Table.Verify+    ( getSchemaErrors+    , SomeTableSchema(..)+    , showCreateTable+    , checkedShowCreateTable+    ) where++-- base+import Control.Monad+import Data.Bits (shiftR, (.&.))+import Data.Either (lefts)+import Data.Function+import Data.Functor ((<&>))+import Data.Functor.Const+import Data.Functor.Contravariant ( (>$<) )+import Data.Int ( Int16, Int64 )+import qualified Data.List as L+import Data.List.NonEmpty ( NonEmpty((:|)) )+import qualified Data.List.NonEmpty as NonEmpty+import Data.Maybe (isJust, mapMaybe)+import Data.Text ( Text )+import qualified Data.Text as T+import GHC.Generics+import Prelude hiding ( filter )+import qualified Prelude as P++-- containers+import qualified Data.Map as M++-- hasql+import Hasql.Connection+import qualified Hasql.Statement as HS++-- rel8+import Rel8 -- not importing this seems to cause a type error???+import Rel8.Column ( Column )+import Rel8.Column.List ( HList )+import Rel8.Expr ( Expr )+import Rel8.Generic.Rel8able (GFromExprs, Rel8able)+import Rel8.Query ( Query )+import Rel8.Schema.HTable+import Rel8.Schema.Name ( Name(Name) )+import Rel8.Schema.Null hiding (nullable)+import qualified Rel8.Schema.Null as Null+import qualified Rel8.Statement.Run as RSR+import Rel8.Schema.Table ( TableSchema(..) )+import Rel8.Schema.Spec+import Rel8.Schema.Result ( Result )+import Rel8.Schema.QualifiedName ( QualifiedName(..) )+import Rel8.Table ( Columns )+import Rel8.Table.List ( ListTable )+import Rel8.Table.Serialize ( ToExprs )+import Rel8.Type ( DBType(..) )+import Rel8.Type.Eq ( DBEq )+import Rel8.Type.Name ( TypeName(..) )++-- these+import Data.These+++data Relkind+    = OrdinaryTable+    | Index+    | Sequence+    | ToastTable+    | View+    | MaterializedView+    | CompositeType+    | ForeignTable+    | PartitionedTable+    | PartitionedIndex+  deriving stock (Show)+  deriving anyclass (DBEq)++instance DBType Relkind where+  typeInformation = parseTypeInformation parser printer typeInformation+    where+      parser = \case+        "r"         -> pure OrdinaryTable+        "i"         -> pure Index+        "S"         -> pure Sequence+        "t"         -> pure ToastTable+        "v"         -> pure View+        "m"         -> pure MaterializedView+        "c"         -> pure CompositeType+        "f"         -> pure ForeignTable+        "p"         -> pure PartitionedTable+        "I"         -> pure PartitionedIndex+        (x :: Text) -> Left $ "Unknown relkind: " ++ show x++      printer = \case+        OrdinaryTable -> "r"+        Index -> "i"+        Sequence -> "S"+        ToastTable -> "t"+        View -> "v"+        MaterializedView -> "m"+        CompositeType -> "c"+        ForeignTable -> "f"+        PartitionedTable -> "p"+        PartitionedIndex -> "I"++newtype Oid = Oid Int64+  deriving newtype (DBType, DBEq, Show)++data PGClass f = PGClass+  { oid :: Column f Oid+  , relname :: Column f Text+  , relkind :: Column f Relkind+  , relnamespace :: Column f Oid+  }+  deriving stock (Generic)+  deriving anyclass (Rel8able)++deriving stock instance Show (PGClass Result)++pgclass :: TableSchema (PGClass Name)+pgclass = TableSchema+  { name = QualifiedName "pg_class" (Just "pg_catalog")+  , columns = namesFromLabelsWith NonEmpty.last+  }++data PGAttribute f = PGAttribute+  { attrelid :: Column f Oid+  , attname :: Column f Text+  , atttypid :: Column f Oid+  , attnum :: Column f Int64+  , atttypmod :: Column f Int64+  , attnotnull :: Column f Bool+  , attndims :: Column f Int16+  }+  deriving stock (Generic)+  deriving anyclass (Rel8able)++deriving stock instance Show (PGAttribute Result)++pgattribute :: TableSchema (PGAttribute Name)+pgattribute = TableSchema+  { name = QualifiedName "pg_attribute" (Just "pg_catalog")+  , columns = namesFromLabelsWith NonEmpty.last+  }++data PGType f = PGType+  { oid :: Column f Oid+  , typname :: Column f Text+  , typnamespace :: Column f Oid+  }+  deriving stock (Generic)+  deriving anyclass (Rel8able)++deriving stock instance Show (PGType Result)++pgtype :: TableSchema (PGType Name)+pgtype = TableSchema+  { name = QualifiedName "pg_type" (Just "pg_catalog")+  , columns = namesFromLabelsWith NonEmpty.last+  }++data PGNamespace f = PGNamespace+  { oid :: Column f Oid+  , nspname :: Column f Text+  }+  deriving stock (Generic)+  deriving anyclass (Rel8able)++deriving stock instance Show (PGNamespace Result)++pgnamespace :: TableSchema (PGNamespace Name)+pgnamespace = TableSchema+  { name = QualifiedName "pg_namespace" (Just "pg_catalog")+  , columns = namesFromLabelsWith NonEmpty.last+  }++data PGCast f = PGCast+  { oid :: Column f Oid+  , castsource :: Column f Oid+  , casttarget :: Column f Oid+  , castfunc :: Column f Oid+  , castcontext :: Column f Text -- Char+  , castmethod :: Column f Char+  }+  deriving stock (Generic)+  deriving anyclass (Rel8able)++deriving stock instance Show (PGCast Result)++pgcast :: TableSchema (PGCast Name)+pgcast = TableSchema+  { name = QualifiedName "pg_cast" (Just "pg_catalog")+  , columns = namesFromLabelsWith NonEmpty.last+  }++data PGTable f = PGTable+  { name :: Column f Text+  , columns :: HList f (Attribute f)+  }+  deriving stock (Generic)+  deriving anyclass (Rel8able)++deriving stock instance Show (PGTable Result)++data Attribute f = Attribute+  { attribute :: PGAttribute f+  , typ :: PGType f+  , namespace :: PGNamespace f+  }+  deriving stock (Generic)+  deriving anyclass (Rel8able)++deriving stock instance Show (Attribute Result)++data Cast f = Cast+  { source :: PGType f+  , target :: PGType f+  , context :: Column f Text -- Char +  }+  deriving stock (Generic)+  deriving anyclass (Rel8able)++deriving stock instance Show (Cast Result)++fetchTables :: Query (ListTable Expr (PGTable Expr))+fetchTables = many do+    PGClass{ oid = tableOid, relname } <- orderBy (relname >$< asc) do+      each pgclass+        >>= filter ((lit OrdinaryTable ==.) . relkind)++    columns <- many do+      attribute@PGAttribute{ atttypid } <-+        each pgattribute+          >>= filter ((tableOid ==.) . attrelid)+          >>= filter ((>. 0) . attnum)++      typ <-+        each pgtype+          >>= filter (\PGType{ oid = typoid } -> atttypid ==. typoid)++      namespace <-+        each pgnamespace+          >>= filter (\PGNamespace{ oid = nsoid } -> nsoid ==. typ.typnamespace)++++      return Attribute{ attribute, typ, namespace }++    return PGTable+      { name = relname+      , ..+      }++fetchCasts :: Query (ListTable Expr (Cast Expr))+fetchCasts = many do+    PGCast {castsource, casttarget, castcontext} <- each pgcast+    src <- each pgtype >>= filter (\PGType { oid = typoid } -> typoid ==. castsource)+    tgt <- each pgtype >>= filter (\PGType { oid = typoid } -> typoid ==. casttarget)+    return Cast { source = src, target = tgt, context = castcontext }+++data CheckEnv = CheckEnv+  { schemaMap :: M.Map String [Attribute Result] -- map of schemas to attributes+  , casts :: [(String, String)] -- list of implicit casts+  } deriving (Show)+++nullableToBool :: Nullity a -> Bool+nullableToBool Null = True+nullableToBool NotNull = False+++attrsToMap :: [Attribute Result] -> M.Map String (Attribute Result)+attrsToMap = M.fromList . map (\attr -> (T.unpack attr.attribute.attname, attr))+++data TypeInfo = TypeInfo+  { label :: [String]+  , isNull :: Bool+  , typeName :: TypeName+  }+instance Show TypeInfo where+  show = showTypeInfo+++-- @'schemaToTypeMap'@ takes a schema and returns a map of database column names+-- to the type information associated with the column. It is possible (though+-- undesirable) to write a schema which has multiple columns with the same name,+-- so a list of results are returned for each key.+schemaToTypeMap :: forall k. Rel8able k => k Name -> M.Map String (NonEmpty.NonEmpty TypeInfo)+schemaToTypeMap cols = go . uncurry zip . getConst $+  htabulateA @(Columns (k Name)) $ \field -> +    case (hfield hspecs field, hfield (toColumns cols) field) of +      (Spec {..}, Name name) -> Const ([name], [+        TypeInfo { label = labels+                 , isNull = nullableToBool nullity+                 , typeName = info.typeName}])+  where+    go :: [(String, TypeInfo)] -> M.Map String (NonEmpty.NonEmpty TypeInfo)+    go = M.fromListWith (<>) . map (\(name, typeInfo) -> (name, NonEmpty.singleton typeInfo))++-- A checked version of @schemaToTypeMap@, which returns a list of columns with+-- duplicate names if any such columns are present. Otherwise it returns the+-- type map with no duplicates.+checkedSchemaToTypeMap :: Rel8able k+  => k Name+  -> Either (M.Map String (NonEmpty.NonEmpty TypeInfo)) (M.Map String TypeInfo)+checkedSchemaToTypeMap cols =+  let typeMap = schemaToTypeMap cols+      duplicates = M.filter (\col -> length col > 1) typeMap+  in if length duplicates > 0+  then Left duplicates+  else Right (typeMap & M.mapMaybe \case+    a :| [] -> Just a+    _ -> Nothing)+++showCreateTable_helper :: String -> M.Map String TypeInfo -> String+showCreateTable_helper name typeMap = "CREATE TABLE " <> show name <> " ("+    ++ L.intercalate "," (fmap go $ M.assocs typeMap)+    ++ "\n);"+  where+    go :: (String, TypeInfo) -> String+    go (name, typeInfo) = "\n    " ++ show name ++ " " ++ showTypeInfo typeInfo+++-- |@'showCreateTable'@ shows an example CREATE TABLE statement for the table.+-- This does not show relationships like primary or foreign keys, but can still+-- be useful to see what types @rel8@ will expect of the underlying database.+--+-- In the event that multiple columns have the same name, this will fail silently. To+-- handle that case, see 'checkedShowCreateTable'+showCreateTable :: Rel8able k => TableSchema (k Name) -> String+showCreateTable schema = showCreateTable_helper schema.name.name $ fmap NonEmpty.head $ schemaToTypeMap schema.columns++-- |@'checkedShowCreateTable'@ shows an example CREATE TABLE statement for the+-- table. This does not show relationships like primary or foreign keys, but can+-- still be useful to see what types rel8 will expect of the underlying database.+--+-- In the event that multiple columns have the same name, this will return a map of+-- names to the labels identifying the column.+checkedShowCreateTable :: Rel8able k => TableSchema (k Name) -> Either (M.Map String (NonEmpty [String])) String+checkedShowCreateTable schema = case checkedSchemaToTypeMap schema.columns of+    Left e -> Left $ (fmap . fmap) (\typ -> typ.label)  e+    Right a -> Right $ showCreateTable_helper schema.name.name a++-- implicit casts are ok as long as they're bidirectional+checkTypeEquality :: CheckEnv -> TypeInfo -> TypeInfo -> Maybe ColumnError+checkTypeEquality env db hs+  | Prelude.and [sameDims, sameMods, toName db == toName hs || castExists]+    = Nothing+  | otherwise+    = Just BidirectionalCastDoesNotExist+  where+    castExists = Prelude.and+      [ (toName db, toName hs) `elem` env.casts+      , (toName hs, toName db) `elem` env.casts+      ]++    sameMods, sameDims :: Bool+    sameMods = db.typeName.modifiers == hs.typeName.modifiers+    sameDims = db.typeName.arrayDepth == hs.typeName.arrayDepth++    sameName = equalName db.typeName.name hs.typeName.name++    toName :: TypeInfo -> String+    toName typeInfo = case typeInfo.typeName.name of+        QualifiedName name _ -> L.dropWhile (=='_') name++equalName :: QualifiedName -> QualifiedName -> Bool+equalName (QualifiedName a (Just b)) (QualifiedName a' (Just b'))+  = L.dropWhile (=='_') a == L.dropWhile (=='_') a' && b == b'+equalName (QualifiedName a _) (QualifiedName a' _)+  = dropWhile (=='_') a == dropWhile (=='_') a'++-- check types for a single table+compareTypes+    :: CheckEnv+    -> M.Map String (Attribute Result)+    -> M.Map String TypeInfo+    -> [ColumnInfo]+compareTypes env attrMap typeMap = fmap (uncurry go) $ M.assocs (disjointUnion attrMap typeMap)+  where+    go :: String -> These (Attribute Result) TypeInfo -> ColumnInfo+    go name (These a b) = ColumnInfo+        { name = name+        , dbType = Just $ fromAttribute a+        , hsType = Just $ b+        , error = checkTypeEquality env (fromAttribute a) b+        }+    go name (This a) = ColumnInfo+        { name = name+        , dbType = Just $ fromAttribute a+        , hsType = Nothing+        , error =+            if a.attribute.attnotnull+            then Just DbTypeIsNotNullButNotPresentInHsType+            else Nothing+        }+    go name (That b) = ColumnInfo+        { name = name+        , dbType = Nothing+        , hsType = Just $ b+        , error = Just HsTypeIsPresentButNotPresentInDbType+        }++    fromAttribute :: Attribute Result -> TypeInfo+    fromAttribute attr = TypeInfo+        { label = [T.unpack attr.attribute.attname]+        , isNull = not attr.attribute.attnotnull+        , typeName = TypeName+            { name = QualifiedName+                (T.unpack attr.typ.typname)+                (Just $ T.unpack attr.namespace.nspname)+            , modifiers = toModifier+                (T.dropWhile (=='_') attr.typ.typname)+                attr.attribute.atttypmod+            , arrayDepth = fromIntegral attr.attribute.attndims+            }+        }++    toModifier :: Text -> Int64 -> [String]+    toModifier "bpchar" (-1) = []+    toModifier "bpchar" n = [show (n - 4)]+    toModifier "numeric" (-1) = []+    toModifier "numeric" n = [show $ (n - 4) `shiftR` 16, show $ (n - 4) .&. 65535]+    toModifier _ _ = []++    disjointUnion :: Ord k => M.Map k a -> M.Map k b -> M.Map k (These a b)+    disjointUnion a b = M.unionWith go (fmap This a) (fmap That b)+      where+        go :: These a b -> These a b -> These a b+        go (This a) (That b) = These a b+        go _ _ = undefined+++-- |@pShowTable@ is a helper function which takes a grid of text and prints it+-- as a table, with padding so that cells are lined in columns, and a bordered+-- header for the first row+pShowTable :: [[Text]] -> Text+pShowTable xs+    = T.intercalate "\n"+    $ addHeaderBorder+    $ fmap (T.intercalate " | ")+    $ L.transpose+    $ zip lengths xs' <&> \(n, column) -> column <&> \cell -> T.justifyLeft n ' ' cell+  where+    addHeaderBorder :: [Text] -> [Text]+    addHeaderBorder [] = []+    addHeaderBorder (x : xs) = x : T.replicate (T.length x) "-" : xs++    xs' :: [[Text]]+    xs' = L.transpose xs++    lengths :: [Int]+    lengths = fmap (maximum . fmap T.length) $ xs'+++pShowErrors :: [TableInfo] -> Text+pShowErrors = T.intercalate "\n\n" . fmap go+  where+    go :: TableInfo -> Text+    go (TableInfo {tableExists, name, columns}) = "Table: " <> T.pack name+        <> if not tableExists then " does not exist\n" else "\n"+        <> pShowTable (["Column Name", "Implied DB type", "Current DB type", "Error"] : (columns <&> \column ->+            [ T.pack $ column.name+            , T.pack $ maybe "" showTypeInfo column.hsType+            , T.pack $ maybe "" showTypeInfo column.dbType+            , T.pack $ maybe "" show column.error+            ]))+    go (DuplicateNames {name, duplicates}) = mconcat+        [ "Table "+        , T.pack (show name)+        , " has multiple columns with the same name. This is an error with the Haskell code generating an impossible schema, rather than an error in your current setup of the database itself. Using 'namesFromLabels' can ensure each column has unique names, which is the easiest way to prevent this, but may require changing names in your database to match the new generated names."+        , pShowTable (["DB name", "Haskell label"] : (M.assocs duplicates <&> \(name, typs) ->+            [ T.pack name+            , T.intercalate " " $ fmap (\typ -> T.intercalate "/" $ fmap T.pack typ.label) $ NonEmpty.toList typs+            ]))+        ]+++data TableInfo+  = TableInfo+    { tableExists :: Bool+    , name :: String+    , columns :: [ColumnInfo]+    }+  | DuplicateNames+    { name :: String+    , duplicates :: M.Map String (NonEmpty.NonEmpty TypeInfo)+    }+  deriving (Show)++data ColumnInfo = ColumnInfo+    { name   :: String+    , hsType :: Maybe TypeInfo+    , dbType :: Maybe TypeInfo+    , error :: Maybe ColumnError+    } deriving (Show)++data ColumnError+    = DbTypeIsNotNullButNotPresentInHsType+    | HsTypeIsPresentButNotPresentInDbType+    | BidirectionalCastDoesNotExist+    deriving (Show)+++showTypeInfo :: TypeInfo -> String+showTypeInfo typeInfo = concat+    [ name+    , if Prelude.null modifiers then "" else "(" <> L.intercalate "," modifiers <> ")"+    , concat (replicate (fromIntegral typeInfo.typeName.arrayDepth) "[]")+    , if typeInfo.isNull then "" else " NOT NULL"+    ]+  where+    name = case typeInfo.typeName.name of+        QualifiedName a Nothing -> show (dropWhile (=='_') a)+        QualifiedName a (Just b) -> show b <> "." <> show (dropWhile (=='_') a)++    modifiers :: [String]+    modifiers = typeInfo.typeName.modifiers+++verifySchema :: Rel8able k => CheckEnv -> TableSchema (k Name) -> TableInfo+verifySchema env schema = case checkedSchemaToTypeMap schema.columns of+    Left dups -> DuplicateNames schema.name.name dups+    Right typeMap -> go typeMap maybeTable+  where+    maybeTable = M.lookup schema.name.name env.schemaMap+    go typeMap Nothing = TableInfo+        { tableExists = False+        , name = schema.name.name+        , columns = compareTypes env mempty typeMap+        }+    go typeMap (Just attrs) = TableInfo+        { tableExists = True+        , name = schema.name.name+        , columns = compareTypes env (attrsToMap attrs) typeMap+        }+++fetchCheckEnv :: HS.Statement () CheckEnv+fetchCheckEnv = fetchSchema <&> \(tbls, casts) -> +  let tblMap = foldMap (\PGTable {..} -> M.singleton (T.unpack name) columns) tbls+      castMap = map (\Cast {..} -> (T.unpack source.typname, T.unpack target.typname)) $ L.filter (\Cast {context} -> context == "i") casts+  in CheckEnv tblMap castMap+ where+  fetchSchema :: HS.Statement () ([PGTable Result], [Cast Result])+  fetchSchema = run1 $ select $ liftA2 (,) fetchTables fetchCasts+++-- |@'SomeTableSchema'@ is used to allow the collection of a variety of different+-- @TableSchema@s under a single type, like:+--+-- @+-- userTable :: TableSchema (User Name)+-- orderTable :: TableSchema (Order Name)+--+-- tables :: [SomeTableSchema]+-- tables = [SomeTableSchema userTable, SomeTable orderTable]+-- @+--+-- This is used by @'schemaErrors'@ to conveniently group every table an+-- application relies on for typechecking the postgresql schemas+-- together in a single batch.+data SomeTableSchema where+    -- The ToExpr constraint isn't used here, but can be used to read from the+    -- SomeTableSchema, which can be useful to combine the type checking with more+    -- thorough value-level checking of the validity of existing rows in the+    -- table.+    SomeTableSchema+        :: (ToExprs (k Expr) (GFromExprs k), Rel8able k)+        => TableSchema (k Name) -> SomeTableSchema++-- |@'getSchemaErrors'@ checks whether the provided schemas have the correct PostgreSQL+-- column names and types to allow reading and writing from their equivalent Haskell+-- types, returning a list of errors if that is not the case. The function does not+-- crash on encountering a bug, instead leaving it to the caller to decide how+-- to respond. A schema is valid if:+--+-- 1. for every existing field, the types match+-- 2. all non-nullable columns are present in the hs type+-- 3. no nonexistent columns are present in the hs type+-- 4. no two columns in the same schema share the same name+--+-- It's still possible for a valid schema to allow invalid data, for instance,+-- if using an ADT, which can introduce restrictions on which values are allowed+-- for the column representing the tag, and introduce restrictions on which+-- columns are non-null depending on the value of the tag. However, if the+-- schema is valid rel8 shouldn't be able to write invalid data to the table.+--+-- However, it is possible for migrations to cause valid data to become invalid+-- in ways not detectable by this function, if the migration code changes the+-- schema correctly but doesn't handle the value-level constraints correctly. So+-- it is a good idea to both read from the tables and check the schema for errors+-- in a transaction during the migration. The former will catch value-level+-- bugs, while the latter will help ensure the schema is set up correctly to+-- be able to insert new data.+--+-- This function does nothing to check that the conflict target of an @Upsert@+-- are valid for the schema, nor can it prevent invalid uses of @unsafeDefault@.+-- However, it should be enough to catch the most likely errors.+getSchemaErrors :: [SomeTableSchema] -> HS.Statement () (Maybe Text)+getSchemaErrors someTables = fmap collectErrors fetchCheckEnv+  where+    collectErrors :: CheckEnv -> Maybe Text+    collectErrors env+        = fmap pShowErrors+        . filterErrors+        . fmap \case+            SomeTableSchema t -> verifySchema env t+        $ someTables++    -- removes each column which is valid for use by rel8, as well as each table+    -- which contains only valid columns+    filterErrors :: [TableInfo] -> Maybe [TableInfo]+    filterErrors tables = case mapMaybe go tables of+        [] -> Nothing+        xs -> Just xs+      where+        go :: TableInfo -> Maybe TableInfo+        go TableInfo {..} = case P.filter (\cd -> isJust cd.error) columns of+            [] -> if tableExists then Nothing else Just $ TableInfo { name , tableExists , columns = [] }+            xs -> Just $ TableInfo { name , tableExists , columns = xs }+        go DuplicateNames {..} = Just (DuplicateNames {..})++
+ src/Rel8/Table/Window.hs view
@@ -0,0 +1,120 @@+{-# language ApplicativeDo #-}+{-# language FlexibleContexts #-}+{-# language MonoLocalBinds #-}+{-# language NamedFieldPuns #-}++module Rel8.Table.Window+  ( currentRow+  , lag, lagOn+  , lead, leadOn+  , firstValue, firstValueOn+  , lastValue, lastValueOn+  , nthValue, nthValueOn+  )+where++-- base+import Data.Int (Int32)+import Prelude hiding (null)++-- opaleye+import qualified Opaleye.Window as Opaleye++-- profunctor+import Data.Profunctor (dimap, lmap)++-- rel8+import Rel8.Expr (Expr)+import Rel8.Expr.Null (null, nullify, snull)+import Rel8.Expr.Serialize (litExpr)+import Rel8.Expr.Window+  ( lagExpr, lagExprOn+  , leadExpr, leadExprOn+  , firstValueExpr+  , lastValueExpr+  , nthValueExpr, nthValueExprOn+  )+import Rel8.Schema.HTable (htraverseP)+import Rel8.Schema.HTable.Identity (HIdentity (HIdentity))+import Rel8.Schema.HTable.Label (hlabel)+import Rel8.Schema.HTable.Maybe (HMaybeTable (HMaybeTable))+import Rel8.Schema.HTable.Nullify (hnullify)+import Rel8.Schema.Null (Nullity (NotNull, Null))+import Rel8.Schema.Spec (Spec (..))+import Rel8.Table (Table, fromColumns, toColumns)+import Rel8.Table.Maybe (MaybeTable)+import Rel8.Type.Tag (MaybeTag (IsJust))+import Rel8.Window (Window (Window))+++-- | Return every column of the current row of a window query.+currentRow :: Window a a+currentRow = Window $ Opaleye.over (Opaleye.noWindowFunction id) mempty mempty+++-- | @'lag' n@ returns the row @n@ rows before the current row in a given+-- window. Returns 'Rel8.nothingTable' if @n@ is out of bounds.+lag :: Table Expr a => Expr Int32 -> Window a (MaybeTable Expr a)+lag n = do+  htag <- lagExprOn n null (\_ -> nullify (litExpr IsJust))+  hjust <- lmap toColumns $ hnullify $ \Spec {info, nullity} ->+    case nullity of+      NotNull -> lagExprOn n (snull info) nullify+      Null -> lagExpr n (snull info)+  pure $ fromColumns $ HMaybeTable (hlabel (HIdentity htag)) (hlabel hjust)+++-- | Applies 'lag' to the columns selected by the given function.+lagOn :: Table Expr a => Expr Int32 -> (i -> a) -> Window i (MaybeTable Expr a)+lagOn n f = lmap f (lag n)+++-- | @'lead' n@ returns the row @n@ rows after the current row in a given+-- window. Returns 'Rel8.nothingTable' if @n@ is out of bounds.+lead :: Table Expr a => Expr Int32 -> Window a (MaybeTable Expr a)+lead n = do+  htag <- leadExprOn n null (\_ -> nullify (litExpr IsJust))+  hjust <- lmap toColumns $ hnullify $ \Spec {info, nullity} ->+    case nullity of+      NotNull -> leadExprOn n (snull info) nullify+      Null -> leadExpr n (snull info)+  pure $ fromColumns $ HMaybeTable (hlabel (HIdentity htag)) (hlabel hjust)+++-- | Applies 'lead' to the columns selected by the given function.+leadOn :: Table Expr a => Expr Int32 -> (i -> a) -> Window i (MaybeTable Expr a)+leadOn n f = lmap f (lead n)+++-- | 'firstValue' returns the first row of the window of the current row.+firstValue :: Table Expr a => Window a a+firstValue = dimap toColumns fromColumns $ htraverseP firstValueExpr+++-- | Applies 'firstValue' to the columns selected by the given function.+firstValueOn :: Table Expr a => (i -> a) -> Window i a+firstValueOn f = lmap f firstValue+++-- | 'lastValue' returns the first row of the window of the current row.+lastValue :: Table Expr a => Window a a+lastValue = dimap toColumns fromColumns $ htraverseP lastValueExpr+++-- | Applies 'lastValue' to the columns selected by the given function.+lastValueOn :: Table Expr a => (i -> a) -> Window i a+lastValueOn f = lmap f lastValue+++-- | @'nthValue' n@ returns the @n@th row of the window of the current row.+-- Returns 'Rel8.nothingTable' if @n@ is out of bounds.+nthValue :: Table Expr a => Expr Int32 -> Window a (MaybeTable Expr a)+nthValue n = do+  htag <- nthValueExprOn n (\_ -> litExpr IsJust)+  hjust <- lmap toColumns $ hnullify $ \_ -> nthValueExpr n+  pure $ fromColumns $ HMaybeTable (hlabel (HIdentity htag)) (hlabel hjust)+++-- | Applies 'nthValue' to the columns selected by the given function.+nthValueOn :: Table Expr a => Expr Int32 -> (i -> a) -> Window i (MaybeTable Expr a)+nthValueOn n f = lmap f (nthValue n)
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@@ -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,31 +84,33 @@ import qualified Data.Profunctor.Product as PP  -- rel8-import Rel8.Aggregate ( Aggregates )+import Rel8.Aggregate (Aggregator' (Aggregator), Aggregator, toAggregator1)+import Rel8.Aggregate.Fold (Fallback (Fallback)) import Rel8.Expr ( Expr )-import Rel8.Expr.Aggregate ( countStar )+import Rel8.Expr.Aggregate (countStar) import Rel8.Expr.Bool ( true ) import Rel8.Order ( Order( Order ) ) import Rel8.Query ( Query )+import qualified Rel8.Query.Aggregate as Q 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.Materialize as Q import qualified Rel8.Query.Maybe as Q ( optional ) import Rel8.Query.Opaleye ( mapOpaleye, unsafePeekQuery )+import Rel8.Query.Rebind ( rebind ) import Rel8.Query.These ( alignBy ) import Rel8.Table ( Table, fromColumns, toColumns )-import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )+import Rel8.Table.Aggregate (groupBy, listAgg, nonEmptyAgg) import Rel8.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.Eq (EqTable, (==:))+import Rel8.Table.List (ListTable)+import Rel8.Table.Maybe (MaybeTable (MaybeTable), fromMaybeTable)+import Rel8.Table.NonEmpty (NonEmptyTable)+import Rel8.Table.Opaleye ( unpackspec ) import Rel8.Table.Ord ( OrdTable ) import Rel8.Table.Order ( ascTable ) import Rel8.Table.Projection@@ -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 view
@@ -1,8 +1,13 @@+{-# language DisambiguateRecordFields #-} {-# language FlexibleContexts #-} {-# language FlexibleInstances #-}+{-# language LambdaCase #-} {-# language MonoLocalBinds #-} {-# language MultiWayIf #-}+{-# language OverloadedStrings #-}+{-# language ScopedTypeVariables #-} {-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-} {-# language UndecidableInstances #-}  module Rel8.Type@@ -13,25 +18,41 @@ -- aeson import Data.Aeson ( Value ) import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Text as Aeson +-- attoparsec+import qualified Data.Attoparsec.ByteString.Char8 as A+ -- base-import Data.Int ( Int16, Int32, Int64 )+import Control.Applicative ((<|>))+import Data.Fixed (Fixed)+import Data.Functor.Contravariant ((>$<))+import Data.Int (Int16, Int32, Int64) import Data.List.NonEmpty ( NonEmpty ) import Data.Kind ( Constraint, Type ) import Prelude+import Text.Read (readMaybe)  -- bytestring-import Data.ByteString ( ByteString )+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as Lazy ( ByteString ) import qualified Data.ByteString.Lazy as ByteString ( fromStrict, toStrict )+import qualified Data.ByteString.Builder as B+import Data.ByteString.Builder.Prim (primBounded)  -- case-insensitive import Data.CaseInsensitive ( CI ) import qualified Data.CaseInsensitive as CI  -- hasql-import qualified Hasql.Decoders as Hasql+import qualified Hasql.Decoders as Decoders+import qualified Hasql.Encoders as Encoders +-- iproute+import Data.IP (IPRange)+ -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye import qualified Opaleye.Internal.HaskellDB.Sql.Default as Opaleye ( quote )@@ -39,28 +60,41 @@ -- rel8 import Rel8.Schema.Null ( NotNull, Sql, nullable ) import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )+import Rel8.Type.Decimal (PowerOf10, resolution)+import Rel8.Type.Decoder (Decoder (..))+import Rel8.Type.Encoder (Encoder (..)) import Rel8.Type.Information ( TypeInformation(..), mapTypeInformation )+import Rel8.Type.Name (TypeName (..))+import Rel8.Type.Parser (parse)+import qualified Rel8.Type.Builder.ByteString as Builder+import qualified Rel8.Type.Parser.ByteString as Parser+import qualified Rel8.Type.Builder.Time as Builder+import qualified Rel8.Type.Parser.Time as Parser  -- scientific-import Data.Scientific ( Scientific )+import Data.ByteString.Builder.Scientific (scientificBuilder)+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 )+import qualified Data.Text.Encoding as Text (decodeUtf8, encodeUtf8Builder)+import qualified Data.Text.Lazy as Lazy (Text, unpack)+import qualified Data.Text.Lazy as Text (fromStrict, toStrict)  -- time-import Data.Time.Calendar ( Day )-import Data.Time.Clock ( UTCTime )+import Data.Time.Calendar (Day)+import Data.Time.Clock (DiffTime, UTCTime) import Data.Time.LocalTime-  ( CalendarDiffTime( CalendarDiffTime )+  ( CalendarDiffTime (CalendarDiffTime)   , LocalTime   , TimeOfDay   )-import Data.Time.Format ( formatTime, defaultTimeLocale )+import Data.Time.Format (formatTime, defaultTimeLocale) +-- utf8+import qualified Data.ByteString.UTF8 as UTF8+ -- uuid import Data.UUID ( UUID ) import qualified Data.UUID as UUID@@ -82,8 +116,23 @@ -- | Corresponds to @bool@ instance DBType Bool where   typeInformation = TypeInformation-    { encode = Opaleye.ConstExpr . Opaleye.BoolLit-    , decode = Hasql.bool+    { encode =+        Encoder+          { binary = Encoders.bool+          , text = \case+              False -> "f"+              True -> "t"+          , quote = Opaleye.ConstExpr . Opaleye.BoolLit+          }+    , decode =+        Decoder+          { binary = Decoders.bool+          , text = \case+              "t" -> pure True+              "f" -> pure False+              input -> Left $ "bool: bad bool " <> show input+          }+    , delimiter = ','     , typeName = "bool"     } @@ -91,17 +140,44 @@ -- | Corresponds to @char@ instance DBType Char where   typeInformation = TypeInformation-    { encode = Opaleye.ConstExpr . Opaleye.StringLit . pure-    , decode = Hasql.char-    , typeName = "char"+    { encode =+        Encoder+          { binary = Encoders.char+          , text = B.charUtf8+          , quote = Opaleye.ConstExpr . Opaleye.StringLit . pure+          }+    , decode = +        Decoder+          { binary = Decoders.char+          , text = \input -> case UTF8.uncons input of+              Just (char, rest) | BS.null rest -> pure char+              _ -> Left $ "char: bad char " <> show input+          }+    , delimiter = ','+    , typeName =+        TypeName+          { name = "bpchar"+          , modifiers = ["1"]+          , arrayDepth = 0+          }     }   -- | Corresponds to @int2@ instance DBType Int16 where   typeInformation = TypeInformation-    { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger-    , decode = Hasql.int2+    { encode =+        Encoder+          { binary = Encoders.int2+          , text = B.int16Dec+          , quote = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger+          }+    , decode =+        Decoder+          { binary = Decoders.int2+          , text = parse (A.signed A.decimal)+          }+    , delimiter = ','     , typeName = "int2"     } @@ -109,8 +185,18 @@ -- | Corresponds to @int4@ instance DBType Int32 where   typeInformation = TypeInformation-    { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger-    , decode = Hasql.int4+    { encode =+        Encoder+          { binary = Encoders.int4+          , text = B.int32Dec+          , quote = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger+          }+    , decode =+        Decoder+          { binary = Decoders.int4+          , text = parse (A.signed A.decimal)+          }+    , delimiter = ','     , typeName = "int4"     } @@ -118,34 +204,76 @@ -- | Corresponds to @int8@ instance DBType Int64 where   typeInformation = TypeInformation-    { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger-    , decode = Hasql.int8+    { encode =+        Encoder+          { binary = Encoders.int8+          , text = B.int64Dec+          , quote = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger+          }+    , decode =+        Decoder+          { binary = Decoders.int8+          , text = parse (A.signed A.decimal)+          }+    , delimiter = ','     , typeName = "int8"     }  --- | Corresponds to @float4@+-- | Corresponds to @float4@ and @real@ 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+    { encode =+        Encoder+          { binary = Encoders.float4+          , text =+              \x ->+                if | x == (1 / 0)  -> "Infinity"+                   | isNaN x       -> "NaN"+                   | x == (-1 / 0) -> "-Infinity"+                   | otherwise     -> B.floatDec x+          , quote =+              \x -> Opaleye.ConstExpr+                if | x == (1 / 0)  -> Opaleye.OtherLit "'Infinity'"+                   | isNaN x       -> Opaleye.OtherLit "'NaN'"+                   | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"+                   | otherwise     -> Opaleye.DoubleLit $ realToFrac x+          }+    , decode =+        Decoder+          { binary = Decoders.float4+          , text = parse (floating (realToFrac <$> A.double))+          }+    , delimiter = ','     , typeName = "float4"     }  --- | Corresponds to @float8@+-- | Corresponds to @float8@ and @double precision@ 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+    { encode =+        Encoder+          { binary = Encoders.float8+          , text =+              \x ->+                if | x == (1 / 0)  -> "Infinity"+                   | isNaN x       -> "NaN"+                   | x == (-1 / 0) -> "-Infinity"+                   | otherwise     -> B.doubleDec x+          , quote =+              \x -> Opaleye.ConstExpr+                if | x == (1 / 0)  -> Opaleye.OtherLit "'Infinity'"+                   | isNaN x       -> Opaleye.OtherLit "'NaN'"+                   | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"+                   | otherwise     -> Opaleye.DoubleLit x+          }+    , decode =+        Decoder+          { binary = Decoders.float8+          , text = parse (floating A.double)+          }+    , delimiter = ','     , typeName = "float8"     } @@ -153,19 +281,52 @@ -- | Corresponds to @numeric@ instance DBType Scientific where   typeInformation = TypeInformation-    { encode = Opaleye.ConstExpr . Opaleye.NumericLit-    , decode = Hasql.numeric+    { encode =+        Encoder+          { binary = Encoders.numeric+          , text = scientificBuilder+          , quote = Opaleye.ConstExpr . Opaleye.NumericLit+          }+    , decode =+        Decoder+          { binary = Decoders.numeric+          , text = parse A.scientific+          }+    , delimiter = ','     , typeName = "numeric"     }  +-- | Corresponds to @numeric(1000, log₁₀ n)@+instance PowerOf10 n => DBType (Fixed n) where+  typeInformation =+    mapTypeInformation realToFrac realToFrac (typeInformation @Scientific)+      { typeName =+          TypeName+            { name = "numeric"+            , modifiers = ["1000", show (resolution @n)]+            , arrayDepth = 0+            }+      }++ -- | Corresponds to @timestamptz@ instance DBType UTCTime where   typeInformation = TypeInformation     { encode =-        Opaleye.ConstExpr . Opaleye.OtherLit .-        formatTime defaultTimeLocale "'%FT%T%QZ'"-    , decode = Hasql.timestamptz+        Encoder+          { binary = Encoders.timestamptz+          , text = primBounded Builder.utcTime+          , quote =+              Opaleye.ConstExpr . Opaleye.OtherLit .+              formatTime defaultTimeLocale "'%FT%T%QZ'"+          }+    , decode =+        Decoder+          { binary = Decoders.timestamptz+          , text = parse Parser.utcTime+          }+    , delimiter = ','     , typeName = "timestamptz"     } @@ -174,9 +335,19 @@ instance DBType Day where   typeInformation = TypeInformation     { encode =-        Opaleye.ConstExpr . Opaleye.OtherLit .-        formatTime defaultTimeLocale "'%F'"-    , decode = Hasql.date+        Encoder+          { binary = Encoders.date+          , text = primBounded Builder.day+          , quote =+              Opaleye.ConstExpr . Opaleye.OtherLit .+              formatTime defaultTimeLocale "'%F'"+          }+    , decode =+        Decoder+          { binary = Decoders.date+          , text = parse Parser.day+          }+    , delimiter = ','     , typeName = "date"     } @@ -185,9 +356,19 @@ instance DBType LocalTime where   typeInformation = TypeInformation     { encode =-        Opaleye.ConstExpr . Opaleye.OtherLit .-        formatTime defaultTimeLocale "'%FT%T%Q'"-    , decode = Hasql.timestamp+        Encoder+          { binary = Encoders.timestamp+          , text = primBounded Builder.localTime+          , quote =+              Opaleye.ConstExpr . Opaleye.OtherLit .+              formatTime defaultTimeLocale "'%FT%T%Q'"+          }+    , decode =+        Decoder+          { binary = Decoders.timestamp+          , text = parse Parser.localTime+          }+    , delimiter = ','     , typeName = "timestamp"     } @@ -196,9 +377,19 @@ instance DBType TimeOfDay where   typeInformation = TypeInformation     { encode =-        Opaleye.ConstExpr . Opaleye.OtherLit .-        formatTime defaultTimeLocale "'%T%Q'"-    , decode = Hasql.time+        Encoder+          { binary = Encoders.time+          , text = primBounded Builder.timeOfDay+          , quote =+              Opaleye.ConstExpr . Opaleye.OtherLit .+              formatTime defaultTimeLocale "'%T%Q'"+          }+    , decode =+        Decoder+          { binary = Decoders.time+          , text = parse Parser.timeOfDay+          }+    , delimiter = ','     , typeName = "time"     } @@ -207,9 +398,19 @@ instance DBType CalendarDiffTime where   typeInformation = TypeInformation     { encode =-        Opaleye.ConstExpr . Opaleye.OtherLit .-        formatTime defaultTimeLocale "'%bmon %0Es'"-    , decode = CalendarDiffTime 0 . realToFrac <$> Hasql.interval+        Encoder+          { binary = toDiffTime >$< Encoders.interval+          , text = Builder.calendarDiffTime+          , quote =+              Opaleye.ConstExpr . Opaleye.OtherLit .+              formatTime defaultTimeLocale "'%bmon %0Es'"+          }+    , decode =+        Decoder+          { binary = CalendarDiffTime 0 . realToFrac <$> Decoders.interval+          , text = parse Parser.calendarDiffTime+          }+    , delimiter = ','     , typeName = "interval"     } @@ -217,8 +418,18 @@ -- | Corresponds to @text@ instance DBType Text where   typeInformation = TypeInformation-    { encode = Opaleye.ConstExpr . Opaleye.StringLit . Text.unpack-    , decode = Hasql.text+    { encode =+        Encoder+          { binary = Encoders.text+          , text = Text.encodeUtf8Builder+          , quote = Opaleye.ConstExpr . Opaleye.StringLit . Text.unpack+          }+    , decode =+        Decoder+          { binary = Decoders.text+          , text = pure . Text.decodeUtf8+          }+    , delimiter = ','     , typeName = "text"     } @@ -246,8 +457,18 @@ -- | Corresponds to @bytea@ instance DBType ByteString where   typeInformation = TypeInformation-    { encode = Opaleye.ConstExpr . Opaleye.ByteStringLit-    , decode = Hasql.bytea+    { encode =+        Encoder+          { binary = Encoders.bytea+          , text = Builder.bytestring+          , quote = Opaleye.ConstExpr . Opaleye.ByteStringLit+          }+    , decode =+        Decoder+          { binary = Decoders.bytea+          , text = parse Parser.bytestring+          }+    , delimiter = ','     , typeName = "bytea"     } @@ -262,8 +483,20 @@ -- | Corresponds to @uuid@ instance DBType UUID where   typeInformation = TypeInformation-    { encode = Opaleye.ConstExpr . Opaleye.StringLit . UUID.toString-    , decode = Hasql.uuid+    { encode =+        Encoder+          { binary = Encoders.uuid+          , text = B.byteString . UUID.toASCIIBytes+          , quote = Opaleye.ConstExpr . Opaleye.StringLit . UUID.toString+          }+    , decode =+        Decoder+          { binary = Decoders.uuid+          , text = \input -> case UUID.fromASCIIBytes input of+              Just a -> pure a+              Nothing -> Left $ "uuid: bad UUID " <> show input+          }+    , delimiter = ','     , typeName = "uuid"     } @@ -272,17 +505,56 @@ instance DBType Value where   typeInformation = TypeInformation     { encode =-        Opaleye.ConstExpr . Opaleye.OtherLit .-        Opaleye.quote .-        Lazy.unpack . Lazy.decodeUtf8 . Aeson.encode-    , decode = Hasql.jsonb+        Encoder+          { binary = Encoders.jsonb+          , text = Aeson.fromEncoding . Aeson.toEncoding+          , quote =+              Opaleye.ConstExpr . Opaleye.OtherLit . Opaleye.quote .+              Lazy.unpack . Aeson.encodeToLazyText+          }+    , decode =+        Decoder+          { binary = Decoders.jsonb+          , text = Aeson.eitherDecodeStrict+          }+    , delimiter = ','     , typeName = "jsonb"     }  +-- | Corresponds to @inet@+instance DBType IPRange where+  typeInformation = TypeInformation+    { encode =+        Encoder+          { binary = Encoders.inet+          , text = B.string7 . show+          , quote = Opaleye.ConstExpr . Opaleye.StringLit . show+          }+    , decode =+        Decoder+          { binary = Decoders.inet+          , text = \str -> case readMaybe $ BS8.unpack str of+              Just x -> Right x+              Nothing -> Left "Failed to parse inet"+          }+    , delimiter = ','+    , typeName = "inet"+    }++ instance Sql DBType a => DBType [a] where   typeInformation = listTypeInformation nullable typeInformation   instance Sql DBType a => DBType (NonEmpty a) where   typeInformation = nonEmptyTypeInformation nullable typeInformation+++floating :: Floating a => A.Parser a -> A.Parser a+floating p = p <|> A.signed (1.0 / 0 <$ "Infinity") <|> 0.0 / 0 <$ "NaN"+++toDiffTime :: CalendarDiffTime -> DiffTime+toDiffTime (CalendarDiffTime months seconds) =+  realToFrac (months * 30 * 24 * 60 * 60) + realToFrac seconds
src/Rel8/Type/Array.hs view
@@ -1,37 +1,69 @@+{-# language DisambiguateRecordFields #-} {-# language GADTs #-} {-# language LambdaCase #-} {-# language NamedFieldPuns #-} {-# language OverloadedStrings #-}+{-# language TypeApplications #-} {-# language ViewPatterns #-}  module Rel8.Type.Array-  ( array, encodeArrayElement, extractArrayElement+  ( array, quoteArrayElement, extractArrayElement+  , arrayTypeName   , listTypeInformation   , nonEmptyTypeInformation+  , head, index, last, length   ) where +-- attoparsec+import qualified Data.Attoparsec.ByteString.Char8 as A+ -- base-import Data.Foldable ( toList )-import Data.List.NonEmpty ( NonEmpty, nonEmpty )-import Prelude hiding ( null, repeat, zipWith )+import Control.Applicative ((<|>), many)+import Data.Bifunctor (first)+import Data.Foldable (fold, toList)+import Data.Functor.Contravariant ((>$<))+import Data.List.NonEmpty (NonEmpty, nonEmpty)+import Prelude hiding (head, last, length, null, repeat, zipWith) +-- bytestring+import Data.ByteString (ByteString)+import Data.ByteString.Builder (Builder, toLazyByteString)+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy as L++-- case-insensitive+import qualified Data.CaseInsensitive as CI+ -- hasql-import qualified Hasql.Decoders as Hasql+import qualified Hasql.Decoders as Decoders+import qualified Hasql.Encoders as Encoders  -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye  -- rel8-import Rel8.Schema.Null ( Unnullify, Nullity( Null, NotNull ) )-import Rel8.Type.Information ( TypeInformation(..), parseTypeInformation )+import Rel8.Schema.Null (Unnullify, Nullity (Null, NotNull))+import Rel8.Type.Builder.Fold (interfoldMap)+import Rel8.Type.Decoder (Decoder (..), Parser)+import Rel8.Type.Encoder (Encoder (..))+import Rel8.Type.Information (TypeInformation(..), parseTypeInformation)+import Rel8.Type.Name (TypeName (..), showTypeName)+import Rel8.Type.Nullable (NullableOrNot (..))+import Rel8.Type.Parser (parse) +-- text+import qualified Data.Text as Text+import qualified Data.Text.Lazy as Text (toStrict)+import qualified Data.Text.Lazy.Encoding as Lazy (decodeUtf8) + array :: Foldable f   => TypeInformation a -> f Opaleye.PrimExpr -> Opaleye.PrimExpr array info =-  Opaleye.CastExpr (arrayType info <> "[]") .-  Opaleye.ArrayExpr . map (encodeArrayElement info) . toList+  Opaleye.CastExpr (showTypeName (arrayType info) <> "[]") .+  Opaleye.ArrayExpr . map (quoteArrayElement info) . toList {-# INLINABLE array #-}  @@ -39,21 +71,35 @@   => Nullity a   -> TypeInformation (Unnullify a)   -> TypeInformation [a]-listTypeInformation nullity info@TypeInformation {encode, decode} =+listTypeInformation nullity info@TypeInformation {decode, encode, delimiter} =   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 <> "[]"+    { decode =+        Decoder+          { binary = Decoders.listArray $ case nullity of+              Null -> Decoders.nullable (decodeArrayElement info decode)+              NotNull -> Decoders.nonNullable (decodeArrayElement info decode)+          , text = case nullity of+              Null -> arrayParser delimiter (Nullable decode)+              NotNull -> arrayParser delimiter (NonNullable decode)+          }+    , encode =+        Encoder+          { binary = Encoders.foldableArray $ case nullity of+              Null -> Encoders.nullable (encodeArrayElement info encode)+              NotNull -> Encoders.nonNullable (encodeArrayElement info encode)+          , text = case nullity of+              Null -> arrayBuild delimiter (Nullable encode)+              NotNull -> arrayBuild delimiter (NonNullable encode)+          , quote = case nullity of+              Null ->+                Opaleye.ArrayExpr .+                fmap (quoteArrayElement info . maybe null (quote encode))+              NotNull ->+                Opaleye.ArrayExpr .+                fmap (quoteArrayElement info . quote encode)+          }+    , delimiter = ','+    , typeName = arrayTypeName info     }   where     null = Opaleye.ConstExpr Opaleye.NullLit@@ -64,37 +110,151 @@   -> TypeInformation (Unnullify a)   -> TypeInformation (NonEmpty a) nonEmptyTypeInformation nullity =-  parseTypeInformation parse toList . listTypeInformation nullity+  parseTypeInformation fromList toList . listTypeInformation nullity   where-    parse = maybe (Left message) Right . nonEmpty+    fromList = maybe (Left message) Right . nonEmpty     message = "failed to decode NonEmptyList: got empty list"  +arrayTypeName :: TypeInformation a -> TypeName+arrayTypeName info = (arrayType info) {arrayDepth = 1}++ isArray :: TypeInformation a -> Bool-isArray = \case-  (reverse . typeName -> ']' : '[' : _) -> True-  _ -> False+isArray = (> 0) . arrayDepth . typeName  -arrayType :: TypeInformation a -> String+arrayType :: TypeInformation a -> TypeName arrayType info-  | isArray info = "record"+  | isArray info = "text"   | 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+decodeArrayElement :: TypeInformation a -> Decoder x -> Decoders.Value x+decodeArrayElement info Decoder {binary, text}+  | isArray info =+      Decoders.refine (first Text.pack . text) Decoders.bytea+  | otherwise = binary  -encodeArrayElement :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr-encodeArrayElement info-  | isArray info = Opaleye.UnExpr (Opaleye.UnOpOther "ROW")+encodeArrayElement :: TypeInformation a -> Encoder x -> Encoders.Value x+encodeArrayElement info Encoder {binary, text}+  | isArray info = Text.toStrict . Lazy.decodeUtf8 . toLazyByteString . text >$< Encoders.text+  | otherwise = binary+++quoteArrayElement :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr+quoteArrayElement info+  | isArray info = Opaleye.CastExpr "text" . Opaleye.CastExpr (showTypeName (typeName info))   | otherwise = id   extractArrayElement :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr extractArrayElement info-  | isArray info = flip Opaleye.CompositeExpr "f1"+  | isArray info = Opaleye.CastExpr (showTypeName (typeName info))   | otherwise = id+++parseArray :: Char -> ByteString -> Either String [Maybe ByteString]+parseArray delimiter = parse $ do+  A.char '{' *> A.sepBy element (A.char delimiter) <* A.char '}'+  where+    element = null <|> nonNull+      where+        null = Nothing <$ A.string "NULL"+        nonNull = Just <$> (quoted <|> unquoted)+          where+            unquoted = A.takeWhile1 (A.notInClass (delimiter : "\"{}"))+            quoted = A.char '"' *> contents <* A.char '"'+              where+                contents = fold <$> many (unquote <|> unescape)+                  where+                    unquote = A.takeWhile1 (A.notInClass "\"\\")+                    unescape = A.char '\\' *> do+                      BS.singleton <$> do+                        A.char '\\' <|> A.char '"'+++arrayParser :: Char -> NullableOrNot Decoder a -> Parser [a]+arrayParser delimiter = \case+  Nullable Decoder {text} -> \input -> do+    elements <- parseArray delimiter input+    traverse (traverse text) elements+  NonNullable Decoder {text} -> \input -> do+    elements <- parseArray delimiter input+    traverse (maybe (Left "array: unexpected null") text) elements+++buildArray :: Char -> [Maybe ByteString] -> Builder+buildArray delimiter elements =+  B.char8 '{' <>+  interfoldMap (B.char8 delimiter) element elements <>+  B.char8 '}'+  where+    element = \case+      Nothing -> B.string7 "NULL"+      Just a+        | BS.null a -> "\"\""+        | CI.mk a == "null" -> escaped+        | BS.any (A.inClass escapeClass) a -> escaped+        | otherwise -> unescaped+        where+          escapeClass = delimiter : "\\\"{}\t\n"+          unescaped = B.byteString a+          escaped =+            B.char8 '"' <> BS.foldr ((<>) . escape) mempty a <> B.char8 '"'+            where+              escape = \case+                '"' -> B.string7 "\\\""+                '\\' -> B.string7 "\\\\"+                c -> B.char8 c+++arrayBuild :: Char -> NullableOrNot Encoder a -> [a] -> Builder+arrayBuild delimiter = \case+  Nullable Encoder {text} ->+    buildArray delimiter .+    map (fmap (L.toStrict . toLazyByteString . text))+  NonNullable Encoder {text} ->+    buildArray delimiter .+    map (Just . L.toStrict . toLazyByteString . text)+++head :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr+head info a = extractArrayElement info $ subscript (lower a) a+++last :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr+last info a = extractArrayElement info $ subscript (upper a) a+++subscript :: Opaleye.PrimExpr -> Opaleye.PrimExpr -> Opaleye.PrimExpr+subscript i a = Opaleye.ArrayIndex a i+++index :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr -> Opaleye.PrimExpr+index info i a = extractArrayElement info $ subscript (plus (lower a) i) a+++lower :: Opaleye.PrimExpr -> Opaleye.PrimExpr+lower a = Opaleye.FunExpr "array_lower" [a, one]+++upper :: Opaleye.PrimExpr -> Opaleye.PrimExpr+upper a = Opaleye.FunExpr "array_lower" [a, one]+++length :: Opaleye.PrimExpr -> Opaleye.PrimExpr+length a = Opaleye.FunExpr "coalesce" [Opaleye.FunExpr "array_length" [a, one], zero]+++one :: Opaleye.PrimExpr+one = Opaleye.ConstExpr (Opaleye.IntegerLit 1)+++zero :: Opaleye.PrimExpr+zero = Opaleye.ConstExpr (Opaleye.IntegerLit 0)+++plus :: Opaleye.PrimExpr -> Opaleye.PrimExpr -> Opaleye.PrimExpr+plus = Opaleye.BinExpr (Opaleye.:+)
+ src/Rel8/Type/Builder/ByteString.hs view
@@ -0,0 +1,16 @@+{-# language OverloadedStrings #-}++module Rel8.Type.Builder.ByteString (+  bytestring,+) where++-- base+import Prelude++-- bytestring+import Data.ByteString (ByteString)+import Data.ByteString.Builder (Builder, byteStringHex, string7)+++bytestring :: ByteString -> Builder+bytestring bytes = string7 "\\x" <> byteStringHex bytes
+ src/Rel8/Type/Builder/Fold.hs view
@@ -0,0 +1,16 @@+{-# language LambdaCase #-}++module Rel8.Type.Builder.Fold (+  interfoldMap+) where++-- base+import Prelude+++interfoldMap :: (Foldable t, Monoid m) => m -> (a -> m) -> t a -> m+interfoldMap sep f = maybe mempty id . foldr go Nothing+  where+    go x = \case+      Nothing -> Just (f x)+      Just acc -> Just (f x <> sep <> acc)
+ src/Rel8/Type/Builder/Time.hs view
@@ -0,0 +1,151 @@+{-# language BangPatterns #-}+{-# language NumericUnderscores #-}+{-# language OverloadedStrings #-}+{-# language PatternSynonyms #-}+{-# language PartialTypeSignatures #-}+{-# language TypeApplications #-}+{-# language ViewPatterns #-}++{-# options_ghc -Wno-partial-type-signatures #-}+-- bytestring does not export Monoidal so we can't write a complete type+-- signature for 'divide'++{-# options_ghc -Wno-unused-top-binds #-}+-- GHC considers the YMD pattern unused but we use its selectors++module Rel8.Type.Builder.Time (+  calendarDiffTime,+  day,+  localTime,+  timeOfDay,+  utcTime,+) where++-- base+import Data.Char (chr)+import Data.Fixed (Fixed (MkFixed), Pico)+import Data.Int (Int32, Int64)+import Prelude hiding ((<>))++-- bytestring+import Data.ByteString.Builder (Builder, string7)+import Data.ByteString.Builder.Prim (+  BoundedPrim, condB, emptyB, liftFixedToBounded,+  FixedPrim, char8, int32Dec,+  (>$<), (>*<),+ )++-- time+import Data.Time.Calendar (Day, toGregorian)+import Data.Time.Clock (UTCTime (utctDay, utctDayTime))+import Data.Time.Format.ISO8601 (iso8601Show)+import Data.Time.LocalTime (+  CalendarDiffTime,+  LocalTime (localDay, localTimeOfDay),+  TimeOfDay (todHour, todMin, todSec),+  timeToTimeOfDay+ )+++digit :: FixedPrim Int+digit = (\x -> chr (x + 48)) >$< char8+++digits2 :: FixedPrim Int+digits2 = divide (`quotRem` 10) digit digit+++digits3 :: FixedPrim Int+digits3 = divide (`quotRem` 10) digits2 digit+++digits4 :: FixedPrim Int+digits4 = divide (`quotRem` 10) digits3 digit+++frac :: BoundedPrim Int64+frac = condB (== 0) emptyB $ liftFixedToBounded (char '.') <> trunc12+  where+    trunc12 =+      divide+        (`quotRem` 1_000_000)+        (fromIntegral >$< ifZero trunc6 (liftFixedToBounded digits6))+        (fromIntegral >$< nonZero trunc6)++    digitB = liftFixedToBounded digit++    digits6 = divide (`quotRem` 10) digits5 digit+    digits5 = divide (`quotRem` 10) digits4 digit++    trunc6 = divide (`quotRem` 100_000) digitB trunc5+    trunc5 = nonZero $ divide (`quotRem` 10_000) digitB trunc4+    trunc4 = nonZero $ divide (`quotRem` 1_000) digitB trunc3+    trunc3 = nonZero $ divide (`quotRem` 100) digitB trunc2+    trunc2 = nonZero $ divide (`quotRem` 10) digitB trunc1+    trunc1 = nonZero digitB++    nonZero = ifZero emptyB+    ifZero = condB (== 0)+++seconds :: BoundedPrim Pico+seconds =+  (\(MkFixed s) -> fromIntegral s `quotRem` 1_000_000_000_000) >$<+  (liftFixedToBounded (fromIntegral >$< digits2) >*< frac)+++year :: BoundedPrim Int32+year = condB (>= 10000) int32Dec (liftFixedToBounded (fromIntegral >$< digits4))+++day :: BoundedPrim Day+day =+  (fromIntegral . ymdYear >$< year) <>+  liftFixedToBounded+    ( char '-' <> (ymdMonth >$< digits2) <> char '-' <> (ymdDay >$< digits2)+    )+++pattern YMD :: Integer -> Int -> Int -> Day+pattern YMD {ymdYear, ymdMonth, ymdDay} <-+  (toGregorian -> (ymdYear, ymdMonth, ymdDay))+++timeOfDay :: BoundedPrim TimeOfDay+timeOfDay =+  liftFixedToBounded+    ( (todHour >$< digits2) <> char ':' <> (todMin >$< digits2) <> char ':'+    ) <>+  (todSec >$< seconds)+++utcTime :: BoundedPrim UTCTime+utcTime =+  (utctDay >$< day) <>+  liftFixedToBounded (char ' ') <>+  (timeToTimeOfDay . utctDayTime >$< timeOfDay) <>+  liftFixedToBounded (char 'Z')+++localTime :: BoundedPrim LocalTime+localTime =+  (localDay >$< day) <>+  liftFixedToBounded (char ' ') <>+  (localTimeOfDay >$< timeOfDay)+++calendarDiffTime :: CalendarDiffTime -> Builder+calendarDiffTime = string7 . iso8601Show+++char :: Char -> FixedPrim a+char c = (\_ -> c) >$< char8+++(<>) :: _ => f a -> f a -> f a+(<>) = divide (\a -> (a, a))+infixr 6 <>+++divide :: _ => (a -> (b, c)) -> f b -> f c -> f a+divide f a b = f >$< (a >*< b)
src/Rel8/Type/Composite.hs view
@@ -1,9 +1,12 @@ {-# language AllowAmbiguousTypes #-} {-# language BlockArguments #-} {-# language DataKinds #-}+{-# language DisambiguateRecordFields #-} {-# language FlexibleContexts #-} {-# language GADTs #-}+{-# language LambdaCase #-} {-# language NamedFieldPuns #-}+{-# language OverloadedStrings #-} {-# language ScopedTypeVariables #-} {-# language StandaloneKindSignatures #-} {-# language TypeApplications #-}@@ -18,14 +21,30 @@   ) where +-- attoparsec+import qualified Data.Attoparsec.ByteString.Char8 as A+ -- base-import Data.Functor.Const ( Const( Const ), getConst )-import Data.Functor.Identity ( Identity( Identity ) )+import Control.Applicative ((<|>), many, optional)+import Data.Foldable (fold)+import Data.Functor.Const (Const (Const), getConst)+import Data.Functor.Contravariant ((>$<))+import Data.Functor.Identity (Identity (Identity), runIdentity) import Data.Kind ( Constraint, Type )+import Data.List (uncons) import Prelude +-- bytestring+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS+import Data.ByteString.Builder (Builder)+import Data.ByteString.Builder (toLazyByteString)+import qualified Data.ByteString.Builder as B+import Data.ByteString.Lazy (toStrict)+ -- hasql-import qualified Hasql.Decoders as Hasql+import qualified Hasql.Decoders as Decoders+import qualified Hasql.Encoders as Encoders  -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye@@ -36,6 +55,7 @@ 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.QualifiedName (QualifiedName) import Rel8.Schema.Result ( Result ) import Rel8.Schema.Spec ( Spec( Spec, nullity, info ) ) import Rel8.Table ( fromColumns, toColumns, fromResult, toResult )@@ -45,14 +65,25 @@ import Rel8.Table.Rel8able () import Rel8.Table.Serialize ( litHTable ) import Rel8.Type ( DBType, typeInformation )+import Rel8.Type.Builder.Fold (interfoldMap)+import Rel8.Type.Decoder (Decoder (Decoder), Parser)+import qualified Rel8.Type.Decoder as Decoder+import Rel8.Type.Encoder (Encoder (Encoder))+import qualified Rel8.Type.Encoder as Encoder import Rel8.Type.Eq ( DBEq ) import Rel8.Type.Information ( TypeInformation(..) )+import Rel8.Type.Name (TypeName (..)) import Rel8.Type.Ord ( DBOrd, DBMax, DBMin )+import Rel8.Type.Parser (parse)  -- semigroupoids import Data.Functor.Apply ( WrappedApplicative(..) ) +-- transformers+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.State.Strict (StateT (StateT), runStateT) + -- | A deriving-via helper type for column types that store a Haskell product -- type in a single Postgres column using a Postgres composite type. --@@ -68,9 +99,24 @@  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+    { decode =+        Decoder+          { binary = Decoders.composite (Composite . fromResult @_ @(HKD a Expr) <$> decoder)+          , text = fmap (Composite . fromResult @_ @(HKD a Expr)) . parser+          }+    , encode =+        Encoder+          { binary = Encoders.composite (toResult @_ @(HKD a Expr) . unComposite >$< encoder)+          , text = builder . toResult @_ @(HKD a Expr) . unComposite+          , quote = quoter . litHTable . toResult @_ @(HKD a Expr) . unComposite+          }+    , delimiter = ','+    , typeName =+        TypeName+          { name = compositeTypeName @a+          , modifiers = []+          , arrayDepth = 0+          }     }  @@ -94,7 +140,7 @@   compositeFields :: HKD a Name    -- | The name of the composite type that @a@ maps to.-  compositeTypeName :: String+  compositeTypeName :: QualifiedName   -- | Collapse a 'HKD' into a PostgreSQL composite type.@@ -104,7 +150,7 @@ -- single column expression, by combining them into a PostgreSQL composite -- type. compose :: DBComposite a => HKD a Expr -> Expr a-compose = castExpr . fromPrimExpr . encoder . toColumns+compose = castExpr . fromPrimExpr . quoter . toColumns   -- | Expand a composite type into a 'HKD'.@@ -119,17 +165,99 @@     names = toColumns (compositeFields @a)  -decoder :: HTable t => Hasql.Composite (t Result)+decoder :: HTable t => Decoders.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+        Null -> Decoders.field $ Decoders.nullable $ Decoder.binary $ decode info+        NotNull -> Decoders.field $ Decoders.nonNullable $ Decoder.binary $ decode info  -encoder :: HTable t => t Expr -> Opaleye.PrimExpr-encoder a = Opaleye.FunExpr "ROW" exprs+parser :: HTable t => Parser (t Result)+parser input = do+  fields <- parseRow input+  (a, rest) <- runStateT go fields+  case rest of+    [] -> pure a+    _ -> Left "composite: too many fields"+  where+    go = htabulateA \field -> do+      mbytes <- StateT $ maybe missing pure . uncons+      lift $ Identity <$> case hfield hspecs field of+        Spec {nullity, info} -> case nullity of+          Null -> traverse (Decoder.text (decode info)) mbytes+          NotNull -> case mbytes of+            Nothing -> Left "composite: unexpected null"+            Just bytes -> Decoder.text (decode info) bytes+    missing = Left "composite: missing fields"+++parseRow :: ByteString -> Either String [Maybe ByteString]+parseRow = parse $ do+  A.char '(' *> A.sepBy element (A.char ',') <* A.char ')'+  where+    element = optional (quoted <|> unquoted)+      where+        unquoted = A.takeWhile1 (A.notInClass ",\"()")+        quoted = A.char '"' *> contents <* A.char '"'+          where+            contents = fold <$> many (unquote <|> unescape <|> quote)+              where+                unquote = A.takeWhile1 (A.notInClass "\"\\")+                unescape = A.char '\\' *> do+                  BS.singleton <$> do+                    A.char '\\' <|> A.char '"'+                quote = "\"" <$ A.string "\"\""+++encoder :: forall t. HTable t => Encoders.Composite (t Result)+encoder = getConst $ htabulateA @t \field ->+  case hfield hspecs field of+    Spec {nullity, info} -> Const $+      runIdentity . (`hfield` field) >$<+        case nullity of+          Null -> Encoders.field $ Encoders.nullable build+          NotNull -> Encoders.field $ Encoders.nonNullable build+        where+          build = Encoder.binary (encode info)+++builder :: HTable t => t Result -> Builder+builder input = buildRow $ getConst $ htabulateA \field ->+  Const $ pure $+    case hfield input field of+      Identity a ->+        case hfield hspecs field of+          Spec {nullity, info} -> case nullity of+            Null -> build <$> a+            NotNull -> Just $ build a+            where+              build =+                toStrict . toLazyByteString . Encoder.text (encode info)+++buildRow :: [Maybe ByteString] -> Builder+buildRow elements =+  B.char8 '(' <>+  interfoldMap (B.char8 ',') (foldMap element) elements <>+  B.char8 ')'+  where+    element a+        | BS.null a = "\"\""+        | BS.all (A.notInClass escapeClass) a = B.byteString a+        | otherwise =+            B.char8 '"' <> BS.foldr ((<>) . escape) mempty a <> B.char8 '"'+        where+          escapeClass = ",\\\"()\t\n"+          escape = \case+            '"' -> B.string7 "\"\""+            '\\' -> B.string7 "\\\\"+            c -> B.char8 c+++quoter :: HTable t => t Expr -> Opaleye.PrimExpr+quoter a = Opaleye.FunExpr "ROW" exprs   where     exprs = getConst $ htabulateA \field -> case hfield a field of       expr -> Const [toPrimExpr expr]
+ src/Rel8/Type/Decimal.hs view
@@ -0,0 +1,103 @@+{-# language AllowAmbiguousTypes #-}+{-# language ConstraintKinds #-}+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language NoStarIsType #-}+{-# language PolyKinds #-}+{-# language RankNTypes #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language TypeOperators #-}+{-# language UndecidableInstances #-}++module Rel8.Type.Decimal+  ( PowerOf10+  , resolution+  )+where++-- base+import Data.Fixed (E0, E1, E2, E3, E6, E9, E12, HasResolution)+import Data.Proxy (Proxy (Proxy))+import Data.Type.Equality (type (==))+import Data.Type.Ord (type (<?))+import Data.Kind (Constraint)+import GHC.TypeLits (ErrorMessage ((:<>:), ShowType, Text), TypeError)+import GHC.TypeNats (KnownNat, Nat, type (+), type (-), type (*), Div, natVal)+import Numeric.Natural (Natural)+import Prelude+++type PowerOf10 :: a -> Constraint+class (HasResolution n, KnownNat (Log n)) => PowerOf10 n where+  type Log n :: Nat+++instance (KnownNat n, KnownNat (Log n), IsPowerOf10 n) => PowerOf10 n where+  type Log n = Log10 n+++instance PowerOf10 E0 where+  type Log E0 = 0+++instance PowerOf10 E1 where+  type Log E1 = 1+++instance PowerOf10 E2 where+  type Log E2 = 2+++instance PowerOf10 E3 where+  type Log E3 = 3+++instance PowerOf10 E6 where+  type Log E6 = 6+++instance PowerOf10 E9 where+  type Log E9 = 9+++instance PowerOf10 E12 where+  type Log E12 = 12+++resolution :: forall n. PowerOf10 n => Natural+resolution = natVal (Proxy @(Log n))+++type Exp10 :: Nat -> Nat+type Exp10 n = Exp10' 1 n+++type Exp10' :: Nat -> Nat -> Nat+type family Exp10' x n where+  Exp10' x 0 = x+  Exp10' x n = Exp10' (x * 10) (n - 1)+++type Log10 :: Nat -> Nat+type Log10 n = Log10' (n <? 10) n+++type Log10' :: Bool -> Nat -> Nat+type family Log10' bool n where+  Log10' 'True _n = 0+  Log10' 'False n = 1 + Log10 (Div n 10)+++type IsPowerOf10 :: Nat -> Constraint+type IsPowerOf10 n = IsPowerOf10' (Exp10 (Log10 n) == n) n+++type IsPowerOf10' :: Bool -> Nat -> Constraint+type family IsPowerOf10' bool n where+  IsPowerOf10' 'True _n = ()+  IsPowerOf10' 'False n =+    TypeError ('ShowType n ' :<>: 'Text " is not a power of 10")
+ src/Rel8/Type/Decoder.hs view
@@ -0,0 +1,54 @@+{-# language DerivingStrategies #-}+{-# language DeriveFunctor #-}+{-# language NamedFieldPuns #-}+{-# language StandaloneKindSignatures #-}+{-# language DuplicateRecordFields #-}++module Rel8.Type.Decoder (+  Decoder (..),+  Parser,+  parseDecoder,+) where++-- base+import Control.Monad ((>=>))+import Data.Bifunctor (first)+import Data.Kind (Type)+import Prelude++-- bytestring+import Data.ByteString (ByteString)++-- hasql+import qualified Hasql.Decoders as Hasql++-- text+import qualified Data.Text as Text+++type Parser :: Type -> Type+type Parser a = ByteString -> Either String a+++type Decoder :: Type -> Type+data Decoder a = Decoder+  { binary :: Hasql.Value a+    -- ^ How to deserialize from PostgreSQL's binary format.+  , text :: Parser a+    -- ^ How to deserialize from PostgreSQL's text format.+  }+  deriving stock (Functor)+++-- | Apply a parser to 'Decoder'.+--+-- This can be used if the data stored in the database should only be subset of+-- a given 'Decoder'. The parser is applied when deserializing rows+-- returned.+parseDecoder :: (a -> Either String b) -> Decoder a -> Decoder b+parseDecoder f Decoder {binary, text} =+  Decoder+    { binary = Hasql.refine (first Text.pack . f) binary+    , text = text >=> f+    }+
+ src/Rel8/Type/Encoder.hs view
@@ -0,0 +1,43 @@+{-# language LambdaCase #-}+{-# language NamedFieldPuns #-}+{-# language RecordWildCards #-}+{-# language StandaloneKindSignatures #-}+{-# language StrictData #-}+{-# language DuplicateRecordFields #-}++module Rel8.Type.Encoder (+  Encoder (..),+) where++-- base+import Data.Functor.Contravariant (Contravariant, (>$<), contramap)+import Data.Kind (Type)+import Prelude++-- bytestring+import Data.ByteString.Builder (Builder)++-- hasql+import qualified Hasql.Encoders as Hasql++-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye+++type Encoder :: Type -> Type+data Encoder a = Encoder+  { binary :: Hasql.Value a+    -- ^ How to serialize to PostgreSQL's binary format.+  , text :: a -> Builder+    -- ^ How to serialize to PostgreSQL's text format.+  , quote :: a -> Opaleye.PrimExpr+    -- ^ How to encode a single Haskell value as an SQL expression.+  }+++instance Contravariant Encoder where+  contramap f Encoder {..} = Encoder+    { binary = f >$< binary+    , text = text . f+    , quote = quote . f+    }
src/Rel8/Type/Enum.hs view
@@ -1,5 +1,7 @@ {-# language AllowAmbiguousTypes #-} {-# language DataKinds #-}+{-# language DefaultSignatures #-}+{-# language DisambiguateRecordFields #-} {-# language FlexibleContexts #-} {-# language FlexibleInstances #-} {-# language LambdaCase #-}@@ -13,7 +15,7 @@  module Rel8.Type.Enum   ( Enum( Enum )-  , DBEnum( enumValue, enumTypeName )+  , DBEnum( enumValue, enumTypeName, enumerate )   , Enumable   ) where@@ -32,19 +34,25 @@ import Prelude hiding ( Enum )  -- hasql-import qualified Hasql.Decoders as Hasql+import qualified Hasql.Decoders as Decoders+import qualified Hasql.Encoders as Encoders  -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye  -- rel8+import Rel8.Schema.QualifiedName (QualifiedName) import Rel8.Type ( DBType, typeInformation )+import Rel8.Type.Decoder (Decoder (..))+import Rel8.Type.Encoder (Encoder (..)) import Rel8.Type.Eq ( DBEq ) import Rel8.Type.Information ( TypeInformation(..) )+import Rel8.Type.Name (TypeName (..)) import Rel8.Type.Ord ( DBOrd, DBMax, DBMin )  -- text-import Data.Text ( pack )+import Data.Text (pack)+import Data.Text.Encoding (decodeUtf8, encodeUtf8Builder)   -- | A deriving-via helper type for column types that store an \"enum\" type@@ -65,17 +73,35 @@  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+    { encode =+        let+          toText (Enum a) = pack $ enumValue a+        in+        Encoder+          { binary = Encoders.enum toText+          , text = encodeUtf8Builder . toText+          , quote =+              Opaleye.ConstExpr .+              Opaleye.StringLit .+              enumValue @a .+              unEnum+          }+    , decode =+        let+          mapping = (pack . enumValue &&& Enum) <$> enumerate+          unrecognised = Left "enum: unrecognised value"+        in+          Decoder+            { binary = Decoders.enum (`lookup` mapping)+            , text = maybe unrecognised pure . (`lookup` mapping) . decodeUtf8+            }+    , delimiter = ','+    , typeName =+        TypeName+          { name = enumTypeName @a+          , modifiers = []+          , arrayDepth = 0+          }     }  @@ -93,19 +119,28 @@  -- | @DBEnum@ contains the necessary metadata to describe a PostgreSQL @enum@ type. type DBEnum :: Type -> Constraint-class (DBType a, Enumable a) => DBEnum a where+class DBType 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+  enumTypeName :: QualifiedName +  -- | List of all possible values of the enum type.+  enumerate :: [a] +  default enumValue :: Enumable a => a -> String+  enumValue = gshow @(Rep a) . from++  default enumerate :: Enumable a => [a]+  enumerate = to <$> genumerate @(Rep a)++ -- | Types that are sum types, where each constructor is unary (that is, has no -- fields).+type Enumable :: Type -> Constraint class (Generic a, GEnumable (Rep a)) => Enumable a instance (Generic a, GEnumable (Rep a)) => Enumable a
src/Rel8/Type/Eq.hs view
@@ -14,9 +14,10 @@ import Data.Aeson ( Value )  -- base-import Data.List.NonEmpty ( NonEmpty )+import Data.Fixed (Fixed) import Data.Int ( Int16, Int32, Int64 ) import Data.Kind ( Constraint, Type )+import Data.List.NonEmpty ( NonEmpty ) import Prelude  -- bytestring@@ -29,6 +30,7 @@ -- rel8 import Rel8.Schema.Null ( Sql ) import Rel8.Type ( DBType )+import Rel8.Type.Decimal (PowerOf10)  -- scientific import Data.Scientific ( Scientific )@@ -58,6 +60,7 @@ instance DBEq Int16 instance DBEq Int32 instance DBEq Int64+instance PowerOf10 n => DBEq (Fixed n) instance DBEq Float instance DBEq Double instance DBEq Scientific
src/Rel8/Type/Information.hs view
@@ -1,27 +1,23 @@ {-# language GADTs #-} {-# language NamedFieldPuns #-} {-# language StandaloneKindSignatures #-}+{-# language StrictData #-} -module Rel8.Type.Information-  ( TypeInformation(..)-  , mapTypeInformation-  , parseTypeInformation-  )-where+module Rel8.Type.Information (+  TypeInformation(..),+  mapTypeInformation,+  parseTypeInformation,+) where  -- base-import Data.Bifunctor ( first )-import Data.Kind ( Type )+import Data.Functor.Contravariant ((>$<))+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+-- rel8+import Rel8.Type.Decoder (Decoder, parseDecoder)+import Rel8.Type.Encoder (Encoder)+import Rel8.Type.Name (TypeName)   -- | @TypeInformation@ describes how to encode and decode a Haskell type to and@@ -29,14 +25,17 @@ -- 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+  { encode :: Encoder a+    -- ^ How to serialize a Haskell value to PostgreSQL.+  , decode :: Decoder a+    -- ^ How to deserialize a PostgreSQL result back to Haskell.+  , delimiter :: Char+    -- ^ The delimiter that is used in PostgreSQL's text format in arrays of+    -- this type (this is almost always ',').+  , typeName :: TypeName     -- ^ 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@@ -59,9 +58,10 @@ parseTypeInformation :: ()   => (a -> Either String b) -> (b -> a)   -> TypeInformation a -> TypeInformation b-parseTypeInformation to from TypeInformation {encode, decode, typeName} =+parseTypeInformation to from TypeInformation {encode, decode, delimiter, typeName} =   TypeInformation-    { encode = encode . from-    , decode = Hasql.refine (first Text.pack . to) decode+    { decode = parseDecoder to decode+    , encode = from >$< encode+    , delimiter     , typeName     }
src/Rel8/Type/JSONBEncoded.hs view
@@ -1,31 +1,67 @@-module Rel8.Type.JSONBEncoded ( JSONBEncoded(..) ) where+{-# language DisambiguateRecordFields #-}+{-# language OverloadedStrings #-}+{-# language StandaloneKindSignatures #-} +module Rel8.Type.JSONBEncoded (+  JSONBEncoded(..),+) where+ -- aeson-import Data.Aeson ( FromJSON, ToJSON, parseJSON, toJSON )-import Data.Aeson.Types ( parseEither )+import Data.Aeson (FromJSON, ToJSON, eitherDecodeStrict, parseJSON, toJSON)+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Text as Aeson+import Data.Aeson.Types (parseEither)  -- base import Data.Bifunctor ( first )+import Data.Functor.Contravariant ((>$<))+import Data.Kind ( Type ) import Prelude  -- hasql-import qualified Hasql.Decoders as Hasql+import qualified Hasql.Decoders as Decoders+import qualified Hasql.Encoders as Encoders +-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye+import qualified Opaleye.Internal.HaskellDB.Sql.Default as Opaleye (quote)+ -- rel8 import Rel8.Type ( DBType(..) )+import Rel8.Type.Decoder (Decoder (..))+import Rel8.Type.Encoder (Encoder (..)) import Rel8.Type.Information ( TypeInformation(..) )  -- text import Data.Text ( pack )+import Data.Text.Lazy (unpack)   -- | Like 'Rel8.JSONEncoded', but works for @jsonb@ columns.+type JSONBEncoded :: Type -> Type newtype JSONBEncoded a = JSONBEncoded { fromJSONBEncoded :: a }+  deriving (Show, Eq, Ord)   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+    { encode =+        Encoder+          { binary = toJSON . fromJSONBEncoded >$< Encoders.jsonb+          , text = Aeson.fromEncoding . Aeson.toEncoding . fromJSONBEncoded+          , quote =+              Opaleye.ConstExpr . Opaleye.OtherLit .+              Opaleye.quote .+              unpack . Aeson.encodeToLazyText . fromJSONBEncoded+          }+    , decode =+        Decoder+          { binary =+              Decoders.refine+                (first pack . fmap JSONBEncoded . parseEither parseJSON)+                Decoders.jsonb+          , text = fmap JSONBEncoded . eitherDecodeStrict+          }+    , delimiter = ','     , typeName = "jsonb"     }
src/Rel8/Type/JSONEncoded.hs view
@@ -1,25 +1,69 @@-module Rel8.Type.JSONEncoded ( JSONEncoded(..) ) where+{-# language DisambiguateRecordFields #-}+{-# language StandaloneKindSignatures #-}+{-# language OverloadedStrings #-}+{-# language TypeApplications #-} +module Rel8.Type.JSONEncoded (+  JSONEncoded(..),+) where+ -- aeson-import Data.Aeson ( FromJSON, ToJSON, parseJSON, toJSON )-import Data.Aeson.Types ( parseEither )+import Data.Aeson (FromJSON, ToJSON, eitherDecodeStrict, parseJSON, toJSON)+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Text as Aeson+import Data.Aeson.Types (parseEither)  -- base+import Data.Bifunctor (first)+import Data.Functor.Contravariant ((>$<))+import Data.Kind ( Type ) import Prelude +-- hasql+import qualified Hasql.Decoders as Decoders+import qualified Hasql.Encoders as Encoders+ -- rel8 import Rel8.Type ( DBType(..) )-import Rel8.Type.Information ( parseTypeInformation )+import Rel8.Type.Decoder (Decoder (..))+import Rel8.Type.Encoder (Encoder (..))+import Rel8.Type.Information ( TypeInformation(..) ) +-- opaleye+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye+import qualified Opaleye.Internal.HaskellDB.Sql.Default as Opaleye ( quote ) +-- text+import Data.Text (pack)+import Data.Text.Lazy (unpack)++ -- | 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.+type JSONEncoded :: Type -> Type newtype JSONEncoded a = JSONEncoded { fromJSONEncoded :: a }+  deriving (Show, Eq, Ord)   instance (FromJSON a, ToJSON a) => DBType (JSONEncoded a) where-  typeInformation = parseTypeInformation f g typeInformation-    where-      f = fmap JSONEncoded . parseEither parseJSON-      g = toJSON . fromJSONEncoded+  typeInformation = TypeInformation+    { encode =+        Encoder+          { binary = toJSON . fromJSONEncoded >$< Encoders.json+          , text = Aeson.fromEncoding . Aeson.toEncoding . fromJSONEncoded+          , quote =+              Opaleye.ConstExpr . Opaleye.OtherLit . Opaleye.quote .+              unpack . Aeson.encodeToLazyText . fromJSONEncoded+          }+    , decode =+        Decoder+          { binary =+              Decoders.refine+                (first pack . fmap JSONEncoded . parseEither parseJSON)+                Decoders.json+          , text = fmap JSONEncoded . eitherDecodeStrict+          }+    , delimiter = ','+    , typeName = "json"+    }
+ src/Rel8/Type/Name.hs view
@@ -0,0 +1,58 @@+{-# language RecordWildCards #-}+{-# language StrictData #-}++module Rel8.Type.Name+  ( TypeName (..)+  , showTypeName+  )+where++-- base+import Data.Semigroup (mtimesDefault)+import Data.String (IsString, fromString)+import Prelude++-- pretty+import Text.PrettyPrint (Doc, comma, hcat, parens, punctuate, text)++-- rel8+import Rel8.Schema.QualifiedName (QualifiedName, ppQualifiedName)+++-- | A PostgreSQL type consists of a 'QualifiedName' (name, schema), and+-- optional 'modifiers' and 'arrayDepth'. 'modifiers' will usually be @[]@,+-- but a type like @numeric(6, 2)@ will have @["6", "2"]@. 'arrayDepth' is+-- always @0@ for non-array types.+data TypeName = TypeName+  { name :: QualifiedName+    -- ^ The name (and schema) of the type.+  , modifiers :: [String]+    -- ^ Any modifiers applied to the underlying type.+  , arrayDepth :: Word+    -- ^ If this is an array type, the depth of that array (@1@ for @[]@, @2@+    -- for @[][]@, etc).+  }+++-- | Constructs 'TypeName's with 'schema' set to 'Nothing', 'modifiers' set+-- to @[]@ and 'arrayDepth' set to @0@.+instance IsString TypeName where+  fromString string =+    TypeName+      { name = fromString string+      , modifiers = []+      , arrayDepth = 0+      }+++ppTypeName :: TypeName -> Doc+ppTypeName TypeName {..} =+  ppQualifiedName name <> modifier <> mtimesDefault arrayDepth (text "[]")+  where+    modifier+      | null modifiers = mempty+      | otherwise = parens (hcat $ punctuate comma $ text <$> modifiers)+++showTypeName :: TypeName -> String+showTypeName = show . ppTypeName
+ src/Rel8/Type/Nullable.hs view
@@ -0,0 +1,16 @@+{-# language GADTs #-}+{-# language StandaloneKindSignatures #-}++module Rel8.Type.Nullable (+  NullableOrNot (..),+) where++-- base+import Data.Kind (Type)+import Prelude+++type NullableOrNot :: (Type -> Type) -> Type -> Type+data NullableOrNot decoder a where+  NonNullable :: decoder a -> NullableOrNot decoder a+  Nullable :: decoder a -> NullableOrNot decoder (Maybe a)
src/Rel8/Type/Num.hs view
@@ -12,12 +12,15 @@ where  -- base+import Data.Fixed (Fixed) import Data.Int ( Int16, Int32, Int64 ) import Data.Kind ( Constraint, Type ) import Prelude  -- rel8 import Rel8.Type ( DBType )+import Rel8.Type.Decimal (PowerOf10)+import Rel8.Type.Ord ( DBOrd )  -- scientific import Data.Scientific ( Scientific )@@ -30,6 +33,7 @@ instance DBNum Int16 instance DBNum Int32 instance DBNum Int64+instance PowerOf10 n => DBNum (Fixed n) instance DBNum Float instance DBNum Double instance DBNum Scientific@@ -37,22 +41,25 @@  -- | The class of database types that can be coerced to from integral -- expressions. This is a Rel8 concept, and allows us to provide--- 'fromIntegral'.+-- 'Rel8.Expr.Num.fromIntegral'. type DBIntegral :: Type -> Constraint-class DBNum a => DBIntegral a+class (DBNum a, DBOrd a) => DBIntegral a instance DBIntegral Int16 instance DBIntegral Int32 instance DBIntegral Int64   -- | The class of database types that support the @/@ operator.+type DBFractional :: Type -> Constraint class DBNum a => DBFractional a+instance PowerOf10 n => DBFractional (Fixed n) instance DBFractional Float instance DBFractional Double instance DBFractional Scientific   -- | The class of database types that support the @/@ operator.+type DBFloating :: Type -> Constraint class DBFractional a => DBFloating a instance DBFloating Float instance DBFloating Double
src/Rel8/Type/Ord.hs view
@@ -12,6 +12,7 @@ where  -- base+import Data.Fixed (Fixed) import Data.Int ( Int16, Int32, Int64 ) import Data.Kind ( Constraint, Type ) import Data.List.NonEmpty ( NonEmpty )@@ -26,6 +27,7 @@  -- rel8 import Rel8.Schema.Null ( Sql )+import Rel8.Type.Decimal (PowerOf10) import Rel8.Type.Eq ( DBEq )  -- scientific@@ -53,6 +55,7 @@ instance DBOrd Int16 instance DBOrd Int32 instance DBOrd Int64+instance PowerOf10 n => DBOrd (Fixed n) instance DBOrd Float instance DBOrd Double instance DBOrd Scientific@@ -79,6 +82,7 @@ instance DBMax Int16 instance DBMax Int32 instance DBMax Int64+instance PowerOf10 n => DBMax (Fixed n) instance DBMax Float instance DBMax Double instance DBMax Scientific@@ -104,6 +108,7 @@ instance DBMin Int16 instance DBMin Int32 instance DBMin Int64+instance PowerOf10 n => DBMin (Fixed n) instance DBMin Float instance DBMin Double instance DBMin Scientific
+ src/Rel8/Type/Parser.hs view
@@ -0,0 +1,17 @@+module Rel8.Type.Parser+  ( parse+  )+where++-- attoparsec+import qualified Data.Attoparsec.ByteString as A++-- base+import Prelude++-- bytestring+import Data.ByteString (ByteString)+++parse :: A.Parser a -> ByteString -> Either String a+parse parser = A.parseOnly (parser <* A.endOfInput)
+ src/Rel8/Type/Parser/ByteString.hs view
@@ -0,0 +1,54 @@+{-# language OverloadedStrings #-}+{-# language TypeApplications #-}++module Rel8.Type.Parser.ByteString+  ( bytestring+  )+where++-- attoparsec+import qualified Data.Attoparsec.ByteString.Char8 as A++-- base+import Control.Applicative ((<|>), many)+import Control.Monad (guard)+import Data.Bits ((.|.), shiftL)+import Data.Char (isOctDigit)+import Data.Foldable (fold)+import Prelude++-- base16+import Data.ByteString.Base16 (decodeBase16Untyped)++-- bytestring+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS++-- text+import qualified Data.Text as Text+++bytestring :: A.Parser ByteString+bytestring = hex <|> escape+  where+    hex = do+      digits <- "\\x" *> A.takeByteString+      either (fail . Text.unpack) pure $ decodeBase16Untyped digits+    escape = fold <$> many (escaped <|> unescaped)+      where+        unescaped = A.takeWhile1 (/= '\\')+        escaped = BS.singleton <$> (backslash <|> octal)+          where+            backslash = '\\' <$ "\\\\"+            octal = do+              a <- A.char '\\' *> digit+              b <- digit+              c <- digit+              let+                result = a `shiftL` 6 .|. b `shiftL` 3 .|. c+              guard $ result < 0o400+              pure $ toEnum result+              where+                digit = do+                  c <- A.satisfy isOctDigit+                  pure $ fromEnum c - fromEnum '0'
+ src/Rel8/Type/Parser/Time.hs view
@@ -0,0 +1,156 @@+{-# language OverloadedStrings #-}+{-# language TypeApplications #-}++module Rel8.Type.Parser.Time+  ( calendarDiffTime+  , day+  , localTime+  , timeOfDay+  , utcTime+  )+where++-- attoparsec+import qualified Data.Attoparsec.ByteString.Char8 as A++-- base+import Control.Applicative ((<|>), optional)+import Data.Bits ((.&.))+import Data.Bool (bool)+import Data.Fixed (Fixed (MkFixed), Pico, divMod')+import Data.Functor (void)+import Data.Int (Int64)+import Prelude++-- bytestring+import qualified Data.ByteString as BS++-- time+import Data.Time.Calendar (Day, addDays, fromGregorianValid)+import Data.Time.Clock (DiffTime, UTCTime (UTCTime))+import Data.Time.Format.ISO8601 (iso8601ParseM)+import Data.Time.LocalTime+  ( CalendarDiffTime (CalendarDiffTime)+  , LocalTime (LocalTime)+  , TimeOfDay (TimeOfDay)+  , sinceMidnight+  )++-- utf8+import qualified Data.ByteString.UTF8 as UTF8+++day :: A.Parser Day+day = do+  y <- A.decimal <* A.char '-'+  m <- twoDigits <* A.char '-'+  d <- twoDigits+  maybe (fail "Day: invalid date") pure $ fromGregorianValid y m d+++timeOfDay :: A.Parser TimeOfDay+timeOfDay = do+  h <- twoDigits+  m <- A.char ':' *> twoDigits+  s <- A.char ':' *> secondsParser+  if h < 24 && m < 60 && s <= 60+    then pure $ TimeOfDay h m s+    else fail "TimeOfDay: invalid time"+++localTime :: A.Parser LocalTime+localTime = LocalTime <$> day <* separator <*> timeOfDay+  where+    separator = A.char ' ' <|> A.char 'T'+++utcTime :: A.Parser UTCTime+utcTime = do+  LocalTime date time <- localTime+  tz <- timeZone+  let+    (days, time') = (sinceMidnight time + tz) `divMod'` oneDay+      where+        oneDay = 24 * 60 * 60+    date' = addDays days date+  pure $ UTCTime date' time'+++calendarDiffTime :: A.Parser CalendarDiffTime+calendarDiffTime = iso8601 <|> postgres+  where+    iso8601 = A.takeByteString >>= iso8601ParseM . UTF8.toString+    at = optional (A.char '@') *> A.skipSpace+    plural unit = A.skipSpace <* (unit <* optional "s") <* A.skipSpace+    parseMonths = sql <|> postgresql+      where+        sql = A.signed $ do+          years <- A.decimal <* A.char '-'+          months <- A.decimal <* A.skipSpace+          pure $ years * 12 + months+        postgresql = do+          at+          years <- A.signed A.decimal <* plural "year" <|> pure 0+          months <- A.signed A.decimal <* plural "mon" <|> pure 0+          pure $ years * 12 + months+    parseTime = (+) <$> parseDays <*> time+      where+        time = realToFrac <$> (sql <|> postgresql)+          where+            sql = A.signed $ do+              h <- A.signed A.decimal <* A.char ':'+              m <- twoDigits <* A.char ':'+              s <- secondsParser+              pure $ fromIntegral (((h * 60) + m) * 60) + s+            postgresql = do+              h <- A.signed A.decimal <* plural "hour" <|> pure 0+              m <- A.signed A.decimal <* plural "min" <|> pure 0+              s <- secondsParser <* plural "sec" <|> pure 0+              pure $ fromIntegral @Int (((h * 60) + m) * 60) + s+        parseDays = do+          days <- A.signed A.decimal <* (plural "days" <|> skipSpace1) <|> pure 0+          pure $ fromIntegral @Int days * 24 * 60 * 60+    postgres = do+      months <- parseMonths+      time <- parseTime+      ago <- (True <$ (A.skipSpace *> "ago")) <|> pure False+      pure $ CalendarDiffTime (bool id negate ago months) (bool id negate ago time)+++secondsParser :: A.Parser Pico+secondsParser = do+  integral <- twoDigits+  mfractional <- optional (A.char '.' *> A.takeWhile1 A.isDigit)+  pure $ case mfractional of+    Nothing -> fromIntegral integral+    Just fractional -> parseFraction (fromIntegral integral) fractional+ where+  parseFraction integral digits = MkFixed (fromIntegral (n * 10 ^ e))+    where+      e = max 0 (12 - BS.length digits)+      n = BS.foldl' go (integral :: Int64) (BS.take 12 digits)+        where+          go acc digit = 10 * acc + fromIntegral (fromEnum digit .&. 0xf)+++twoDigits :: A.Parser Int+twoDigits = do+  u <- A.digit+  l <- A.digit+  pure $ fromEnum u .&. 0xf * 10 + fromEnum l .&. 0xf+++timeZone :: A.Parser DiffTime+timeZone = 0 <$ A.char 'Z' <|> diffTime+++diffTime :: A.Parser DiffTime+diffTime = A.signed $ do+  h <- twoDigits+  m <- A.char ':' *> twoDigits <|> pure 0+  s <- A.char ':' *> secondsParser <|> pure 0+  pure $ sinceMidnight $ TimeOfDay h m s+++skipSpace1 :: A.Parser ()+skipSpace1 = void $ A.takeWhile1 A.isSpace
src/Rel8/Type/ReadShow.hs view
@@ -1,10 +1,12 @@ {-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-} {-# language TypeApplications #-} {-# language ViewPatterns #-}  module Rel8.Type.ReadShow ( ReadShow(..) ) where  -- base+import Data.Kind ( Type ) import Data.Proxy ( Proxy( Proxy ) ) import Data.Typeable ( Typeable, typeRep ) import Prelude @@ -20,6 +22,7 @@  -- | A deriving-via helper type for column types that store a Haskell value -- using a Haskell's 'Read' and 'Show' type classes.+type ReadShow :: Type -> Type newtype ReadShow a = ReadShow { fromReadShow :: a }
src/Rel8/Type/Sum.hs view
@@ -12,12 +12,14 @@ where  -- base+import Data.Fixed (Fixed) import Data.Int ( Int16, Int32, Int64 ) import Data.Kind ( Constraint, Type ) import Prelude  -- rel8 import Rel8.Type ( DBType )+import Rel8.Type.Decimal (PowerOf10)  -- scientific import Data.Scientific ( Scientific )@@ -32,6 +34,7 @@ instance DBSum Int16 instance DBSum Int32 instance DBSum Int64+instance PowerOf10 n => DBSum (Fixed n) instance DBSum Float instance DBSum Double instance DBSum Scientific
src/Rel8/Type/Tag.hs view
@@ -90,6 +90,7 @@   memptyExpr = litExpr mempty  +type Tag :: Type newtype Tag = Tag Text   deriving newtype     ( Eq, Ord, Read, Show
+ src/Rel8/Window.hs view
@@ -0,0 +1,97 @@+{-# language DerivingVia #-}+{-# language FlexibleContexts #-}+{-# language GeneralizedNewtypeDeriving #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-}++module Rel8.Window+  ( Window(..)+  , Partition+  , over+  , partitionBy+  , orderPartitionBy+  )+where++-- base+import Data.Functor.Const ( Const( Const ), getConst )+import Data.Functor.Contravariant ( Contravariant, contramap )+import Data.Kind ( Type )+import Prelude++-- opaleye+import qualified Opaleye.Internal.Window as Opaleye+import qualified Opaleye.Internal.PackMap as Opaleye++-- profunctors+import Data.Profunctor ( Profunctor )++-- product-profunctors+import Data.Profunctor.Product ( ProductProfunctor, (****), purePP )++-- rel8+import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )+import Rel8.Order( Order( Order ) )+import Rel8.Schema.HTable ( hfield, htabulateA )+import Rel8.Table ( Columns, toColumns )+import Rel8.Table.Eq ( EqTable )++-- semigroupoids+import Data.Functor.Apply ( Apply, WrappedApplicative(..) )+++-- | 'Window' is an applicative functor that represents expressions that+-- contain+-- [window functions](https://www.postgresql.org/docs/current/tutorial-window.html).+-- 'Rel8.Query.Window.window' can be used to+-- evaluate these expressions over a particular query.+type Window :: Type -> Type -> Type+newtype Window a b = Window (Opaleye.Windows a b)+  deriving newtype (Profunctor)+  deriving newtype (Functor, Applicative)+  deriving (Apply) via (WrappedApplicative (Window a))+++instance ProductProfunctor Window where+  purePP = pure+  (****) = (<*>)+++-- | In PostgreSQL, window functions must specify the \"window\" or+-- \"partition\" over which they operate. The syntax for this looks like:+-- @SUM(salary) OVER (PARTITION BY department)@. The Rel8 type 'Partition'+-- represents everything that comes after @OVER@.+--+-- 'Partition' is a 'Monoid', so 'Window's created with 'partitionBy' and+-- 'orderWindowBy' can be combined using '<>'.+type Partition :: Type -> Type+newtype Partition a = Partition (Opaleye.Window a)+  deriving newtype (Contravariant, Semigroup, Monoid)+++-- | 'over' adds a 'Partition' to a 'Window' expression.+--+-- @+--   'Rel8.Table.Window.cumulative' ('Rel8.Expr.Aggregate.sum' . salary) `over` 'partitionBy' department <> 'orderPartitionBy' (salary >$< 'Rel8.desc')+-- @+over :: Window a b -> Partition a -> Window a b+over (Window (Opaleye.Windows (Opaleye.PackMap w))) (Partition p) =+  Window $ Opaleye.Windows $ Opaleye.PackMap $ \f ->+    w (\(o, p') -> f (o, p' <> p))+infixl 1 `over`+++-- | Restricts a window function to operate only the group of rows that share+-- the same value(s) for the given expression(s).+partitionBy :: forall b a. EqTable b => (a -> b) -> Partition a+partitionBy f =+  Partition $ contramap (toColumns . f) $ getConst $+    htabulateA @(Columns b) $ \field ->+      Const $ Opaleye.partitionBy (toColumn . toPrimExpr . (`hfield` field))+++-- | Controls the order in which rows are processed by window functions. This+-- does not need to match the ordering of the overall query.+orderPartitionBy :: Order a -> Partition a+orderPartitionBy (Order ordering) = Partition $ Opaleye.orderPartitionBy ordering
tests/Main.hs view
@@ -1,8 +1,9 @@ {-# language BangPatterns #-} {-# language BlockArguments #-}+{-# language CPP #-} {-# language DeriveAnyClass #-} {-# language DeriveGeneric #-}-{-# language DerivingStrategies #-}+{-# language DerivingVia #-} {-# language FlexibleContexts #-} {-# language FlexibleInstances #-} {-# language MonoLocalBinds #-}@@ -13,26 +14,39 @@ {-# language StandaloneDeriving #-} {-# language TypeApplications #-} +{-# language PartialTypeSignatures #-}+ module Main   ( main   ) 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.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 +56,34 @@ 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, 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.Table.Verify as Verify  -- scientific import Data.Scientific ( Scientific )@@ -71,7 +95,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 +112,10 @@ -- uuid import qualified Data.UUID +-- vector+import qualified Data.Vector as Vector + main :: IO () main = defaultMain tests @@ -97,6 +125,7 @@   withResource startTestDatabase stopTestDatabase \getTestDatabase ->   testGroup "rel8"     [ testSelectTestTable getTestDatabase+    , testWithStatement getTestDatabase     , testWhere_ getTestDatabase     , testFilter getTestDatabase     , testLimit getTestDatabase@@ -112,7 +141,7 @@     , testDBType getTestDatabase     , testDBEq getTestDatabase     , testTableEquality getTestDatabase-    , testFromString getTestDatabase+    , testFromRational getTestDatabase     , testCatMaybeTable getTestDatabase     , testCatMaybe getTestDatabase     , testMaybeTable getTestDatabase@@ -127,19 +156,19 @@     , testSelectArray getTestDatabase     , testNestedMaybeTable getTestDatabase     , testEvaluate 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 +176,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+            , 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 +319,6 @@ testTableSchema =   Rel8.TableSchema     { name = "test_table"-    , schema = Nothing     , columns = TestTable         { testTableColumn1 = "column1"         , testTableColumn2 = "column2"@@ -194,14 +332,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 ()+        , returning = Rel8.NoReturning         } -      statement () $ Rel8.select do+      statement () $ Rel8.run $ Rel8.select do         Rel8.each testTableSchema      sort selected === sort rows@@ -221,7 +359,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 +379,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 +397,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 +418,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 +430,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 +447,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 +461,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 +474,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 +486,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 +498,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 +510,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 +522,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 +538,142 @@    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   ]    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 +681,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 +704,49 @@     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 . Aeson.KeyMap.fromMap <$> Gen.map (Range.linear 0 10) ((,) <$> genKey <*> genValue)+     , Aeson.Array . Vector.fromList <$> Gen.list (Range.linear 0 10) genValue+     ]++    genJSONEncoded = Rel8.JSONEncoded <$> genValue+    genJSONBEncoded = Rel8.JSONBEncoded <$> genValue++ 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 +764,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 +823,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 +836,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 +848,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 +872,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 +900,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 +913,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 +926,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 +942,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 ()+        , returning = Rel8.NoReturning         } -      statement () $ Rel8.update Rel8.Update+      statement () $ Rel8.run_ $ Rel8.update Rel8.Update         { target = testTableSchema         , from = pure ()         , set = \_ r ->@@ -672,10 +967,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 +986,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 ()+        , 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 +1008,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+                , 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+                , 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+                , 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 +1099,6 @@ uniqueTableSchema =   Rel8.TableSchema     { name = "unique_table"-    , schema = Nothing     , columns = UniqueTable         { uniqueTableKey = "key"         , uniqueTableValue = "value"@@ -752,25 +1120,26 @@    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 ()+        , 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+            , 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 +1163,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 +1175,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 +1210,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 +1222,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 +1234,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")
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,264 @@   ) where +-- aeson+import Data.Aeson ( Value(..) )+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.KeyMap as Aeson+ -- base+import Data.Fixed ( Fixed ( MkFixed ), E2 )+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 +-- 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 Data.Vector ( Vector )+import qualified Data.Vector as Vector+++makeSchema :: forall f. Rel8able f => QualifiedName -> TableSchema (f Name)+makeSchema name = TableSchema+  { name = name+  , columns = namesFromLabels @(f Name)+  }+++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 +287,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 +309,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 +373,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 +417,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 <$> 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 <$> 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"++