diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,134 @@ + + +# 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 diff --git a/rel8.cabal b/rel8.cabal --- a/rel8.cabal +++ b/rel8.cabal @@ -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 diff --git a/src/Rel8.hs b/src/Rel8.hs --- a/src/Rel8.hs +++ b/src/Rel8.hs @@ -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 diff --git a/src/Rel8/Aggregate.hs b/src/Rel8/Aggregate.hs --- a/src/Rel8/Aggregate.hs +++ b/src/Rel8/Aggregate.hs @@ -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 diff --git a/src/Rel8/Aggregate/Fold.hs b/src/Rel8/Aggregate/Fold.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Aggregate/Fold.hs @@ -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 diff --git a/src/Rel8/Aggregate/Function.hs b/src/Rel8/Aggregate/Function.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Aggregate/Function.hs @@ -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))) diff --git a/src/Rel8/Array.hs b/src/Rel8/Array.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Array.hs @@ -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 diff --git a/src/Rel8/Expr.hs b/src/Rel8/Expr.hs --- a/src/Rel8/Expr.hs +++ b/src/Rel8/Expr.hs @@ -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" diff --git a/src/Rel8/Expr/Aggregate.hs b/src/Rel8/Expr/Aggregate.hs --- a/src/Rel8/Expr/Aggregate.hs +++ b/src/Rel8/Expr/Aggregate.hs @@ -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 diff --git a/src/Rel8/Expr/Array.hs b/src/Rel8/Expr/Array.hs --- a/src/Rel8/Expr/Array.hs +++ b/src/Rel8/Expr/Array.hs @@ -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] diff --git a/src/Rel8/Expr/Default.hs b/src/Rel8/Expr/Default.hs --- a/src/Rel8/Expr/Default.hs +++ b/src/Rel8/Expr/Default.hs @@ -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 diff --git a/src/Rel8/Expr/Eq.hs b/src/Rel8/Expr/Eq.hs --- a/src/Rel8/Expr/Eq.hs +++ b/src/Rel8/Expr/Eq.hs @@ -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 diff --git a/src/Rel8/Expr/Function.hs b/src/Rel8/Expr/Function.hs --- a/src/Rel8/Expr/Function.hs +++ b/src/Rel8/Expr/Function.hs @@ -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) diff --git a/src/Rel8/Expr/List.hs b/src/Rel8/Expr/List.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Expr/List.hs @@ -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) diff --git a/src/Rel8/Expr/NonEmpty.hs b/src/Rel8/Expr/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Expr/NonEmpty.hs @@ -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) diff --git a/src/Rel8/Expr/Num.hs b/src/Rel8/Expr/Num.hs --- a/src/Rel8/Expr/Num.hs +++ b/src/Rel8/Expr/Num.hs @@ -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'. diff --git a/src/Rel8/Expr/Opaleye.hs b/src/Rel8/Expr/Opaleye.hs --- a/src/Rel8/Expr/Opaleye.hs +++ b/src/Rel8/Expr/Opaleye.hs @@ -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. diff --git a/src/Rel8/Expr/Read.hs b/src/Rel8/Expr/Read.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Expr/Read.hs @@ -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 diff --git a/src/Rel8/Expr/Sequence.hs b/src/Rel8/Expr/Sequence.hs --- a/src/Rel8/Expr/Sequence.hs +++ b/src/Rel8/Expr/Sequence.hs @@ -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)) + ] diff --git a/src/Rel8/Expr/Serialize.hs b/src/Rel8/Expr/Serialize.hs --- a/src/Rel8/Expr/Serialize.hs +++ b/src/Rel8/Expr/Serialize.hs @@ -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 diff --git a/src/Rel8/Expr/Show.hs b/src/Rel8/Expr/Show.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Expr/Show.hs @@ -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 diff --git a/src/Rel8/Expr/Text.hs b/src/Rel8/Expr/Text.hs --- a/src/Rel8/Expr/Text.hs +++ b/src/Rel8/Expr/Text.hs @@ -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)) diff --git a/src/Rel8/Expr/Time.hs b/src/Rel8/Expr/Time.hs --- a/src/Rel8/Expr/Time.hs +++ b/src/Rel8/Expr/Time.hs @@ -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. diff --git a/src/Rel8/Expr/Window.hs b/src/Rel8/Expr/Window.hs --- a/src/Rel8/Expr/Window.hs +++ b/src/Rel8/Expr/Window.hs @@ -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) diff --git a/src/Rel8/Generic/Construction.hs b/src/Rel8/Generic/Construction.hs --- a/src/Rel8/Generic/Construction.hs +++ b/src/Rel8/Generic/Construction.hs @@ -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 diff --git a/src/Rel8/Generic/Rel8able.hs b/src/Rel8/Generic/Rel8able.hs --- a/src/Rel8/Generic/Rel8able.hs +++ b/src/Rel8/Generic/Rel8able.hs @@ -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 diff --git a/src/Rel8/Kind/Context.hs b/src/Rel8/Kind/Context.hs --- a/src/Rel8/Kind/Context.hs +++ b/src/Rel8/Kind/Context.hs @@ -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 diff --git a/src/Rel8/Query/Aggregate.hs b/src/Rel8/Query/Aggregate.hs --- a/src/Rel8/Query/Aggregate.hs +++ b/src/Rel8/Query/Aggregate.hs @@ -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 <$) diff --git a/src/Rel8/Query/Distinct.hs b/src/Rel8/Query/Distinct.hs --- a/src/Rel8/Query/Distinct.hs +++ b/src/Rel8/Query/Distinct.hs @@ -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 diff --git a/src/Rel8/Query/Function.hs b/src/Rel8/Query/Function.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Query/Function.hs @@ -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 diff --git a/src/Rel8/Query/List.hs b/src/Rel8/Query/List.hs --- a/src/Rel8/Query/List.hs +++ b/src/Rel8/Query/List.hs @@ -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 diff --git a/src/Rel8/Query/Loop.hs b/src/Rel8/Query/Loop.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Query/Loop.hs @@ -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 diff --git a/src/Rel8/Query/Materialize.hs b/src/Rel8/Query/Materialize.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Query/Materialize.hs @@ -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 diff --git a/src/Rel8/Query/Maybe.hs b/src/Rel8/Query/Maybe.hs --- a/src/Rel8/Query/Maybe.hs +++ b/src/Rel8/Query/Maybe.hs @@ -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. diff --git a/src/Rel8/Query/Rebind.hs b/src/Rel8/Query/Rebind.hs --- a/src/Rel8/Query/Rebind.hs +++ b/src/Rel8/Query/Rebind.hs @@ -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 diff --git a/src/Rel8/Query/SQL.hs b/src/Rel8/Query/SQL.hs --- a/src/Rel8/Query/SQL.hs +++ b/src/Rel8/Query/SQL.hs @@ -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 diff --git a/src/Rel8/Schema/Context/Nullify.hs b/src/Rel8/Schema/Context/Nullify.hs --- a/src/Rel8/Schema/Context/Nullify.hs +++ b/src/Rel8/Schema/Context/Nullify.hs @@ -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 diff --git a/src/Rel8/Schema/Escape.hs b/src/Rel8/Schema/Escape.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Schema/Escape.hs @@ -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] diff --git a/src/Rel8/Schema/HTable.hs b/src/Rel8/Schema/HTable.hs --- a/src/Rel8/Schema/HTable.hs +++ b/src/Rel8/Schema/HTable.hs @@ -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) diff --git a/src/Rel8/Schema/HTable/Nullify.hs b/src/Rel8/Schema/HTable/Nullify.hs --- a/src/Rel8/Schema/HTable/Nullify.hs +++ b/src/Rel8/Schema/HTable/Nullify.hs @@ -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 #-} diff --git a/src/Rel8/Schema/HTable/Vectorize.hs b/src/Rel8/Schema/HTable/Vectorize.hs --- a/src/Rel8/Schema/HTable/Vectorize.hs +++ b/src/Rel8/Schema/HTable/Vectorize.hs @@ -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 diff --git a/src/Rel8/Schema/Null.hs b/src/Rel8/Schema/Null.hs --- a/src/Rel8/Schema/Null.hs +++ b/src/Rel8/Schema/Null.hs @@ -7,6 +7,7 @@ {-# language RankNTypes #-} {-# language StandaloneKindSignatures #-} {-# language TypeFamilies #-} +{-# language TypeOperators #-} {-# language UndecidableInstances #-} {-# language UndecidableSuperClasses #-} diff --git a/src/Rel8/Schema/QualifiedName.hs b/src/Rel8/Schema/QualifiedName.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Schema/QualifiedName.hs @@ -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 diff --git a/src/Rel8/Schema/Table.hs b/src/Rel8/Schema/Table.hs --- a/src/Rel8/Schema/Table.hs +++ b/src/Rel8/Schema/Table.hs @@ -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 diff --git a/src/Rel8/Statement.hs b/src/Rel8/Statement.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Statement.hs @@ -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 diff --git a/src/Rel8/Statement/Delete.hs b/src/Rel8/Statement/Delete.hs --- a/src/Rel8/Statement/Delete.hs +++ b/src/Rel8/Statement/Delete.hs @@ -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 diff --git a/src/Rel8/Statement/Insert.hs b/src/Rel8/Statement/Insert.hs --- a/src/Rel8/Statement/Insert.hs +++ b/src/Rel8/Statement/Insert.hs @@ -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 diff --git a/src/Rel8/Statement/OnConflict.hs b/src/Rel8/Statement/OnConflict.hs --- a/src/Rel8/Statement/OnConflict.hs +++ b/src/Rel8/Statement/OnConflict.hs @@ -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) diff --git a/src/Rel8/Statement/Returning.hs b/src/Rel8/Statement/Returning.hs --- a/src/Rel8/Statement/Returning.hs +++ b/src/Rel8/Statement/Returning.hs @@ -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 diff --git a/src/Rel8/Statement/Rows.hs b/src/Rel8/Statement/Rows.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Statement/Rows.hs @@ -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) diff --git a/src/Rel8/Statement/Run.hs b/src/Rel8/Statement/Run.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Statement/Run.hs @@ -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 diff --git a/src/Rel8/Statement/SQL.hs b/src/Rel8/Statement/SQL.hs --- a/src/Rel8/Statement/SQL.hs +++ b/src/Rel8/Statement/SQL.hs @@ -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 diff --git a/src/Rel8/Statement/Select.hs b/src/Rel8/Statement/Select.hs --- a/src/Rel8/Statement/Select.hs +++ b/src/Rel8/Statement/Select.hs @@ -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 diff --git a/src/Rel8/Statement/Update.hs b/src/Rel8/Statement/Update.hs --- a/src/Rel8/Statement/Update.hs +++ b/src/Rel8/Statement/Update.hs @@ -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 diff --git a/src/Rel8/Statement/Using.hs b/src/Rel8/Statement/Using.hs --- a/src/Rel8/Statement/Using.hs +++ b/src/Rel8/Statement/Using.hs @@ -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 = ()} diff --git a/src/Rel8/Statement/View.hs b/src/Rel8/Statement/View.hs --- a/src/Rel8/Statement/View.hs +++ b/src/Rel8/Statement/View.hs @@ -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" diff --git a/src/Rel8/Table.hs b/src/Rel8/Table.hs --- a/src/Rel8/Table.hs +++ b/src/Rel8/Table.hs @@ -8,6 +8,7 @@ {-# language StandaloneKindSignatures #-} {-# language TypeApplications #-} {-# language TypeFamilies #-} +{-# language TypeOperators #-} {-# language UndecidableInstances #-} module Rel8.Table diff --git a/src/Rel8/Table/ADT.hs b/src/Rel8/Table/ADT.hs --- a/src/Rel8/Table/ADT.hs +++ b/src/Rel8/Table/ADT.hs @@ -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) diff --git a/src/Rel8/Table/Aggregate.hs b/src/Rel8/Table/Aggregate.hs --- a/src/Rel8/Table/Aggregate.hs +++ b/src/Rel8/Table/Aggregate.hs @@ -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 diff --git a/src/Rel8/Table/Cols.hs b/src/Rel8/Table/Cols.hs --- a/src/Rel8/Table/Cols.hs +++ b/src/Rel8/Table/Cols.hs @@ -3,6 +3,7 @@ {-# language MultiParamTypeClasses #-} {-# language StandaloneKindSignatures #-} {-# language TypeFamilies #-} +{-# language TypeOperators #-} {-# language UndecidableInstances #-} module Rel8.Table.Cols diff --git a/src/Rel8/Table/Either.hs b/src/Rel8/Table/Either.hs --- a/src/Rel8/Table/Either.hs +++ b/src/Rel8/Table/Either.hs @@ -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 diff --git a/src/Rel8/Table/HKD.hs b/src/Rel8/Table/HKD.hs --- a/src/Rel8/Table/HKD.hs +++ b/src/Rel8/Table/HKD.hs @@ -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) diff --git a/src/Rel8/Table/List.hs b/src/Rel8/Table/List.hs --- a/src/Rel8/Table/List.hs +++ b/src/Rel8/Table/List.hs @@ -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 diff --git a/src/Rel8/Table/Maybe.hs b/src/Rel8/Table/Maybe.hs --- a/src/Rel8/Table/Maybe.hs +++ b/src/Rel8/Table/Maybe.hs @@ -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 + } diff --git a/src/Rel8/Table/Name.hs b/src/Rel8/Table/Name.hs --- a/src/Rel8/Table/Name.hs +++ b/src/Rel8/Table/Name.hs @@ -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] diff --git a/src/Rel8/Table/NonEmpty.hs b/src/Rel8/Table/NonEmpty.hs --- a/src/Rel8/Table/NonEmpty.hs +++ b/src/Rel8/Table/NonEmpty.hs @@ -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 diff --git a/src/Rel8/Table/Null.hs b/src/Rel8/Table/Null.hs --- a/src/Rel8/Table/Null.hs +++ b/src/Rel8/Table/Null.hs @@ -6,6 +6,7 @@ {-# language StandaloneKindSignatures #-} {-# language TypeApplications #-} {-# language TypeFamilies #-} +{-# language TypeOperators #-} {-# language UndecidableInstances #-} module Rel8.Table.Null diff --git a/src/Rel8/Table/Nullify.hs b/src/Rel8/Table/Nullify.hs --- a/src/Rel8/Table/Nullify.hs +++ b/src/Rel8/Table/Nullify.hs @@ -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) diff --git a/src/Rel8/Table/Opaleye.hs b/src/Rel8/Table/Opaleye.hs --- a/src/Rel8/Table/Opaleye.hs +++ b/src/Rel8/Table/Opaleye.hs @@ -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) diff --git a/src/Rel8/Table/Rel8able.hs b/src/Rel8/Table/Rel8able.hs --- a/src/Rel8/Table/Rel8able.hs +++ b/src/Rel8/Table/Rel8able.hs @@ -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 ) diff --git a/src/Rel8/Table/Serialize.hs b/src/Rel8/Table/Serialize.hs --- a/src/Rel8/Table/Serialize.hs +++ b/src/Rel8/Table/Serialize.hs @@ -7,6 +7,7 @@ {-# language StandaloneKindSignatures #-} {-# language TypeApplications #-} {-# language TypeFamilies #-} +{-# language TypeOperators #-} {-# language UndecidableInstances #-} module Rel8.Table.Serialize diff --git a/src/Rel8/Table/These.hs b/src/Rel8/Table/These.hs --- a/src/Rel8/Table/These.hs +++ b/src/Rel8/Table/These.hs @@ -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 diff --git a/src/Rel8/Table/Transpose.hs b/src/Rel8/Table/Transpose.hs --- a/src/Rel8/Table/Transpose.hs +++ b/src/Rel8/Table/Transpose.hs @@ -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 diff --git a/src/Rel8/Table/Window.hs b/src/Rel8/Table/Window.hs --- a/src/Rel8/Table/Window.hs +++ b/src/Rel8/Table/Window.hs @@ -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) diff --git a/src/Rel8/Tabulate.hs b/src/Rel8/Tabulate.hs --- a/src/Rel8/Tabulate.hs +++ b/src/Rel8/Tabulate.hs @@ -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 diff --git a/src/Rel8/Type.hs b/src/Rel8/Type.hs --- a/src/Rel8/Type.hs +++ b/src/Rel8/Type.hs @@ -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" diff --git a/src/Rel8/Type/Array.hs b/src/Rel8/Type/Array.hs --- a/src/Rel8/Type/Array.hs +++ b/src/Rel8/Type/Array.hs @@ -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.:+) diff --git a/src/Rel8/Type/Composite.hs b/src/Rel8/Type/Composite.hs --- a/src/Rel8/Type/Composite.hs +++ b/src/Rel8/Type/Composite.hs @@ -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 "\"\"" diff --git a/src/Rel8/Type/Decimal.hs b/src/Rel8/Type/Decimal.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Type/Decimal.hs @@ -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 (:), 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 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") diff --git a/src/Rel8/Type/Decoder.hs b/src/Rel8/Type/Decoder.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Type/Decoder.hs @@ -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) diff --git a/src/Rel8/Type/Enum.hs b/src/Rel8/Type/Enum.hs --- a/src/Rel8/Type/Enum.hs +++ b/src/Rel8/Type/Enum.hs @@ -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 diff --git a/src/Rel8/Type/Eq.hs b/src/Rel8/Type/Eq.hs --- a/src/Rel8/Type/Eq.hs +++ b/src/Rel8/Type/Eq.hs @@ -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 diff --git a/src/Rel8/Type/Information.hs b/src/Rel8/Type/Information.hs --- a/src/Rel8/Type/Information.hs +++ b/src/Rel8/Type/Information.hs @@ -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 } diff --git a/src/Rel8/Type/JSONBEncoded.hs b/src/Rel8/Type/JSONBEncoded.hs --- a/src/Rel8/Type/JSONBEncoded.hs +++ b/src/Rel8/Type/JSONBEncoded.hs @@ -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" } diff --git a/src/Rel8/Type/Name.hs b/src/Rel8/Type/Name.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Type/Name.hs @@ -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 diff --git a/src/Rel8/Type/Num.hs b/src/Rel8/Type/Num.hs --- a/src/Rel8/Type/Num.hs +++ b/src/Rel8/Type/Num.hs @@ -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 diff --git a/src/Rel8/Type/Ord.hs b/src/Rel8/Type/Ord.hs --- a/src/Rel8/Type/Ord.hs +++ b/src/Rel8/Type/Ord.hs @@ -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 diff --git a/src/Rel8/Type/Parser.hs b/src/Rel8/Type/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Type/Parser.hs @@ -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) diff --git a/src/Rel8/Type/Parser/ByteString.hs b/src/Rel8/Type/Parser/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Type/Parser/ByteString.hs @@ -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' diff --git a/src/Rel8/Type/Parser/Time.hs b/src/Rel8/Type/Parser/Time.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Type/Parser/Time.hs @@ -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 diff --git a/src/Rel8/Type/Sum.hs b/src/Rel8/Type/Sum.hs --- a/src/Rel8/Type/Sum.hs +++ b/src/Rel8/Type/Sum.hs @@ -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 diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -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") diff --git a/tests/Rel8/Generic/Rel8able/Test.hs b/tests/Rel8/Generic/Rel8able/Test.hs --- a/tests/Rel8/Generic/Rel8able/Test.hs +++ b/tests/Rel8/Generic/Rel8able/Test.hs @@ -7,6 +7,7 @@ {-# language MultiParamTypeClasses #-} {-# language StandaloneKindSignatures #-} {-# language TypeFamilies #-} +{-# language TypeOperators #-} {-# language UndecidableInstances #-} {-# options_ghc -O0 #-}