rel8 1.4.1.0 → 1.5.0.0

raw patch · 93 files changed

+4095/−1049 lines, 93 filesdep +attoparsecdep +attoparsec-aesondep +base-compatdep ~basedep ~hasqldep ~hedgehog

Dependencies added: attoparsec, attoparsec-aeson, base-compat, base16, data-dword, data-textual, network-ip, utf8-string, vector

Dependency ranges changed: base, hasql, hedgehog, opaleye

Files

Changelog.md +131/−0
rel8.cabal +39/−5
src/Rel8.hs +96/−41
src/Rel8/Aggregate.hs +172/−58
src/Rel8/Aggregate/Fold.hs +52/−0
src/Rel8/Aggregate/Function.hs +40/−0
src/Rel8/Array.hs +26/−0
src/Rel8/Expr.hs +17/−5
src/Rel8/Expr/Aggregate.hs +406/−61
src/Rel8/Expr/Array.hs +4/−7
src/Rel8/Expr/Default.hs +5/−0
src/Rel8/Expr/Eq.hs +3/−3
src/Rel8/Expr/Function.hs +44/−22
src/Rel8/Expr/List.hs +52/−0
src/Rel8/Expr/NonEmpty.hs +53/−0
src/Rel8/Expr/Num.hs +5/−4
src/Rel8/Expr/Opaleye.hs +9/−6
src/Rel8/Expr/Read.hs +29/−0
src/Rel8/Expr/Sequence.hs +11/−8
src/Rel8/Expr/Serialize.hs +4/−3
src/Rel8/Expr/Show.hs +18/−0
src/Rel8/Expr/Text.hs +35/−30
src/Rel8/Expr/Time.hs +4/−2
src/Rel8/Expr/Window.hs +56/−28
src/Rel8/Generic/Construction.hs +47/−83
src/Rel8/Generic/Rel8able.hs +2/−7
src/Rel8/Kind/Context.hs +0/−6
src/Rel8/Query/Aggregate.hs +28/−25
src/Rel8/Query/Distinct.hs +2/−2
src/Rel8/Query/Function.hs +32/−0
src/Rel8/Query/List.hs +32/−30
src/Rel8/Query/Loop.hs +73/−0
src/Rel8/Query/Materialize.hs +42/−0
src/Rel8/Query/Maybe.hs +2/−6
src/Rel8/Query/Rebind.hs +10/−1
src/Rel8/Query/SQL.hs +7/−1
src/Rel8/Schema/Context/Nullify.hs +0/−14
src/Rel8/Schema/Escape.hs +20/−0
src/Rel8/Schema/HTable.hs +34/−6
src/Rel8/Schema/HTable/Nullify.hs +14/−8
src/Rel8/Schema/HTable/Vectorize.hs +67/−5
src/Rel8/Schema/Null.hs +1/−0
src/Rel8/Schema/QualifiedName.hs +54/−0
src/Rel8/Schema/Table.hs +9/−15
src/Rel8/Statement.hs +319/−0
src/Rel8/Statement/Delete.hs +23/−28
src/Rel8/Statement/Insert.hs +20/−27
src/Rel8/Statement/OnConflict.hs +27/−11
src/Rel8/Statement/Returning.hs +27/−77
src/Rel8/Statement/Rows.hs +30/−0
src/Rel8/Statement/Run.hs +84/−0
src/Rel8/Statement/SQL.hs +18/−3
src/Rel8/Statement/Select.hs +20/−35
src/Rel8/Statement/Update.hs +25/−29
src/Rel8/Statement/Using.hs +19/−10
src/Rel8/Statement/View.hs +10/−4
src/Rel8/Table.hs +1/−0
src/Rel8/Table/ADT.hs +11/−16
src/Rel8/Table/Aggregate.hs +135/−33
src/Rel8/Table/Cols.hs +1/−0
src/Rel8/Table/Either.hs +16/−13
src/Rel8/Table/HKD.hs +11/−16
src/Rel8/Table/List.hs +46/−2
src/Rel8/Table/Maybe.hs +27/−9
src/Rel8/Table/Name.hs +13/−3
src/Rel8/Table/NonEmpty.hs +47/−1
src/Rel8/Table/Null.hs +1/−0
src/Rel8/Table/Nullify.hs +14/−8
src/Rel8/Table/Opaleye.hs +32/−14
src/Rel8/Table/Rel8able.hs +4/−0
src/Rel8/Table/Serialize.hs +1/−0
src/Rel8/Table/These.hs +14/−11
src/Rel8/Table/Transpose.hs +4/−0
src/Rel8/Table/Window.hs +102/−25
src/Rel8/Tabulate.hs +45/−37
src/Rel8/Type.hs +193/−25
src/Rel8/Type/Array.hs +117/−21
src/Rel8/Type/Composite.hs +75/−7
src/Rel8/Type/Decimal.hs +103/−0
src/Rel8/Type/Decoder.hs +64/−0
src/Rel8/Type/Enum.hs +21/−7
src/Rel8/Type/Eq.hs +4/−1
src/Rel8/Type/Information.hs +8/−8
src/Rel8/Type/JSONBEncoded.hs +14/−4
src/Rel8/Type/Name.hs +58/−0
src/Rel8/Type/Num.hs +4/−0
src/Rel8/Type/Ord.hs +5/−0
src/Rel8/Type/Parser.hs +17/−0
src/Rel8/Type/Parser/ByteString.hs +54/−0
src/Rel8/Type/Parser/Time.hs +156/−0
src/Rel8/Type/Sum.hs +3/−0
tests/Main.hs +264/−72
tests/Rel8/Generic/Rel8able/Test.hs +1/−0

Changelog.md view

@@ -1,3 +1,134 @@++<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.cabal view

@@ -1,6 +1,6 @@ cabal-version:       2.0 name:                rel8-version:             1.4.1.0+version:             1.5.0.0 synopsis:            Hey! Hey! Can u rel8? license:             BSD3 license-file:        LICENSE@@ -20,14 +20,20 @@ library   build-depends:       aeson-    , base ^>= 4.14 || ^>=4.15 || ^>=4.16 || ^>=4.17+    , attoparsec+    , attoparsec-aeson+    , base ^>= 4.16 || ^>= 4.17 || ^>= 4.18 || ^>= 4.19+    , base16 >= 1.0+    , base-compat ^>= 0.11 || ^>= 0.12 || ^>= 0.13     , bifunctors     , bytestring     , case-insensitive     , comonad     , contravariant-    , hasql ^>= 1.4.5.1 || ^>= 1.5.0.0 || ^>= 1.6.0.0-    , opaleye ^>= 0.9.6.1+    , data-textual+    , hasql ^>= 1.6.1.2+    , network-ip+    , opaleye ^>= 0.10.2.1     , pretty     , profunctors     , product-profunctors@@ -37,7 +43,11 @@     , text     , these     , time+    , transformers+    , utf8-string     , uuid+    , vector+   default-language:     Haskell2010   ghc-options:@@ -51,6 +61,7 @@     src   exposed-modules:     Rel8+    Rel8.Array     Rel8.Expr.Num     Rel8.Expr.Text     Rel8.Expr.Time@@ -58,6 +69,8 @@    other-modules:     Rel8.Aggregate+    Rel8.Aggregate.Fold+    Rel8.Aggregate.Function      Rel8.Column     Rel8.Column.ADT@@ -76,12 +89,16 @@     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.Window      Rel8.FCF@@ -109,9 +126,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@@ -125,6 +145,7 @@      Rel8.Schema.Context.Nullify     Rel8.Schema.Dict+    Rel8.Schema.Escape     Rel8.Schema.Field     Rel8.Schema.HTable     Rel8.Schema.HTable.Either@@ -141,14 +162,18 @@     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.Returning+    Rel8.Statement.Rows+    Rel8.Statement.Run     Rel8.Statement.Select     Rel8.Statement.Set     Rel8.Statement.SQL@@ -186,14 +211,20 @@     Rel8.Type     Rel8.Type.Array     Rel8.Type.Composite+    Rel8.Type.Decimal+    Rel8.Type.Decoder     Rel8.Type.Eq     Rel8.Type.Enum     Rel8.Type.Information     Rel8.Type.JSONEncoded     Rel8.Type.JSONBEncoded     Rel8.Type.Monoid+    Rel8.Type.Name     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@@ -210,10 +241,12 @@     , bytestring     , case-insensitive     , containers+    , data-dword     , hasql     , hasql-transaction-    , hedgehog          ^>= 1.0 || ^>= 1.1+    , hedgehog          ^>= 1.0 || ^>= 1.1 || ^>= 1.2 || ^>= 1.3 || ^>= 1.4 || ^>= 1.5     , mmorph+    , network-ip     , rel8     , scientific     , tasty@@ -235,3 +268,4 @@     -Wno-missing-import-lists -Wno-prepositive-qualified-module     -Wno-deprecations -Wno-monomorphism-restriction     -Wno-missing-local-signatures -Wno-implicit-prelude+    -Wno-missing-kind-signatures

src/Rel8.hs view

@@ -19,9 +19,13 @@      -- *** @TypeInformation@   , TypeInformation(..)+  , TypeName(..)   , mapTypeInformation   , parseTypeInformation +    -- *** @Decoder@+  , Decoder(..)+     -- ** The @DBType@ hierarchy   , DBSemigroup(..)   , DBMonoid(..)@@ -135,9 +139,6 @@   , BuildADT, buildADT   , ConstructADT, constructADT -    -- *** Other ADT operations-  , AggregateADT, aggregateADT-     -- *** Miscellaneous notes     -- $misc-notes @@ -147,10 +148,10 @@   , ConstructHKD, constructHKD   , DeconstructHKD, deconstructHKD   , NameHKD, nameHKD-  , AggregateHKD, aggregateHKD      -- ** Table schemas   , TableSchema(..)+  , QualifiedName(..)   , Name   , namesFromLabels   , namesFromLabelsWith@@ -193,10 +194,10 @@   , leastExpr, greatestExpr      -- ** Functions-  , Function+  , Arguments   , function-  , nullaryFunction   , binaryOperator+  , queryFunction      -- * Queries   , Query@@ -246,26 +247,53 @@   , 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-  , mode-  , nonEmptyAgg, nonEmptyAggExpr-  , DBMax, max-  , DBMin, min-  , DBSum, sum, sumWhere, avg+  , 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 +  , mode, modeOn+  , percentile, percentileOn+  , percentileContinuous, percentileContinuousOn+  , hypotheticalRank+  , hypotheticalDenseRank+  , hypotheticalPercentRank+  , hypotheticalCumeDist+     -- ** Ordering   , orderBy   , Order@@ -282,7 +310,6 @@   , partitionBy   , orderPartitionBy   , cumulative-  , cumulative_   , currentRow   , rowNumber   , rank@@ -290,11 +317,11 @@   , percentRank   , cumeDist   , ntile-  , lag-  , lead-  , firstValue-  , lastValue-  , nthValue+  , lag, lagOn+  , lead, leadOn+  , firstValue, firstValueOn+  , lastValue, lastValueOn+  , nthValue, nthValueOn   , indexed      -- ** Bindings@@ -307,6 +334,12 @@      -- * Running statements     -- $running+  , run+  , run_+  , runN+  , run1+  , runMaybe+  , runVector      -- ** @SELECT@   , select@@ -332,6 +365,10 @@     -- ** @.. RETURNING@   , Returning(..) +    -- ** @WITH@+  , Statement+  , showStatement+     -- ** @CREATE VIEW@   , createView   , createOrReplaceView@@ -346,6 +383,8 @@  -- rel8 import Rel8.Aggregate+import Rel8.Aggregate.Fold+import Rel8.Aggregate.Function import Rel8.Column import Rel8.Column.ADT import Rel8.Column.Either@@ -368,7 +407,7 @@ import Rel8.Expr.Serialize import Rel8.Expr.Sequence import Rel8.Expr.Text ( like, ilike )-import Rel8.Expr.Window hiding ( cumulative )+import Rel8.Expr.Window import Rel8.Generic.Rel8able ( KRel8able, Rel8able ) import Rel8.Order import Rel8.Query@@ -379,9 +418,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@@ -395,12 +437,15 @@ 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.Returning+import Rel8.Statement.Run import Rel8.Statement.Select import Rel8.Statement.SQL import Rel8.Statement.Update@@ -429,12 +474,14 @@ import Rel8.Table.Window import Rel8.Type import Rel8.Type.Composite+import Rel8.Type.Decoder import Rel8.Type.Eq import Rel8.Type.Enum import Rel8.Type.Information import Rel8.Type.JSONBEncoded import Rel8.Type.JSONEncoded import Rel8.Type.Monoid+import Rel8.Type.Name import Rel8.Type.Num import Rel8.Type.Ord import Rel8.Type.ReadShow@@ -446,9 +493,17 @@  -- $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.@@ -508,9 +563,9 @@ -- query = do --   thingExpr <- each thingSchema --   where_ $---     deconstructADT @Thing---       (\employer -> employerName employer ==. lit \"Mary\")---       (\potato -> grower potato ==. lit \"Mary\")+--     deconstructADT \@Thing+--       (\\employer -> employerName employer ==. lit \"Mary\")+--       (\\potato -> grower potato ==. lit \"Mary\") --       (lit False) -- Nullary case --       thingExpr --   pure thingExpr@@ -554,10 +609,10 @@ -- 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+-- > :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@@ -580,8 +635,8 @@ -- @ -- > :{ -- showQuery $ values---   [ buildADT @Task @\"Pending\"---   , buildADT @Task @\"Complete\" CompletedTask {date = Rel8.Expr.Time.now}+--   [ buildADT \@Task \@\"Pending\"+--   , buildADT \@Task \@\"Complete\" CompletedTask {date = Rel8.Expr.Time.now} --   ] -- :} -- @@@ -630,10 +685,10 @@ -- @ -- let --   pending :: ADT Task Expr---   pending = constructADT @Task $ \pending _complete -> pending+--   pending = constructADT \@Task $ \\pending _complete -> pending -- --   complete :: ADT Task Expr---   complete = constructADT @Task $ \_pending complete -> complete CompletedTask {date = Rel8.Expr.Time.now}+--   complete = constructADT \@Task $ \\_pending complete -> complete CompletedTask {date = Rel8.Expr.Time.now} -- @ -- -- These values are otherwise identical to the ones we saw above with

src/Rel8/Aggregate.hs view

@@ -1,83 +1,197 @@ {-# language DataKinds #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language MultiParamTypeClasses #-}-{-# language RankNTypes #-}+{-# language GADTs #-}+{-# language KindSignatures #-}+{-# language ScopedTypeVariables #-} {-# language StandaloneKindSignatures #-}-{-# language TypeFamilies #-}-{-# language UndecidableInstances #-}  module Rel8.Aggregate-  ( Aggregate(..), zipOutputs-  , 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 --- profunctors-import Data.Profunctor ( dimap )- -- opaleye import qualified Opaleye.Aggregate as Opaleye-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye-import qualified Opaleye.Internal.Column 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 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+  (****) = (<*>)  -unsafeMakeAggregate :: forall (input :: Type) (output :: Type) n n' a a'. ()-  => (Expr input -> Opaleye.PrimExpr)-  -> (Opaleye.PrimExpr -> Expr output)-  -> Opaleye.Aggregator (Opaleye.Field_ n a) (Opaleye.Field_ n' a')-  -> Expr input-  -> Aggregate output-unsafeMakeAggregate input output aggregator expr =-  Aggregate $ dimap in_ out aggregator-  where out = output . Opaleye.unColumn-        in_ = Opaleye.Column . input . const expr+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)+++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+    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/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,40 @@+{-# language FlexibleContexts #-}+{-# language MonoLocalBinds #-}++module Rel8.Aggregate.Function (+  aggregateFunction,+) 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 =+  unsafeMakeAggregator+    id+    (castExpr . fromPrimExpr . fromColumn)+    Empty+    (Opaleye.makeAggrExplicit unpackspec+      (Opaleye.AggrOther (showQualifiedName name)))

+ src/Rel8/Array.hs view

@@ -0,0 +1,26 @@+module Rel8.Array+  (+    -- ** @ListTable@+    ListTable+  , head, headExpr+  , index, indexExpr+  , last, lastExpr+  , length, lengthExpr++    -- ** @NonEmptyTable@+  , NonEmptyTable+  , head1, head1Expr+  , index1, index1Expr+  , last1, last1Expr+  , length1, length1Expr+  )+where++-- base+import Prelude hiding (head, last, length)++-- rel8+import Rel8.Expr.List+import Rel8.Expr.NonEmpty+import Rel8.Table.List+import Rel8.Table.NonEmpty

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,150 +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-  , avg-  , 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.Internal.Aggregate as Opaleye-import Opaleye.Internal.Column ( Field_( Column ) ) 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, 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, encodeArrayElement) import Rel8.Type.Eq ( DBEq )-import Rel8.Type.Information ( TypeInformation )-import Rel8.Type.Num ( DBNum )-import Rel8.Type.Ord ( DBMax, DBMin )+import Rel8.Type.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 Opaleye.count+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 $-  Opaleye.distinctAggregator Opaleye.count+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 Opaleye.boolAnd+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 Opaleye.boolOr+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 Opaleye.unsafeMax+-- | 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 Opaleye.unsafeMin+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 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) Opaleye.unsafeSum+sum :: (Sql DBNum a, Sql DBSum a) => Aggregator' fold (Expr a) (Expr a)+sum =+  unsafeMakeAggregator+    (toColumn . toPrimExpr)+    (fromPrimExpr . fromColumn)+    (Fallback 0)+    Opaleye.unsafeSum  +-- | 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)+  => (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 => Expr a -> Aggregate a-avg = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) Opaleye.unsafeAvg+avg :: Sql DBSum a => Aggregator1 (Expr a) (Expr a)+avg =+  unsafeMakeAggregator+    (toColumn . toPrimExpr)+    (fromPrimExpr . fromColumn)+    Empty+    Opaleye.unsafeAvg --- | Take the sum of all expressions that satisfy a predicate.-sumWhere :: (Sql DBNum a, Sql DBSum a)-  => Expr Bool -> Expr a -> Aggregate a-sumWhere condition a = sum (caseExpr [(condition, a)] 0) +-- | 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) (Opaleye.stringAgg (Column (toPrimExpr delimiter)))+  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 Opaleye.groupBy+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 Opaleye.arrayAgg-  where-    to = encodeArrayElement info . toPrimExpr+  => TypeInformation (Unnullify a) -> Aggregator' fold (Expr a) (Expr [a])+slistAggExpr info =+  unsafeMakeAggregator+    (toColumn . encodeArrayElement info . toPrimExpr)+    (fromPrimExpr . fromColumn)+    (Fallback (sempty info))+    Opaleye.arrayAgg   snonEmptyAggExpr :: ()-  => TypeInformation (Unnullify a) -> Expr a -> Aggregate (NonEmpty a)-snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg+  => TypeInformation (Unnullify a) -> Aggregator1 (Expr a) (Expr (NonEmpty a))+snonEmptyAggExpr info =+  unsafeMakeAggregator+    (toColumn . encodeArrayElement 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

@@ -27,6 +27,11 @@ -- 3. @DEFAULT@ values can not 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 -- used is with auto-incrementing identifier columns. In this case, we suggest

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,13 +1,16 @@ {-# 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   , binaryOperator   ) where@@ -19,45 +22,64 @@ -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye +-- pretty+import Text.PrettyPrint (parens, text)+ -- rel8-import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )+import {-# SOURCE #-} Rel8.Expr (Expr) import Rel8.Expr.Opaleye   ( castExpr   , fromPrimExpr, toPrimExpr, zipPrimExprsWith   )+import Rel8.Schema.Escape (escape)+import Rel8.Schema.HTable (hfoldMap) import Rel8.Schema.Null ( Sql )+import Rel8.Schema.QualifiedName (QualifiedName (..), showQualifiedName)+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 . fromPrimExpr . primFunction qualified  --- | Construct a function call for functions with no arguments.-nullaryFunction :: Sql DBType a => String -> Expr a-nullaryFunction name = castExpr $ Expr (Opaleye.FunExpr name [])+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 :: Sql DBType c => QualifiedName -> Expr a -> Expr b -> Expr c binaryOperator operator a b =-  castExpr $ zipPrimExprsWith (Opaleye.BinExpr (Opaleye.OpOther operator)) a b+  castExpr $ zipPrimExprsWith (Opaleye.BinExpr (Opaleye.OpOther name)) a b+  where+    name = showQualifiedOperator operator+++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/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/Num.hs view

@@ -1,4 +1,5 @@ {-# language FlexibleContexts #-}+{-# language OverloadedStrings #-} {-# language TypeFamilies #-}  {-# options_ghc -fno-warn-redundant-constraints #-}@@ -18,7 +19,7 @@ -- rel import Rel8.Expr ( Expr( Expr ) ) import Rel8.Expr.Eq ( (==.) )-import Rel8.Expr.Function ( function )+import Rel8.Expr.Function (function) import Rel8.Expr.Opaleye ( castExpr ) import Rel8.Schema.Null ( Homonullable, Sql ) import Rel8.Table.Bool ( bool )@@ -32,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@@ -71,13 +72,13 @@ -- PostgreSQL, which behaves like Haskell's 'Prelude.quot' rather than -- 'Prelude.div'. quot :: Sql DBIntegral a => Expr a -> Expr a -> Expr a-quot = function "div"+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 = function "mod"+rem n d = function "mod" (n, d)   -- | Simultaneous 'quot' and 'rem'.

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 #-}@@ -26,6 +27,7 @@ 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 )@@ -37,18 +39,19 @@  -- | 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   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.

+ 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,16 +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 )-import Rel8.Expr.Text ( quoteIdent )---- 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" . quoteIdent . litExpr . pack+nextval :: QualifiedName -> Expr Int64+nextval name =+  fromPrimExpr $+    Opaleye.FunExpr "nextval"+      [ Opaleye.ConstExpr (Opaleye.StringLit (showQualifiedName name))+      ]

src/Rel8/Expr/Serialize.hs view

@@ -23,6 +23,7 @@ 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.Information ( TypeInformation(..) )  @@ -44,6 +45,6 @@   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/Text.hs view

@@ -1,4 +1,5 @@ {-# language DataKinds #-}+{-# language OverloadedStrings #-}  module Rel8.Expr.Text   (@@ -32,9 +33,13 @@ -- 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)@@ -120,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  @@ -131,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.@@ -161,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.@@ -171,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  @@ -193,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.@@ -214,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.@@ -242,40 +247,40 @@  -- | 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@.@@ -284,7 +289,7 @@ -- you can write expressions like -- @filter (like "Rel%" . packageName) =<< each haskellPackages@ like :: Expr Text -> Expr Text -> Expr Bool-like = flip (binaryOperator "LIKE")+like = flip (zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpLike))   -- | @ilike x y@ corresponds to the expression @y ILIKE x@.@@ -293,4 +298,4 @@ -- you can write expressions like -- @filter (ilike "Rel%" . packageName) =<< each haskellPackages@ ilike :: Expr Text -> Expr Text -> Expr Bool-ilike = flip (binaryOperator "ILIKE")+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

@@ -6,11 +6,11 @@   , percentRank   , cumeDist   , ntile-  , lag-  , lead-  , firstValue-  , lastValue-  , nthValue+  , lagExpr, lagExprOn+  , leadExpr, leadExprOn+  , firstValueExpr, firstValueExprOn+  , lastValueExpr, lastValueExprOn+  , nthValueExpr, nthValueExprOn   ) where @@ -25,97 +25,125 @@ import qualified Opaleye.Window as Opaleye  -- profunctors-import Data.Profunctor (dimap)+import Data.Profunctor (dimap, lmap)  -- rel8-import Rel8.Aggregate ( Aggregate( Aggregate ) )+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 :: (a -> Aggregate b) -> Window a (Expr b)+-- | '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 a (Expr Int64)+rowNumber :: Window i (Expr Int64) rowNumber = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.rowNumber   -- | [@rank()@](https://www.postgresql.org/docs/current/functions-window.html)-rank :: Window a (Expr Int64)+rank :: Window i (Expr Int64) rank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.rank   -- | [@dense_rank()@](https://www.postgresql.org/docs/current/functions-window.html)-denseRank :: Window a (Expr Int64)+denseRank :: Window i (Expr Int64) denseRank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.denseRank   -- | [@percent_rank()@](https://www.postgresql.org/docs/current/functions-window.html)-percentRank :: Window a (Expr Double)+percentRank :: Window i (Expr Double) percentRank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.percentRank   -- | [@cume_dist()@](https://www.postgresql.org/docs/current/functions-window.html)-cumeDist :: Window a (Expr Double)+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 a (Expr Int32)+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)-lag :: Expr Int32 -> Expr a -> Window (Expr a) (Expr a)-lag offset def =+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)-lead :: Expr Int32 -> Expr a -> Window (Expr a) (Expr a)-lead offset def =+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)-firstValue :: Window (Expr a) (Expr a)-firstValue =+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)-lastValue :: Window (Expr a) (Expr a)-lastValue =+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)-nthValue :: Expr Int32 -> Window (Expr a) (Expr (Nullify a))-nthValue n =+nthValueExpr :: Expr Int32 -> Window (Expr a) (Expr (Nullify a))+nthValueExpr n =   fromWindowFunction $     dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $       Opaleye.nthValue (toColumn (toPrimExpr n))  -fromAggregate :: (a -> Aggregate b) -> Opaleye.Aggregator a (Expr b)-fromAggregate f = Opaleye.Aggregator $ Opaleye.PackMap $ \w a -> case f a of-  Aggregate (Opaleye.Aggregator (Opaleye.PackMap x)) -> x w ()+-- | [@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)  -fromWindowFunction :: Opaleye.WindowFunction a b -> Window a b+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/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(..) )@@ -170,30 +169,26 @@   type GFromExprs t = t Result    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    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

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/Query/Aggregate.hs view

@@ -1,56 +1,59 @@ {-# language FlexibleContexts #-} {-# language MonoLocalBinds #-} {-# language ScopedTypeVariables #-}-{-# language TypeApplications #-}  module Rel8.Query.Aggregate   ( aggregate+  , aggregate1+  , aggregateU   , countRows-  , mode   ) where  -- base-import Data.Functor.Contravariant ( (>$<) )+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.Order ( desc )+import Rel8.Expr.Bool (true) import Rel8.Query ( Query )-import Rel8.Query.Limit ( limit ) import Rel8.Query.Maybe ( optional ) import Rel8.Query.Opaleye ( mapOpaleye )-import Rel8.Query.Order ( orderBy )-import Rel8.Table ( toColumns )-import Rel8.Table.Aggregate ( hgroupBy )-import Rel8.Table.Cols ( Cols( Cols ), fromCols )-import Rel8.Table.Eq ( EqTable, eqTable )-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)----- | Return the most common row in a query.-mode :: forall a. EqTable a => Query a -> Query a-mode rows = limit 1 $ fmap (fromCols . snd) $ orderBy (fst >$< desc) $ do-  aggregate $ do-    row <- toColumns <$> rows-    pure (countStar, Cols $ hgroupBy (eqTable @a) row)+countRows = aggregate countStar . (true <$)

src/Rel8/Query/Distinct.hs view

@@ -17,13 +17,13 @@ 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

+ 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/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,42 @@+{-# 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.Query.Rebind ( rebind )+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, Table Expr b)+  => Query a -> (Query a -> Query b) -> Query b+materialize query f =+  (>>= rebind "with") . 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/Rebind.hs view

@@ -2,6 +2,7 @@  module Rel8.Query.Rebind   ( rebind+  , hrebind   ) where @@ -15,7 +16,10 @@ -- rel8 import Rel8.Expr ( Expr ) 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) @@ -24,4 +28,9 @@ -- 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 = fromOpaleye (Opaleye.rebindExplicitPrefix prefix unpackspec <<< pure a)+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/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,15 +15,17 @@  module Rel8.Schema.HTable   ( HTable (HField, HConstrainTable)-  , hfield, htabulate, htraverse, hdicts, hspecs-  , hfoldMap, hmap, htabulateA, htraverseP, htraversePWithField+  , hfield, htabulate, hdicts, hspecs+  , hfoldMap, hmap, htabulateA, htabulateP+  , htraverse, htraverse_, htraverseP, htraversePWithField   ) where  -- base+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.Functor.Compose ( Compose( Compose ), getCompose ) import Data.Proxy ( Proxy ) import GHC.Generics   ( (:*:)( (:*:) )@@ -46,7 +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@@ -130,27 +132,53 @@ 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 = unApplyP $ htabulateA $ \field -> ApplyP $-  lmap (flip hfield field) (f field)+htraversePWithField f =+  htabulateP $ \field -> lmap (flip hfield field) (f field)+  type GHField :: K.HTable -> Type -> Type newtype GHField t a = GHField (HField (GHColumns (Rep (t Proxy))) a)

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 ( 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,20 @@   , 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)@@ -104,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@@ -139,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/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,54 @@+{-# language DerivingStrategies #-}+{-# language DuplicateRecordFields #-}+{-# language RecordWildCards #-}+{-# language StandaloneKindSignatures #-}+{-# language StrictData #-}++module Rel8.Schema.QualifiedName+  ( QualifiedName (..)+  , ppQualifiedName+  , showQualifiedName+  )+where++-- base+import Data.Kind (Type)+import Data.String (IsString, fromString)+import Prelude++-- pretty+import Text.PrettyPrint (Doc, 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

src/Rel8/Schema/Table.hs view

@@ -1,8 +1,9 @@ {-# language DeriveFunctor #-} {-# language DerivingStrategies #-}-{-# language DisambiguateRecordFields #-}+{-# language DuplicateRecordFields #-} {-# language NamedFieldPuns #-} {-# language StandaloneKindSignatures #-}+{-# language StrictData #-}  module Rel8.Schema.Table   ( TableSchema(..)@@ -14,14 +15,13 @@ 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.@@ -30,20 +30,14 @@ -- @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/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,84 @@+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_ :: 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 :: 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=> 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=> 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+  => 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+  => Statement (Query exprs) -> Hasql.Statement () (Vector a)+runVector = makeRun Vector

src/Rel8/Statement/SQL.hs view

@@ -2,28 +2,43 @@   ( showDelete   , showInsert   , showUpdate+  , showStatement   ) where  -- base import Prelude +-- opaleye+import qualified Opaleye.Internal.Tag as Opaleye+ -- rel8+import Rel8.Statement (Statement, ppDecodeStatement) import Rel8.Statement.Delete ( Delete, ppDelete ) import Rel8.Statement.Insert ( Insert, ppInsert )+import Rel8.Statement.Rows (Rows (Void))+import Rel8.Statement.Select (ppSelect) import Rel8.Statement.Update ( Update, ppUpdate ) +-- 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

src/Rel8/Statement/Select.hs view

@@ -1,3 +1,4 @@+{-# language DataKinds #-} {-# language DeriveTraversable #-} {-# language DerivingStrategies #-} {-# language FlexibleContexts #-}@@ -9,7 +10,6 @@ module Rel8.Statement.Select   ( select   , ppSelect-   , Optimized(..)   , ppPrimSelect   , ppRows@@ -22,11 +22,6 @@ 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@@ -48,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.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) ()@@ -110,11 +96,10 @@       = 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

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

@@ -15,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 )@@ -22,14 +28,14 @@ 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  @@ -72,7 +78,7 @@   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,37 +1,57 @@+{-# 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, filterWhereOptional+  , orderAggregateBy+  , optionalAggregate   ) 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+  , toAggregator+  )+import Rel8.Aggregate.Fold (Fallback (Fallback)) import Rel8.Expr ( Expr ) import Rel8.Expr.Aggregate-  ( groupByExpr+  ( filterWhereExplicit+  , groupByExprOn   , slistAggExpr+  , slistCatExpr   , snonEmptyAggExpr+  , snonEmptyCatExpr   )+import Rel8.Expr.Opaleye (toColumn, toPrimExpr)+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.Maybe (MaybeTable, makeMaybeTable, justTable, nothingTable) import Rel8.Table.NonEmpty ( NonEmptyTable )+import Rel8.Table.Opaleye (ifPP) import Rel8.Type.Eq ( DBEq )  @@ -43,24 +63,50 @@ -- -- @ -- itemsByOrder :: Query (OrderId Expr, ListTable Expr (Item Expr))--- itemsByOrder = aggregate $ do---   item <- each itemSchema---   let orderId = groupBy (itemOrderId item)---   let orderItems = listAgg item---   pure (orderId, orderItems)+-- itemsByOrder =+--   aggregate+--     do+--       orderId <- groupByOn (.orderId)+--       items <- listAgg+--       pure (orderId, items)+--     do+--       each itemSchema -- @-groupBy :: forall exprs aggregates. (EqTable exprs, Aggregates aggregates exprs)-  => exprs -> aggregates-groupBy = fromColumns . hgroupBy (eqTable @exprs) . toColumns+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 'filterWhereOptional'.+filterWhere :: Table Expr a+  => (i -> Expr Bool) -> Aggregator i a -> Aggregator' fold i a+filterWhere = filterWhereExplicit ifPP+++-- | 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++ -- | 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@@ -74,19 +120,75 @@ -- 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+++-- | '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

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

@@ -10,6 +10,7 @@ {-# language StandaloneKindSignatures #-} {-# language TypeApplications #-} {-# language TypeFamilies #-}+{-# language TypeOperators #-} {-# language UndecidableInstances #-}  {-# options_ghc -fno-warn-orphans #-}@@ -32,10 +33,13 @@ -- comonad import Control.Comonad ( extract ) +-- profunctors+import Data.Profunctor (lmap)+ -- rel8-import Rel8.Aggregate ( Aggregate )+import Rel8.Aggregate (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 )@@ -214,18 +218,17 @@ 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 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))))@@ -204,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,6 +9,7 @@ {-# language StandaloneKindSignatures #-} {-# language TypeApplications #-} {-# language TypeFamilies #-}+{-# language TypeOperators #-} {-# language UndecidableInstances #-}  module Rel8.Table.Maybe@@ -19,6 +20,7 @@   , ($?)   , aggregateMaybeTable   , nameMaybeTable+  , makeMaybeTable   ) where @@ -32,12 +34,20 @@ -- comonad import Control.Comonad ( extract ) +-- opaleye+import qualified Opaleye.Field as Opaleye+import qualified Opaleye.SqlTypes as Opaleye++-- profunctors+import Data.Profunctor (lmap)+ -- rel8-import Rel8.Aggregate ( Aggregate )+import Rel8.Aggregate (Aggregator', Aggregator1, toAggregator1) import Rel8.Expr ( Expr )-import Rel8.Expr.Aggregate ( groupByExpr )+import Rel8.Expr.Aggregate (groupByExprOn) 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@@ -223,14 +233,15 @@ infixl 4 $?  --- | Lift an aggregating function to operate on a 'MaybeTable'.--- @nothingTable@s and @justTable@s are grouped separately.+-- | Lift an aggregator 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)+  => Aggregator' fold i a+  -> Aggregator1 (MaybeTable Expr i) (MaybeTable Expr a)+aggregateMaybeTable aggregator =+  MaybeTable+    <$> groupByExprOn tag+    <*> lmap just (toAggregator1 (aggregateNullify aggregator))   -- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you@@ -244,3 +255,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

@@ -6,6 +6,7 @@ {-# language StandaloneKindSignatures #-} {-# language TypeApplications #-} {-# language TypeFamilies #-}+{-# language TypeOperators #-} {-# language UndecidableInstances #-}  module Rel8.Table.Null

src/Rel8/Table/Nullify.hs view

@@ -8,6 +8,7 @@ {-# language StandaloneKindSignatures #-} {-# language TypeApplications #-} {-# language TypeFamilies #-}+{-# language TypeOperators #-} {-# language UndecidableInstances #-}  module Rel8.Table.Nullify@@ -28,14 +29,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@@ -174,12 +178,14 @@   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 = \case+      Table _ a -> a+      Fields notNullifiable _ -> absurd NExpr notNullifiable+    to = Table NExpr   guard :: (Reifiable context, HTable t)

src/Rel8/Table/Opaleye.hs view

@@ -10,22 +10,25 @@ {-# 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@@ -33,8 +36,11 @@ -- opaleye import qualified Opaleye.Adaptors as Opaleye import qualified Opaleye.Field as Opaleye ( Field_ )-import qualified Opaleye.Internal.Aggregate as Opaleye 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.Table as Opaleye @@ -42,31 +48,28 @@ import Data.Profunctor ( dimap, lmap )  -- rel8-import Rel8.Aggregate ( Aggregate( Aggregate ), Aggregates ) import Rel8.Expr ( Expr ) import Rel8.Expr.Opaleye   ( fromPrimExpr, toPrimExpr   , scastExpr, traverseFieldP   )-import Rel8.Schema.HTable ( htabulateA, hfield, hspecs, htabulate,-                            htraverseP, htraversePWithField )+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.Type.Information ( typeName )+import Rel8.Type.Name (showTypeName)  -- semigroupoids import Data.Functor.Apply ( WrappedApplicative(..) ) import Data.Profunctor.Product ( ProductProfunctor )  -aggregator :: Aggregates aggregates exprs => Opaleye.Aggregator aggregates exprs-aggregator = dimap toColumns fromColumns $-             htraverseP $-             lmap (\(Aggregate a) -> (a, ())) Opaleye.aggregatorApply-- attributes :: Selects names exprs => TableSchema names -> exprs attributes schema@TableSchema {columns} = fromColumns $ htabulate $ \field ->   case hfield (toColumns columns) field of@@ -103,8 +106,16 @@     (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)@@ -131,7 +142,8 @@ valuesspec :: Table Expr a => Opaleye.Valuesspec a a valuesspec = dimap toColumns fromColumns $   htraversePWithField (traverseFieldP . Opaleye.valuesspecFieldType . typeName)-  where typeName = Rel8.Type.Information.typeName . info . hfield hspecs+  where+    typeName = showTypeName . Rel8.Type.Information.typeName . info . hfield hspecs   view :: Selects names exprs => names -> exprs@@ -148,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/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 #-}@@ -32,8 +33,11 @@ import Data.Maybe ( isJust ) import Prelude hiding ( null, undefined ) +-- profunctors+import Data.Profunctor (lmap)+ -- rel8-import Rel8.Aggregate ( Aggregate )+import Rel8.Aggregate (Aggregator', Aggregator1) import Rel8.Expr ( Expr ) import Rel8.Expr.Bool ( (&&.), (||.), boolExpr, not_ ) import Rel8.Expr.Null ( null, isNonNull )@@ -324,17 +328,16 @@     there  --- | Lift a pair of aggregating functions to operate on an 'TheseTable'.--- @thisTable@s, @thatTable@s and @thoseTable@s are grouped separately.+-- | 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/Window.hs view

@@ -1,43 +1,120 @@+{-# language ApplicativeDo #-}+{-# language FlexibleContexts #-} {-# language MonoLocalBinds #-}+{-# language NamedFieldPuns #-}  module Rel8.Table.Window-  ( cumulative-  , cumulative_-  , currentRow+  ( currentRow+  , lag, lagOn+  , lead, leadOn+  , firstValue, firstValueOn+  , lastValue, lastValueOn+  , nthValue, nthValueOn   ) where  -- base-import Prelude+import Data.Int (Int32)+import Prelude hiding (null)  -- opaleye import qualified Opaleye.Window as Opaleye +-- profunctor+import Data.Profunctor (dimap, lmap)+ -- rel8-import Rel8.Aggregate ( Aggregates )-import qualified Rel8.Expr.Window as Expr-import Rel8.Schema.HTable ( hfield, htabulateA )-import Rel8.Table ( fromColumns, toColumns )-import Rel8.Window ( Window( Window ) )+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))  --- | '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 :: Aggregates aggregates exprs => (a -> aggregates) -> Window a exprs-cumulative f =-  fmap fromColumns $-    htabulateA $ \field ->-      Expr.cumulative ((`hfield` field) . toColumns . f)+-- | Return every column of the current row of a window query.+currentRow :: Window a a+currentRow = Window $ Opaleye.over (Opaleye.noWindowFunction id) mempty mempty  --- | A version of 'cumulative' for use with nullary aggregators like--- 'Rel8.Expr.Aggregate.countStar'.-cumulative_ :: Aggregates aggregates exprs => aggregates -> Window a exprs-cumulative_ = cumulative . const+-- | @'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)  --- | Return every column of the current row of a window query.-currentRow :: Window a a-currentRow = Window $ Opaleye.over (Opaleye.noWindowFunction id) mempty mempty+-- | 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@@ -68,7 +71,6 @@ import Control.Comonad ( extract )  -- opaleye-import qualified Opaleye.Aggregate as Opaleye import qualified Opaleye.Order as Opaleye ( orderBy, distinctOnExplicit )  -- profunctors@@ -82,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.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@@ -329,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@@ -408,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@@ -439,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@@ -452,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@@ -628,6 +625,17 @@ -- @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, Table Expr b)+  => 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

src/Rel8/Type.hs view

@@ -1,8 +1,12 @@+{-# language LambdaCase #-} {-# language FlexibleContexts #-} {-# language FlexibleInstances #-} {-# language MonoLocalBinds #-} {-# language MultiWayIf #-}+{-# language OverloadedStrings #-}+{-# language ScopedTypeVariables #-} {-# language StandaloneKindSignatures #-}+{-# language TypeApplications #-} {-# language UndecidableInstances #-}  module Rel8.Type@@ -14,14 +18,23 @@ import Data.Aeson ( Value ) import qualified Data.Aeson as Aeson +-- attoparsec+import qualified Data.Attoparsec.ByteString.Char8 as A++-- attoparsec-aeson+import qualified Data.Aeson.Parser as Aeson+ -- base+import Control.Applicative ((<|>))+import Data.Fixed (Fixed) import Data.Int ( Int16, Int32, Int64 ) import Data.List.NonEmpty ( NonEmpty ) import Data.Kind ( Constraint, Type ) import Prelude  -- bytestring-import Data.ByteString ( ByteString )+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as Lazy ( ByteString ) import qualified Data.ByteString.Lazy as ByteString ( fromStrict, toStrict ) @@ -29,9 +42,15 @@ import Data.CaseInsensitive ( CI ) import qualified Data.CaseInsensitive as CI +-- data-textual+import Data.Textual (textual)+ -- hasql import qualified Hasql.Decoders as Hasql +-- network-ip+import qualified Network.IP.Addr as IP+ -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye import qualified Opaleye.Internal.HaskellDB.Sql.Default as Opaleye ( quote )@@ -39,7 +58,13 @@ -- 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.Information ( TypeInformation(..), mapTypeInformation )+import Rel8.Type.Name (TypeName (..))+import Rel8.Type.Parser (parse)+import Rel8.Type.Parser.ByteString (bytestring)+import qualified Rel8.Type.Parser.Time as Time  -- scientific import Data.Scientific ( Scientific )@@ -47,20 +72,24 @@ -- text import Data.Text ( Text ) import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text (decodeUtf8) import qualified Data.Text.Lazy as Lazy ( Text, unpack ) import qualified Data.Text.Lazy as Text ( fromStrict, toStrict ) import qualified Data.Text.Lazy.Encoding as Lazy ( decodeUtf8 )  -- time-import Data.Time.Calendar ( Day )-import Data.Time.Clock ( UTCTime )+import Data.Time.Calendar (Day)+import Data.Time.Clock (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@@ -83,7 +112,15 @@ instance DBType Bool where   typeInformation = TypeInformation     { encode = Opaleye.ConstExpr . Opaleye.BoolLit-    , decode = Hasql.bool+    , decode =+        Decoder+          { binary = Hasql.bool+          , parser = \case+              "t" -> pure True+              "f" -> pure False+              input -> Left $ "bool: bad bool " <> show input+          , delimiter = ','+          }     , typeName = "bool"     } @@ -92,8 +129,20 @@ instance DBType Char where   typeInformation = TypeInformation     { encode = Opaleye.ConstExpr . Opaleye.StringLit . pure-    , decode = Hasql.char-    , typeName = "char"+    , typeName =+        TypeName+          { name = "bpchar"+          , modifiers = ["1"]+          , arrayDepth = 0+          }+    , decode = +        Decoder+          { binary = Hasql.char+          , parser = \input -> case UTF8.uncons input of+              Just (char, rest) | BS.null rest -> pure char+              _ -> Left $ "char: bad char " <> show input+          , delimiter = ','+          }     }  @@ -101,7 +150,12 @@ instance DBType Int16 where   typeInformation = TypeInformation     { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger-    , decode = Hasql.int2+    , decode =+        Decoder+          { binary = Hasql.int2+          , parser = parse (A.signed A.decimal)+          , delimiter = ','+          }     , typeName = "int2"     } @@ -110,7 +164,12 @@ instance DBType Int32 where   typeInformation = TypeInformation     { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger-    , decode = Hasql.int4+    , decode =+        Decoder+          { binary = Hasql.int4+          , parser = parse (A.signed A.decimal)+          , delimiter = ','+          }     , typeName = "int4"     } @@ -119,7 +178,12 @@ instance DBType Int64 where   typeInformation = TypeInformation     { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger-    , decode = Hasql.int8+    , decode =+        Decoder+          { binary = Hasql.int8+          , parser = parse (A.signed A.decimal)+          , delimiter = ','+          }     , typeName = "int8"     } @@ -131,8 +195,13 @@         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+           | otherwise     -> Opaleye.DoubleLit $ realToFrac x+    , decode =+        Decoder+          { binary = Hasql.float4+          , parser = parse (floating (realToFrac <$> A.double))+          , delimiter = ','+          }     , typeName = "float4"     } @@ -144,8 +213,13 @@         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+           | otherwise     -> Opaleye.DoubleLit x+    , decode =+        Decoder+          { binary = Hasql.float8+          , parser = parse (floating A.double)+          , delimiter = ','+          }     , typeName = "float8"     } @@ -154,18 +228,48 @@ instance DBType Scientific where   typeInformation = TypeInformation     { encode = Opaleye.ConstExpr . Opaleye.NumericLit-    , decode = Hasql.numeric+    , decode =+        Decoder+          { binary = Hasql.numeric+          , parser = parse A.scientific+          , delimiter = ','+          }     , typeName = "numeric"     }  +-- | Corresponds to @numeric(1000, log₁₀ n)@+instance PowerOf10 n => DBType (Fixed n) where+  typeInformation = TypeInformation+    { encode = Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac+    , decode =+        realToFrac <$>+        Decoder+          { binary = Hasql.numeric+          , parser = parse A.scientific+          , delimiter = ','+          }+    , 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+    , decode =+        Decoder+          { binary = Hasql.timestamptz+          , parser = parse Time.utcTime+          , delimiter = ','+          }     , typeName = "timestamptz"     } @@ -176,7 +280,12 @@     { encode =         Opaleye.ConstExpr . Opaleye.OtherLit .         formatTime defaultTimeLocale "'%F'"-    , decode = Hasql.date+    , decode =+        Decoder+          { binary = Hasql.date+          , parser = parse Time.day+          , delimiter = ','+          }     , typeName = "date"     } @@ -187,7 +296,12 @@     { encode =         Opaleye.ConstExpr . Opaleye.OtherLit .         formatTime defaultTimeLocale "'%FT%T%Q'"-    , decode = Hasql.timestamp+    , decode =+        Decoder+          { binary = Hasql.timestamp+          , parser = parse Time.localTime+          , delimiter = ','+          }     , typeName = "timestamp"     } @@ -198,7 +312,12 @@     { encode =         Opaleye.ConstExpr . Opaleye.OtherLit .         formatTime defaultTimeLocale "'%T%Q'"-    , decode = Hasql.time+    , decode =+        Decoder+          { binary = Hasql.time+          , parser = parse Time.timeOfDay+          , delimiter = ','+          }     , typeName = "time"     } @@ -209,7 +328,12 @@     { encode =         Opaleye.ConstExpr . Opaleye.OtherLit .         formatTime defaultTimeLocale "'%bmon %0Es'"-    , decode = CalendarDiffTime 0 . realToFrac <$> Hasql.interval+    , decode =+        Decoder+          { binary = CalendarDiffTime 0 . realToFrac <$> Hasql.interval+          , parser = parse Time.calendarDiffTime+          , delimiter = ','+          }     , typeName = "interval"     } @@ -218,7 +342,12 @@ instance DBType Text where   typeInformation = TypeInformation     { encode = Opaleye.ConstExpr . Opaleye.StringLit . Text.unpack-    , decode = Hasql.text+    , decode =+        Decoder+          { binary = Hasql.text+          , parser = pure . Text.decodeUtf8+          , delimiter = ','+          }     , typeName = "text"     } @@ -247,7 +376,12 @@ instance DBType ByteString where   typeInformation = TypeInformation     { encode = Opaleye.ConstExpr . Opaleye.ByteStringLit-    , decode = Hasql.bytea+    , decode =+        Decoder+          { binary = Hasql.bytea+          , parser = parse bytestring+          , delimiter = ','+          }     , typeName = "bytea"     } @@ -263,7 +397,14 @@ instance DBType UUID where   typeInformation = TypeInformation     { encode = Opaleye.ConstExpr . Opaleye.StringLit . UUID.toString-    , decode = Hasql.uuid+    , decode =+        Decoder+          { binary = Hasql.uuid+          , parser = \input -> case UUID.fromASCIIBytes input of+              Just a -> pure a+              Nothing -> Left $ "uuid: bad UUID " <> show input+          , delimiter = ','+          }     , typeName = "uuid"     } @@ -275,14 +416,41 @@         Opaleye.ConstExpr . Opaleye.OtherLit .         Opaleye.quote .         Lazy.unpack . Lazy.decodeUtf8 . Aeson.encode-    , decode = Hasql.jsonb+    , decode =+        Decoder+          { binary = Hasql.jsonb+          , parser = parse Aeson.value+          , delimiter = ','+          }     , typeName = "jsonb"     }  +-- | Corresponds to @inet@+instance DBType (IP.NetAddr IP.IP) where+  typeInformation = TypeInformation+    { encode =+        Opaleye.ConstExpr . Opaleye.StringLit . IP.printNetAddr+    , decode =+        Decoder+          { binary = Hasql.inet+          , parser = parse $+              textual+                <|> (`IP.netAddr` 32) . IP.IPv4 <$> textual+                <|> (`IP.netAddr` 128) . IP.IPv6 <$> textual+          , 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"

src/Rel8/Type/Array.hs view

@@ -2,20 +2,32 @@ {-# language LambdaCase #-} {-# language NamedFieldPuns #-} {-# language OverloadedStrings #-}+{-# language TypeApplications #-} {-# language ViewPatterns #-}  module Rel8.Type.Array   ( array, encodeArrayElement, extractArrayElement+  , arrayTypeName   , listTypeInformation   , nonEmptyTypeInformation+  , head, index, last, length   ) where +-- attoparsec+import qualified Data.Attoparsec.ByteString.Char8 as A+ -- base-import Data.Foldable ( toList )+import Control.Applicative ((<|>), many)+import Data.Bifunctor (first)+import Data.Foldable (fold, toList) import Data.List.NonEmpty ( NonEmpty, nonEmpty )-import Prelude hiding ( null, repeat, zipWith )+import Prelude hiding ( head, last, length, null, repeat, zipWith ) +-- bytestring+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS+ -- hasql import qualified Hasql.Decoders as Hasql @@ -24,13 +36,19 @@  -- rel8 import Rel8.Schema.Null ( Unnullify, Nullity( Null, NotNull ) )+import Rel8.Type.Decoder (Decoder (..), NullableOrNot (..), Parser) import Rel8.Type.Information ( TypeInformation(..), parseTypeInformation )+import Rel8.Type.Name (TypeName (..), showTypeName)+import Rel8.Type.Parser (parse) +-- text+import qualified Data.Text as Text + array :: Foldable f   => TypeInformation a -> f Opaleye.PrimExpr -> Opaleye.PrimExpr array info =-  Opaleye.CastExpr (arrayType info <> "[]") .+  Opaleye.CastExpr (showTypeName (arrayType info) <> "[]") .   Opaleye.ArrayExpr . map (encodeArrayElement info) . toList {-# INLINABLE array #-} @@ -41,11 +59,16 @@   -> TypeInformation [a] listTypeInformation nullity info@TypeInformation {encode, decode} =   TypeInformation-    { decode = case nullity of-        Null ->-          Hasql.listArray (decodeArrayElement info (Hasql.nullable decode))-        NotNull ->-          Hasql.listArray (decodeArrayElement info (Hasql.nonNullable decode))+    { decode =+        Decoder+          { binary = Hasql.listArray $ case nullity of+              Null -> Hasql.nullable (decodeArrayElement info decode)+              NotNull -> Hasql.nonNullable (decodeArrayElement info decode)+          , parser = case nullity of+              Null -> arrayParser (Nullable decode)+              NotNull -> arrayParser (NonNullable decode)+          , delimiter = ','+          }     , encode = case nullity of         Null ->           Opaleye.ArrayExpr .@@ -53,7 +76,7 @@         NotNull ->           Opaleye.ArrayExpr .           fmap (encodeArrayElement info . encode)-    , typeName = arrayType info <> "[]"+    , typeName = arrayTypeName info     }   where     null = Opaleye.ConstExpr Opaleye.NullLit@@ -64,37 +87,110 @@   -> 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 :: TypeInformation a -> Decoder x -> Hasql.Value x decodeArrayElement info-  | isArray info = Hasql.nonNullable . Hasql.composite . Hasql.field-  | otherwise = id+  | isArray info = \decoder ->+      Hasql.refine (first Text.pack . parser decoder) Hasql.bytea+  | otherwise = binary   encodeArrayElement :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr encodeArrayElement info-  | isArray info = Opaleye.UnExpr (Opaleye.UnOpOther "ROW")+  | 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 :: NullableOrNot Decoder a -> Parser [a]+arrayParser = \case+  Nullable Decoder {parser, delimiter} -> \input -> do+    elements <- parseArray delimiter input+    traverse (traverse parser) elements+  NonNullable Decoder {parser, delimiter} -> \input -> do+    elements <- parseArray delimiter input+    traverse (maybe (Left "array: unexpected null") parser) elements+++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/Composite.hs view

@@ -1,9 +1,11 @@ {-# language AllowAmbiguousTypes #-} {-# language BlockArguments #-} {-# language DataKinds #-}+{-# language DisambiguateRecordFields #-} {-# language FlexibleContexts #-} {-# language GADTs #-} {-# language NamedFieldPuns #-}+{-# language OverloadedStrings #-} {-# language ScopedTypeVariables #-} {-# language StandaloneKindSignatures #-} {-# language TypeApplications #-}@@ -18,12 +20,22 @@   ) 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.Identity (Identity (Identity)) import Data.Kind ( Constraint, Type )+import Data.List (uncons) import Prelude +-- bytestring+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS+ -- hasql import qualified Hasql.Decoders as Hasql @@ -36,6 +48,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 +58,22 @@ import Rel8.Table.Rel8able () import Rel8.Table.Serialize ( litHTable ) import Rel8.Type ( DBType, typeInformation )+import Rel8.Type.Decoder (Decoder (Decoder), Parser)+import qualified Rel8.Type.Decoder as Decoder 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 +89,19 @@  instance DBComposite a => DBType (Composite a) where   typeInformation = TypeInformation-    { decode = Hasql.composite (Composite . fromResult @_ @(HKD a Expr) <$> decoder)+    { decode =+        Decoder+          { binary = Hasql.composite (Composite . fromResult @_ @(HKD a Expr) <$> decoder)+          , parser = fmap (Composite . fromResult @_ @(HKD a Expr)) . parser+          , delimiter = ','+          }     , encode = encoder . litHTable . toResult @_ @(HKD a Expr) . unComposite-    , typeName = compositeTypeName @a+    , typeName =+        TypeName+          { name = compositeTypeName @a+          , modifiers = []+          , arrayDepth = 0+          }     }  @@ -94,7 +125,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.@@ -124,8 +155,8 @@   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 -> Hasql.field $ Hasql.nullable $ Decoder.binary $ decode info+        NotNull -> Hasql.field $ Hasql.nonNullable $ Decoder.binary $ decode info   encoder :: HTable t => t Expr -> Opaleye.PrimExpr@@ -133,3 +164,40 @@   where     exprs = getConst $ htabulateA \field -> case hfield a field of       expr -> Const [toPrimExpr expr]+++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.parser (decode info)) mbytes+          NotNull -> case mbytes of+            Nothing -> Left "composite: unexpected null"+            Just bytes -> Decoder.parser (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 "\"\""

+ 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,64 @@+{-# language DerivingStrategies #-}+{-# language DeriveFunctor #-}+{-# language GADTs #-}+{-# language NamedFieldPuns #-}+{-# language StandaloneKindSignatures #-}++module Rel8.Type.Decoder (+  Decoder (..),+  NullableOrNot (..),+  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.+  , parser :: Parser a+    -- ^ How to deserialize from PostgreSQL's text format.+  , delimiter :: Char+    -- ^ The delimiter that is used in PostgreSQL's text format in arrays of+    -- this type (this is almost always ',').+  }+  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, parser, delimiter} =+  Decoder+    { binary = Hasql.refine (first Text.pack . f) binary+    , parser = parser >=> f+    , delimiter+    }+++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/Enum.hs view

@@ -38,13 +38,17 @@ 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.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)   -- | A deriving-via helper type for column types that store an \"enum\" type@@ -66,16 +70,26 @@ instance DBEnum a => DBType (Enum a) where   typeInformation = TypeInformation     { decode =-        Hasql.enum $-        flip lookup $-        map ((pack . enumValue &&& Enum) . to) $-        genumerate @(Rep a)+        let+          mapping = (pack . enumValue &&& Enum) . to <$> genumerate @(Rep a)+          unrecognised = Left "enum: unrecognised value"+        in+          Decoder+            { binary = Hasql.enum (`lookup` mapping)+            , parser = maybe unrecognised pure . (`lookup` mapping) . decodeUtf8+            , delimiter = ','+            }     , encode =         Opaleye.ConstExpr .         Opaleye.StringLit .         enumValue @a .         unEnum-    , typeName = enumTypeName @a+    , typeName =+        TypeName+          { name = enumTypeName @a+          , modifiers = []+          , arrayDepth = 0+          }     }  @@ -101,7 +115,7 @@   enumValue = gshow @(Rep a) . from    -- | The name of the PostgreSQL @enum@ type that @a@ maps to.-  enumTypeName :: String+  enumTypeName :: QualifiedName   -- | Types that are sum types, where each constructor is unary (that is, has no

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,6 +1,7 @@ {-# language GADTs #-} {-# language NamedFieldPuns #-} {-# language StandaloneKindSignatures #-}+{-# language StrictData #-}  module Rel8.Type.Information   ( TypeInformation(..)@@ -10,18 +11,17 @@ where  -- base-import Data.Bifunctor ( first ) import Data.Kind ( Type ) import Prelude --- hasql-import qualified Hasql.Decoders as Hasql- -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye +-- rel8+import Rel8.Type.Name (TypeName)+ -- text-import qualified Data.Text as Text+import Rel8.Type.Decoder (Decoder, parseDecoder)   -- | @TypeInformation@ describes how to encode and decode a Haskell type to and@@ -31,9 +31,9 @@ data TypeInformation a = TypeInformation   { encode :: a -> Opaleye.PrimExpr     -- ^ How to encode a single Haskell value as a SQL expression.-  , decode :: Hasql.Value a+  , decode :: Decoder a     -- ^ How to deserialize a single result back to Haskell.-  , typeName :: String+  , typeName :: TypeName     -- ^ The name of the SQL type.   } @@ -62,6 +62,6 @@ parseTypeInformation to from TypeInformation {encode, decode, typeName} =   TypeInformation     { encode = encode . from-    , decode = Hasql.refine (first Text.pack . to) decode+    , decode = parseDecoder to decode     , typeName     }

src/Rel8/Type/JSONBEncoded.hs view

@@ -1,10 +1,14 @@+{-# language OverloadedStrings #-} {-# language StandaloneKindSignatures #-} -module Rel8.Type.JSONBEncoded ( JSONBEncoded(..) ) where+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 Data.Aeson.Types (parseEither)  -- base import Data.Bifunctor ( first )@@ -16,6 +20,7 @@  -- rel8 import Rel8.Type ( DBType(..) )+import Rel8.Type.Decoder (Decoder (..)) import Rel8.Type.Information ( TypeInformation(..) )  -- text@@ -30,6 +35,11 @@ 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+    , decode =+        Decoder+          { binary = Hasql.refine (first pack . fmap JSONBEncoded . parseEither parseJSON) Hasql.jsonb+          , parser = fmap JSONBEncoded . eitherDecodeStrict+          , delimiter = ','+          }     , typeName = "jsonb"     }

+ 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/Num.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) import Rel8.Type.Ord ( DBOrd )  -- scientific@@ -31,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@@ -49,6 +52,7 @@ -- | 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

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

tests/Main.hs view

@@ -2,7 +2,7 @@ {-# language BlockArguments #-} {-# language DeriveAnyClass #-} {-# language DeriveGeneric #-}-{-# language DerivingStrategies #-}+{-# language DerivingVia #-} {-# language FlexibleContexts #-} {-# language FlexibleInstances #-} {-# language MonoLocalBinds #-}@@ -21,15 +21,20 @@ -- 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.Ratio ((%)) import Data.String ( fromString )-import Data.Word (Word32)+import Data.Word (Word32, Word8) import GHC.Generics ( Generic )+import Prelude hiding (truncate)  -- bytestring import qualified Data.ByteString.Lazy@@ -57,6 +62,10 @@ -- mmorph import Control.Monad.Morph ( hoist ) +-- network-ip+import Network.IP.Addr (NetAddr, IP, IP4(..), IP6(..), IP46(..), net4Addr, net6Addr, fromNetAddr46, Net4Addr, Net6Addr)+import Data.DoubleWord (Word128(..))+ -- rel8 import Rel8 ( Result ) import qualified Rel8@@ -97,6 +106,7 @@   withResource startTestDatabase stopTestDatabase \getTestDatabase ->   testGroup "rel8"     [ testSelectTestTable getTestDatabase+    , testWithStatement getTestDatabase     , testWhere_ getTestDatabase     , testFilter getTestDatabase     , testLimit getTestDatabase@@ -112,6 +122,7 @@     , testDBType getTestDatabase     , testDBEq getTestDatabase     , testTableEquality getTestDatabase+    , testFromRational getTestDatabase     , testFromString getTestDatabase     , testCatMaybeTable getTestDatabase     , testCatMaybe getTestDatabase@@ -140,6 +151,7 @@           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\" char, \"array\" int4[])"        return db @@ -180,7 +192,6 @@ testTableSchema =   Rel8.TableSchema     { name = "test_table"-    , schema = Nothing     , columns = TestTable         { testTableColumn1 = "column1"         , testTableColumn2 = "column2"@@ -194,14 +205,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 +232,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 +252,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 +270,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 +291,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 +303,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 +320,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 +334,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 +347,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 +359,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 +371,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 +383,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 +395,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 +411,113 @@    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 :: !Char+  , 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 "CalendarDiffTime" genCalendarDiffTime   , 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 "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 "LocalTime" genLocalTime-  , dbTypeTest "Scientific" $ (/10) . fromIntegral @Int @Scientific <$> Gen.integral (Range.linear (-100) 100)+  , dbTypeTest "Scientific" $ (/ 10) . fromIntegral @Int @Scientific <$> Gen.integral (Range.linear (-100) 100)   , dbTypeTest "Text" $ Gen.text (Range.linear 0 10) Gen.unicode   , dbTypeTest "TimeOfDay" genTimeOfDay   , dbTypeTest "UTCTime" $ UTCTime <$> genDay <*> genDiffTime   , dbTypeTest "UUID" $ Data.UUID.fromWords <$> genWord32 <*> genWord32 <*> genWord32 <*> genWord32+  , dbTypeTest "INet" genNetAddrIP   ]    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 b. (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     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)+       +      ++    genComposite :: Gen Composite+    genComposite = do+      bool <- Gen.bool+      char <- Gen.unicode+      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 +525,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,7 +548,27 @@     genWord32 :: Gen Word32     genWord32 = Gen.integral Range.linearBounded +    genWord128 :: Gen Word128+    genWord128 = Gen.integral Range.linearBounded +    genNetAddrIP  :: Gen (NetAddr IP)+    genNetAddrIP =+      let+        genIP4Mask :: Gen Word8+        genIP4Mask = Gen.integral (Range.linearFrom 0 0 32)++        genIPv4 :: Gen (IP46 Net4Addr Net6Addr)+        genIPv4 = IPv4 <$> (liftA2 net4Addr (IP4 <$> genWord32) genIP4Mask)++        genIP6Mask :: Gen Word8+        genIP6Mask = Gen.integral (Range.linearFrom 0 0 128)++        genIPv6 :: Gen (IP46 Net4Addr Net6Addr)+        genIPv6 = IPv6 <$> (liftA2 net6Addr (IP6 <$> genWord128) genIP6Mask)++       in fromNetAddr46 <$> Gen.choice [ genIPv4, genIPv6 ]++ testDBEq :: IO TmpPostgres.DB -> TestTree testDBEq getTestDatabase = testGroup "DBEq instances"   [ dbEqTest "Bool" Gen.bool@@ -493,8 +592,8 @@       (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) @@ -504,20 +603,39 @@    (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)  +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.run1 $ Rel8.select do+        pure $ fromRational rational+    diff result (~=) double+  where+    a ~= b = abs (a - b) < 1e-15+    infix 4 ~=++ testFromString :: IO TmpPostgres.DB -> TestTree-testFromString = databasePropertyTest "FromString" \transaction -> do+testFromString = databasePropertyTest "fromString" \transaction -> do   str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode    transaction do-    [result] <- lift do-      statement () $ Rel8.select do+    result <- lift do+      statement () $ Rel8.run1 $ Rel8.select do         pure $ fromString str     result === pack str @@ -528,7 +646,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 +659,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 +671,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 +695,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 +723,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 +736,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@@ -647,14 +765,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 +790,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 +809,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 +831,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 +922,6 @@ uniqueTableSchema =   Rel8.TableSchema     { name = "unique_table"-    , schema = Nothing     , columns = UniqueTable         { uniqueTableKey = "key"         , uniqueTableValue = "value"@@ -752,25 +943,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 +986,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 +998,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 +1033,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 +1045,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 +1057,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

@@ -7,6 +7,7 @@ {-# language MultiParamTypeClasses #-} {-# language StandaloneKindSignatures #-} {-# language TypeFamilies #-}+{-# language TypeOperators #-} {-# language UndecidableInstances #-}  {-# options_ghc -O0 #-}