From 019f5f783a5ee0b8bcc8ebe4a5d088f0f2ccafaf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Juan=20Raphael=20Diaz=20Sim=C3=B5es?= Date: Fri, 12 May 2023 16:25:36 +0500 Subject: [PATCH 1/3] Add EXTRACT function to Rel8.Expr.Time This adds unsafe EXTRACT function to Rel8.Expr.Time, using the low-level Opaleye functions. Should solve #236. --- src/Rel8/Expr/Time.hs | 26 ++++++++++++++++++++++++-- 1 file changed, 24 insertions(+), 2 deletions(-) diff --git a/src/Rel8/Expr/Time.hs b/src/Rel8/Expr/Time.hs index 97666298..e56ffd8a 100644 --- a/src/Rel8/Expr/Time.hs +++ b/src/Rel8/Expr/Time.hs @@ -14,6 +14,7 @@ module Rel8.Expr.Time , addTime , diffTime , subtractTime + , unsafeExtractFromTime -- * Working with @CalendarDiffTime@ , scaleInterval @@ -24,6 +25,7 @@ module Rel8.Expr.Time , week, weeks , month, months , year, years + , unsafeExtractFromInterval ) where -- base @@ -32,8 +34,10 @@ import Prelude -- rel8 import Rel8.Expr ( Expr ) -import Rel8.Expr.Function (binaryOperator, function) -import Rel8.Expr.Opaleye ( castExpr, unsafeCastExpr, unsafeLiteral ) +import Rel8.Expr.Function ( binaryOperator, function ) +import Rel8.Expr.Opaleye ( castExpr, unsafeCastExpr, unsafeLiteral, fromPrimExpr, toPrimExpr ) +import Rel8.Type ( DBType ) +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye -- time import Data.Time.Calendar ( Day ) @@ -90,6 +94,14 @@ diffTime = binaryOperator "-" subtractTime :: Expr CalendarDiffTime -> Expr UTCTime -> Expr UTCTime subtractTime = flip (binaryOperator "-") +-- | Extract a part of a point in time. See possibilities +-- [here](https://www.postgresqltutorial.com/postgresql-date-functions/postgresql-extract/). +-- This function is unsafe because you must decide yourself the output type. +unsafeExtractFromTime :: DBType a => String -> Expr UTCTime -> Expr a +unsafeExtractFromTime name expr = + castExpr $ + fromPrimExpr $ + Opaleye.FunExpr "EXTRACT" [Opaleye.FunExpr (name <> " FROM") [toPrimExpr expr]] scaleInterval :: Expr Double -> Expr CalendarDiffTime -> Expr CalendarDiffTime scaleInterval = binaryOperator "*" @@ -167,3 +179,13 @@ years = (`scaleInterval` year) singleton :: String -> Expr CalendarDiffTime singleton unit = castExpr $ unsafeLiteral $ "'1 " ++ unit ++ "'" + +-- | Extract a part of an interval. See possibilities +-- [here](https://www.postgresqltutorial.com/postgresql-date-functions/postgresql-extract/). +-- This function is unsafe because you must decide yourself the output type. +unsafeExtractFromInterval :: DBType a => String -> Expr CalendarDiffTime -> Expr a +unsafeExtractFromInterval name expr = + castExpr $ + fromPrimExpr $ + Opaleye.FunExpr "EXTRACT" [Opaleye.FunExpr (name <> " FROM") [toPrimExpr expr]] + From c758fbc23480bb58393879c5a41c1bf707dcf982 Mon Sep 17 00:00:00 2001 From: James Muturi Date: Fri, 12 Jun 2026 11:22:47 +0300 Subject: [PATCH 2/3] Add forUpdate query locking helper Expose a new Rel8.Query.Locking module and re-export forUpdate from Rel8, wrapping Opaleye's FOR UPDATE support for Rel8 queries. --- rel8.cabal | 1 + src/Rel8.hs | 2 ++ src/Rel8/Query/Locking.hs | 16 ++++++++++++++++ 3 files changed, 19 insertions(+) create mode 100644 src/Rel8/Query/Locking.hs diff --git a/rel8.cabal b/rel8.cabal index 6d196ecf..2ca01bdb 100644 --- a/rel8.cabal +++ b/rel8.cabal @@ -134,6 +134,7 @@ library Rel8.Query.Indexed Rel8.Query.Limit Rel8.Query.List + Rel8.Query.Locking Rel8.Query.Loop Rel8.Query.Materialize Rel8.Query.Maybe diff --git a/src/Rel8.hs b/src/Rel8.hs index 6a091f63..fec8c1b5 100644 --- a/src/Rel8.hs +++ b/src/Rel8.hs @@ -216,6 +216,7 @@ module Rel8 -- * Queries , Query , showQuery + , forUpdate -- ** Projection , Projection @@ -436,6 +437,7 @@ import Rel8.Query.Exists import Rel8.Query.Filter import Rel8.Query.Function import Rel8.Query.Indexed +import Rel8.Query.Locking import Rel8.Query.Limit import Rel8.Query.List import Rel8.Query.Loop diff --git a/src/Rel8/Query/Locking.hs b/src/Rel8/Query/Locking.hs new file mode 100644 index 00000000..6a3f1829 --- /dev/null +++ b/src/Rel8/Query/Locking.hs @@ -0,0 +1,16 @@ +module Rel8.Query.Locking + ( forUpdate + ) +where + +-- opaleye +import qualified Opaleye.Internal.Locking as Opaleye + +-- rel8 +import Rel8.Query (Query) +import Rel8.Query.Opaleye (mapOpaleye) + + +-- | Adds a PostgreSQL @FOR UPDATE@ locking clause to a query. +forUpdate :: Query a -> Query a +forUpdate = mapOpaleye Opaleye.forUpdate From 550d624ab039dd056a62aa4c7a2accbdadce9893 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Juan=20Raphael=20Diaz=20Sim=C3=B5es?= Date: Fri, 12 Jun 2026 11:00:04 +0200 Subject: [PATCH 3/3] Revert "Merge branch 'circuithub:master' into master" This reverts commit efe9165b4766cd773ef927a68ecb8ac306aa38ec, reversing changes made to c4c98023df41f0c59aefdef7e60b68e5408da003. --- .github/workflows/build.yaml | 2 +- Changelog.md | 82 --- cabal.project | 8 +- cabal.project.haskell-nix | 5 - ...9_170238_shane.obrien_aggregateFunction.md | 3 + .../20231009_170616_shane.obrien_mode.md | 3 + ..._022306_shane.obrien_aggregateJustTable.md | 5 + .../20240701_173914_shane.obrien_raw.md | 4 + ...20240822_184927_teofilcamarasu_ghc_9_10.md | 3 + changelog.d/20240918_124205_shane.obrien.md | 3 + ...0241008_181955_teofilcamarasu_hasql_1_8.md | 4 + ...1018_112157_teofilcamarasu_try_noinline.md | 5 + .../20241018_113208_teofilcamarasu_jsonb.md | 3 + ..._151415_teofilcamarasu_support_ghc_9_12.md | 3 - ...20251030_125129_shane.obrien_OnConflict.md | 9 - .../20260322_223524_shane.obrien_range.md | 3 - docs/tutorial.rst | 3 + flake.lock | 380 ++++++----- flake.nix | 4 +- rel8.cabal | 42 +- src/Rel8.hs | 16 +- src/Rel8/Aggregate.hs | 2 +- src/Rel8/Aggregate/Range.hs | 21 - src/Rel8/Array.hs | 31 +- src/Rel8/Data/Range.hs | 338 --------- src/Rel8/Decoder.hs | 6 - src/Rel8/Encoder.hs | 4 - src/Rel8/Expr/Aggregate.hs | 6 +- src/Rel8/Expr/Order.hs | 2 +- src/Rel8/Expr/Range.hs | 28 - src/Rel8/Expr/Serialize.hs | 8 +- src/Rel8/Generic/Construction/ADT.hs | 8 +- src/Rel8/Generic/Construction/Record.hs | 4 +- src/Rel8/Query/List.hs | 2 +- src/Rel8/Range.hs | 33 - src/Rel8/Statement.hs | 11 +- src/Rel8/Statement/Insert.hs | 2 +- src/Rel8/Statement/OnConflict.hs | 118 ++-- src/Rel8/Statement/Prepared.hs | 87 --- src/Rel8/Statement/Run.hs | 31 +- src/Rel8/Statement/SQL.hs | 12 - src/Rel8/Statement/Select.hs | 5 +- src/Rel8/Table/Bool.hs | 2 +- src/Rel8/Table/Name.hs | 39 +- src/Rel8/Table/Verify.hs | 644 ------------------ src/Rel8/Type.hs | 433 +++++------- src/Rel8/Type/Array.hs | 136 +--- src/Rel8/Type/Builder/ByteString.hs | 16 - src/Rel8/Type/Builder/Fold.hs | 16 - src/Rel8/Type/Builder/Time.hs | 151 ---- src/Rel8/Type/Composite.hs | 98 +-- src/Rel8/Type/Decimal.hs | 2 +- src/Rel8/Type/Decoder.hs | 18 +- src/Rel8/Type/Encoder.hs | 43 -- src/Rel8/Type/Enum.hs | 50 +- src/Rel8/Type/Information.hs | 40 +- src/Rel8/Type/JSONBEncoded.hs | 40 +- src/Rel8/Type/JSONEncoded.hs | 47 +- src/Rel8/Type/Monoid.hs | 6 - src/Rel8/Type/Nullable.hs | 16 - src/Rel8/Type/Range.hs | 95 --- src/Rel8/Type/Semigroup.hs | 6 - tests/Main.hs | 422 +++--------- tests/Rel8/Generic/Rel8able/Test.hs | 373 +--------- 64 files changed, 757 insertions(+), 3285 deletions(-) create mode 100644 changelog.d/20231009_170238_shane.obrien_aggregateFunction.md create mode 100644 changelog.d/20231009_170616_shane.obrien_mode.md create mode 100644 changelog.d/20240527_022306_shane.obrien_aggregateJustTable.md create mode 100644 changelog.d/20240701_173914_shane.obrien_raw.md create mode 100644 changelog.d/20240822_184927_teofilcamarasu_ghc_9_10.md create mode 100644 changelog.d/20240918_124205_shane.obrien.md create mode 100644 changelog.d/20241008_181955_teofilcamarasu_hasql_1_8.md create mode 100644 changelog.d/20241018_112157_teofilcamarasu_try_noinline.md create mode 100644 changelog.d/20241018_113208_teofilcamarasu_jsonb.md delete mode 100644 changelog.d/20241219_151415_teofilcamarasu_support_ghc_9_12.md delete mode 100644 changelog.d/20251030_125129_shane.obrien_OnConflict.md delete mode 100644 changelog.d/20260322_223524_shane.obrien_range.md delete mode 100644 src/Rel8/Aggregate/Range.hs delete mode 100644 src/Rel8/Data/Range.hs delete mode 100644 src/Rel8/Decoder.hs delete mode 100644 src/Rel8/Encoder.hs delete mode 100644 src/Rel8/Expr/Range.hs delete mode 100644 src/Rel8/Range.hs delete mode 100644 src/Rel8/Statement/Prepared.hs delete mode 100644 src/Rel8/Table/Verify.hs delete mode 100644 src/Rel8/Type/Builder/ByteString.hs delete mode 100644 src/Rel8/Type/Builder/Fold.hs delete mode 100644 src/Rel8/Type/Builder/Time.hs delete mode 100644 src/Rel8/Type/Encoder.hs delete mode 100644 src/Rel8/Type/Nullable.hs delete mode 100644 src/Rel8/Type/Range.hs diff --git a/.github/workflows/build.yaml b/.github/workflows/build.yaml index c4f5ddb7..97a82d78 100644 --- a/.github/workflows/build.yaml +++ b/.github/workflows/build.yaml @@ -22,4 +22,4 @@ jobs: authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' - run: nix build .#devShells.x86_64-linux.default --print-build-logs - - run: nix build .#checks.x86_64-linux.tests --print-build-logs + - run: nix flake check --print-build-logs diff --git a/Changelog.md b/Changelog.md index 1d24bbec..5edc28e8 100644 --- a/Changelog.md +++ b/Changelog.md @@ -1,86 +1,4 @@ - -# 1.7.0.0 — 2025-07-31 - -## Removed - -- Removed support for `network-ip`. We still support `iproute`. - -## Added - -- Add support for prepared statements. To use prepared statements, simply use `prepare run` instead of `run` with a function that passes the parameters to your statement. - -- Added new `Encoder` type with three members: `binary`, which is the Hasql binary encoder, `text` which encodes a type in PostgreSQL's text format (needed for nested arrays) and `quote`, which is the does the thing that the function we previously called `encode` does (i.e., `a -> Opaleye.PrimExpr`). - -- Add `elem` and `elem1` to `Rel8.Array` for testing if an element is contained in `[]` and `NonEmpty` `Expr`s. - -- Support hasql-1.9 - -- Support GHC-9.12 - -## Changed - -- Several changes to `TypeInformation`: - - * Changed the `encode` field of `TypeInformation` to be `Encoder a` instead of `a -> Opaleye.PrimExpr`. - - * Moved the `delimiter` field of `Decoder` into the top level of `TypeInformation`, as it's not "decoding" specific, it's also used when "encoding". - - * Renamed the `parser` field of `Decoder` to `text`, to mirror the `text` field of the new `Encoder` type. - - All of this will break any downstream code that uses a completely custom `DBType` implementation, but anything that uses `ReadShow`, `Enum`, `Composite`, `JSONBEncoded` or `parseTypeInformation` will continue working as before (which should cover all common cases). - -- Stop exporting `Decoder` and `Encoder` from the `Rel8` module. These can now be found in `Rel8.Decoder` and `Rel8.Encoder`. - -- Some changes were made to the `DBEnum` type class: - - * `Enumable` was removed as a superclass constraint. It is still used to provide the default implementation of the `DBEnum` class. - * A new method, `enumerate`, was added to the `DBEnum` class (with the default implementation provided by `Enumable`). - - This is unlikely to break any existing `DBEnum` instances, it just allows some instances that weren't possible before (e.g., for types that are not `Generic`). - - -# 1.6.0.0 — 2024-12-13 - -## Removed - -- Remove `Table Expr b` constraint from `materialize`. ([#334](https://github.com/circuithub/rel8/pull/334)) - -## Added - -- Support GHC-9.10. ([#340](https://github.com/circuithub/rel8/pull/340)) - -- Support hasql-1.8 ([#345](https://github.com/circuithub/rel8/pull/345)) - -- Add `aggregateJustTable`, `aggregateJustTable` aggregator functions. These provide another way to do aggregation of `MaybeTable`s than the existing `aggregateMaybeTable` function. ([#333](https://github.com/circuithub/rel8/pull/333)) - -- Add `aggregateLeftTable`, `aggregateLeftTable1`, `aggregateRightTable` and `aggregateRightTable1` aggregator functions. These provide another way to do aggregation of `EitherTable`s than the existing `aggregateEitherTable` function. ([#333](https://github.com/circuithub/rel8/pull/333)) - -- Add `aggregateThisTable`, `aggregateThisTable1`, `aggregateThatTable`, `aggregateThatTable1`, `aggregateThoseTable`, `aggregateThoseTable1`, `aggregateHereTable`, `aggregateHereTable1`, `aggregateThereTable` and `aggregateThereTable1` aggregation functions. These provide another way to do aggregation of `TheseTable`s than the existing `aggregateTheseTable` function. ([#333](https://github.com/circuithub/rel8/pull/333)) - -- Add `rawFunction`, `rawBinaryOperator`, `rawAggregateFunction`, `unsafeCoerceExpr`, `unsafePrimExpr`, `unsafeSubscript`, `unsafeSubscripts` — these give more options for generating SQL expressions that Rel8 does not support natively. ([#331](https://github.com/circuithub/rel8/pull/331)) - -- Expose `unsafeUnnullify` and `unsafeUnnullifyTable` from `Rel8`. ([#343](https://github.com/circuithub/rel8/pull/343)) - -- Expose `listOf` and `nonEmptyOf`. ([#330](https://github.com/circuithub/rel8/pull/330)) - -- Add `NOINLINE` pragmas to `Generic` derived default methods of `Rel8able`. This should speed up - compilation times. If users wish for these methods to be `INLINE`d, they can override with a - pragma in their own code. ([#346](https://github.com/circuithub/rel8/pull/346)) - -## Fixed - -- `JSONEncoded` should be encoded as `json` not `jsonb`. ([#347](https://github.com/circuithub/rel8/pull/347)) - -- Disallow NULL characters in Hedgehog generated text values. ([#339](https://github.com/circuithub/rel8/pull/339)) - -- Fix fromRational bug. ([#338](https://github.com/circuithub/rel8/pull/338)) - -- Fix regex match operator. ([#336](https://github.com/circuithub/rel8/pull/336)) - -- Fix some documentation formatting issues. ([#332](https://github.com/circuithub/rel8/pull/332)), ([#329](https://github.com/circuithub/rel8/pull/329)), ([#327](https://github.com/circuithub/rel8/pull/327)), and ([#318](https://github.com/circuithub/rel8/pull/318)) - - # 1.5.0.0 — 2024-03-19 diff --git a/cabal.project b/cabal.project index 9c5314c1..9ea02062 100644 --- a/cabal.project +++ b/cabal.project @@ -1,9 +1,3 @@ packages: . - -source-repository-package - type: git - location: https://github.com/jfischoff/tmp-postgres - tag: 7f2467a6d6d5f6db7eed59919a6773fe006cf22b - +constraints: ansi-wl-pprint < 1.0.0 allow-newer: base16:base, base16:deepseq, base16:text -allow-newer: *:base, *:template-haskell, *:ghc-prim diff --git a/cabal.project.haskell-nix b/cabal.project.haskell-nix index 38adb634..49a9b688 100644 --- a/cabal.project.haskell-nix +++ b/cabal.project.haskell-nix @@ -2,8 +2,3 @@ -- will interpret them as local packages, and try to build them when we cabal -- build. The only reason we have to specify these is for Haskell.nix to know to -- override these packages by fetching them rather than using Hackage. - --- Workaround a build failure until the fix mentioned in https://github.com/NixOS/nixpkgs/issues/370138 --- is merged to nixpkgs-unstable -package postgresql-libpq - flags: +use-pkg-config diff --git a/changelog.d/20231009_170238_shane.obrien_aggregateFunction.md b/changelog.d/20231009_170238_shane.obrien_aggregateFunction.md new file mode 100644 index 00000000..e40c2a53 --- /dev/null +++ b/changelog.d/20231009_170238_shane.obrien_aggregateFunction.md @@ -0,0 +1,3 @@ +### Added + +- `aggregationFunction`, which allows custom aggregation functions to be used. diff --git a/changelog.d/20231009_170616_shane.obrien_mode.md b/changelog.d/20231009_170616_shane.obrien_mode.md new file mode 100644 index 00000000..158dea7b --- /dev/null +++ b/changelog.d/20231009_170616_shane.obrien_mode.md @@ -0,0 +1,3 @@ +### Added + +- Add support for ordered-set aggregation functions, including `mode`, `percentile`, `percentileContinuous`, `hypotheticalRank`, `hypotheticalDenseRank`, `hypotheticalPercentRank` and `hypotheticalCumeDist`. diff --git a/changelog.d/20240527_022306_shane.obrien_aggregateJustTable.md b/changelog.d/20240527_022306_shane.obrien_aggregateJustTable.md new file mode 100644 index 00000000..2a10e12b --- /dev/null +++ b/changelog.d/20240527_022306_shane.obrien_aggregateJustTable.md @@ -0,0 +1,5 @@ +### Added + +- Add `aggregateJustTable`, `aggregateJustTable` aggregator functions. These provide another way to do aggregation of `MaybeTable`s than the existing `aggregateMaybeTable` function. +- Add `aggregateLeftTable`, `aggregateLeftTable1`, `aggregateRightTable` and `aggregateRightTable1` aggregator functions. These provide another way to do aggregation of `EitherTable`s than the existing `aggregateEitherTable` function. +- Add `aggregateThisTable`, `aggregateThisTable1`, `aggregateThatTable`, `aggregateThatTable1`, `aggregateThoseTable`, `aggregateThoseTable1`, `aggregateHereTable`, `aggregateHereTable1`, `aggregateThereTable` and `aggregateThereTable1` aggregation functions. These provide another way to do aggregation of `TheseTable`s than the existing `aggregateTheseTable` function. diff --git a/changelog.d/20240701_173914_shane.obrien_raw.md b/changelog.d/20240701_173914_shane.obrien_raw.md new file mode 100644 index 00000000..52b6f932 --- /dev/null +++ b/changelog.d/20240701_173914_shane.obrien_raw.md @@ -0,0 +1,4 @@ +### Added + +- `rawFunction`, `rawBinaryOperator`, `rawAggregateFunction`, `unsafeCoerceExpr`, `unsafePrimExpr`, `unsafeSubscript`, `unsafeSubscripts` — these give more options for generating SQL expressions that Rel8 does not support natively. + diff --git a/changelog.d/20240822_184927_teofilcamarasu_ghc_9_10.md b/changelog.d/20240822_184927_teofilcamarasu_ghc_9_10.md new file mode 100644 index 00000000..ea95d0aa --- /dev/null +++ b/changelog.d/20240822_184927_teofilcamarasu_ghc_9_10.md @@ -0,0 +1,3 @@ +### Added + +- Support GHC 9.10 diff --git a/changelog.d/20240918_124205_shane.obrien.md b/changelog.d/20240918_124205_shane.obrien.md new file mode 100644 index 00000000..197c1266 --- /dev/null +++ b/changelog.d/20240918_124205_shane.obrien.md @@ -0,0 +1,3 @@ +### Added + +- Expose `unsafeUnnullify` and `unsafeUnnullifyTable` from `Rel8`. diff --git a/changelog.d/20241008_181955_teofilcamarasu_hasql_1_8.md b/changelog.d/20241008_181955_teofilcamarasu_hasql_1_8.md new file mode 100644 index 00000000..9c4c560a --- /dev/null +++ b/changelog.d/20241008_181955_teofilcamarasu_hasql_1_8.md @@ -0,0 +1,4 @@ +### Added + +- Support hasql-1.8 + diff --git a/changelog.d/20241018_112157_teofilcamarasu_try_noinline.md b/changelog.d/20241018_112157_teofilcamarasu_try_noinline.md new file mode 100644 index 00000000..5a30feaa --- /dev/null +++ b/changelog.d/20241018_112157_teofilcamarasu_try_noinline.md @@ -0,0 +1,5 @@ +### Added + +- Add `NOINLINE` pragmas to `Generic` derived default methods of `Rel8able`. This should speed up + compilation times. If users wish for these methods to be `INLINE`d, they can override with a + pragma in their own code. diff --git a/changelog.d/20241018_113208_teofilcamarasu_jsonb.md b/changelog.d/20241018_113208_teofilcamarasu_jsonb.md new file mode 100644 index 00000000..e2105bb2 --- /dev/null +++ b/changelog.d/20241018_113208_teofilcamarasu_jsonb.md @@ -0,0 +1,3 @@ +### Fixed + +- `JSONEncoded` should be encoded as `json` not `jsonb`. Resolves #344 diff --git a/changelog.d/20241219_151415_teofilcamarasu_support_ghc_9_12.md b/changelog.d/20241219_151415_teofilcamarasu_support_ghc_9_12.md deleted file mode 100644 index 52add6be..00000000 --- a/changelog.d/20241219_151415_teofilcamarasu_support_ghc_9_12.md +++ /dev/null @@ -1,3 +0,0 @@ -### Added - -- Support GHC-9.12 diff --git a/changelog.d/20251030_125129_shane.obrien_OnConflict.md b/changelog.d/20251030_125129_shane.obrien_OnConflict.md deleted file mode 100644 index eaca44d1..00000000 --- a/changelog.d/20251030_125129_shane.obrien_OnConflict.md +++ /dev/null @@ -1,9 +0,0 @@ -### Added - -- Added new `Conflict` and `Index` types. `Conflict` represents a [`conflict_target`](https://www.postgresql.org/docs/current/sql-insert.html#SQL-ON-CONFLICT) in an `ON CONFLICT`. It can be either a named constraint (`ON CONSTRAINT`) or a an `Index`. -- Added `Index`. `Index` is a description of a unique index which PostgreSQL can use for *unique index inference*. This is an alternative to specifying an explicit named constraint in a `conflict_target`. - -### Changed - -- The `Upsert` type was changed. Previously it had the columns (`index`, `predicate`) of what is now the `Index` type baked into its record. It now instead has a single `conflict` column (of type `Conflict`, which can be either an `Index` or a named constraint). -- The `DoNothing` constructor of `OnConflict` was changed to also take an optional `Conflict` value. Even though `ON CONFLICT DO NOTHING` does not generally require a `conflict_target`, there are cases where it can be necessary, e.g., if you have table that has both deferrable and non-deferrable constraints. diff --git a/changelog.d/20260322_223524_shane.obrien_range.md b/changelog.d/20260322_223524_shane.obrien_range.md deleted file mode 100644 index 050bbfd2..00000000 --- a/changelog.d/20260322_223524_shane.obrien_range.md +++ /dev/null @@ -1,3 +0,0 @@ -### Added - -- Added preliminary support for PostgreSQL ranges. diff --git a/docs/tutorial.rst b/docs/tutorial.rst index 9a1520a8..a30ecf98 100644 --- a/docs/tutorial.rst +++ b/docs/tutorial.rst @@ -127,6 +127,7 @@ associated with the ``Author`` type:: authorSchema :: TableSchema (Author Name) authorSchema = TableSchema { name = "author" + , schema = Nothing , columns = Author { authorId = "author_id" , authorName = "name" @@ -139,6 +140,7 @@ And likewise for ``project`` and ``Project``:: projectSchema :: TableSchema (Project Name) projectSchema = TableSchema { name = "project" + , schema = Nothing , columns = Project { projectAuthorId = "author_id" , projectName = "name" @@ -151,6 +153,7 @@ information from your ``Rel8able`` type:: projectSchema :: TableSchema (Project Name) projectSchema = TableSchema { name = "project" + , schema = Nothing , columns = namesFromLabels @(Project Name) } diff --git a/flake.lock b/flake.lock index f7e614fd..941a67b4 100644 --- a/flake.lock +++ b/flake.lock @@ -105,11 +105,11 @@ "systems": "systems" }, "locked": { - "lastModified": 1731533236, - "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", + "lastModified": 1710146030, + "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=", "owner": "numtide", "repo": "flake-utils", - "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", + "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a", "type": "github" }, "original": { @@ -135,47 +135,51 @@ "type": "github" } }, - "hackage": { + "ghc910X": { "flake": false, "locked": { - "lastModified": 1755735907, - "narHash": "sha256-8fOqP45pBWQVFW4tBGgWw1vJmRRBSrQX1TOkCIRZUlw=", - "owner": "input-output-hk", - "repo": "hackage.nix", - "rev": "6313548135c7dc5daea2ae1ed1d0dd1afa3d485e", - "type": "github" + "lastModified": 1709693152, + "narHash": "sha256-j7K/oZLy1ZZIpOsjq101IF7cz/i/UxY1ofIeNUfuuXc=", + "ref": "ghc-9.10", + "rev": "21e3f3250e88640087a1a60bee2cc113bf04509f", + "revCount": 62524, + "submodules": true, + "type": "git", + "url": "https://gitlab.haskell.org/ghc/ghc" }, "original": { - "owner": "input-output-hk", - "repo": "hackage.nix", - "type": "github" + "ref": "ghc-9.10", + "submodules": true, + "type": "git", + "url": "https://gitlab.haskell.org/ghc/ghc" } }, - "hackage-for-stackage": { + "ghc911": { "flake": false, "locked": { - "lastModified": 1755735896, - "narHash": "sha256-X4HTWcv6vgx6EncLyyJJdaNTkL8F8P69HAMaEgZLYhg=", - "owner": "input-output-hk", - "repo": "hackage.nix", - "rev": "54203507c2141dfea4463ba5c4015f11f2c2a503", - "type": "github" + "lastModified": 1710286031, + "narHash": "sha256-fz71zsU/ZukFMUsRNk2Ro3xTNMKsNrpvQtRtPqRI60c=", + "ref": "refs/heads/master", + "rev": "e6bfb85c842edca36754bb8914e725fbaa1a83a6", + "revCount": 62586, + "submodules": true, + "type": "git", + "url": "https://gitlab.haskell.org/ghc/ghc" }, "original": { - "owner": "input-output-hk", - "ref": "for-stackage", - "repo": "hackage.nix", - "type": "github" + "submodules": true, + "type": "git", + "url": "https://gitlab.haskell.org/ghc/ghc" } }, - "hackage-internal": { + "hackage": { "flake": false, "locked": { - "lastModified": 1750307553, - "narHash": "sha256-iiafNoeLHwlSLQTyvy8nPe2t6g5AV4PPcpMeH/2/DLs=", + "lastModified": 1710721411, + "narHash": "sha256-0B1YATLPUKKOexhhfSFkTQlZH6o4yWJ/0WJeyZMxBKg=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "f7867baa8817fab296528f4a4ec39d1c7c4da4f3", + "rev": "99719945242bc0c965560ed708868aa088748524", "type": "github" }, "original": { @@ -193,43 +197,41 @@ "cardano-shell": "cardano-shell", "flake-compat": "flake-compat", "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", + "ghc910X": "ghc910X", + "ghc911": "ghc911", "hackage": "hackage", - "hackage-for-stackage": "hackage-for-stackage", - "hackage-internal": "hackage-internal", - "hls": "hls", "hls-1.10": "hls-1.10", "hls-2.0": "hls-2.0", - "hls-2.10": "hls-2.10", - "hls-2.11": "hls-2.11", "hls-2.2": "hls-2.2", "hls-2.3": "hls-2.3", "hls-2.4": "hls-2.4", "hls-2.5": "hls-2.5", "hls-2.6": "hls-2.6", - "hls-2.7": "hls-2.7", - "hls-2.8": "hls-2.8", - "hls-2.9": "hls-2.9", "hpc-coveralls": "hpc-coveralls", + "hydra": "hydra", "iserv-proxy": "iserv-proxy", + "nix-tools-static": "nix-tools-static", "nixpkgs": [ "haskellNix", "nixpkgs-unstable" ], + "nixpkgs-2003": "nixpkgs-2003", + "nixpkgs-2105": "nixpkgs-2105", + "nixpkgs-2111": "nixpkgs-2111", + "nixpkgs-2205": "nixpkgs-2205", + "nixpkgs-2211": "nixpkgs-2211", "nixpkgs-2305": "nixpkgs-2305", "nixpkgs-2311": "nixpkgs-2311", - "nixpkgs-2405": "nixpkgs-2405", - "nixpkgs-2411": "nixpkgs-2411", - "nixpkgs-2505": "nixpkgs-2505", "nixpkgs-unstable": "nixpkgs-unstable", "old-ghc-nix": "old-ghc-nix", "stackage": "stackage" }, "locked": { - "lastModified": 1755737525, - "narHash": "sha256-BVHCMhwjwl+uxDUgQOQu3EoGRwcDYLuJ/6DNTgWDSys=", + "lastModified": 1710723015, + "narHash": "sha256-2qi4uMWfBWjVfVJgyUpcIy3RQZI4yHu2WzSEZZ4tGRc=", "owner": "input-output-hk", "repo": "haskell.nix", - "rev": "a808cbd430a74c00a0e5959d384e1a11e2ea1e2a", + "rev": "4e75d25fc02dccb3ee350b2401fba529942eb77b", "type": "github" }, "original": { @@ -238,22 +240,6 @@ "type": "github" } }, - "hls": { - "flake": false, - "locked": { - "lastModified": 1741604408, - "narHash": "sha256-tuq3+Ip70yu89GswZ7DSINBpwRprnWnl6xDYnS4GOsc=", - "owner": "haskell", - "repo": "haskell-language-server", - "rev": "682d6894c94087da5e566771f25311c47e145359", - "type": "github" - }, - "original": { - "owner": "haskell", - "repo": "haskell-language-server", - "type": "github" - } - }, "hls-1.10": { "flake": false, "locked": { @@ -288,40 +274,6 @@ "type": "github" } }, - "hls-2.10": { - "flake": false, - "locked": { - "lastModified": 1743069404, - "narHash": "sha256-q4kDFyJDDeoGqfEtrZRx4iqMVEC2MOzCToWsFY+TOzY=", - "owner": "haskell", - "repo": "haskell-language-server", - "rev": "2318c61db3a01e03700bd4b05665662929b7fe8b", - "type": "github" - }, - "original": { - "owner": "haskell", - "ref": "2.10.0.0", - "repo": "haskell-language-server", - "type": "github" - } - }, - "hls-2.11": { - "flake": false, - "locked": { - "lastModified": 1747306193, - "narHash": "sha256-/MmtpF8+FyQlwfKHqHK05BdsxC9LHV70d/FiMM7pzBM=", - "owner": "haskell", - "repo": "haskell-language-server", - "rev": "46ef4523ea4949f47f6d2752476239f1c6d806fe", - "type": "github" - }, - "original": { - "owner": "haskell", - "ref": "2.11.0.0", - "repo": "haskell-language-server", - "type": "github" - } - }, "hls-2.2": { "flake": false, "locked": { @@ -407,183 +359,273 @@ "type": "github" } }, - "hls-2.7": { + "hpc-coveralls": { "flake": false, "locked": { - "lastModified": 1708965829, - "narHash": "sha256-LfJ+TBcBFq/XKoiNI7pc4VoHg4WmuzsFxYJ3Fu+Jf+M=", - "owner": "haskell", - "repo": "haskell-language-server", - "rev": "50322b0a4aefb27adc5ec42f5055aaa8f8e38001", + "lastModified": 1607498076, + "narHash": "sha256-8uqsEtivphgZWYeUo5RDUhp6bO9j2vaaProQxHBltQk=", + "owner": "sevanspowell", + "repo": "hpc-coveralls", + "rev": "14df0f7d229f4cd2e79f8eabb1a740097fdfa430", "type": "github" }, "original": { - "owner": "haskell", - "ref": "2.7.0.0", - "repo": "haskell-language-server", + "owner": "sevanspowell", + "repo": "hpc-coveralls", + "type": "github" + } + }, + "hydra": { + "inputs": { + "nix": "nix", + "nixpkgs": [ + "haskellNix", + "hydra", + "nix", + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1671755331, + "narHash": "sha256-hXsgJj0Cy0ZiCiYdW2OdBz5WmFyOMKuw4zyxKpgUKm4=", + "owner": "NixOS", + "repo": "hydra", + "rev": "f48f00ee6d5727ae3e488cbf9ce157460853fea8", "type": "github" + }, + "original": { + "id": "hydra", + "type": "indirect" } }, - "hls-2.8": { + "iserv-proxy": { "flake": false, "locked": { - "lastModified": 1715153580, - "narHash": "sha256-Vi/iUt2pWyUJlo9VrYgTcbRviWE0cFO6rmGi9rmALw0=", - "owner": "haskell", - "repo": "haskell-language-server", - "rev": "dd1be1beb16700de59e0d6801957290bcf956a0a", + "lastModified": 1708894040, + "narHash": "sha256-Rv+PajrnuJ6AeyhtqzMN+bcR8z9+aEnrUass+N951CQ=", + "owner": "stable-haskell", + "repo": "iserv-proxy", + "rev": "2f2a318fd8837f8063a0d91f329aeae29055fba9", "type": "github" }, "original": { - "owner": "haskell", - "ref": "2.8.0.0", - "repo": "haskell-language-server", + "owner": "stable-haskell", + "ref": "iserv-syms", + "repo": "iserv-proxy", "type": "github" } }, - "hls-2.9": { + "lowdown-src": { "flake": false, "locked": { - "lastModified": 1719993701, - "narHash": "sha256-wy348++MiMm/xwtI9M3vVpqj2qfGgnDcZIGXw8sF1sA=", - "owner": "haskell", - "repo": "haskell-language-server", - "rev": "90319a7e62ab93ab65a95f8f2bcf537e34dae76a", + "lastModified": 1633514407, + "narHash": "sha256-Dw32tiMjdK9t3ETl5fzGrutQTzh2rufgZV4A/BbxuD4=", + "owner": "kristapsdz", + "repo": "lowdown", + "rev": "d2c2b44ff6c27b936ec27358a2653caaef8f73b8", "type": "github" }, "original": { - "owner": "haskell", - "ref": "2.9.0.1", - "repo": "haskell-language-server", + "owner": "kristapsdz", + "repo": "lowdown", "type": "github" } }, - "hpc-coveralls": { - "flake": false, + "nix": { + "inputs": { + "lowdown-src": "lowdown-src", + "nixpkgs": "nixpkgs", + "nixpkgs-regression": "nixpkgs-regression" + }, "locked": { - "lastModified": 1607498076, - "narHash": "sha256-8uqsEtivphgZWYeUo5RDUhp6bO9j2vaaProQxHBltQk=", - "owner": "sevanspowell", - "repo": "hpc-coveralls", - "rev": "14df0f7d229f4cd2e79f8eabb1a740097fdfa430", + "lastModified": 1661606874, + "narHash": "sha256-9+rpYzI+SmxJn+EbYxjGv68Ucp22bdFUSy/4LkHkkDQ=", + "owner": "NixOS", + "repo": "nix", + "rev": "11e45768b34fdafdcf019ddbd337afa16127ff0f", "type": "github" }, "original": { - "owner": "sevanspowell", - "repo": "hpc-coveralls", + "owner": "NixOS", + "ref": "2.11.0", + "repo": "nix", "type": "github" } }, - "iserv-proxy": { + "nix-tools-static": { "flake": false, "locked": { - "lastModified": 1755040634, - "narHash": "sha256-8W7uHpAIG8HhO3ig5OGHqvwduoye6q6dlrea1IrP2eI=", - "owner": "stable-haskell", - "repo": "iserv-proxy", - "rev": "1383d199a2c64f522979005d112b4fbdee38dd92", + "lastModified": 1706266250, + "narHash": "sha256-9t+GRk3eO9muCtKdNAwBtNBZ5dH1xHcnS17WaQyftwA=", + "owner": "input-output-hk", + "repo": "haskell-nix-example", + "rev": "580cb6db546a7777dad3b9c0fa487a366c045c4e", "type": "github" }, "original": { - "owner": "stable-haskell", - "ref": "iserv-syms", - "repo": "iserv-proxy", + "owner": "input-output-hk", + "ref": "nix", + "repo": "haskell-nix-example", "type": "github" } }, - "nixpkgs-2305": { + "nixpkgs": { "locked": { - "lastModified": 1705033721, - "narHash": "sha256-K5eJHmL1/kev6WuqyqqbS1cdNnSidIZ3jeqJ7GbrYnQ=", + "lastModified": 1657693803, + "narHash": "sha256-G++2CJ9u0E7NNTAi9n5G8TdDmGJXcIjkJ3NF8cetQB8=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "a1982c92d8980a0114372973cbdfe0a307f1bdea", + "rev": "365e1b3a859281cf11b94f87231adeabbdd878a2", "type": "github" }, "original": { "owner": "NixOS", - "ref": "nixpkgs-23.05-darwin", + "ref": "nixos-22.05-small", "repo": "nixpkgs", "type": "github" } }, - "nixpkgs-2311": { + "nixpkgs-2003": { "locked": { - "lastModified": 1719957072, - "narHash": "sha256-gvFhEf5nszouwLAkT9nWsDzocUTqLWHuL++dvNjMp9I=", + "lastModified": 1620055814, + "narHash": "sha256-8LEHoYSJiL901bTMVatq+rf8y7QtWuZhwwpKE2fyaRY=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "7144d6241f02d171d25fba3edeaf15e0f2592105", + "rev": "1db42b7fe3878f3f5f7a4f2dc210772fd080e205", "type": "github" }, "original": { "owner": "NixOS", - "ref": "nixpkgs-23.11-darwin", + "ref": "nixpkgs-20.03-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2105": { + "locked": { + "lastModified": 1659914493, + "narHash": "sha256-lkA5X3VNMKirvA+SUzvEhfA7XquWLci+CGi505YFAIs=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "022caabb5f2265ad4006c1fa5b1ebe69fb0c3faf", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-21.05-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2111": { + "locked": { + "lastModified": 1659446231, + "narHash": "sha256-hekabNdTdgR/iLsgce5TGWmfIDZ86qjPhxDg/8TlzhE=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "eabc38219184cc3e04a974fe31857d8e0eac098d", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-21.11-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2205": { + "locked": { + "lastModified": 1685573264, + "narHash": "sha256-Zffu01pONhs/pqH07cjlF10NnMDLok8ix5Uk4rhOnZQ=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "380be19fbd2d9079f677978361792cb25e8a3635", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-22.05-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2211": { + "locked": { + "lastModified": 1688392541, + "narHash": "sha256-lHrKvEkCPTUO+7tPfjIcb7Trk6k31rz18vkyqmkeJfY=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "ea4c80b39be4c09702b0cb3b42eab59e2ba4f24b", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-22.11-darwin", "repo": "nixpkgs", "type": "github" } }, - "nixpkgs-2405": { + "nixpkgs-2305": { "locked": { - "lastModified": 1735564410, - "narHash": "sha256-HB/FA0+1gpSs8+/boEavrGJH+Eq08/R2wWNph1sM1Dg=", + "lastModified": 1701362232, + "narHash": "sha256-GVdzxL0lhEadqs3hfRLuj+L1OJFGiL/L7gCcelgBlsw=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "1e7a8f391f1a490460760065fa0630b5520f9cf8", + "rev": "d2332963662edffacfddfad59ff4f709dde80ffe", "type": "github" }, "original": { "owner": "NixOS", - "ref": "nixpkgs-24.05-darwin", + "ref": "nixpkgs-23.05-darwin", "repo": "nixpkgs", "type": "github" } }, - "nixpkgs-2411": { + "nixpkgs-2311": { "locked": { - "lastModified": 1748037224, - "narHash": "sha256-92vihpZr6dwEMV6g98M5kHZIttrWahb9iRPBm1atcPk=", + "lastModified": 1701386440, + "narHash": "sha256-xI0uQ9E7JbmEy/v8kR9ZQan6389rHug+zOtZeZFiDJk=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "f09dede81861f3a83f7f06641ead34f02f37597f", + "rev": "293822e55ec1872f715a66d0eda9e592dc14419f", "type": "github" }, "original": { "owner": "NixOS", - "ref": "nixpkgs-24.11-darwin", + "ref": "nixpkgs-23.11-darwin", "repo": "nixpkgs", "type": "github" } }, - "nixpkgs-2505": { + "nixpkgs-regression": { "locked": { - "lastModified": 1748852332, - "narHash": "sha256-r/wVJWmLYEqvrJKnL48r90Wn9HWX9SHFt6s4LhuTh7k=", + "lastModified": 1643052045, + "narHash": "sha256-uGJ0VXIhWKGXxkeNnq4TvV3CIOkUJ3PAoLZ3HMzNVMw=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "a8167f3cc2f991dd4d0055746df53dae5fd0c953", + "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", "type": "github" }, "original": { "owner": "NixOS", - "ref": "nixpkgs-25.05-darwin", "repo": "nixpkgs", + "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", "type": "github" } }, "nixpkgs-unstable": { "locked": { - "lastModified": 1748856973, - "narHash": "sha256-RlTsJUvvr8ErjPBsiwrGbbHYW8XbB/oek0Gi78XdWKg=", + "lastModified": 1694822471, + "narHash": "sha256-6fSDCj++lZVMZlyqOe9SIOL8tYSBz1bI8acwovRwoX8=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "e4b09e47ace7d87de083786b404bf232eb6c89d8", + "rev": "47585496bcb13fb72e4a90daeea2f434e2501998", "type": "github" }, "original": { "owner": "NixOS", - "ref": "nixpkgs-unstable", "repo": "nixpkgs", + "rev": "47585496bcb13fb72e4a90daeea2f434e2501998", "type": "github" } }, @@ -617,11 +659,11 @@ "stackage": { "flake": false, "locked": { - "lastModified": 1755735102, - "narHash": "sha256-/oZzMO5tdwz0V3uLRI5N9BrMEQc6/MFOpDfHRMRehEI=", + "lastModified": 1710461339, + "narHash": "sha256-l2/ekwA4Z4NjiaCZytZrBTag2VaAOBUvsNttsH6kH4E=", "owner": "input-output-hk", "repo": "stackage.nix", - "rev": "999a41c7e94d417cd507977e1050a18f3a7a2424", + "rev": "724970b7dc837bf0d813b91f821948c3c5cc719f", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index 419fd713..082ea83b 100644 --- a/flake.nix +++ b/flake.nix @@ -19,7 +19,7 @@ }; outputs = { self, nixpkgs, flake-utils, haskellNix }: - flake-utils.lib.eachDefaultSystem (system: + flake-utils.lib.eachSystem ["x86_64-linux"] (system: let pkgs = import nixpkgs { inherit system; @@ -28,7 +28,7 @@ }; rel8 = pkgs.haskell-nix.project { - compiler-nix-name = "ghc9121"; + compiler-nix-name = "ghc982"; cabalProjectLocal = builtins.readFile ./cabal.project.haskell-nix; diff --git a/rel8.cabal b/rel8.cabal index cc1badff..2ca01bdb 100644 --- a/rel8.cabal +++ b/rel8.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: rel8 -version: 1.7.0.0 +version: 1.5.0.0 synopsis: Hey! Hey! Can u rel8? license: BSD3 license-file: LICENSE @@ -21,19 +21,22 @@ library build-depends: aeson , attoparsec - , base >= 4.16 && < 4.22 + , attoparsec-aeson + , base ^>= 4.16 || ^>= 4.17 || ^>= 4.18 || ^>= 4.19 || ^>= 4.20 , base16 >= 1.0 - , base-compat >= 0.11 && < 0.15 + , base-compat ^>= 0.11 || ^>= 0.12 || ^>= 0.13 || ^>= 0.14 , bifunctors + , binary-parser ^>= 0.5 + , data-dword ^>= 0.3 , bytestring , case-insensitive , comonad - , containers , contravariant - , hasql >= 1.8 && < 1.10 + , data-textual + , hasql >= 1.6.1.2 && < 1.9 + , network-ip ^>= 0.3 , iproute ^>= 1.7 , opaleye ^>= 0.10.2.1 - , postgresql-binary ^>= 0.14.2 , pretty , profunctors , product-profunctors @@ -57,29 +60,20 @@ library -Wno-monomorphism-restriction -Wno-missing-local-signatures -Wno-missing-kind-signatures - -Wno-missing-role-annotations - -Wno-missing-deriving-strategies - -Wno-term-variable-capture - hs-source-dirs: src exposed-modules: Rel8 Rel8.Array - Rel8.Decoder - Rel8.Encoder Rel8.Expr.Num Rel8.Expr.Text Rel8.Expr.Time - Rel8.Range - Rel8.Table.Verify Rel8.Tabulate other-modules: Rel8.Aggregate Rel8.Aggregate.Fold Rel8.Aggregate.Function - Rel8.Aggregate.Range Rel8.Column Rel8.Column.ADT @@ -91,8 +85,6 @@ library Rel8.Column.Null Rel8.Column.These - Rel8.Data.Range - Rel8.Expr Rel8.Expr.Aggregate Rel8.Expr.Array @@ -106,7 +98,6 @@ library Rel8.Expr.Opaleye Rel8.Expr.Ord Rel8.Expr.Order - Rel8.Expr.Range Rel8.Expr.Read Rel8.Expr.Sequence Rel8.Expr.Serialize @@ -185,7 +176,6 @@ library Rel8.Statement.Delete Rel8.Statement.Insert Rel8.Statement.OnConflict - Rel8.Statement.Prepared Rel8.Statement.Returning Rel8.Statement.Rows Rel8.Statement.Run @@ -226,27 +216,21 @@ library Rel8.Type Rel8.Type.Array - Rel8.Type.Builder.ByteString - Rel8.Type.Builder.Fold - Rel8.Type.Builder.Time Rel8.Type.Composite Rel8.Type.Decimal Rel8.Type.Decoder Rel8.Type.Eq - Rel8.Type.Encoder Rel8.Type.Enum Rel8.Type.Information Rel8.Type.JSONEncoded Rel8.Type.JSONBEncoded Rel8.Type.Monoid Rel8.Type.Name - Rel8.Type.Nullable Rel8.Type.Num Rel8.Type.Ord Rel8.Type.Parser Rel8.Type.Parser.ByteString Rel8.Type.Parser.Time - Rel8.Type.Range Rel8.Type.ReadShow Rel8.Type.Semigroup Rel8.Type.String @@ -264,19 +248,20 @@ test-suite tests , bytestring , case-insensitive , containers + , data-dword , hasql , hasql-transaction - , hedgehog >= 1.0 && < 1.6 + , hedgehog ^>= 1.0 || ^>= 1.1 || ^>= 1.2 || ^>= 1.3 || ^>= 1.4 || ^>= 1.5 , mmorph + , network-ip , iproute , rel8 , scientific , tasty , tasty-hedgehog , text - , these , time - , tmp-postgres >=1.34 && <1.36 + , tmp-postgres ^>=1.34.1.0 , transformers , uuid , vector @@ -293,4 +278,3 @@ test-suite tests -Wno-deprecations -Wno-monomorphism-restriction -Wno-missing-local-signatures -Wno-implicit-prelude -Wno-missing-kind-signatures - -Wno-missing-role-annotations diff --git a/src/Rel8.hs b/src/Rel8.hs index 50f037e6..fec8c1b5 100644 --- a/src/Rel8.hs +++ b/src/Rel8.hs @@ -23,6 +23,9 @@ module Rel8 , mapTypeInformation , parseTypeInformation + -- *** @Decoder@ + , Decoder(..) + -- ** The @DBType@ hierarchy , DBSemigroup(..) , DBMonoid(..) @@ -353,7 +356,6 @@ module Rel8 , run1 , runMaybe , runVector - , prepared -- ** @SELECT@ , select @@ -361,8 +363,6 @@ module Rel8 -- ** @INSERT@ , Insert(..) , OnConflict(..) - , Conflict (..) - , Index (..) , Upsert(..) , insert , unsafeDefault @@ -384,7 +384,6 @@ module Rel8 -- ** @WITH@ , Statement , showStatement - , showPreparedStatement -- ** @CREATE VIEW@ , createView @@ -463,7 +462,6 @@ import Rel8.Statement import Rel8.Statement.Delete import Rel8.Statement.Insert import Rel8.Statement.OnConflict -import Rel8.Statement.Prepared import Rel8.Statement.Returning import Rel8.Statement.Run import Rel8.Statement.Select @@ -495,6 +493,7 @@ import Rel8.Table.Transpose 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 @@ -538,11 +537,11 @@ import Rel8.Window -- data Thing f = ThingEmployer (Employer f) | ThingPotato (Potato f) | Nullary -- deriving stock Generic -- --- data Employer f = Employer { employerId :: Column f Int32, employerName :: Column f Text} +-- data Employer f = Employer { employerId :: f Int32, employerName :: f Text} -- deriving stock Generic -- deriving anyclass Rel8able -- --- data Potato f = Potato { size :: Column f Int32, grower :: Column f Text } +-- data Potato f = Potato { size :: f Int32, grower :: f Text } -- deriving stock Generic -- deriving anyclass Rel8able -- @ @@ -555,7 +554,8 @@ import Rel8.Window -- thingSchema :: TableSchema (ADT Thing Name) -- thingSchema = -- TableSchema --- { name = \"thing\", +-- { schema = Nothing, +-- name = \"thing\", -- columns = -- nameADT @Thing -- \"tag\" diff --git a/src/Rel8/Aggregate.hs b/src/Rel8/Aggregate.hs index da611aee..546ad84b 100644 --- a/src/Rel8/Aggregate.hs +++ b/src/Rel8/Aggregate.hs @@ -76,7 +76,7 @@ import Data.Functor.Apply (Apply, liftF2) -- { customerId :: Column f CustomerId -- , totalOrders :: Column f Int64 -- , productsOrdered :: Column f Int64 --- , totalPrice :: Column f Scientific +-- , totalPrice :: Column Scientific -- } -- deriving (Generic, Rel8able) -- diff --git a/src/Rel8/Aggregate/Range.hs b/src/Rel8/Aggregate/Range.hs deleted file mode 100644 index 2d7e598d..00000000 --- a/src/Rel8/Aggregate/Range.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Rel8.Aggregate.Range ( - rangeAgg, -) where - --- base -import Prelude - --- rel8 -import Rel8.Aggregate (Aggregator', toAggregator) -import Rel8.Aggregate.Function (aggregateFunction) -import Rel8.Data.Range (Multirange, Range) -import Rel8.Expr (Expr) -import Rel8.Type.Range (DBRange) - - -rangeAgg :: - DBRange a => - Aggregator' fold (Expr (Range a)) (Expr (Multirange a)) -rangeAgg = toAggregator mempty $ aggregateFunction "range_agg" diff --git a/src/Rel8/Array.hs b/src/Rel8/Array.hs index d8447945..ad602c61 100644 --- a/src/Rel8/Array.hs +++ b/src/Rel8/Array.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE OverloadedStrings #-} - module Rel8.Array ( -- ** @ListTable@ @@ -10,7 +6,6 @@ module Rel8.Array , index, indexExpr , last, lastExpr , length, lengthExpr - , elem -- ** @NonEmptyTable@ , NonEmptyTable @@ -18,7 +13,6 @@ module Rel8.Array , index1, index1Expr , last1, last1Expr , length1, length1Expr - , elem1 -- ** Unsafe , unsafeSubscript @@ -27,34 +21,11 @@ module Rel8.Array where -- base -import Data.List.NonEmpty (NonEmpty) -import Prelude hiding (elem, head, last, length) +import Prelude hiding (head, last, length) -- rel8 -import Rel8.Expr (Expr) -import Rel8.Expr.Array (listOf, nonEmptyOf) -import Rel8.Expr.Function (rawBinaryOperator) import Rel8.Expr.List import Rel8.Expr.NonEmpty import Rel8.Expr.Subscript -import Rel8.Schema.Null (Sql) import Rel8.Table.List import Rel8.Table.NonEmpty -import Rel8.Type.Eq (DBEq) - - --- | @'elem' a as@ tests whether @a@ is an element of the list @as@. -elem :: Sql DBEq a => Expr a -> Expr [a] -> Expr Bool -elem = (<@) . listOf . pure - where - (<@) = rawBinaryOperator "<@" -infix 4 `elem` - - --- | @'elem1' a as@ tests whether @a@ is an element of the non-empty list --- @as@. -elem1 :: Sql DBEq a => Expr a -> Expr (NonEmpty a) -> Expr Bool -elem1 = (<@) . nonEmptyOf . pure - where - (<@) = rawBinaryOperator "<@" -infix 4 `elem1` diff --git a/src/Rel8/Data/Range.hs b/src/Rel8/Data/Range.hs deleted file mode 100644 index 3a85ef13..00000000 --- a/src/Rel8/Data/Range.hs +++ /dev/null @@ -1,338 +0,0 @@ -{-# LANGUAGE DisambiguateRecordFields #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module Rel8.Data.Range ( - Bound (Incl, Excl, Inf), - Range (Empty, Range), - quoteRange, - mapRange, - Multirange (Multirange), - primMultirange, -) where - --- attoparsec -import qualified Data.Attoparsec.ByteString.Char8 as A - --- base -import Control.Applicative (many, optional, (<|>)) -import Control.Monad ((>=>)) -import Data.Foldable (fold) -import Data.Functor (void) -import Data.Functor.Contravariant ((>$<)) -import Prelude - --- bytestring -import Data.ByteString (ByteString) -import Data.ByteString.Builder (Builder, toLazyByteString) -import qualified Data.ByteString.Builder as B -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy as L - --- hasql -import qualified Hasql.Decoders as Decoder -import qualified Hasql.Encoders as Encoder - --- opaleye -import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye - --- postgresql-binary -import PostgreSQL.Binary.Range (Bound (Incl, Excl, Inf), Range (Empty, Range)) -import qualified PostgreSQL.Binary.Range as PostgreSQL - --- rel8 -import Rel8.Schema.QualifiedName (QualifiedName, showQualifiedName) -import Rel8.Type (DBType, typeInformation) -import Rel8.Type.Builder.Fold (interfoldMap) -import Rel8.Type.Decoder (Decoder (Decoder)) -import qualified Rel8.Type.Decoder -import Rel8.Type.Encoder (Encoder (Encoder)) -import qualified Rel8.Type.Encoder -import Rel8.Type.Eq (DBEq) -import Rel8.Type.Information (TypeInformation (TypeInformation)) -import qualified Rel8.Type.Information -import Rel8.Type.Name (TypeName (TypeName)) -import qualified Rel8.Type.Name -import Rel8.Type.Ord (DBOrd) -import Rel8.Type.Range ( - DBRange, - rangeTypeName, rangeEncoder, rangeDecoder, - multirangeTypeName, multirangeEncoder, multirangeDecoder, - ) -import Rel8.Type.Parser (parse) - - -newtype Multirange a = Multirange (PostgreSQL.Multirange a) - deriving (Eq, Ord, Show) - - -instance DBRange a => DBType (Range a) where - typeInformation = - rangeTypeInformation name rangeEncoder rangeDecoder element - where - name = rangeTypeName @a - element = typeInformation @a - - -instance DBRange a => DBEq (Range a) - - -instance DBRange a => DBOrd (Range a) - - -instance DBRange a => DBType (Multirange a) where - typeInformation = - multirangeTypeInformation - multiname - name - multirangeEncoder - multirangeDecoder - element - where - multiname = multirangeTypeName @a - name = rangeTypeName @a - element = typeInformation @a - - -instance DBRange a => DBEq (Multirange a) - - -instance DBRange a => DBOrd (Multirange a) - - -rangeTypeInformation :: - QualifiedName -> - Encoder.Value (Range a) -> - Decoder.Value (Range a) -> - TypeInformation a -> - TypeInformation (Range a) -rangeTypeInformation name encoder decoder element = - TypeInformation - { encode = - Encoder - { binary = encoder - , text = buildRange . mapRange (render . element.encode.text) - , quote = quoteRange name . mapRange element.encode.quote - } - , decode = - Decoder - { binary = decoder - , text = parseRange >=> traverseRange element.decode.text - } - , delimiter = ',' - , typeName = - TypeName - { name - , modifiers = [] - , arrayDepth = 0 - } - } - where - render = L.toStrict . toLazyByteString - - -multirangeTypeInformation :: - QualifiedName -> - QualifiedName -> - Encoder.Value (PostgreSQL.Multirange a) -> - Decoder.Value (PostgreSQL.Multirange a) -> - TypeInformation a -> - TypeInformation (Multirange a) -multirangeTypeInformation multiname name encoder decoder element = - TypeInformation - { encode = - Encoder - { binary = (\(Multirange ranges) -> ranges) >$< encoder - , text = - buildMultirange . mapMultirange (render . element.encode.text) - , quote = - quoteMultirange multiname name - . mapMultirange element.encode.quote - } - , decode = - Decoder - { binary = Multirange <$> decoder - , text = parseMultirange >=> traverseMultirange element.decode.text - } - , delimiter = ',' - , typeName = - TypeName - { name = multiname - , modifiers = [] - , arrayDepth = 0 - } - } - where - render = L.toStrict . toLazyByteString - - -buildRange :: Range ByteString -> Builder -buildRange = \case - Empty -> B.string7 "empty" - Range lo hi -> lower <> B.char8 ',' <> upper - where - lower = case lo of - Incl a -> B.char8 '[' <> element a - Excl a -> B.char8 '(' <> element a - Inf -> B.char8 '(' - upper = case hi of - Incl a -> element a <> B.char8 ']' - Excl a -> element a <> B.char8 ')' - Inf -> B.char8 ')' - where - element bytes - | BS.null bytes = B.string7 "\"\"" - | BS.any (A.inClass escapeClass) bytes = escape bytes - | otherwise = B.byteString bytes - escapeClass = ",()[]\\\" \t\n\r\v\f" - escape bytes = - B.char8 '"' <> BS.foldr ((<>) . go) mempty bytes <> B.char8 '"' - where - go = \case - '"' -> B.string7 "\\\"" - '\\' -> B.string7 "\\\\" - c -> B.char8 c - - -quoteRange :: QualifiedName -> Range Opaleye.PrimExpr -> Opaleye.PrimExpr -quoteRange name = \case - Empty -> - Opaleye.ConstExpr (Opaleye.StringLit "empty") - Range lo hi -> - Opaleye.FunExpr constructor [lower, upper, bounds] - where - lower = case lo of - Incl a -> a - Excl a -> a - Inf -> Opaleye.ConstExpr Opaleye.NullLit - upper = case hi of - Incl a -> a - Excl a -> a - Inf -> Opaleye.ConstExpr Opaleye.NullLit - bounds = Opaleye.ConstExpr (Opaleye.StringLit (l : h : [])) - where - l = case lo of - Incl _ -> '[' - _ -> '(' - h = case hi of - Incl _ -> ']' - _ -> ')' - where - constructor = showQualifiedName name - - -parseRange :: ByteString -> Either String (Range ByteString) -parseRange = parse $ empty <|> nonEmpty - where - empty = Empty <$ A.string "empty" - nonEmpty = rangeParser - - -rangeParser :: A.Parser (Range ByteString) -rangeParser = do - lo <- Incl <$ A.char '[' <|> Excl <$ A.char '(' - mlower <- optional element - void $ A.char ',' - mupper <- optional element - hi <- Incl <$ A.char ']' <|> Excl <$ A.char ')' - let - lower = maybe Inf lo mlower - upper = maybe Inf hi mupper - pure $ Range lower upper - where - element = quoted <|> unquoted - where - unquoted = A.takeWhile1 (A.notInClass ",)]") - 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 '"' - - -buildMultirange :: Multirange ByteString -> Builder -buildMultirange (Multirange ranges) = - B.char8 '{' <> interfoldMap (B.char8 ',') buildRange ranges <> B.char8 '}' - - -quoteMultirange :: - QualifiedName -> - QualifiedName -> - Multirange Opaleye.PrimExpr -> - Opaleye.PrimExpr -quoteMultirange multiname name (Multirange ranges) = - primMultirange multiname (map (cast . quoteRange name) ranges) - where - cast = Opaleye.CastExpr (showQualifiedName name) - - -primMultirange :: QualifiedName -> [Opaleye.PrimExpr] -> Opaleye.PrimExpr -primMultirange = Opaleye.FunExpr . showQualifiedName - - -parseMultirange :: - ByteString -> - Either String (Multirange ByteString) -parseMultirange = - parse $ - Multirange <$> do - A.char '{' *> A.sepBy rangeParser (A.char ',') <* A.char '}' - - -mapBound :: (a -> b) -> Bound a -> Bound b -mapBound f = \case - Incl a -> Incl (f a) - Excl a -> Excl (f a) - Inf -> Inf - - -traverseBound :: - Applicative f => - (a -> f b) -> - Bound a -> - f (Bound b) -traverseBound f = \case - Incl a -> Incl <$> f a - Excl a -> Excl <$> f a - Inf -> pure Inf - - -mapRange :: (a -> b) -> Range a -> Range b -mapRange f = \case - Empty -> Empty - Range a b -> Range (mapBound f a) (mapBound f b) - - -traverseRange :: - Applicative f => - (a -> f b) -> - Range a -> - f (Range b) -traverseRange f = \case - Empty -> pure Empty - Range a b -> - Range <$> traverseBound f a <*> traverseBound f b - - -mapMultirange :: - (a -> b) -> - Multirange a -> - Multirange b -mapMultirange f (Multirange ranges) = Multirange (map (mapRange f) ranges) - - -traverseMultirange :: - Applicative f => - (a -> f b) -> - Multirange a -> - f (Multirange b) -traverseMultirange f (Multirange ranges) = - Multirange <$> traverse (traverseRange f) ranges diff --git a/src/Rel8/Decoder.hs b/src/Rel8/Decoder.hs deleted file mode 100644 index cbeaf312..00000000 --- a/src/Rel8/Decoder.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Rel8.Decoder ( - Decoder (..), - Parser, - parseDecoder, -) where -import Rel8.Type.Decoder diff --git a/src/Rel8/Encoder.hs b/src/Rel8/Encoder.hs deleted file mode 100644 index 70c2d545..00000000 --- a/src/Rel8/Encoder.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Rel8.Encoder ( - Encoder (..), -) where -import Rel8.Type.Encoder diff --git a/src/Rel8/Expr/Aggregate.hs b/src/Rel8/Expr/Aggregate.hs index 78a12c82..b1ede727 100644 --- a/src/Rel8/Expr/Aggregate.hs +++ b/src/Rel8/Expr/Aggregate.hs @@ -80,7 +80,7 @@ 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 (arrayTypeName, quoteArrayElement) +import Rel8.Type.Array (arrayTypeName, encodeArrayElement) import Rel8.Type.Eq ( DBEq ) import Rel8.Type.Information (TypeInformation) import Rel8.Type.Num (DBFractional, DBNum) @@ -451,7 +451,7 @@ slistAggExpr :: () => TypeInformation (Unnullify a) -> Aggregator' fold (Expr a) (Expr [a]) slistAggExpr info = unsafeMakeAggregator - (toColumn . quoteArrayElement info . toPrimExpr) + (toColumn . encodeArrayElement info . toPrimExpr) (fromPrimExpr . fromColumn) (Fallback (sempty info)) Opaleye.arrayAgg @@ -461,7 +461,7 @@ snonEmptyAggExpr :: () => TypeInformation (Unnullify a) -> Aggregator1 (Expr a) (Expr (NonEmpty a)) snonEmptyAggExpr info = unsafeMakeAggregator - (toColumn . quoteArrayElement info . toPrimExpr) + (toColumn . encodeArrayElement info . toPrimExpr) (fromPrimExpr . fromColumn) Empty Opaleye.arrayAgg diff --git a/src/Rel8/Expr/Order.hs b/src/Rel8/Expr/Order.hs index cb9c9e84..1333fb82 100644 --- a/src/Rel8/Expr/Order.hs +++ b/src/Rel8/Expr/Order.hs @@ -59,7 +59,7 @@ nullsFirst (Order (Opaleye.Order f)) = g orderOp = orderOp { Opaleye.orderNulls = Opaleye.NullsFirst } --- | Transform an ordering so that @null@ values appear last. This corresponds +-- | Transform an ordering so that @null@ values appear first. This corresponds -- to @NULLS LAST@ in SQL. nullsLast :: Order (Expr a) -> Order (Expr (Maybe a)) nullsLast (Order (Opaleye.Order f)) = diff --git a/src/Rel8/Expr/Range.hs b/src/Rel8/Expr/Range.hs deleted file mode 100644 index 160a35be..00000000 --- a/src/Rel8/Expr/Range.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module Rel8.Expr.Range ( - range, - multirange, -) where - --- rel8 -import Rel8.Data.Range ( - Range, mapRange, quoteRange, - Multirange, primMultirange, - ) -import Rel8.Expr (Expr) -import Rel8.Expr.Opaleye (fromPrimExpr, toPrimExpr) -import Rel8.Type.Range (DBRange, rangeTypeName, multirangeTypeName) - - -range :: forall a. DBRange a => Range (Expr a) -> Expr (Range a) -range = fromPrimExpr . quoteRange name . mapRange toPrimExpr - where - name = rangeTypeName @a - - -multirange :: forall a. DBRange a => [Expr (Range a)] -> Expr (Multirange a) -multirange = fromPrimExpr . primMultirange name . map toPrimExpr - where - name = multirangeTypeName @a diff --git a/src/Rel8/Expr/Serialize.hs b/src/Rel8/Expr/Serialize.hs index 95993c4d..5812ad32 100644 --- a/src/Rel8/Expr/Serialize.hs +++ b/src/Rel8/Expr/Serialize.hs @@ -1,4 +1,3 @@ -{-# language DisambiguateRecordFields #-} {-# language FlexibleContexts #-} {-# language NamedFieldPuns #-} {-# language TypeFamilies #-} @@ -25,7 +24,6 @@ import Rel8.Expr.Opaleye ( scastExpr ) import Rel8.Schema.Null ( Unnullify, Nullity( Null, NotNull ), Sql, nullable ) import Rel8.Type ( DBType, typeInformation ) import Rel8.Type.Decoder (Decoder (..)) -import Rel8.Type.Encoder (Encoder (..)) import Rel8.Type.Information ( TypeInformation(..) ) @@ -38,12 +36,12 @@ litExpr = slitExpr nullable typeInformation slitExpr :: Nullity a -> TypeInformation (Unnullify a) -> a -> Expr a -slitExpr nullity info@TypeInformation {encode = Encoder {quote}} = +slitExpr nullity info@TypeInformation {encode} = scastExpr info . Expr . encoder where encoder = case nullity of - Null -> maybe (Opaleye.ConstExpr Opaleye.NullLit) quote - NotNull -> quote + Null -> maybe (Opaleye.ConstExpr Opaleye.NullLit) encode + NotNull -> encode sparseValue :: Nullity a -> TypeInformation (Unnullify a) -> Hasql.Row a diff --git a/src/Rel8/Generic/Construction/ADT.hs b/src/Rel8/Generic/Construction/ADT.hs index 7b52f985..f5cc0cf8 100644 --- a/src/Rel8/Generic/Construction/ADT.hs +++ b/src/Rel8/Generic/Construction/ADT.hs @@ -77,10 +77,10 @@ type Unnullifier context = forall a. Spec a -> context (Nullify a) -> context a type NoConstructor :: Symbol -> Symbol -> ErrorMessage type NoConstructor datatype constructor = - ( 'Text "The type `" ' :<>: - 'Text datatype ' :<>: - 'Text "` has no constructor `" ' :<>: - 'Text constructor ' :<>: + ( 'Text "The type `" ':<>: + 'Text datatype ':<>: + 'Text "` has no constructor `" ':<>: + 'Text constructor ':<>: 'Text "`." ) diff --git a/src/Rel8/Generic/Construction/Record.hs b/src/Rel8/Generic/Construction/Record.hs index 5d4f3a2f..9350b442 100644 --- a/src/Rel8/Generic/Construction/Record.hs +++ b/src/Rel8/Generic/Construction/Record.hs @@ -63,8 +63,8 @@ type GConstructor :: (Type -> Type) -> Symbol type family GConstructor rep where GConstructor (M1 D _ (M1 C ('MetaCons name _ _) _)) = name GConstructor (M1 D ('MetaData name _ _ _) _) = TypeError ( - 'Text "`" ' :<>: - 'Text name ' :<>: + 'Text "`" ':<>: + 'Text name ':<>: 'Text "` does not appear to have exactly 1 constructor" ) diff --git a/src/Rel8/Query/List.hs b/src/Rel8/Query/List.hs index 859ffab4..0ba686bc 100644 --- a/src/Rel8/Query/List.hs +++ b/src/Rel8/Query/List.hs @@ -66,7 +66,7 @@ manyExpr :: Sql DBType a => Query (Expr a) -> Query (Expr [a]) manyExpr = aggregate listAggExpr --- | A version of 'some' specialised to single expressions. +-- | A version of 'many' specialised to single expressions. someExpr :: Sql DBType a => Query (Expr a) -> Query (Expr (NonEmpty a)) someExpr = aggregate1 nonEmptyAggExpr diff --git a/src/Rel8/Range.hs b/src/Rel8/Range.hs deleted file mode 100644 index 2297291d..00000000 --- a/src/Rel8/Range.hs +++ /dev/null @@ -1,33 +0,0 @@ -module Rel8.Range ( - -- * Basic range functionality - Bound (Incl, Excl, Inf), - Range (Empty, Range), - Multirange (Multirange), - range, - multirange, - rangeAgg, - - -- * Defining new range types - DBRange ( - rangeTypeName, rangeDecoder, rangeEncoder, - multirangeTypeName, multirangeDecoder, multirangeEncoder - ) -) where - --- base -import Prelude () - --- rel8 -import Rel8.Aggregate.Range (rangeAgg) -import Rel8.Data.Range ( - Bound (Incl, Excl, Inf), - Range (Empty, Range), - Multirange (Multirange), - ) -import Rel8.Expr.Range (range, multirange) -import Rel8.Type.Range ( - DBRange ( - rangeTypeName, rangeDecoder, rangeEncoder, - multirangeTypeName, multirangeDecoder, multirangeEncoder - ), - ) diff --git a/src/Rel8/Statement.hs b/src/Rel8/Statement.hs index 713de7e7..2ce69c9e 100644 --- a/src/Rel8/Statement.hs +++ b/src/Rel8/Statement.hs @@ -59,7 +59,7 @@ import Rel8.Schema.Table (TableSchema (..)) import Rel8.Statement.Rows (Rows (..)) import Rel8.Table (Table) import Rel8.Table.Cols (fromCols) -import Rel8.Table.Name (namesFromLabelsTagged, showNames) +import Rel8.Table.Name (namesFromLabelsWithA, showNames) import Rel8.Table.Serialize (parse) -- semigroupoids @@ -192,7 +192,14 @@ statementReturning pp = Statement $ do tag <- Opaleye.fresh let relation = Opaleye.tagWith tag "statement" - names = namesFromLabelsTagged tag + 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 diff --git a/src/Rel8/Statement/Insert.hs b/src/Rel8/Statement/Insert.hs index 3e6ef14f..120fe721 100644 --- a/src/Rel8/Statement/Insert.hs +++ b/src/Rel8/Statement/Insert.hs @@ -50,7 +50,7 @@ data Insert a where , rows :: Query exprs -- ^ The rows to insert. This can be an arbitrary query — use -- 'Rel8.values' insert a static list of rows. - , onConflict :: OnConflict exprs + , onConflict :: OnConflict names -- ^ What to do if the inserted rows conflict with data already in the -- table. , returning :: Returning names a diff --git a/src/Rel8/Statement/OnConflict.hs b/src/Rel8/Statement/OnConflict.hs index b5d1132e..4731b6d5 100644 --- a/src/Rel8/Statement/OnConflict.hs +++ b/src/Rel8/Statement/OnConflict.hs @@ -11,14 +11,13 @@ module Rel8.Statement.OnConflict ( OnConflict(..) - , Conflict (..) - , Index (..) , Upsert(..) , ppOnConflict ) where -- base +import Data.Foldable ( toList ) import Data.Kind ( Type ) import Prelude @@ -32,32 +31,28 @@ import Text.PrettyPrint ( Doc, (<+>), ($$), parens, text ) -- rel8 import Rel8.Expr ( Expr ) import Rel8.Expr.Opaleye (toPrimExpr) -import Rel8.Schema.Escape (escape) -import Rel8.Schema.Name ( Selects ) -import Rel8.Schema.HTable (hfoldMap) +import Rel8.Schema.Name ( Name, Selects, ppColumn ) import Rel8.Schema.Table ( TableSchema(..) ) import Rel8.Statement.Set ( ppSet ) import Rel8.Statement.Where ( ppWhere ) import Rel8.Table ( Table, toColumns ) +import Rel8.Table.Cols ( Cols( Cols ) ) +import Rel8.Table.Name ( showNames ) import Rel8.Table.Opaleye (attributes, view) +import Rel8.Table.Projection ( Projecting, Projection, apply ) -- | 'OnConflict' represents the @ON CONFLICT@ clause of an @INSERT@ -- statement. This specifies what ought to happen when one or more of the -- rows proposed for insertion conflict with an existing row in the table. type OnConflict :: Type -> Type -data OnConflict exprs +data OnConflict names = Abort -- ^ Abort the transaction if there are conflicting rows (Postgres' default) - | DoNothing (Maybe (Conflict exprs)) - -- ^ @ON CONFLICT DO NOTHING@, or @ON CONFLICT (...) DO NOTHING@ if an - -- explicit conflict target is supplied. Specifying a conflict target is - -- essential when your table has has deferrable constraints — @ON - -- CONFLICT@ can't work on deferrable constraints, so it's necessary - -- to explicitly name one of its non-deferrable constraints in order to - -- use @ON CONFLICT@. - | DoUpdate (Upsert exprs) - -- ^ @ON CONFLICT (...) DO UPDATE ...@ + | DoNothing + -- ^ @ON CONFLICT DO NOTHING@ + | DoUpdate (Upsert names) + -- ^ @ON CONFLICT DO UPDATE@ -- | The @ON CONFLICT (...) DO UPDATE@ clause of an @INSERT@ statement, also @@ -74,75 +69,35 @@ data OnConflict exprs -- 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 exprs where - Upsert :: excluded ~ exprs => - { conflict :: Conflict exprs - -- ^ The conflict target to supply to @DO UPDATE@. +data Upsert names where + Upsert :: (Selects names exprs, Projecting names index, excluded ~ exprs) => + { index :: Projection names index + -- ^ 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 -- ^ Which rows to select for update. } - -> Upsert exprs - - --- | Represents what PostgreSQL calls a --- [@conflict_target@](https://www.postgresql.org/docs/current/sql-insert.html#SQL-ON-CONFLICT) --- in an @ON CONFLICT@ clause of an @INSERT@ statement. -type Conflict :: Type -> Type -data Conflict exprs - = OnConstraint String - -- ^ Use a specific named constraint for the conflict target. This - -- corresponds the the syntax @ON CONFLICT constraint@ in PostgreSQL. - | OnIndex (Index exprs) - -- ^ Have PostgreSQL perform what it calls _unique index inference_ by - -- giving it a description of the target index. - - --- | A description of the target unique index — its columns (and/or --- expressions) and, in the case of partial indexes, a predicate. -type Index :: Type -> Type -data Index exprs where - Index :: Table Expr index => - { columns :: exprs -> index - -- ^ The set of columns and/or expressions comprising the @UNIQUE@ index - , predicate :: Maybe (exprs -> Expr Bool) - -- ^ An optional predicate used to specify a - -- [partial index](https://www.postgresql.org/docs/current/indexes-partial.html). - } - -> Index exprs + -> Upsert names -ppOnConflict :: Selects names exprs => TableSchema names -> OnConflict exprs -> Doc -ppOnConflict schema@TableSchema {columns} = \case +ppOnConflict :: TableSchema names -> OnConflict names -> Doc +ppOnConflict schema = \case Abort -> mempty - DoNothing conflict -> text "ON CONFLICT" <+> foldMap (ppConflict row) conflict <+> text "DO NOTHING" - DoUpdate upsert -> ppUpsert schema row upsert - where - row = view columns - + DoNothing -> text "ON CONFLICT DO NOTHING" + DoUpdate upsert -> ppUpsert schema upsert -ppConflict :: exprs -> Conflict exprs -> Doc -ppConflict row = \case - OnConstraint name -> "ON CONSTRAINT" <+> escape name - OnIndex index -> ppIndex row index - -ppIndex :: exprs -> Index exprs -> Doc -ppIndex row Index {columns, predicate} = - parens (Opaleye.commaH id exprs) <> - foldMap (ppPredicate . ($ row)) predicate - where - exprs = hfoldMap (pure . parens . ppExpr) $ toColumns $ columns row - - -ppPredicate :: Expr Bool -> Doc -ppPredicate condition = text "WHERE" <+> ppExpr condition - - -ppUpsert :: Selects names exprs => TableSchema names -> exprs -> Upsert exprs -> Doc -ppUpsert schema@TableSchema {columns} row Upsert {..} = - text "ON CONFLICT" <+> ppConflict row conflict <+> "DO UPDATE" $$ +ppUpsert :: TableSchema names -> Upsert names -> Doc +ppUpsert schema@TableSchema {columns} Upsert {..} = + text "ON CONFLICT" <+> + ppIndex columns index <+> foldMap (ppPredicate columns) predicate <+> + text "DO UPDATE" $$ ppSet schema (set excluded) $$ ppWhere schema (updateWhere excluded) where @@ -152,5 +107,16 @@ ppUpsert schema@TableSchema {columns} row Upsert {..} = } -ppExpr :: Expr a -> Doc -ppExpr = Opaleye.ppSqlExpr . Opaleye.sqlExpr . toPrimExpr +ppIndex :: (Table Name names, Projecting names 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/Prepared.hs b/src/Rel8/Statement/Prepared.hs deleted file mode 100644 index 2f54638a..00000000 --- a/src/Rel8/Statement/Prepared.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# language AllowAmbiguousTypes #-} -{-# language BlockArguments #-} -{-# language FlexibleContexts #-} -{-# language MonoLocalBinds #-} -{-# language NamedFieldPuns #-} -{-# language ScopedTypeVariables #-} -{-# language TypeApplications #-} - -module Rel8.Statement.Prepared ( - input, - prepared, -) where - --- base -import Data.Functor.Const (Const (Const), getConst) -import Data.Functor.Contravariant (contramap, (>$<)) -import Data.Functor.Identity (runIdentity) -import Prelude - --- hasql -import qualified Hasql.Encoders as Hasql -import qualified Hasql.Statement as Hasql - --- opaleye -import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye - --- rel8 -import Rel8.Expr (Expr) -import Rel8.Expr.Opaleye (fromPrimExpr, scastExpr) -import Rel8.Schema.HTable (hfield, hspecs, htabulateA) -import Rel8.Schema.Null (Nullity (Null, NotNull)) -import Rel8.Schema.Spec (Spec (..)) -import Rel8.Statement (Statement) -import Rel8.Table (Table, fromColumns, toResult) -import Rel8.Table.Serialize (Serializable) -import Rel8.Type.Encoder (binary) -import Rel8.Type.Information (encode) - --- transformers -import Control.Monad.Trans.State.Strict (evalState, state) - - -{-| Given a 'Rel8.run' function that converts a 'Statement' to a -'Hasql.Statement', return a 'Rel8.run'-like function which instead takes a -/parameterized/ 'Statement' and converts it to a /preparable/ -'Hasql.Statement'. - -The parameters @i@ are sent to the database directly via PostgreSQL's binary -format. For large amounts of data this can be significantly more efficient -than embedding the values in the statement with 'Rel8.lit'. --} -prepared :: forall a b i o. - Serializable a i => - (Statement b -> Hasql.Statement () o) -> - (a -> Statement b) -> - Hasql.Statement i o -prepared run mkStatement = Hasql.Statement sql (encoder @a) decode True - where - Hasql.Statement sql _ decode _ = run $ mkStatement input - - -encoder :: forall a i. Serializable a i => Hasql.Params i -encoder = - contramap (toResult @_ @a) $ - getConst $ - htabulateA \field -> - case hfield hspecs field of - Spec {nullity, info} -> Const $ - runIdentity . (`hfield` field) >$< - case nullity of - Null -> Hasql.param $ Hasql.nullable build - NotNull -> Hasql.param $ Hasql.nonNullable build - where - build = binary (encode info) - - -input :: Table Expr a => a -input = - fromColumns $ - flip (evalState @Word) 1 do - htabulateA \field -> do - n <- state (\n -> (n, n + 1)) - pure - case hfield hspecs field of - Spec {info} -> - scastExpr info $ fromPrimExpr $ - Opaleye.ConstExpr $ Opaleye.OtherLit $ '$' : show n diff --git a/src/Rel8/Statement/Run.hs b/src/Rel8/Statement/Run.hs index 1c9b8223..188cb366 100644 --- a/src/Rel8/Statement/Run.hs +++ b/src/Rel8/Statement/Run.hs @@ -43,10 +43,6 @@ makeRun rows statement = Hasql.Statement bytes params decode prepare -- | Convert a 'Statement' to a runnable 'Hasql.Statement', disregarding the -- results of that statement (if any). --- --- @ --- run_ :: Rel8.'Statement' exprs -> Hasql.'Hasql.Statement' () () --- @ run_ :: Statement exprs -> Hasql.Statement () () run_ = makeRun Void @@ -54,10 +50,6 @@ run_ = makeRun Void -- | Convert a 'Statement' to a runnable 'Hasql.Statement', returning the -- number of rows affected by that statement (for 'Rel8.insert's, -- 'Rel8.update's or Rel8.delete's with 'Rel8.NoReturning'). --- --- @ --- runN :: Rel8.'Statement' () -> Hasql.'Hasql.Statement' () 'Int64' --- @ runN :: Statement () -> Hasql.Statement () Int64 runN = makeRun RowsAffected @@ -65,32 +57,21 @@ runN = makeRun RowsAffected -- | Convert a 'Statement' to a runnable 'Hasql.Statement', processing the -- result of the statement as a single row. If the statement returns a number -- of rows other than 1, a runtime exception is thrown. --- --- @ --- run1 :: 'Serializable' exprs a => Rel8.'Statement' ('Query' exprs) -> Hasql.'Hasql.Statement' () a --- @ -run1 :: Serializable exprs a => Statement (Query exprs) -> Hasql.Statement () a +run1 :: Serializable exprs + a=> Statement (Query exprs) -> Hasql.Statement () a run1 = makeRun Single -- | Convert a 'Statement' to a runnable 'Hasql.Statement', processing the -- result of the statement as 'Maybe' a single row. If the statement returns -- a number of rows other than 0 or 1, a runtime exception is thrown. --- --- @ --- runMaybe :: 'Serializable' exprs a => Rel8.'Statement' ('Query' exprs) -> Hasql.'Hasql.Statement' () ('Maybe' a) --- @ -runMaybe :: Serializable exprs a - => Statement (Query exprs) -> Hasql.Statement () (Maybe a) +runMaybe :: Serializable exprs + a=> Statement (Query exprs) -> Hasql.Statement () (Maybe a) runMaybe = makeRun Maybe -- | Convert a 'Statement' to a runnable 'Hasql.Statement', processing the -- result of the statement as a list of rows. --- --- @ --- run :: 'Serializable' exprs a => Rel8.'Statement' ('Query' exprs) -> Hasql.'Hasql.Statement' () [a] --- @ run :: Serializable exprs a => Statement (Query exprs) -> Hasql.Statement () [a] run = makeRun List @@ -98,10 +79,6 @@ run = makeRun List -- | Convert a 'Statement' to a runnable 'Hasql.Statement', processing the -- result of the statement as a 'Vector' of rows. --- --- @ --- runVector :: 'Serializable' exprs a => Rel8.'Statement' ('Query' exprs) -> Hasql.'Hasql.Statement' () ('Vector' a) --- @ runVector :: Serializable exprs a => Statement (Query exprs) -> Hasql.Statement () (Vector a) runVector = makeRun Vector diff --git a/src/Rel8/Statement/SQL.hs b/src/Rel8/Statement/SQL.hs index 2ec21367..aa9dfef2 100644 --- a/src/Rel8/Statement/SQL.hs +++ b/src/Rel8/Statement/SQL.hs @@ -1,11 +1,8 @@ -{-# language FlexibleContexts #-} - module Rel8.Statement.SQL ( showDelete , showInsert , showUpdate , showStatement - , showPreparedStatement ) where @@ -16,15 +13,12 @@ import Prelude import qualified Opaleye.Internal.Tag as Opaleye -- rel8 -import Rel8.Expr (Expr) import Rel8.Statement (Statement, ppDecodeStatement) import Rel8.Statement.Delete ( Delete, ppDelete ) import Rel8.Statement.Insert ( Insert, ppInsert ) -import Rel8.Statement.Prepared (input) import Rel8.Statement.Rows (Rows (Void)) import Rel8.Statement.Select (ppSelect) import Rel8.Statement.Update ( Update, ppUpdate ) -import Rel8.Table (Table) -- transformers import Control.Monad.Trans.State.Strict (evalState) @@ -48,9 +42,3 @@ showUpdate = show . (`evalState` Opaleye.start) . ppUpdate -- | Convert a 'Statement' to a 'String' containing an SQL statement. showStatement :: Statement a -> String showStatement = show . fst . ppDecodeStatement ppSelect Void - - --- | Convert a parameterized 'Statement' to a 'String' containing an SQL --- statement. -showPreparedStatement :: Table Expr i => (i -> Statement a) -> String -showPreparedStatement = showStatement . ($ input) diff --git a/src/Rel8/Statement/Select.hs b/src/Rel8/Statement/Select.hs index 256df11d..d277365f 100644 --- a/src/Rel8/Statement/Select.hs +++ b/src/Rel8/Statement/Select.hs @@ -46,7 +46,7 @@ import Rel8.Schema.Name ( Selects ) import Rel8.Statement (Statement, statementReturning) import Rel8.Table ( Table ) import Rel8.Table.Cols ( toCols ) -import Rel8.Table.Name ( namesFromLabelsTagged ) +import Rel8.Table.Name ( namesFromLabels ) import Rel8.Table.Opaleye ( castTable, exprsWithNames ) import qualified Rel8.Table.Opaleye as T import Rel8.Table.Undefined ( undefined ) @@ -62,16 +62,15 @@ select query = statementReturning (ppSelect query) ppSelect :: Table Expr a => Query a -> State Opaleye.Tag Doc ppSelect query = do - relationTag <- Opaleye.fresh (exprs, primQuery) <- Opaleye.runSimpleSelect (toOpaleye query) let - names = namesFromLabelsTagged relationTag (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) diff --git a/src/Rel8/Table/Bool.hs b/src/Rel8/Table/Bool.hs index 62339b3f..557c27fa 100644 --- a/src/Rel8/Table/Bool.hs +++ b/src/Rel8/Table/Bool.hs @@ -20,7 +20,7 @@ import Rel8.Schema.HTable ( htabulate, hfield ) import Rel8.Table ( Table, fromColumns, toColumns ) --- | Case analysis for an @Expr Bool@. Corresponds to 'Data.Bool.bool'. +-- | An if-then-else expression on tables. -- -- @bool x y p@ returns @x@ if @p@ is @False@, and returns @y@ if @p@ is -- @True@. diff --git a/src/Rel8/Table/Name.hs b/src/Rel8/Table/Name.hs index 0b6e163d..4cb4c63d 100644 --- a/src/Rel8/Table/Name.hs +++ b/src/Rel8/Table/Name.hs @@ -11,12 +11,10 @@ module Rel8.Table.Name ( namesFromLabels - , namesFromLabelsTagged , namesFromLabelsWith , namesFromLabelsWithA , showLabels , showNames - , shortenName ) where @@ -28,9 +26,6 @@ import Data.List.NonEmpty ( NonEmpty, intersperse, nonEmpty ) import Data.Maybe ( fromMaybe ) import Prelude --- opaleye -import qualified Opaleye.Internal.Tag as Opaleye - -- rel8 import Rel8.Schema.HTable (htabulateA, hfield, hspecs) import Rel8.Schema.Name ( Name( Name ) ) @@ -40,41 +35,15 @@ import Rel8.Table ( Table(..) ) -- semigroupoids import Data.Functor.Apply (Apply) --- transformers -import Control.Monad.Trans.State.Strict (State, evalState) - -- | Construct a table in the 'Name' context containing the names of all --- columns. Nested column names will be combined with @/@, the resulting --- name will be truncated and a unique tag appended to the end of the name --- so that the resulting name has 63 or less characters (Postgres' default --- maximum column name length). +-- columns. Nested column names will be combined with @/@. -- --- See also: 'namesFromLabelsTagged', 'namesFromLabelsWith'. +-- See also: 'namesFromLabelsWith'. namesFromLabels :: Table Name a => a -namesFromLabels = namesFromLabelsWithA (shortenName Nothing) `evalState` Opaleye.start - - --- | Similar to 'namesFromLabels', but receives an additional 'Opaleye.Tag' --- to distinguish between relations. Resulting names will also have 63 or --- less characters. -namesFromLabelsTagged :: Table Name a => Opaleye.Tag -> a -namesFromLabelsTagged relationTag = namesFromLabelsWithA (shortenName (Just relationTag)) `evalState` Opaleye.start - - --- | Map a non-empty list of labels to a short SQL identifier with an opaleye tag appended, --- truncated if it would be too large. -shortenName :: Maybe Opaleye.Tag -> NonEmpty String -> State Opaleye.Tag String -shortenName mtag labels = do - subtag <- Opaleye.fresh - let - addRelationTag = case mtag of - Nothing -> id - Just tag -> Opaleye.tagWith tag - suffix = addRelationTag (Opaleye.tagWith subtag "") - pure $ take (63 - length suffix) label ++ suffix +namesFromLabels = namesFromLabelsWith go where - label = fold (intersperse "/" labels) + go = fold . intersperse "/" -- | Construct a table in the 'Name' context containing the names of all diff --git a/src/Rel8/Table/Verify.hs b/src/Rel8/Table/Verify.hs deleted file mode 100644 index 306c3b65..00000000 --- a/src/Rel8/Table/Verify.hs +++ /dev/null @@ -1,644 +0,0 @@ -{-# language BlockArguments #-} -{-# language DeriveAnyClass #-} -{-# language DeriveGeneric #-} -{-# language DerivingStrategies #-} -{-# language DuplicateRecordFields #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language GADTs #-} -{-# language GeneralizedNewtypeDeriving #-} -{-# language LambdaCase #-} -{-# language NamedFieldPuns #-} -{-# language OverloadedRecordDot #-} -{-# language OverloadedStrings #-} -{-# language RankNTypes #-} -{-# language RecordWildCards #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneDeriving #-} -{-# language TypeApplications #-} -{-# options_ghc -Wno-partial-fields #-} - -module Rel8.Table.Verify - ( getSchemaErrors - , SomeTableSchema(..) - , showCreateTable - , checkedShowCreateTable - ) -where - --- base -import Data.Bits (shiftR, (.&.)) -import Data.Function ((&)) -import Data.Functor ((<&>)) -import Data.Functor.Const -import Data.Functor.Contravariant ( (>$<) ) -import Data.Int ( Int16, Int64 ) -import qualified Data.List as L -import Data.List.NonEmpty ( NonEmpty((:|)) ) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Maybe (isJust, mapMaybe) -import Data.Text ( Text ) -import qualified Data.Text as T -import GHC.Generics -import Prelude hiding ( filter ) -import qualified Prelude as P - --- containers -import qualified Data.Map as M - --- hasql -import qualified Hasql.Statement as HS - --- rel8 -import Rel8.Column ( Column ) -import Rel8.Column.List ( HList ) -import Rel8.Expr ( Expr ) -import Rel8.Expr.Eq ((==.)) -import Rel8.Expr.Ord ((>.)) -import Rel8.Expr.Order (asc) -import Rel8.Generic.Rel8able (GFromExprs, Rel8able) -import Rel8.Query ( Query ) -import Rel8.Query.Each (each) -import Rel8.Query.Filter (filter) -import Rel8.Query.List (many) -import Rel8.Query.Order (orderBy) -import Rel8.Schema.HTable -import Rel8.Schema.Name ( Name(Name) ) -import Rel8.Schema.Null hiding (nullable) -import Rel8.Schema.QualifiedName ( QualifiedName(..) ) -import Rel8.Schema.Result ( Result ) -import Rel8.Schema.Spec (Spec (Spec)) -import qualified Rel8.Schema.Spec -import Rel8.Schema.Table ( TableSchema(..) ) -import Rel8.Statement.Run (run1) -import Rel8.Statement.Select (select) -import Rel8.Table (Columns, toColumns) -import Rel8.Table.List ( ListTable ) -import Rel8.Table.Name (namesFromLabelsWith) -import Rel8.Table.Rel8able () -import Rel8.Table.Serialize (ToExprs, lit) -import Rel8.Type ( DBType(..) ) -import Rel8.Type.Eq ( DBEq ) -import Rel8.Type.Information (parseTypeInformation) -import qualified Rel8.Type.Information -import Rel8.Type.Name ( TypeName(..) ) - --- semialign -import Data.Semialign (align) - --- these -import Data.These - - -data Relkind - = OrdinaryTable - | Index - | Sequence - | ToastTable - | View - | MaterializedView - | CompositeType - | ForeignTable - | PartitionedTable - | PartitionedIndex - deriving stock (Show) - deriving anyclass (DBEq) - -instance DBType Relkind where - typeInformation = parseTypeInformation parser printer typeInformation - where - parser = \case - "r" -> pure OrdinaryTable - "i" -> pure Index - "S" -> pure Sequence - "t" -> pure ToastTable - "v" -> pure View - "m" -> pure MaterializedView - "c" -> pure CompositeType - "f" -> pure ForeignTable - "p" -> pure PartitionedTable - "I" -> pure PartitionedIndex - (x :: Text) -> Left $ "Unknown relkind: " ++ show x - - printer = \case - OrdinaryTable -> "r" - Index -> "i" - Sequence -> "S" - ToastTable -> "t" - View -> "v" - MaterializedView -> "m" - CompositeType -> "c" - ForeignTable -> "f" - PartitionedTable -> "p" - PartitionedIndex -> "I" - -newtype Oid = Oid Int64 - deriving newtype (DBType, DBEq, Show) - -data PGClass f = PGClass - { oid :: Column f Oid - , relname :: Column f Text - , relkind :: Column f Relkind - , relnamespace :: Column f Oid - } - deriving stock (Generic) - deriving anyclass (Rel8able) - -deriving stock instance Show (PGClass Result) - -pgclass :: TableSchema (PGClass Name) -pgclass = TableSchema - { name = QualifiedName "pg_class" (Just "pg_catalog") - , columns = namesFromLabelsWith NonEmpty.last - } - -data PGAttribute f = PGAttribute - { attrelid :: Column f Oid - , attname :: Column f Text - , atttypid :: Column f Oid - , attnum :: Column f Int64 - , atttypmod :: Column f Int64 - , attnotnull :: Column f Bool - , attndims :: Column f Int16 - } - deriving stock (Generic) - deriving anyclass (Rel8able) - -deriving stock instance Show (PGAttribute Result) - -pgattribute :: TableSchema (PGAttribute Name) -pgattribute = TableSchema - { name = QualifiedName "pg_attribute" (Just "pg_catalog") - , columns = namesFromLabelsWith NonEmpty.last - } - -data PGType f = PGType - { oid :: Column f Oid - , typname :: Column f Text - , typnamespace :: Column f Oid - } - deriving stock (Generic) - deriving anyclass (Rel8able) - -deriving stock instance Show (PGType Result) - -pgtype :: TableSchema (PGType Name) -pgtype = TableSchema - { name = QualifiedName "pg_type" (Just "pg_catalog") - , columns = namesFromLabelsWith NonEmpty.last - } - -data PGNamespace f = PGNamespace - { oid :: Column f Oid - , nspname :: Column f Text - } - deriving stock (Generic) - deriving anyclass (Rel8able) - -deriving stock instance Show (PGNamespace Result) - -pgnamespace :: TableSchema (PGNamespace Name) -pgnamespace = TableSchema - { name = QualifiedName "pg_namespace" (Just "pg_catalog") - , columns = namesFromLabelsWith NonEmpty.last - } - -data PGCast f = PGCast - { oid :: Column f Oid - , castsource :: Column f Oid - , casttarget :: Column f Oid - , castfunc :: Column f Oid - , castcontext :: Column f Text -- Char - , castmethod :: Column f Char - } - deriving stock (Generic) - deriving anyclass (Rel8able) - -deriving stock instance Show (PGCast Result) - -pgcast :: TableSchema (PGCast Name) -pgcast = TableSchema - { name = QualifiedName "pg_cast" (Just "pg_catalog") - , columns = namesFromLabelsWith NonEmpty.last - } - -data PGTable f = PGTable - { name :: Column f Text - , columns :: HList f (Attribute f) - } - deriving stock (Generic) - deriving anyclass (Rel8able) - -deriving stock instance Show (PGTable Result) - -data Attribute f = Attribute - { attribute :: PGAttribute f - , typ :: PGType f - , namespace :: PGNamespace f - } - deriving stock (Generic) - deriving anyclass (Rel8able) - -deriving stock instance Show (Attribute Result) - -data Cast f = Cast - { source :: PGType f - , target :: PGType f - , context :: Column f Text -- Char - } - deriving stock (Generic) - deriving anyclass (Rel8able) - -deriving stock instance Show (Cast Result) - -fetchTables :: Query (ListTable Expr (PGTable Expr)) -fetchTables = many do - PGClass{ oid = tableOid, relname } <- orderBy (relname >$< asc) do - each pgclass - >>= filter ((lit OrdinaryTable ==.) . relkind) - - columns <- many do - attribute@PGAttribute{ atttypid } <- - each pgattribute - >>= filter ((tableOid ==.) . attrelid) - >>= filter ((>. 0) . attnum) - - typ <- - each pgtype - >>= filter (\PGType{ oid = typoid } -> atttypid ==. typoid) - - namespace <- - each pgnamespace - >>= filter (\PGNamespace{ oid = nsoid } -> nsoid ==. typ.typnamespace) - - - - return Attribute{ attribute, typ, namespace } - - return PGTable - { name = relname - , .. - } - -fetchCasts :: Query (ListTable Expr (Cast Expr)) -fetchCasts = many do - PGCast {castsource, casttarget, castcontext} <- each pgcast - src <- each pgtype >>= filter (\PGType { oid = typoid } -> typoid ==. castsource) - tgt <- each pgtype >>= filter (\PGType { oid = typoid } -> typoid ==. casttarget) - return Cast { source = src, target = tgt, context = castcontext } - - -data CheckEnv = CheckEnv - { schemaMap :: M.Map String [Attribute Result] -- map of schemas to attributes - , casts :: [(String, String)] -- list of implicit casts - } deriving (Show) - - -nullableToBool :: Nullity a -> Bool -nullableToBool Null = True -nullableToBool NotNull = False - - -attrsToMap :: [Attribute Result] -> M.Map String (Attribute Result) -attrsToMap = M.fromList . map (\attr -> (T.unpack attr.attribute.attname, attr)) - - -data TypeInfo = TypeInfo - { label :: [String] - , isNull :: Bool - , typeName :: TypeName - } -instance Show TypeInfo where - show = showTypeInfo - - --- @'schemaToTypeMap'@ takes a schema and returns a map of database column names --- to the type information associated with the column. It is possible (though --- undesirable) to write a schema which has multiple columns with the same name, --- so a list of results are returned for each key. -schemaToTypeMap :: forall k. Rel8able k => k Name -> M.Map String (NonEmpty.NonEmpty TypeInfo) -schemaToTypeMap cols = go . uncurry zip . getConst $ - htabulateA @(Columns (k Name)) $ \field -> - case (hfield hspecs field, hfield (toColumns cols) field) of - (Spec {..}, Name name) -> Const ([name], [ - TypeInfo { label = labels - , isNull = nullableToBool nullity - , typeName = info.typeName}]) - where - go :: [(String, TypeInfo)] -> M.Map String (NonEmpty.NonEmpty TypeInfo) - go = M.fromListWith (<>) . map (\(name, typeInfo) -> (name, NonEmpty.singleton typeInfo)) - --- A checked version of @schemaToTypeMap@, which returns a list of columns with --- duplicate names if any such columns are present. Otherwise it returns the --- type map with no duplicates. -checkedSchemaToTypeMap :: Rel8able k - => k Name - -> Either (M.Map String (NonEmpty.NonEmpty TypeInfo)) (M.Map String TypeInfo) -checkedSchemaToTypeMap cols = - let typeMap = schemaToTypeMap cols - duplicates = M.filter (\col -> length col > 1) typeMap - in if length duplicates > 0 - then Left duplicates - else Right (typeMap & M.mapMaybe \case - a :| [] -> Just a - _ -> Nothing) - - -showCreateTable_helper :: String -> M.Map String TypeInfo -> String -showCreateTable_helper name typeMap = "CREATE TABLE " <> show name <> " (" - ++ L.intercalate "," (fmap go $ M.assocs typeMap) - ++ "\n);" - where - go :: (String, TypeInfo) -> String - go (name', typeInfo) = "\n " ++ show name' ++ " " ++ showTypeInfo typeInfo - - --- |@'showCreateTable'@ shows an example CREATE TABLE statement for the table. --- This does not show relationships like primary or foreign keys, but can still --- be useful to see what types @rel8@ will expect of the underlying database. --- --- In the event that multiple columns have the same name, this will fail silently. To --- handle that case, see 'checkedShowCreateTable' -showCreateTable :: Rel8able k => TableSchema (k Name) -> String -showCreateTable schema = showCreateTable_helper schema.name.name $ fmap NonEmpty.head $ schemaToTypeMap schema.columns - --- |@'checkedShowCreateTable'@ shows an example CREATE TABLE statement for the --- table. This does not show relationships like primary or foreign keys, but can --- still be useful to see what types rel8 will expect of the underlying database. --- --- In the event that multiple columns have the same name, this will return a map of --- names to the labels identifying the column. -checkedShowCreateTable :: Rel8able k => TableSchema (k Name) -> Either (M.Map String (NonEmpty [String])) String -checkedShowCreateTable schema = case checkedSchemaToTypeMap schema.columns of - Left e -> Left $ (fmap . fmap) (\typ -> typ.label) e - Right a -> Right $ showCreateTable_helper schema.name.name a - --- implicit casts are ok as long as they're bidirectional -checkTypeEquality :: CheckEnv -> TypeInfo -> TypeInfo -> Maybe ColumnError -checkTypeEquality env db hs - | Prelude.and [sameDims, sameMods, toName db == toName hs || castExists] - = Nothing - | otherwise - = Just BidirectionalCastDoesNotExist - where - castExists = Prelude.and - [ (toName db, toName hs) `elem` env.casts - , (toName hs, toName db) `elem` env.casts - ] - - sameMods, sameDims :: Bool - sameMods = db.typeName.modifiers == hs.typeName.modifiers - sameDims = db.typeName.arrayDepth == hs.typeName.arrayDepth - - toName :: TypeInfo -> String - toName typeInfo = case typeInfo.typeName.name of - QualifiedName name _ -> L.dropWhile (== '_') name - --- check types for a single table -compareTypes - :: CheckEnv - -> M.Map String (Attribute Result) - -> M.Map String TypeInfo - -> [ColumnInfo] -compareTypes env attrMap typeMap = fmap (uncurry go) $ M.assocs (disjointUnion attrMap typeMap) - where - go :: String -> These (Attribute Result) TypeInfo -> ColumnInfo - go name (These a b) = ColumnInfo - { name = name - , dbType = Just $ fromAttribute a - , hsType = Just $ b - , error = checkTypeEquality env (fromAttribute a) b - } - go name (This a) = ColumnInfo - { name = name - , dbType = Just $ fromAttribute a - , hsType = Nothing - , error = - if a.attribute.attnotnull - then Just DbTypeIsNotNullButNotPresentInHsType - else Nothing - } - go name (That b) = ColumnInfo - { name = name - , dbType = Nothing - , hsType = Just $ b - , error = Just HsTypeIsPresentButNotPresentInDbType - } - - fromAttribute :: Attribute Result -> TypeInfo - fromAttribute attr = TypeInfo - { label = [T.unpack attr.attribute.attname] - , isNull = not attr.attribute.attnotnull - , typeName = TypeName - { name = QualifiedName - (T.unpack attr.typ.typname) - (Just $ T.unpack attr.namespace.nspname) - , modifiers = toModifier - (T.dropWhile (== '_') attr.typ.typname) - attr.attribute.atttypmod - , arrayDepth = fromIntegral attr.attribute.attndims - } - } - - toModifier :: Text -> Int64 -> [String] - toModifier "bpchar" (-1) = [] - toModifier "bpchar" n = [show (n - 4)] - toModifier "numeric" (-1) = [] - toModifier "numeric" n = [show $ (n - 4) `shiftR` 16, show $ (n - 4) .&. 65535] - toModifier _ _ = [] - - disjointUnion :: Ord k => M.Map k a -> M.Map k b -> M.Map k (These a b) - disjointUnion = align - - --- |@pShowTable@ i's a helper f'unction which takes a grid of text and prints' it' --- as a table, with padding so that cells are lined in columns, and a bordered --- header for the first row -pShowTable :: [[Text]] -> Text -pShowTable xs - = T.intercalate "\n" - $ addHeaderBorder - $ fmap (T.intercalate " | ") - $ L.transpose - $ zip lengths xs' <&> \(n, column) -> column <&> \cell -> T.justifyLeft n ' ' cell - where - addHeaderBorder :: [Text] -> [Text] - addHeaderBorder [] = [] - addHeaderBorder (a : as) = a : T.replicate (T.length a) "-" : as - - xs' :: [[Text]] - xs' = L.transpose xs - - lengths :: [Int] - lengths = fmap (maximum . fmap T.length) $ xs' - - -pShowErrors :: [TableInfo] -> Text -pShowErrors = T.intercalate "\n\n" . fmap go - where - go :: TableInfo -> Text - go (TableInfo {tableExists, name, columns}) = "Table: " <> T.pack name - <> if not tableExists then " does not exist\n" else "\n" - <> pShowTable (["Column Name", "Implied DB type", "Current DB type", "Error"] : (columns <&> \column -> - [ T.pack $ column.name - , T.pack $ maybe "" showTypeInfo column.hsType - , T.pack $ maybe "" showTypeInfo column.dbType - , T.pack $ maybe "" show column.error - ])) - go (DuplicateNames {name, duplicates}) = mconcat - [ "Table " - , T.pack (show name) - , " has multiple columns with the same name. This is an error with the Haskell code generating an impossible schema, rather than an error in your current setup of the database itself. Using 'namesFromLabels' can ensure each column has unique names, which is the easiest way to prevent this, but may require changing names in your database to match the new generated names." - , pShowTable (["DB name", "Haskell label"] : (M.assocs duplicates <&> \(name', typs) -> - [ T.pack name' - , T.intercalate " " $ fmap (\typ -> T.intercalate "/" $ fmap T.pack typ.label) $ NonEmpty.toList typs - ])) - ] - - -data TableInfo - = TableInfo - { tableExists :: Bool - , name :: String - , columns :: [ColumnInfo] - } - | DuplicateNames - { name :: String - , duplicates :: M.Map String (NonEmpty.NonEmpty TypeInfo) - } - deriving (Show) - -data ColumnInfo = ColumnInfo - { name :: String - , hsType :: Maybe TypeInfo - , dbType :: Maybe TypeInfo - , error :: Maybe ColumnError - } deriving (Show) - -data ColumnError - = DbTypeIsNotNullButNotPresentInHsType - | HsTypeIsPresentButNotPresentInDbType - | BidirectionalCastDoesNotExist - deriving (Show) - - -showTypeInfo :: TypeInfo -> String -showTypeInfo typeInfo = concat - [ name - , if Prelude.null modifiers then "" else "(" <> L.intercalate "," modifiers <> ")" - , concat (replicate (fromIntegral typeInfo.typeName.arrayDepth) "[]") - , if typeInfo.isNull then "" else " NOT NULL" - ] - where - name = case typeInfo.typeName.name of - QualifiedName a Nothing -> show (dropWhile (== '_') a) - QualifiedName a (Just b) -> show b <> "." <> show (dropWhile (== '_') a) - - modifiers :: [String] - modifiers = typeInfo.typeName.modifiers - - -verifySchema :: Rel8able k => CheckEnv -> TableSchema (k Name) -> TableInfo -verifySchema env schema = case checkedSchemaToTypeMap schema.columns of - Left dups -> DuplicateNames schema.name.name dups - Right typeMap -> go typeMap maybeTable - where - maybeTable = M.lookup schema.name.name env.schemaMap - go typeMap Nothing = TableInfo - { tableExists = False - , name = schema.name.name - , columns = compareTypes env mempty typeMap - } - go typeMap (Just attrs) = TableInfo - { tableExists = True - , name = schema.name.name - , columns = compareTypes env (attrsToMap attrs) typeMap - } - - -fetchCheckEnv :: HS.Statement () CheckEnv -fetchCheckEnv = fetchSchema <&> \(tbls, casts) -> - let tblMap = foldMap (\PGTable {..} -> M.singleton (T.unpack name) columns) tbls - castMap = map (\Cast {..} -> (T.unpack source.typname, T.unpack target.typname)) $ L.filter (\Cast {context} -> context == "i") casts - in CheckEnv tblMap castMap - where - fetchSchema :: HS.Statement () ([PGTable Result], [Cast Result]) - fetchSchema = run1 $ select $ liftA2 (,) fetchTables fetchCasts - - --- |@'SomeTableSchema'@ is used to allow the collection of a variety of different --- @TableSchema@s under a single type, like: --- --- @ --- userTable :: TableSchema (User Name) --- orderTable :: TableSchema (Order Name) --- --- tables :: [SomeTableSchema] --- tables = [SomeTableSchema userTable, SomeTable orderTable] --- @ --- --- This is used by @'schemaErrors'@ to conveniently group every table an --- application relies on for typechecking the postgresql schemas --- together in a single batch. -data SomeTableSchema where - -- The ToExpr constraint isn't used here, but can be used to read from the - -- SomeTableSchema, which can be useful to combine the type checking with more - -- thorough value-level checking of the validity of existing rows in the - -- table. - SomeTableSchema - :: (ToExprs (k Expr) (GFromExprs k), Rel8able k) - => TableSchema (k Name) -> SomeTableSchema - --- |@'getSchemaErrors'@ checks whether the provided schemas have the correct PostgreSQL --- column names and types to allow reading and writing from their equivalent Haskell --- types, returning a list of errors if that is not the case. The function does not --- crash on encountering a bug, instead leaving it to the caller to decide how --- to respond. A schema is valid if: --- --- 1. for every existing field, the types match --- 2. all non-nullable columns are present in the hs type --- 3. no nonexistent columns are present in the hs type --- 4. no two columns in the same schema share the same name --- --- It's still possible for a valid schema to allow invalid data, for instance, --- if using an ADT, which can introduce restrictions on which values are allowed --- for the column representing the tag, and introduce restrictions on which --- columns are non-null depending on the value of the tag. However, if the --- schema is valid rel8 shouldn't be able to write invalid data to the table. --- --- However, it is possible for migrations to cause valid data to become invalid --- in ways not detectable by this function, if the migration code changes the --- schema correctly but doesn't handle the value-level constraints correctly. So --- it is a good idea to both read from the tables and check the schema for errors --- in a transaction during the migration. The former will catch value-level --- bugs, while the latter will help ensure the schema is set up correctly to --- be able to insert new data. --- --- This function does nothing to check that the conflict target of an @Upsert@ --- are valid for the schema, nor can it prevent invalid uses of @unsafeDefault@. --- However, it should be enough to catch the most likely errors. -getSchemaErrors :: [SomeTableSchema] -> HS.Statement () (Maybe Text) -getSchemaErrors someTables = fmap collectErrors fetchCheckEnv - where - collectErrors :: CheckEnv -> Maybe Text - collectErrors env - = fmap pShowErrors - . filterErrors - . fmap \case - SomeTableSchema t -> verifySchema env t - $ someTables - - -- removes each column which is valid for use by rel8, as well as each table - -- which contains only valid columns - filterErrors :: [TableInfo] -> Maybe [TableInfo] - filterErrors tables = case mapMaybe go tables of - [] -> Nothing - xs -> Just xs - where - go :: TableInfo -> Maybe TableInfo - go TableInfo {..} = case P.filter (\cd -> isJust cd.error) columns of - [] -> if tableExists then Nothing else Just $ TableInfo { name , tableExists , columns = [] } - xs -> Just $ TableInfo { name , tableExists , columns = xs } - go DuplicateNames {..} = Just (DuplicateNames {..}) - - diff --git a/src/Rel8/Type.hs b/src/Rel8/Type.hs index 0e934322..1b31028b 100644 --- a/src/Rel8/Type.hs +++ b/src/Rel8/Type.hs @@ -1,7 +1,6 @@ -{-# language DisambiguateRecordFields #-} +{-# language LambdaCase #-} {-# language FlexibleContexts #-} {-# language FlexibleInstances #-} -{-# language LambdaCase #-} {-# language MonoLocalBinds #-} {-# language MultiWayIf #-} {-# language OverloadedStrings #-} @@ -16,21 +15,25 @@ module Rel8.Type where -- aeson -import Data.Aeson ( Value, Object ) +import Data.Aeson ( Value ) import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Text as Aeson -- attoparsec import qualified Data.Attoparsec.ByteString.Char8 as A +-- attoparsec-aeson +import qualified Data.Aeson.Parser as Aeson + -- base import Control.Applicative ((<|>)) import Data.Fixed (Fixed) -import Data.Functor.Contravariant ((>$<)) -import Data.Int (Int16, Int32, Int64) +import Data.Int ( Int8, Int16, Int32, Int64 ) +import Data.Word (Word8, Word32) import Data.List.NonEmpty ( NonEmpty ) import Data.Kind ( Constraint, Type ) import Prelude +import Data.Bits (Bits (..)) +import Data.DoubleWord (fromHiAndLo) import Text.Read (readMaybe) -- bytestring @@ -39,19 +42,22 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as Lazy ( ByteString ) import qualified Data.ByteString.Lazy as ByteString ( fromStrict, toStrict ) -import qualified Data.ByteString.Builder as B -import Data.ByteString.Builder.Prim (primBounded) -- case-insensitive import Data.CaseInsensitive ( CI ) import qualified Data.CaseInsensitive as CI +-- data-textual +import Data.Textual (textual) + -- hasql -import qualified Hasql.Decoders as Decoders -import qualified Hasql.Encoders as Encoders +import qualified Hasql.Decoders as Hasql + +-- network-ip +import qualified Network.IP.Addr as IP --- iproute -import Data.IP (IPRange) +import qualified Data.IP +import qualified BinaryParser -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye @@ -61,30 +67,27 @@ import qualified Opaleye.Internal.HaskellDB.Sql.Default as Opaleye ( quote ) import Rel8.Schema.Null ( NotNull, Sql, nullable ) import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation ) import Rel8.Type.Decimal (PowerOf10, resolution) -import Rel8.Type.Decoder (Decoder (..)) -import Rel8.Type.Encoder (Encoder (..)) -import Rel8.Type.Information ( TypeInformation(..), mapTypeInformation, parseTypeInformation ) +import Rel8.Type.Decoder ( Decoder(..) ) +import Rel8.Type.Information ( TypeInformation(..), mapTypeInformation ) import Rel8.Type.Name (TypeName (..)) import Rel8.Type.Parser (parse) -import qualified Rel8.Type.Builder.ByteString as Builder -import qualified Rel8.Type.Parser.ByteString as Parser -import qualified Rel8.Type.Builder.Time as Builder -import qualified Rel8.Type.Parser.Time as Parser +import Rel8.Type.Parser.ByteString (bytestring) +import qualified Rel8.Type.Parser.Time as Time -- scientific -import Data.ByteString.Builder.Scientific (scientificBuilder) -import Data.Scientific (Scientific) +import Data.Scientific ( Scientific ) -- text import Data.Text ( Text ) import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text (decodeUtf8, encodeUtf8Builder) -import qualified Data.Text.Lazy as Lazy (Text, unpack) -import qualified Data.Text.Lazy as Text (fromStrict, toStrict) +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 (DiffTime, UTCTime) +import Data.Time.Clock (UTCTime) import Data.Time.LocalTime ( CalendarDiffTime (CalendarDiffTime) , LocalTime @@ -116,23 +119,16 @@ class NotNull a => DBType a where -- | Corresponds to @bool@ instance DBType Bool where typeInformation = TypeInformation - { encode = - Encoder - { binary = Encoders.bool - , text = \case - False -> "f" - True -> "t" - , quote = Opaleye.ConstExpr . Opaleye.BoolLit - } + { encode = Opaleye.ConstExpr . Opaleye.BoolLit , decode = Decoder - { binary = Decoders.bool - , text = \case + { binary = Hasql.bool + , parser = \case "t" -> pure True "f" -> pure False input -> Left $ "bool: bad bool " <> show input + , delimiter = ',' } - , delimiter = ',' , typeName = "bool" } @@ -140,44 +136,34 @@ instance DBType Bool where -- | Corresponds to @char@ instance DBType Char where typeInformation = TypeInformation - { encode = - Encoder - { binary = Encoders.char - , text = B.charUtf8 - , quote = Opaleye.ConstExpr . Opaleye.StringLit . pure - } - , decode = - Decoder - { binary = Decoders.char - , text = \input -> case UTF8.uncons input of - Just (char, rest) | BS.null rest -> pure char - _ -> Left $ "char: bad char " <> show input - } - , delimiter = ',' + { encode = Opaleye.ConstExpr . Opaleye.StringLit . pure , 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 = ',' + } } -- | Corresponds to @int2@ instance DBType Int16 where typeInformation = TypeInformation - { encode = - Encoder - { binary = Encoders.int2 - , text = B.int16Dec - , quote = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger - } + { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger , decode = Decoder - { binary = Decoders.int2 - , text = parse (A.signed A.decimal) + { binary = Hasql.int2 + , parser = parse (A.signed A.decimal) + , delimiter = ',' } - , delimiter = ',' , typeName = "int2" } @@ -185,18 +171,13 @@ instance DBType Int16 where -- | Corresponds to @int4@ instance DBType Int32 where typeInformation = TypeInformation - { encode = - Encoder - { binary = Encoders.int4 - , text = B.int32Dec - , quote = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger - } + { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger , decode = Decoder - { binary = Decoders.int4 - , text = parse (A.signed A.decimal) + { binary = Hasql.int4 + , parser = parse (A.signed A.decimal) + , delimiter = ',' } - , delimiter = ',' , typeName = "int4" } @@ -204,76 +185,49 @@ instance DBType Int32 where -- | Corresponds to @int8@ instance DBType Int64 where typeInformation = TypeInformation - { encode = - Encoder - { binary = Encoders.int8 - , text = B.int64Dec - , quote = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger - } + { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger , decode = Decoder - { binary = Decoders.int8 - , text = parse (A.signed A.decimal) + { binary = Hasql.int8 + , parser = parse (A.signed A.decimal) + , delimiter = ',' } - , delimiter = ',' , typeName = "int8" } --- | Corresponds to @float4@ and @real@ +-- | Corresponds to @float4@ instance DBType Float where typeInformation = TypeInformation - { encode = - Encoder - { binary = Encoders.float4 - , text = - \x -> - if | x == (1 / 0) -> "Infinity" - | isNaN x -> "NaN" - | x == (-1 / 0) -> "-Infinity" - | otherwise -> B.floatDec x - , quote = - \x -> Opaleye.ConstExpr - if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'" - | isNaN x -> Opaleye.OtherLit "'NaN'" - | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'" - | otherwise -> Opaleye.DoubleLit $ realToFrac x - } + { encode = \x -> Opaleye.ConstExpr + if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'" + | isNaN x -> Opaleye.OtherLit "'NaN'" + | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'" + | otherwise -> Opaleye.DoubleLit $ realToFrac x , decode = Decoder - { binary = Decoders.float4 - , text = parse (floating (realToFrac <$> A.double)) + { binary = Hasql.float4 + , parser = parse (floating (realToFrac <$> A.double)) + , delimiter = ',' } - , delimiter = ',' , typeName = "float4" } --- | Corresponds to @float8@ and @double precision@ +-- | Corresponds to @float8@ instance DBType Double where typeInformation = TypeInformation - { encode = - Encoder - { binary = Encoders.float8 - , text = - \x -> - if | x == (1 / 0) -> "Infinity" - | isNaN x -> "NaN" - | x == (-1 / 0) -> "-Infinity" - | otherwise -> B.doubleDec x - , quote = - \x -> Opaleye.ConstExpr - if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'" - | isNaN x -> Opaleye.OtherLit "'NaN'" - | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'" - | otherwise -> Opaleye.DoubleLit x - } + { encode = \x -> Opaleye.ConstExpr + if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'" + | isNaN x -> Opaleye.OtherLit "'NaN'" + | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'" + | otherwise -> Opaleye.DoubleLit x , decode = Decoder - { binary = Decoders.float8 - , text = parse (floating A.double) + { binary = Hasql.float8 + , parser = parse (floating A.double) + , delimiter = ',' } - , delimiter = ',' , typeName = "float8" } @@ -281,52 +235,49 @@ instance DBType Double where -- | Corresponds to @numeric@ instance DBType Scientific where typeInformation = TypeInformation - { encode = - Encoder - { binary = Encoders.numeric - , text = scientificBuilder - , quote = Opaleye.ConstExpr . Opaleye.NumericLit - } + { encode = Opaleye.ConstExpr . Opaleye.NumericLit , decode = Decoder - { binary = Decoders.numeric - , text = parse A.scientific + { binary = Hasql.numeric + , parser = parse A.scientific + , delimiter = ',' } - , delimiter = ',' , typeName = "numeric" } -- | Corresponds to @numeric(1000, log₁₀ n)@ instance PowerOf10 n => DBType (Fixed n) where - typeInformation = - mapTypeInformation realToFrac realToFrac (typeInformation @Scientific) - { typeName = - TypeName - { name = "numeric" - , modifiers = ["1000", show (resolution @n)] - , arrayDepth = 0 - } - } + 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 = - Encoder - { binary = Encoders.timestamptz - , text = primBounded Builder.utcTime - , quote = - Opaleye.ConstExpr . Opaleye.OtherLit . - formatTime defaultTimeLocale "'%FT%T%QZ'" - } + Opaleye.ConstExpr . Opaleye.OtherLit . + formatTime defaultTimeLocale "'%FT%T%QZ'" , decode = Decoder - { binary = Decoders.timestamptz - , text = parse Parser.utcTime + { binary = Hasql.timestamptz + , parser = parse Time.utcTime + , delimiter = ',' } - , delimiter = ',' , typeName = "timestamptz" } @@ -335,19 +286,14 @@ instance DBType UTCTime where instance DBType Day where typeInformation = TypeInformation { encode = - Encoder - { binary = Encoders.date - , text = primBounded Builder.day - , quote = - Opaleye.ConstExpr . Opaleye.OtherLit . - formatTime defaultTimeLocale "'%F'" - } + Opaleye.ConstExpr . Opaleye.OtherLit . + formatTime defaultTimeLocale "'%F'" , decode = Decoder - { binary = Decoders.date - , text = parse Parser.day + { binary = Hasql.date + , parser = parse Time.day + , delimiter = ',' } - , delimiter = ',' , typeName = "date" } @@ -356,19 +302,14 @@ instance DBType Day where instance DBType LocalTime where typeInformation = TypeInformation { encode = - Encoder - { binary = Encoders.timestamp - , text = primBounded Builder.localTime - , quote = - Opaleye.ConstExpr . Opaleye.OtherLit . - formatTime defaultTimeLocale "'%FT%T%Q'" - } + Opaleye.ConstExpr . Opaleye.OtherLit . + formatTime defaultTimeLocale "'%FT%T%Q'" , decode = Decoder - { binary = Decoders.timestamp - , text = parse Parser.localTime + { binary = Hasql.timestamp + , parser = parse Time.localTime + , delimiter = ',' } - , delimiter = ',' , typeName = "timestamp" } @@ -377,19 +318,14 @@ instance DBType LocalTime where instance DBType TimeOfDay where typeInformation = TypeInformation { encode = - Encoder - { binary = Encoders.time - , text = primBounded Builder.timeOfDay - , quote = - Opaleye.ConstExpr . Opaleye.OtherLit . - formatTime defaultTimeLocale "'%T%Q'" - } + Opaleye.ConstExpr . Opaleye.OtherLit . + formatTime defaultTimeLocale "'%T%Q'" , decode = Decoder - { binary = Decoders.time - , text = parse Parser.timeOfDay + { binary = Hasql.time + , parser = parse Time.timeOfDay + , delimiter = ',' } - , delimiter = ',' , typeName = "time" } @@ -398,19 +334,14 @@ instance DBType TimeOfDay where instance DBType CalendarDiffTime where typeInformation = TypeInformation { encode = - Encoder - { binary = toDiffTime >$< Encoders.interval - , text = Builder.calendarDiffTime - , quote = - Opaleye.ConstExpr . Opaleye.OtherLit . - formatTime defaultTimeLocale "'%bmon %0Es'" - } + Opaleye.ConstExpr . Opaleye.OtherLit . + formatTime defaultTimeLocale "'%bmon %0Es'" , decode = Decoder - { binary = CalendarDiffTime 0 . realToFrac <$> Decoders.interval - , text = parse Parser.calendarDiffTime + { binary = CalendarDiffTime 0 . realToFrac <$> Hasql.interval + , parser = parse Time.calendarDiffTime + , delimiter = ',' } - , delimiter = ',' , typeName = "interval" } @@ -418,18 +349,13 @@ instance DBType CalendarDiffTime where -- | Corresponds to @text@ instance DBType Text where typeInformation = TypeInformation - { encode = - Encoder - { binary = Encoders.text - , text = Text.encodeUtf8Builder - , quote = Opaleye.ConstExpr . Opaleye.StringLit . Text.unpack - } + { encode = Opaleye.ConstExpr . Opaleye.StringLit . Text.unpack , decode = Decoder - { binary = Decoders.text - , text = pure . Text.decodeUtf8 + { binary = Hasql.text + , parser = pure . Text.decodeUtf8 + , delimiter = ',' } - , delimiter = ',' , typeName = "text" } @@ -457,18 +383,13 @@ instance DBType (CI Lazy.Text) where -- | Corresponds to @bytea@ instance DBType ByteString where typeInformation = TypeInformation - { encode = - Encoder - { binary = Encoders.bytea - , text = Builder.bytestring - , quote = Opaleye.ConstExpr . Opaleye.ByteStringLit - } + { encode = Opaleye.ConstExpr . Opaleye.ByteStringLit , decode = Decoder - { binary = Decoders.bytea - , text = parse Parser.bytestring + { binary = Hasql.bytea + , parser = parse bytestring + , delimiter = ',' } - , delimiter = ',' , typeName = "bytea" } @@ -483,20 +404,15 @@ instance DBType Lazy.ByteString where -- | Corresponds to @uuid@ instance DBType UUID where typeInformation = TypeInformation - { encode = - Encoder - { binary = Encoders.uuid - , text = B.byteString . UUID.toASCIIBytes - , quote = Opaleye.ConstExpr . Opaleye.StringLit . UUID.toString - } + { encode = Opaleye.ConstExpr . Opaleye.StringLit . UUID.toString , decode = Decoder - { binary = Decoders.uuid - , text = \input -> case UUID.fromASCIIBytes input of + { binary = Hasql.uuid + , parser = \input -> case UUID.fromASCIIBytes input of Just a -> pure a Nothing -> Left $ "uuid: bad UUID " <> show input + , delimiter = ',' } - , delimiter = ',' , typeName = "uuid" } @@ -505,53 +421,85 @@ instance DBType UUID where instance DBType Value where typeInformation = TypeInformation { encode = - Encoder - { binary = Encoders.jsonb - , text = Aeson.fromEncoding . Aeson.toEncoding - , quote = - Opaleye.ConstExpr . Opaleye.OtherLit . Opaleye.quote . - Lazy.unpack . Aeson.encodeToLazyText - } + Opaleye.ConstExpr . Opaleye.OtherLit . + Opaleye.quote . + Lazy.unpack . Lazy.decodeUtf8 . Aeson.encode , decode = Decoder - { binary = Decoders.jsonb - , text = Aeson.eitherDecodeStrict + { binary = Hasql.jsonb + , parser = parse Aeson.value + , delimiter = ',' } - , delimiter = ',' , typeName = "jsonb" } --- | Corresponds to @jsonb@ -instance DBType Object where - typeInformation = parseTypeInformation - (aesonResultToEither . Aeson.fromJSON) - Aeson.Object - typeInformation - where - aesonResultToEither = \case - Aeson.Success o -> Right o - Aeson.Error e -> Left e -- | Corresponds to @inet@ -instance DBType IPRange where +instance DBType (IP.NetAddr IP.IP) where typeInformation = TypeInformation { encode = - Encoder - { binary = Encoders.inet - , text = B.string7 . show - , quote = Opaleye.ConstExpr . Opaleye.StringLit . show + Opaleye.ConstExpr . Opaleye.StringLit . IP.printNetAddr + , decode = + Decoder + { binary = (Hasql.custom . const . BinaryParser.run $ netaddrParser + (\netmask x -> IP.netAddr (IP.IPv4 $ IP.IP4 x) netmask) + (\netmask x1 x2 x3 x4 -> IP.netAddr (IP.IPv6 $ IP.IP6 $ fromHiAndLo (fromHiAndLo x1 x2) (fromHiAndLo x3 x4)) netmask) :: Hasql.Value (IP.NetAddr IP.IP)) + , parser = parse $ + textual + <|> (`IP.netAddr` 32) . IP.IPv4 <$> textual + <|> (`IP.netAddr` 128) . IP.IPv6 <$> textual + , delimiter = ',' } + , typeName = "inet" + } + +-- | Corresponds to @inet@ +instance DBType Data.IP.IPRange where + typeInformation = TypeInformation + { encode = + Opaleye.ConstExpr . Opaleye.StringLit . show , decode = Decoder - { binary = Decoders.inet - , text = \str -> case readMaybe $ BS8.unpack str of + { binary = (Hasql.custom . const . BinaryParser.run $ netaddrParser + (\netmask x -> Data.IP.IPv4Range $ Data.IP.makeAddrRange (Data.IP.toIPv4w x) $ fromIntegral netmask) + (\netmask x1 x2 x3 x4 -> Data.IP.IPv6Range $ Data.IP.makeAddrRange (Data.IP.toIPv6w (x1, x2, x3, x4)) $ fromIntegral netmask)) + , parser = \str -> case readMaybe $ BS8.unpack str of Just x -> Right x Nothing -> Left "Failed to parse inet" + , delimiter = ',' } - , delimiter = ',' , typeName = "inet" } +-- | Address family AF_INET +inetAddressFamily :: Word8 +inetAddressFamily = + 2 + +-- | Address family AF_INET6 +inet6AddressFamily :: Word8 +inet6AddressFamily = + 3 + +-- | This is vendored from `postgresql-binary`. +netaddrParser :: (Word8 -> Word32 -> ip) -> (Word8 -> Word32 -> Word32 -> Word32 -> Word32 -> ip) -> BinaryParser.BinaryParser ip +netaddrParser mkIpv4 mkIpv6 = do + af <- intOfSize 1 + netmask <- intOfSize 1 + isCidr <- intOfSize @Int8 1 + ipSize <- intOfSize @Int8 1 + if | af == inetAddressFamily -> + mkIpv4 netmask <$> intOfSize 4 + | af == inet6AddressFamily -> + mkIpv6 netmask <$> intOfSize 4 <*> intOfSize 4 <*> intOfSize 4 <*> intOfSize 4 + | otherwise -> BinaryParser.failure ("Unknown address family: " <> Text.pack (show af)) + +intOfSize :: (Integral a, Bits a) => Int -> BinaryParser.BinaryParser a +intOfSize x = + fmap integralPack (BinaryParser.bytesOfSize x) + where + integralPack = BS.foldl' (\n h -> shiftL n 8 .|. fromIntegral h) 0 + instance Sql DBType a => DBType [a] where typeInformation = listTypeInformation nullable typeInformation @@ -563,8 +511,3 @@ instance Sql DBType a => DBType (NonEmpty a) where floating :: Floating a => A.Parser a -> A.Parser a floating p = p <|> A.signed (1.0 / 0 <$ "Infinity") <|> 0.0 / 0 <$ "NaN" - - -toDiffTime :: CalendarDiffTime -> DiffTime -toDiffTime (CalendarDiffTime months seconds) = - realToFrac (months * 30 * 24 * 60 * 60) + realToFrac seconds diff --git a/src/Rel8/Type/Array.hs b/src/Rel8/Type/Array.hs index a9f55865..42b75a6c 100644 --- a/src/Rel8/Type/Array.hs +++ b/src/Rel8/Type/Array.hs @@ -1,4 +1,3 @@ -{-# language DisambiguateRecordFields #-} {-# language GADTs #-} {-# language LambdaCase #-} {-# language NamedFieldPuns #-} @@ -7,7 +6,7 @@ {-# language ViewPatterns #-} module Rel8.Type.Array - ( array, quoteArrayElement, extractArrayElement + ( array, encodeArrayElement, extractArrayElement , arrayTypeName , listTypeInformation , nonEmptyTypeInformation @@ -22,48 +21,35 @@ import qualified Data.Attoparsec.ByteString.Char8 as A import Control.Applicative ((<|>), many) import Data.Bifunctor (first) import Data.Foldable (fold, toList) -import Data.Functor.Contravariant ((>$<)) -import Data.List.NonEmpty (NonEmpty, nonEmpty) -import Prelude hiding (head, last, length, null, repeat, zipWith) +import Data.List.NonEmpty ( NonEmpty, nonEmpty ) +import Prelude hiding ( head, last, length, null, repeat, zipWith ) -- bytestring import Data.ByteString (ByteString) -import Data.ByteString.Builder (Builder, toLazyByteString) -import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy as L - --- case-insensitive -import qualified Data.CaseInsensitive as CI -- hasql -import qualified Hasql.Decoders as Decoders -import qualified Hasql.Encoders as Encoders +import qualified Hasql.Decoders as Hasql -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye -- rel8 -import Rel8.Schema.Null (Unnullify, Nullity (Null, NotNull)) -import Rel8.Type.Builder.Fold (interfoldMap) -import Rel8.Type.Decoder (Decoder (..), Parser) -import Rel8.Type.Encoder (Encoder (..)) -import Rel8.Type.Information (TypeInformation(..), parseTypeInformation) +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.Nullable (NullableOrNot (..)) import Rel8.Type.Parser (parse) -- text import qualified Data.Text as Text -import qualified Data.Text.Lazy as Text (toStrict) -import qualified Data.Text.Lazy.Encoding as Lazy (decodeUtf8) array :: Foldable f => TypeInformation a -> f Opaleye.PrimExpr -> Opaleye.PrimExpr array info = Opaleye.CastExpr (showTypeName (arrayType info) <> "[]") . - Opaleye.ArrayExpr . map (quoteArrayElement info) . toList + Opaleye.ArrayExpr . map (encodeArrayElement info) . toList {-# INLINABLE array #-} @@ -71,34 +57,25 @@ listTypeInformation :: () => Nullity a -> TypeInformation (Unnullify a) -> TypeInformation [a] -listTypeInformation nullity info@TypeInformation {decode, encode, delimiter} = +listTypeInformation nullity info@TypeInformation {encode, decode} = TypeInformation { decode = Decoder - { binary = Decoders.listArray $ case nullity of - Null -> Decoders.nullable (decodeArrayElement info decode) - NotNull -> Decoders.nonNullable (decodeArrayElement info decode) - , text = case nullity of - Null -> arrayParser delimiter (Nullable decode) - NotNull -> arrayParser delimiter (NonNullable decode) - } - , encode = - Encoder - { binary = Encoders.foldableArray $ case nullity of - Null -> Encoders.nullable (encodeArrayElement info encode) - NotNull -> Encoders.nonNullable (encodeArrayElement info encode) - , text = case nullity of - Null -> arrayBuild delimiter (Nullable encode) - NotNull -> arrayBuild delimiter (NonNullable encode) - , quote = case nullity of - Null -> - Opaleye.ArrayExpr . - fmap (quoteArrayElement info . maybe null (quote encode)) - NotNull -> - Opaleye.ArrayExpr . - fmap (quoteArrayElement info . quote encode) + { 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 = ',' } - , delimiter = ',' + , encode = case nullity of + Null -> + Opaleye.ArrayExpr . + fmap (encodeArrayElement info . maybe null encode) + NotNull -> + Opaleye.ArrayExpr . + fmap (encodeArrayElement info . encode) , typeName = arrayTypeName info } where @@ -130,21 +107,15 @@ arrayType info | otherwise = typeName info -decodeArrayElement :: TypeInformation a -> Decoder x -> Decoders.Value x -decodeArrayElement info Decoder {binary, text} - | isArray info = - Decoders.refine (first Text.pack . text) Decoders.bytea - | otherwise = binary - - -encodeArrayElement :: TypeInformation a -> Encoder x -> Encoders.Value x -encodeArrayElement info Encoder {binary, text} - | isArray info = Text.toStrict . Lazy.decodeUtf8 . toLazyByteString . text >$< Encoders.text +decodeArrayElement :: TypeInformation a -> Decoder x -> Hasql.Value x +decodeArrayElement info + | isArray info = \decoder -> + Hasql.refine (first Text.pack . parser decoder) Hasql.bytea | otherwise = binary -quoteArrayElement :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr -quoteArrayElement info +encodeArrayElement :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr +encodeArrayElement info | isArray info = Opaleye.CastExpr "text" . Opaleye.CastExpr (showTypeName (typeName info)) | otherwise = id @@ -175,49 +146,14 @@ parseArray delimiter = parse $ do A.char '\\' <|> A.char '"' -arrayParser :: Char -> NullableOrNot Decoder a -> Parser [a] -arrayParser delimiter = \case - Nullable Decoder {text} -> \input -> do +arrayParser :: NullableOrNot Decoder a -> Parser [a] +arrayParser = \case + Nullable Decoder {parser, delimiter} -> \input -> do elements <- parseArray delimiter input - traverse (traverse text) elements - NonNullable Decoder {text} -> \input -> do + traverse (traverse parser) elements + NonNullable Decoder {parser, delimiter} -> \input -> do elements <- parseArray delimiter input - traverse (maybe (Left "array: unexpected null") text) elements - - -buildArray :: Char -> [Maybe ByteString] -> Builder -buildArray delimiter elements = - B.char8 '{' <> - interfoldMap (B.char8 delimiter) element elements <> - B.char8 '}' - where - element = \case - Nothing -> B.string7 "NULL" - Just a - | BS.null a -> "\"\"" - | CI.mk a == "null" -> escaped - | BS.any (A.inClass escapeClass) a -> escaped - | otherwise -> unescaped - where - escapeClass = delimiter : "\\\"{}\t\n" - unescaped = B.byteString a - escaped = - B.char8 '"' <> BS.foldr ((<>) . escape) mempty a <> B.char8 '"' - where - escape = \case - '"' -> B.string7 "\\\"" - '\\' -> B.string7 "\\\\" - c -> B.char8 c - - -arrayBuild :: Char -> NullableOrNot Encoder a -> [a] -> Builder -arrayBuild delimiter = \case - Nullable Encoder {text} -> - buildArray delimiter . - map (fmap (L.toStrict . toLazyByteString . text)) - NonNullable Encoder {text} -> - buildArray delimiter . - map (Just . L.toStrict . toLazyByteString . text) + traverse (maybe (Left "array: unexpected null") parser) elements head :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr @@ -257,4 +193,4 @@ zero = Opaleye.ConstExpr (Opaleye.IntegerLit 0) plus :: Opaleye.PrimExpr -> Opaleye.PrimExpr -> Opaleye.PrimExpr -plus = Opaleye.BinExpr (Opaleye.:+) +plus = Opaleye.BinExpr (Opaleye.:+) \ No newline at end of file diff --git a/src/Rel8/Type/Builder/ByteString.hs b/src/Rel8/Type/Builder/ByteString.hs deleted file mode 100644 index e149755a..00000000 --- a/src/Rel8/Type/Builder/ByteString.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# language OverloadedStrings #-} - -module Rel8.Type.Builder.ByteString ( - bytestring, -) where - --- base -import Prelude - --- bytestring -import Data.ByteString (ByteString) -import Data.ByteString.Builder (Builder, byteStringHex, string7) - - -bytestring :: ByteString -> Builder -bytestring bytes = string7 "\\x" <> byteStringHex bytes diff --git a/src/Rel8/Type/Builder/Fold.hs b/src/Rel8/Type/Builder/Fold.hs deleted file mode 100644 index 49a1deaa..00000000 --- a/src/Rel8/Type/Builder/Fold.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# language LambdaCase #-} - -module Rel8.Type.Builder.Fold ( - interfoldMap -) where - --- base -import Prelude - - -interfoldMap :: (Foldable t, Monoid m) => m -> (a -> m) -> t a -> m -interfoldMap sep f = maybe mempty id . foldr go Nothing - where - go x = \case - Nothing -> Just (f x) - Just acc -> Just (f x <> sep <> acc) diff --git a/src/Rel8/Type/Builder/Time.hs b/src/Rel8/Type/Builder/Time.hs deleted file mode 100644 index eb26d413..00000000 --- a/src/Rel8/Type/Builder/Time.hs +++ /dev/null @@ -1,151 +0,0 @@ -{-# language BangPatterns #-} -{-# language NumericUnderscores #-} -{-# language OverloadedStrings #-} -{-# language PatternSynonyms #-} -{-# language PartialTypeSignatures #-} -{-# language TypeApplications #-} -{-# language ViewPatterns #-} - -{-# options_ghc -Wno-partial-type-signatures #-} --- bytestring does not export Monoidal so we can't write a complete type --- signature for 'divide' - -{-# options_ghc -Wno-unused-top-binds #-} --- GHC considers the YMD pattern unused but we use its selectors - -module Rel8.Type.Builder.Time ( - calendarDiffTime, - day, - localTime, - timeOfDay, - utcTime, -) where - --- base -import Data.Char (chr) -import Data.Fixed (Fixed (MkFixed), Pico) -import Data.Int (Int32, Int64) -import Prelude hiding ((<>)) - --- bytestring -import Data.ByteString.Builder (Builder, string7) -import Data.ByteString.Builder.Prim ( - BoundedPrim, condB, emptyB, liftFixedToBounded, - FixedPrim, char8, int32Dec, - (>$<), (>*<), - ) - --- time -import Data.Time.Calendar (Day, toGregorian) -import Data.Time.Clock (UTCTime (utctDay, utctDayTime)) -import Data.Time.Format.ISO8601 (iso8601Show) -import Data.Time.LocalTime ( - CalendarDiffTime, - LocalTime (localDay, localTimeOfDay), - TimeOfDay (todHour, todMin, todSec), - timeToTimeOfDay - ) - - -digit :: FixedPrim Int -digit = (\x -> chr (x + 48)) >$< char8 - - -digits2 :: FixedPrim Int -digits2 = divide (`quotRem` 10) digit digit - - -digits3 :: FixedPrim Int -digits3 = divide (`quotRem` 10) digits2 digit - - -digits4 :: FixedPrim Int -digits4 = divide (`quotRem` 10) digits3 digit - - -frac :: BoundedPrim Int64 -frac = condB (== 0) emptyB $ liftFixedToBounded (char '.') <> trunc12 - where - trunc12 = - divide - (`quotRem` 1_000_000) - (fromIntegral >$< ifZero trunc6 (liftFixedToBounded digits6)) - (fromIntegral >$< nonZero trunc6) - - digitB = liftFixedToBounded digit - - digits6 = divide (`quotRem` 10) digits5 digit - digits5 = divide (`quotRem` 10) digits4 digit - - trunc6 = divide (`quotRem` 100_000) digitB trunc5 - trunc5 = nonZero $ divide (`quotRem` 10_000) digitB trunc4 - trunc4 = nonZero $ divide (`quotRem` 1_000) digitB trunc3 - trunc3 = nonZero $ divide (`quotRem` 100) digitB trunc2 - trunc2 = nonZero $ divide (`quotRem` 10) digitB trunc1 - trunc1 = nonZero digitB - - nonZero = ifZero emptyB - ifZero = condB (== 0) - - -seconds :: BoundedPrim Pico -seconds = - (\(MkFixed s) -> fromIntegral s `quotRem` 1_000_000_000_000) >$< - (liftFixedToBounded (fromIntegral >$< digits2) >*< frac) - - -year :: BoundedPrim Int32 -year = condB (>= 10000) int32Dec (liftFixedToBounded (fromIntegral >$< digits4)) - - -day :: BoundedPrim Day -day = - (fromIntegral . ymdYear >$< year) <> - liftFixedToBounded - ( char '-' <> (ymdMonth >$< digits2) <> char '-' <> (ymdDay >$< digits2) - ) - - -pattern YMD :: Integer -> Int -> Int -> Day -pattern YMD {ymdYear, ymdMonth, ymdDay} <- - (toGregorian -> (ymdYear, ymdMonth, ymdDay)) - - -timeOfDay :: BoundedPrim TimeOfDay -timeOfDay = - liftFixedToBounded - ( (todHour >$< digits2) <> char ':' <> (todMin >$< digits2) <> char ':' - ) <> - (todSec >$< seconds) - - -utcTime :: BoundedPrim UTCTime -utcTime = - (utctDay >$< day) <> - liftFixedToBounded (char ' ') <> - (timeToTimeOfDay . utctDayTime >$< timeOfDay) <> - liftFixedToBounded (char 'Z') - - -localTime :: BoundedPrim LocalTime -localTime = - (localDay >$< day) <> - liftFixedToBounded (char ' ') <> - (localTimeOfDay >$< timeOfDay) - - -calendarDiffTime :: CalendarDiffTime -> Builder -calendarDiffTime = string7 . iso8601Show - - -char :: Char -> FixedPrim a -char c = (\_ -> c) >$< char8 - - -(<>) :: _ => f a -> f a -> f a -(<>) = divide (\a -> (a, a)) -infixr 6 <> - - -divide :: _ => (a -> (b, c)) -> f b -> f c -> f a -divide f a b = f >$< (a >*< b) diff --git a/src/Rel8/Type/Composite.hs b/src/Rel8/Type/Composite.hs index f4a2e4fa..0a6a537e 100644 --- a/src/Rel8/Type/Composite.hs +++ b/src/Rel8/Type/Composite.hs @@ -4,7 +4,6 @@ {-# language DisambiguateRecordFields #-} {-# language FlexibleContexts #-} {-# language GADTs #-} -{-# language LambdaCase #-} {-# language NamedFieldPuns #-} {-# language OverloadedStrings #-} {-# language ScopedTypeVariables #-} @@ -28,8 +27,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as A import Control.Applicative ((<|>), many, optional) import Data.Foldable (fold) import Data.Functor.Const (Const (Const), getConst) -import Data.Functor.Contravariant ((>$<)) -import Data.Functor.Identity (Identity (Identity), runIdentity) +import Data.Functor.Identity (Identity (Identity)) import Data.Kind ( Constraint, Type ) import Data.List (uncons) import Prelude @@ -37,14 +35,9 @@ import Prelude -- bytestring import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS -import Data.ByteString.Builder (Builder) -import Data.ByteString.Builder (toLazyByteString) -import qualified Data.ByteString.Builder as B -import Data.ByteString.Lazy (toStrict) -- hasql -import qualified Hasql.Decoders as Decoders -import qualified Hasql.Encoders as Encoders +import qualified Hasql.Decoders as Hasql -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye @@ -65,11 +58,8 @@ import Rel8.Table.Ord ( OrdTable ) import Rel8.Table.Rel8able () import Rel8.Table.Serialize ( litHTable ) import Rel8.Type ( DBType, typeInformation ) -import Rel8.Type.Builder.Fold (interfoldMap) import Rel8.Type.Decoder (Decoder (Decoder), Parser) import qualified Rel8.Type.Decoder as Decoder -import Rel8.Type.Encoder (Encoder (Encoder)) -import qualified Rel8.Type.Encoder as Encoder import Rel8.Type.Eq ( DBEq ) import Rel8.Type.Information ( TypeInformation(..) ) import Rel8.Type.Name (TypeName (..)) @@ -101,16 +91,11 @@ instance DBComposite a => DBType (Composite a) where typeInformation = TypeInformation { decode = Decoder - { binary = Decoders.composite (Composite . fromResult @_ @(HKD a Expr) <$> decoder) - , text = fmap (Composite . fromResult @_ @(HKD a Expr)) . parser + { binary = Hasql.composite (Composite . fromResult @_ @(HKD a Expr) <$> decoder) + , parser = fmap (Composite . fromResult @_ @(HKD a Expr)) . parser + , delimiter = ',' } - , encode = - Encoder - { binary = Encoders.composite (toResult @_ @(HKD a Expr) . unComposite >$< encoder) - , text = builder . toResult @_ @(HKD a Expr) . unComposite - , quote = quoter . litHTable . toResult @_ @(HKD a Expr) . unComposite - } - , delimiter = ',' + , encode = encoder . litHTable . toResult @_ @(HKD a Expr) . unComposite , typeName = TypeName { name = compositeTypeName @a @@ -150,7 +135,7 @@ class (DBType a, HKDable a) => DBComposite a where -- single column expression, by combining them into a PostgreSQL composite -- type. compose :: DBComposite a => HKD a Expr -> Expr a -compose = castExpr . fromPrimExpr . quoter . toColumns +compose = castExpr . fromPrimExpr . encoder . toColumns -- | Expand a composite type into a 'HKD'. @@ -165,13 +150,20 @@ decompose (toPrimExpr -> a) = fromColumns $ htabulate \field -> names = toColumns (compositeFields @a) -decoder :: HTable t => Decoders.Composite (t Result) +decoder :: HTable t => Hasql.Composite (t Result) decoder = unwrapApplicative $ htabulateA \field -> case hfield hspecs field of Spec {nullity, info} -> WrapApplicative $ Identity <$> case nullity of - Null -> Decoders.field $ Decoders.nullable $ Decoder.binary $ decode info - NotNull -> Decoders.field $ Decoders.nonNullable $ Decoder.binary $ 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 +encoder a = Opaleye.FunExpr "ROW" exprs + where + exprs = getConst $ htabulateA \field -> case hfield a field of + expr -> Const [toPrimExpr expr] parser :: HTable t => Parser (t Result) @@ -186,10 +178,10 @@ parser input = do mbytes <- StateT $ maybe missing pure . uncons lift $ Identity <$> case hfield hspecs field of Spec {nullity, info} -> case nullity of - Null -> traverse (Decoder.text (decode info)) mbytes + Null -> traverse (Decoder.parser (decode info)) mbytes NotNull -> case mbytes of Nothing -> Left "composite: unexpected null" - Just bytes -> Decoder.text (decode info) bytes + Just bytes -> Decoder.parser (decode info) bytes missing = Left "composite: missing fields" @@ -209,55 +201,3 @@ parseRow = parse $ do BS.singleton <$> do A.char '\\' <|> A.char '"' quote = "\"" <$ A.string "\"\"" - - -encoder :: forall t. HTable t => Encoders.Composite (t Result) -encoder = getConst $ htabulateA @t \field -> - case hfield hspecs field of - Spec {nullity, info} -> Const $ - runIdentity . (`hfield` field) >$< - case nullity of - Null -> Encoders.field $ Encoders.nullable build - NotNull -> Encoders.field $ Encoders.nonNullable build - where - build = Encoder.binary (encode info) - - -builder :: HTable t => t Result -> Builder -builder input = buildRow $ getConst $ htabulateA \field -> - Const $ pure $ - case hfield input field of - Identity a -> - case hfield hspecs field of - Spec {nullity, info} -> case nullity of - Null -> build <$> a - NotNull -> Just $ build a - where - build = - toStrict . toLazyByteString . Encoder.text (encode info) - - -buildRow :: [Maybe ByteString] -> Builder -buildRow elements = - B.char8 '(' <> - interfoldMap (B.char8 ',') (foldMap element) elements <> - B.char8 ')' - where - element a - | BS.null a = "\"\"" - | BS.all (A.notInClass escapeClass) a = B.byteString a - | otherwise = - B.char8 '"' <> BS.foldr ((<>) . escape) mempty a <> B.char8 '"' - where - escapeClass = ",\\\"()\t\n" - escape = \case - '"' -> B.string7 "\"\"" - '\\' -> B.string7 "\\\\" - c -> B.char8 c - - -quoter :: HTable t => t Expr -> Opaleye.PrimExpr -quoter a = Opaleye.FunExpr "ROW" exprs - where - exprs = getConst $ htabulateA \field -> case hfield a field of - expr -> Const [toPrimExpr expr] diff --git a/src/Rel8/Type/Decimal.hs b/src/Rel8/Type/Decimal.hs index 6fcd323f..1c6f94ed 100644 --- a/src/Rel8/Type/Decimal.hs +++ b/src/Rel8/Type/Decimal.hs @@ -100,4 +100,4 @@ 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") + TypeError ('ShowType n ':<>: 'Text " is not a power of 10") \ No newline at end of file diff --git a/src/Rel8/Type/Decoder.hs b/src/Rel8/Type/Decoder.hs index c04ac7f1..5322e7c5 100644 --- a/src/Rel8/Type/Decoder.hs +++ b/src/Rel8/Type/Decoder.hs @@ -1,11 +1,12 @@ {-# language DerivingStrategies #-} {-# language DeriveFunctor #-} +{-# language GADTs #-} {-# language NamedFieldPuns #-} {-# language StandaloneKindSignatures #-} -{-# language DuplicateRecordFields #-} module Rel8.Type.Decoder ( Decoder (..), + NullableOrNot (..), Parser, parseDecoder, ) where @@ -34,8 +35,11 @@ type Decoder :: Type -> Type data Decoder a = Decoder { binary :: Hasql.Value a -- ^ How to deserialize from PostgreSQL's binary format. - , text :: Parser a + , 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) @@ -46,9 +50,15 @@ data Decoder a = Decoder -- a given 'Decoder'. The parser is applied when deserializing rows -- returned. parseDecoder :: (a -> Either String b) -> Decoder a -> Decoder b -parseDecoder f Decoder {binary, text} = +parseDecoder f Decoder {binary, parser, delimiter} = Decoder { binary = Hasql.refine (first Text.pack . f) binary - , text = text >=> f + , 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/Encoder.hs b/src/Rel8/Type/Encoder.hs deleted file mode 100644 index 3d0dbbb0..00000000 --- a/src/Rel8/Type/Encoder.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# language LambdaCase #-} -{-# language NamedFieldPuns #-} -{-# language RecordWildCards #-} -{-# language StandaloneKindSignatures #-} -{-# language StrictData #-} -{-# language DuplicateRecordFields #-} - -module Rel8.Type.Encoder ( - Encoder (..), -) where - --- base -import Data.Functor.Contravariant (Contravariant, (>$<), contramap) -import Data.Kind (Type) -import Prelude - --- bytestring -import Data.ByteString.Builder (Builder) - --- hasql -import qualified Hasql.Encoders as Hasql - --- opaleye -import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye - - -type Encoder :: Type -> Type -data Encoder a = Encoder - { binary :: Hasql.Value a - -- ^ How to serialize to PostgreSQL's binary format. - , text :: a -> Builder - -- ^ How to serialize to PostgreSQL's text format. - , quote :: a -> Opaleye.PrimExpr - -- ^ How to encode a single Haskell value as an SQL expression. - } - - -instance Contravariant Encoder where - contramap f Encoder {..} = Encoder - { binary = f >$< binary - , text = text . f - , quote = quote . f - } diff --git a/src/Rel8/Type/Enum.hs b/src/Rel8/Type/Enum.hs index c9c0e692..6527dd0f 100644 --- a/src/Rel8/Type/Enum.hs +++ b/src/Rel8/Type/Enum.hs @@ -1,7 +1,5 @@ {-# language AllowAmbiguousTypes #-} {-# language DataKinds #-} -{-# language DefaultSignatures #-} -{-# language DisambiguateRecordFields #-} {-# language FlexibleContexts #-} {-# language FlexibleInstances #-} {-# language LambdaCase #-} @@ -15,7 +13,7 @@ module Rel8.Type.Enum ( Enum( Enum ) - , DBEnum( enumValue, enumTypeName, enumerate ) + , DBEnum( enumValue, enumTypeName ) , Enumable ) where @@ -34,8 +32,7 @@ import GHC.TypeLits ( KnownSymbol, symbolVal ) import Prelude hiding ( Enum ) -- hasql -import qualified Hasql.Decoders as Decoders -import qualified Hasql.Encoders as Encoders +import qualified Hasql.Decoders as Hasql -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye @@ -44,7 +41,6 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye import Rel8.Schema.QualifiedName (QualifiedName) import Rel8.Type ( DBType, typeInformation ) import Rel8.Type.Decoder (Decoder (..)) -import Rel8.Type.Encoder (Encoder (..)) import Rel8.Type.Eq ( DBEq ) import Rel8.Type.Information ( TypeInformation(..) ) import Rel8.Type.Name (TypeName (..)) @@ -52,7 +48,7 @@ import Rel8.Type.Ord ( DBOrd, DBMax, DBMin ) -- text import Data.Text (pack) -import Data.Text.Encoding (decodeUtf8, encodeUtf8Builder) +import Data.Text.Encoding (decodeUtf8) -- | A deriving-via helper type for column types that store an \"enum\" type @@ -73,29 +69,21 @@ newtype Enum a = Enum instance DBEnum a => DBType (Enum a) where typeInformation = TypeInformation - { encode = + { decode = let - toText (Enum a) = pack $ enumValue a - in - Encoder - { binary = Encoders.enum toText - , text = encodeUtf8Builder . toText - , quote = - Opaleye.ConstExpr . - Opaleye.StringLit . - enumValue @a . - unEnum - } - , decode = - let - mapping = (pack . enumValue &&& Enum) <$> enumerate + mapping = (pack . enumValue &&& Enum) . to <$> genumerate @(Rep a) unrecognised = Left "enum: unrecognised value" in Decoder - { binary = Decoders.enum (`lookup` mapping) - , text = maybe unrecognised pure . (`lookup` mapping) . decodeUtf8 + { binary = Hasql.enum (`lookup` mapping) + , parser = maybe unrecognised pure . (`lookup` mapping) . decodeUtf8 + , delimiter = ',' } - , delimiter = ',' + , encode = + Opaleye.ConstExpr . + Opaleye.StringLit . + enumValue @a . + unEnum , typeName = TypeName { name = enumTypeName @a @@ -119,24 +107,16 @@ instance DBEnum a => DBMin (Enum a) -- | @DBEnum@ contains the necessary metadata to describe a PostgreSQL @enum@ type. type DBEnum :: Type -> Constraint -class DBType a => DBEnum a where +class (DBType a, Enumable a) => DBEnum a where -- | Map Haskell values to the corresponding element of the @enum@ type. The -- default implementation of this method will use the exact name of the -- Haskell constructors. enumValue :: a -> String + enumValue = gshow @(Rep a) . from -- | The name of the PostgreSQL @enum@ type that @a@ maps to. enumTypeName :: QualifiedName - -- | List of all possible values of the enum type. - enumerate :: [a] - - default enumValue :: Enumable a => a -> String - enumValue = gshow @(Rep a) . from - - default enumerate :: Enumable a => [a] - enumerate = to <$> genumerate @(Rep a) - -- | Types that are sum types, where each constructor is unary (that is, has no -- fields). diff --git a/src/Rel8/Type/Information.hs b/src/Rel8/Type/Information.hs index 3be42165..ac27cf84 100644 --- a/src/Rel8/Type/Information.hs +++ b/src/Rel8/Type/Information.hs @@ -3,39 +3,40 @@ {-# language StandaloneKindSignatures #-} {-# language StrictData #-} -module Rel8.Type.Information ( - TypeInformation(..), - mapTypeInformation, - parseTypeInformation, -) where +module Rel8.Type.Information + ( TypeInformation(..) + , mapTypeInformation + , parseTypeInformation + ) +where -- base -import Data.Functor.Contravariant ((>$<)) -import Data.Kind (Type) +import Data.Kind ( Type ) import Prelude +-- opaleye +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye + -- rel8 -import Rel8.Type.Decoder (Decoder, parseDecoder) -import Rel8.Type.Encoder (Encoder) import Rel8.Type.Name (TypeName) +-- text +import Rel8.Type.Decoder (Decoder, parseDecoder) + -- | @TypeInformation@ describes how to encode and decode a Haskell type to and -- from database queries. The @typeName@ is the name of the type in the -- database, which is used to accurately type literals. type TypeInformation :: Type -> Type data TypeInformation a = TypeInformation - { encode :: Encoder a - -- ^ How to serialize a Haskell value to PostgreSQL. + { encode :: a -> Opaleye.PrimExpr + -- ^ How to encode a single Haskell value as a SQL expression. , decode :: Decoder a - -- ^ How to deserialize a PostgreSQL result back to Haskell. - , delimiter :: Char - -- ^ The delimiter that is used in PostgreSQL's text format in arrays of - -- this type (this is almost always ','). + -- ^ How to deserialize a single result back to Haskell. , typeName :: TypeName -- ^ The name of the SQL type. } - + -- | Simultaneously map over how a type is both encoded and decoded, while -- retaining the name of the type. This operation is useful if you want to @@ -58,10 +59,9 @@ mapTypeInformation = parseTypeInformation . fmap pure parseTypeInformation :: () => (a -> Either String b) -> (b -> a) -> TypeInformation a -> TypeInformation b -parseTypeInformation to from TypeInformation {encode, decode, delimiter, typeName} = +parseTypeInformation to from TypeInformation {encode, decode, typeName} = TypeInformation - { decode = parseDecoder to decode - , encode = from >$< encode - , delimiter + { encode = encode . from + , decode = parseDecoder to decode , typeName } diff --git a/src/Rel8/Type/JSONBEncoded.hs b/src/Rel8/Type/JSONBEncoded.hs index bd0b6d3a..4cf4bd50 100644 --- a/src/Rel8/Type/JSONBEncoded.hs +++ b/src/Rel8/Type/JSONBEncoded.hs @@ -1,40 +1,30 @@ -{-# language DisambiguateRecordFields #-} {-# language OverloadedStrings #-} {-# language StandaloneKindSignatures #-} -module Rel8.Type.JSONBEncoded ( - JSONBEncoded(..), -) where +module Rel8.Type.JSONBEncoded + ( JSONBEncoded(..) + ) +where -- aeson import Data.Aeson (FromJSON, ToJSON, eitherDecodeStrict, parseJSON, toJSON) -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Text as Aeson import Data.Aeson.Types (parseEither) -- base import Data.Bifunctor ( first ) -import Data.Functor.Contravariant ((>$<)) import Data.Kind ( Type ) import Prelude -- hasql -import qualified Hasql.Decoders as Decoders -import qualified Hasql.Encoders as Encoders - --- opaleye -import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye -import qualified Opaleye.Internal.HaskellDB.Sql.Default as Opaleye (quote) +import qualified Hasql.Decoders as Hasql -- rel8 import Rel8.Type ( DBType(..) ) import Rel8.Type.Decoder (Decoder (..)) -import Rel8.Type.Encoder (Encoder (..)) import Rel8.Type.Information ( TypeInformation(..) ) -- text import Data.Text ( pack ) -import Data.Text.Lazy (unpack) -- | Like 'Rel8.JSONEncoded', but works for @jsonb@ columns. @@ -42,26 +32,14 @@ type JSONBEncoded :: Type -> Type newtype JSONBEncoded a = JSONBEncoded { fromJSONBEncoded :: a } deriving (Show, Eq, Ord) - instance (FromJSON a, ToJSON a) => DBType (JSONBEncoded a) where typeInformation = TypeInformation - { encode = - Encoder - { binary = toJSON . fromJSONBEncoded >$< Encoders.jsonb - , text = Aeson.fromEncoding . Aeson.toEncoding . fromJSONBEncoded - , quote = - Opaleye.ConstExpr . Opaleye.OtherLit . - Opaleye.quote . - unpack . Aeson.encodeToLazyText . fromJSONBEncoded - } + { encode = encode typeInformation . toJSON . fromJSONBEncoded , decode = Decoder - { binary = - Decoders.refine - (first pack . fmap JSONBEncoded . parseEither parseJSON) - Decoders.jsonb - , text = fmap JSONBEncoded . eitherDecodeStrict + { binary = Hasql.refine (first pack . fmap JSONBEncoded . parseEither parseJSON) Hasql.jsonb + , parser = fmap JSONBEncoded . eitherDecodeStrict + , delimiter = ',' } - , delimiter = ',' , typeName = "jsonb" } diff --git a/src/Rel8/Type/JSONEncoded.hs b/src/Rel8/Type/JSONEncoded.hs index 398e73ce..8194e001 100644 --- a/src/Rel8/Type/JSONEncoded.hs +++ b/src/Rel8/Type/JSONEncoded.hs @@ -1,41 +1,35 @@ -{-# language DisambiguateRecordFields #-} {-# language StandaloneKindSignatures #-} -{-# language OverloadedStrings #-} -{-# language TypeApplications #-} +{-# language OverloadedStrings #-} +{-# language TypeApplications #-} -module Rel8.Type.JSONEncoded ( - JSONEncoded(..), -) where +module Rel8.Type.JSONEncoded ( JSONEncoded(..) ) where -- aeson -import Data.Aeson (FromJSON, ToJSON, eitherDecodeStrict, parseJSON, toJSON) +import Data.Aeson ( FromJSON, ToJSON, parseJSON ) +import Data.Aeson.Types ( parseEither ) import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Text as Aeson -import Data.Aeson.Types (parseEither) -- base -import Data.Bifunctor (first) -import Data.Functor.Contravariant ((>$<)) import Data.Kind ( Type ) +import Data.Bifunctor (first) import Prelude -- hasql -import qualified Hasql.Decoders as Decoders -import qualified Hasql.Encoders as Encoders +import qualified Hasql.Decoders as Hasql -- rel8 import Rel8.Type ( DBType(..) ) -import Rel8.Type.Decoder (Decoder (..)) -import Rel8.Type.Encoder (Encoder (..)) import Rel8.Type.Information ( TypeInformation(..) ) +import Rel8.Type.Decoder ( Decoder(..) ) -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye import qualified Opaleye.Internal.HaskellDB.Sql.Default as Opaleye ( quote ) -- text -import Data.Text (pack) -import Data.Text.Lazy (unpack) +import qualified Data.Text as Text +import qualified Data.Text.Lazy as Lazy +import qualified Data.Text.Lazy.Encoding as Lazy -- | A deriving-via helper type for column types that store a Haskell value @@ -49,21 +43,14 @@ newtype JSONEncoded a = JSONEncoded { fromJSONEncoded :: a } instance (FromJSON a, ToJSON a) => DBType (JSONEncoded a) where typeInformation = TypeInformation { encode = - Encoder - { binary = toJSON . fromJSONEncoded >$< Encoders.json - , text = Aeson.fromEncoding . Aeson.toEncoding . fromJSONEncoded - , quote = - Opaleye.ConstExpr . Opaleye.OtherLit . Opaleye.quote . - unpack . Aeson.encodeToLazyText . fromJSONEncoded - } + Opaleye.ConstExpr . Opaleye.OtherLit . Opaleye.quote . + Lazy.unpack . Lazy.decodeUtf8 . + Aeson.encode . fromJSONEncoded , decode = Decoder - { binary = - Decoders.refine - (first pack . fmap JSONEncoded . parseEither parseJSON) - Decoders.json - , text = fmap JSONEncoded . eitherDecodeStrict + { binary = Hasql.refine (first Text.pack . fmap JSONEncoded . parseEither parseJSON) Hasql.json + , parser = fmap JSONEncoded . Aeson.eitherDecodeStrict + , delimiter = ',' } - , delimiter = ',' , typeName = "json" } diff --git a/src/Rel8/Type/Monoid.hs b/src/Rel8/Type/Monoid.hs index 95bde50d..d9623eac 100644 --- a/src/Rel8/Type/Monoid.hs +++ b/src/Rel8/Type/Monoid.hs @@ -24,13 +24,11 @@ import qualified Data.ByteString.Lazy as Lazy ( ByteString ) import Data.CaseInsensitive ( CI ) -- rel8 -import Rel8.Data.Range (Multirange (Multirange)) import {-# SOURCE #-} Rel8.Expr ( Expr ) import Rel8.Expr.Array ( sempty ) import Rel8.Expr.Serialize ( litExpr ) import Rel8.Schema.Null ( Sql ) import Rel8.Type ( DBType, typeInformation ) -import Rel8.Type.Range (DBRange) import Rel8.Type.Semigroup ( DBSemigroup ) -- text @@ -79,7 +77,3 @@ instance DBMonoid ByteString where instance DBMonoid Lazy.ByteString where memptyExpr = litExpr "" - - -instance DBRange a => DBMonoid (Multirange a) where - memptyExpr = litExpr (Multirange []) diff --git a/src/Rel8/Type/Nullable.hs b/src/Rel8/Type/Nullable.hs deleted file mode 100644 index 95d3439f..00000000 --- a/src/Rel8/Type/Nullable.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# language GADTs #-} -{-# language StandaloneKindSignatures #-} - -module Rel8.Type.Nullable ( - NullableOrNot (..), -) where - --- base -import Data.Kind (Type) -import Prelude - - -type NullableOrNot :: (Type -> Type) -> Type -> Type -data NullableOrNot decoder a where - NonNullable :: decoder a -> NullableOrNot decoder a - Nullable :: decoder a -> NullableOrNot decoder (Maybe a) diff --git a/src/Rel8/Type/Range.hs b/src/Rel8/Type/Range.hs deleted file mode 100644 index 7dfaeb39..00000000 --- a/src/Rel8/Type/Range.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE OverloadedStrings #-} - -module Rel8.Type.Range ( - DBRange ( - rangeTypeName, rangeDecoder, rangeEncoder, - multirangeTypeName, multirangeDecoder, multirangeEncoder - ), -) where - --- base -import Data.Int (Int32, Int64) - --- hasql -import qualified Hasql.Decoders as Decoder -import qualified Hasql.Encoders as Encoder - --- postgresql-binary -import qualified PostgreSQL.Binary.Range as PostgreSQL - --- rel8 -import Rel8.Schema.QualifiedName (QualifiedName) -import Rel8.Type.Ord (DBOrd) - --- scientific -import Data.Scientific (Scientific) - --- time -import Data.Time.Calendar (Day) -import Data.Time.Clock (UTCTime) -import Data.Time.LocalTime (LocalTime) - - -class DBOrd a => DBRange a where - rangeTypeName :: QualifiedName - rangeDecoder :: Decoder.Value (PostgreSQL.Range a) - rangeEncoder :: Encoder.Value (PostgreSQL.Range a) - - multirangeTypeName :: QualifiedName - multirangeDecoder :: Decoder.Value (PostgreSQL.Multirange a) - multirangeEncoder :: Encoder.Value (PostgreSQL.Multirange a) - - -instance DBRange Int32 where - rangeTypeName = "int4range" - rangeDecoder = Decoder.int4range - rangeEncoder = Encoder.int4range - multirangeTypeName = "int4multirange" - multirangeDecoder = Decoder.int4multirange - multirangeEncoder = Encoder.int4multirange - - -instance DBRange Int64 where - rangeTypeName = "int8range" - rangeDecoder = Decoder.int8range - rangeEncoder = Encoder.int8range - multirangeTypeName = "int8multirange" - multirangeDecoder = Decoder.int8multirange - multirangeEncoder = Encoder.int8multirange - - -instance DBRange Scientific where - rangeTypeName = "numrange" - rangeDecoder = Decoder.numrange - rangeEncoder = Encoder.numrange - multirangeTypeName = "nummultirange" - multirangeDecoder = Decoder.nummultirange - multirangeEncoder = Encoder.nummultirange - - -instance DBRange LocalTime where - rangeTypeName = "tsrange" - rangeDecoder = Decoder.tsrange - rangeEncoder = Encoder.tsrange - multirangeTypeName = "tsmultirange" - multirangeDecoder = Decoder.tsmultirange - multirangeEncoder = Encoder.tsmultirange - - -instance DBRange UTCTime where - rangeTypeName = "tstzrange" - rangeDecoder = Decoder.tstzrange - rangeEncoder = Encoder.tstzrange - multirangeTypeName = "tstzmultirange" - multirangeDecoder = Decoder.tstzmultirange - multirangeEncoder = Encoder.tstzmultirange - - -instance DBRange Day where - rangeTypeName = "daterange" - rangeDecoder = Decoder.daterange - rangeEncoder = Encoder.daterange - multirangeTypeName = "datemultirange" - multirangeDecoder = Decoder.datemultirange - multirangeEncoder = Encoder.datemultirange diff --git a/src/Rel8/Type/Semigroup.hs b/src/Rel8/Type/Semigroup.hs index 93f595d2..c76e8e45 100644 --- a/src/Rel8/Type/Semigroup.hs +++ b/src/Rel8/Type/Semigroup.hs @@ -28,13 +28,11 @@ import Data.CaseInsensitive ( CI ) import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye -- rel8 -import Rel8.Data.Range (Multirange) import {-# SOURCE #-} Rel8.Expr ( Expr ) import Rel8.Expr.Array ( sappend, sappend1 ) import Rel8.Expr.Opaleye ( zipPrimExprsWith ) import Rel8.Schema.Null ( Sql ) import Rel8.Type ( DBType ) -import Rel8.Type.Range (DBRange) -- text import Data.Text ( Text ) @@ -87,7 +85,3 @@ instance DBSemigroup ByteString where instance DBSemigroup Lazy.ByteString where (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||)) - - -instance DBRange a => DBSemigroup (Multirange a) where - (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:+)) diff --git a/tests/Main.hs b/tests/Main.hs index 9c2753e6..75398c6c 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,12 +1,10 @@ {-# language BangPatterns #-} {-# language BlockArguments #-} -{-# language CPP #-} {-# language DeriveAnyClass #-} {-# language DeriveGeneric #-} {-# language DerivingVia #-} {-# language FlexibleContexts #-} {-# language FlexibleInstances #-} -{-# language LambdaCase #-} {-# language MonoLocalBinds #-} {-# language NamedFieldPuns #-} {-# language OverloadedStrings #-} @@ -35,17 +33,16 @@ import Data.Foldable ( for_ ) import Data.Fixed (Centi) import Data.Functor (void) import Data.Int ( Int32, Int64 ) -import Data.List ( isInfixOf, nub, sort ) +import Data.List ( nub, sort ) import Data.Maybe ( catMaybes ) import Data.Ratio ((%)) -import Data.Word (Word32) +import Data.String ( fromString ) +import Data.Word (Word32, Word8) import GHC.Generics ( Generic ) import Prelude hiding (truncate) -- bytestring -import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy -import Data.ByteString ( ByteString ) -- case-insensitive import Data.CaseInsensitive ( mk ) @@ -55,39 +52,30 @@ import Data.Containers.ListUtils ( nubOrdOn ) import qualified Data.Map.Strict as Map -- hasql -import Hasql.Connection ( Connection, ConnectionError, acquire, release ) -#if MIN_VERSION_hasql(1,9,0) -import qualified Hasql.Connection.Setting -import qualified Hasql.Connection.Setting.Connection -#endif +import Hasql.Connection ( Connection, acquire, release ) import Hasql.Session ( sql, run ) -- hasql-transaction import Hasql.Transaction ( Transaction, condemn, statement ) -import qualified Hasql.Transaction as Hasql import qualified Hasql.Transaction.Sessions as Hasql -- hedgehog -import Hedgehog ( annotate, assert, failure, property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen ) +import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen ) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range --- iproute -import qualified Data.IP - -- mmorph import Control.Monad.Morph ( hoist ) +-- network-ip +import Network.IP.Addr (NetAddr, IP, IP4(..), IP6(..), IP46(..), net4Addr, net6Addr, fromNetAddr46, Net4Addr, Net6Addr) +import Data.DoubleWord (Word128(..)) + +import qualified Data.IP + -- rel8 import Rel8 ( Result ) import qualified Rel8 -import qualified Rel8.Generic.Rel8able.Test as Rel8able -import qualified Rel8.Table.Verify as Verify -import Rel8.Range ( - Bound (Incl, Excl, Inf), - Range (Empty, Range), - Multirange (Multirange), - ) -- scientific import Data.Scientific ( Scientific ) @@ -99,7 +87,7 @@ import Test.Tasty import Test.Tasty.Hedgehog ( testProperty ) -- text -import Data.Text ( Text, unpack ) +import Data.Text ( Text, pack, unpack ) import qualified Data.Text as T import qualified Data.Text.Lazy import Data.Text.Encoding ( decodeUtf8 ) @@ -146,6 +134,7 @@ tests = , testDBEq getTestDatabase , testTableEquality getTestDatabase , testFromRational getTestDatabase + , testFromString getTestDatabase , testCatMaybeTable getTestDatabase , testCatMaybe getTestDatabase , testMaybeTable getTestDatabase @@ -160,20 +149,20 @@ tests = , testSelectArray getTestDatabase , testNestedMaybeTable getTestDatabase , testEvaluate getTestDatabase - , testSelectTruncated getTestDatabase - , testShowCreateTable getTestDatabase ] + where + startTestDatabase = do db <- TmpPostgres.start >>= either throwIO return - bracket (either (error . show) return =<< acquireFromConnectionString (TmpPostgres.toConnectionString db)) release \conn -> void do + bracket (either (error . show) return =<< acquire (TmpPostgres.toConnectionString db)) release \conn -> void do flip run conn do sql "CREATE EXTENSION citext" sql "CREATE TABLE test_table ( column1 text not null, column2 bool not null )" sql "CREATE TABLE unique_table ( \"key\" text not null unique, \"value\" text not null )" sql "CREATE SEQUENCE test_seq" - sql "CREATE TYPE composite AS (\"bool\" bool, \"char\" text, \"array\" int4[])" + sql "CREATE TYPE composite AS (\"bool\" bool, \"char\" char, \"array\" int4[])" return db @@ -181,117 +170,7 @@ tests = connect :: TmpPostgres.DB -> IO Connection -connect = acquireFromConnectionString . TmpPostgres.toConnectionString >=> either (maybe empty (fail . unpack . decodeUtf8)) pure - -acquireFromConnectionString :: ByteString -> IO (Either ConnectionError Connection) -acquireFromConnectionString connectionString = -#if MIN_VERSION_hasql(1,9,0) - acquire - [ Hasql.Connection.Setting.connection . Hasql.Connection.Setting.Connection.string . decodeUtf8 $ connectionString - ] -#else - acquire connectionString -#endif - -testShowCreateTable :: IO TmpPostgres.DB -> TestTree -testShowCreateTable getTestDatabase = testGroup "CREATE TABLE" - [ testTypeChecker "tableTest" Rel8able.tableTest Rel8able.genTableTest getTestDatabase - , testTypeChecker "tablePair" Rel8able.tablePair Rel8able.genTablePair getTestDatabase - , testTypeChecker "tableMaybe" Rel8able.tableMaybe Rel8able.genTableMaybe getTestDatabase - , testTypeChecker "tableEither" Rel8able.tableEither Rel8able.genTableEither getTestDatabase - , testTypeChecker "tableThese" Rel8able.tableThese Rel8able.genTableThese getTestDatabase - , testTypeChecker "tableList" Rel8able.tableList Rel8able.genTableList getTestDatabase - , testTypeChecker "tableNest" Rel8able.tableNest Rel8able.genTableNest getTestDatabase - , testTypeChecker "nonRecord" Rel8able.nonRecord Rel8able.genNonRecord getTestDatabase - , testTypeChecker "tableProduct" Rel8able.tableProduct Rel8able.genTableProduct getTestDatabase - , testTypeChecker "tableType" Rel8able.tableType Rel8able.genTableType getTestDatabase - , testWrongTable getTestDatabase - , testDuplicateTable getTestDatabase - , testCharMismatch getTestDatabase - , testNumericMismatch getTestDatabase - ] - where - -- confirms that the type checker works correctly for numeric modifiers - testNumericMismatch = databasePropertyTest "numeric mismatch" \transaction -> transaction do - lift $ Hasql.sql $ "create table \"tableNumeric\" ( foo numeric(1000, 4) not null );" - typeErrors <- lift $ statement () $ Verify.getSchemaErrors - [Verify.SomeTableSchema Rel8able.tableNumeric] - case typeErrors of - Nothing -> failure - Just _ -> pure () - lift $ Hasql.sql $ "alter table \"tableNumeric\" alter column foo set data type numeric(1000, 2);" - typeErrors <- lift $ statement () $ Verify.getSchemaErrors - [Verify.SomeTableSchema Rel8able.tableNumeric] - case typeErrors of - Nothing -> pure () - Just _ -> failure - - -- tests that the type checker works correctly for bpchar modifiers - testCharMismatch = databasePropertyTest "bpchar mismatch" \transaction -> transaction do - lift $ Hasql.sql $ "create table \"tableChar\" ( foo bpchar(2) not null );" - typeErrors <- lift $ statement () $ Verify.getSchemaErrors - [Verify.SomeTableSchema Rel8able.tableChar] - case typeErrors of - Nothing -> failure - Just _ -> pure () - lift $ Hasql.sql $ "alter table \"tableChar\" alter column foo set data type bpchar(1);" - typeErrors <- lift $ statement () $ Verify.getSchemaErrors - [Verify.SomeTableSchema Rel8able.tableChar] - case typeErrors of - Nothing -> pure () - Just a -> do - annotate (unpack a) - failure - - -- confirms that the type checker fails when no type errors are present in a - -- table with duplicate column names - testDuplicateTable = databasePropertyTest "duplicate columns" \transaction -> transaction do - lift $ Hasql.sql $ B.pack $ Verify.showCreateTable Rel8able.tableDuplicate - typeErrors <- lift $ statement () $ Verify.getSchemaErrors - [Verify.SomeTableSchema Rel8able.tableDuplicate] - case typeErrors of - Nothing -> failure - Just _ -> pure () - - -- confirms that the type checker fails if the types mismatch - testWrongTable = databasePropertyTest "type mismatch" \transaction -> transaction do - lift $ Hasql.sql $ B.pack $ Verify.showCreateTable Rel8able.tableType - typeErrors <- lift $ statement () $ Verify.getSchemaErrors - [Verify.SomeTableSchema Rel8able.badTableType] - case typeErrors of - Nothing -> failure - Just _ -> pure () - - testTypeChecker :: - ( Show (k Result), Rel8.Rel8able k, Rel8.Selects (k Rel8.Name) (k Rel8.Expr) - , Rel8.Serializable (k Rel8.Expr) (k Rel8.Result)) - => TestName -> Rel8.TableSchema (k Rel8.Name) -> Gen (k Result) -> IO TmpPostgres.DB -> TestTree - testTypeChecker testName tableSchema genRows = databasePropertyTest testName \transaction -> do - rows <- forAll $ Gen.list (Range.linear 0 10) genRows - - transaction do - lift $ Hasql.sql $ B.pack $ Verify.showCreateTable tableSchema - typeErrors <- lift $ statement () $ Verify.getSchemaErrors [Verify.SomeTableSchema tableSchema] - case typeErrors of - Nothing -> pure () - Just typ -> do - annotate (unpack typ) - failure - - selected <- lift do - statement () $ Rel8.run_ $ Rel8.insert Rel8.Insert - { into = tableSchema - , rows = Rel8.values $ map Rel8.lit rows - , onConflict = Rel8.DoNothing Nothing - , returning = Rel8.NoReturning - } - statement () $ Rel8.run $ Rel8.select do - Rel8.each tableSchema - - -- not every type we use this with has an ord instance, and we're - -- primarily checking the type checker here, not the parser/printer, - -- so we this is only here as one additional check - length selected === length rows +connect = acquire . TmpPostgres.toConnectionString >=> either (maybe empty (fail . unpack . decodeUtf8)) pure databasePropertyTest @@ -340,7 +219,7 @@ testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction - statement () $ Rel8.run_ $ Rel8.insert Rel8.Insert { into = testTableSchema , rows = Rel8.values $ map Rel8.lit rows - , onConflict = Rel8.DoNothing Nothing + , onConflict = Rel8.DoNothing , returning = Rel8.NoReturning } @@ -551,7 +430,7 @@ testAp = databasePropertyTest "Cartesian product (<*>)" \transaction -> do data Composite = Composite { bool :: !Bool - , char :: !Text + , char :: !Char , array :: ![Int32] } deriving stock (Eq, Show, Generic) @@ -562,15 +441,18 @@ instance Rel8.DBComposite Composite where compositeTypeName = "composite" compositeFields = Rel8.namesFromLabels +-- | Postgres doesn't support the NULL character (not to be confused with a NULL value) inside strings. +removeNull :: Text -> Text +removeNull = T.filter (/='\0') + 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 "Char" Gen.unicode - , dbTypeTest "CI Lazy Text" $ mk . Data.Text.Lazy.fromStrict <$> genText - , dbTypeTest "CI Text" $ mk <$> genText + , dbTypeTest "CI Lazy Text" $ mk . Data.Text.Lazy.fromStrict . removeNull <$> Gen.text (Range.linear 0 10) Gen.unicode + , dbTypeTest "CI Text" $ mk .removeNull <$> 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) @@ -579,20 +461,18 @@ testDBType getTestDatabase = testGroup "DBType instances" , 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 <$> genText + , dbTypeTest "Lazy Text" $ Data.Text.Lazy.fromStrict . removeNull <$> Gen.text (Range.linear 0 10) Gen.unicode , dbTypeTest "LocalTime" genLocalTime , dbTypeTest "Scientific" $ genScientific - , dbTypeTest "Text" genText + , dbTypeTest "Text" $ removeNull <$> 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 , dbTypeTest "INet" genIPRange , dbTypeTest "Value" genValue , dbTypeTest "JSONEncoded" genJSONEncoded , dbTypeTest "JSONBEncoded" genJSONBEncoded - , dbTypeTest "Object" genObject - , dbTypeTest "Range" genRange - , dbTypeTest "Multirange" genMultirange ] where @@ -602,10 +482,10 @@ testDBType getTestDatabase = testGroup "DBType instances" , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase ] - t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBType a, Rel8.ToExprs (Rel8.Expr a) 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 ()) - -> PropertyT IO () + -> (TestT Transaction () -> PropertyT IO b) + -> PropertyT IO b t generator transaction = do x <- forAll generator y <- forAll generator @@ -646,31 +526,7 @@ testDBType getTestDatabase = testGroup "DBType instances" Rel8.aggregate Rel8.listCatExpr $ Rel8.values $ map Rel8.litExpr xsss diff res''''' (==) (concat xsss) - - transaction do - res <- lift do - statement x $ Rel8.prepared Rel8.run1 $ - Rel8.select @(Rel8.Expr _) . - pure - diff res (==) x - - res' <- lift do - statement [x, y] $ Rel8.prepared Rel8.run1 $ - Rel8.select @(Rel8.ListTable Rel8.Expr (Rel8.Expr _)) . - Rel8.many . Rel8.catListTable - diff res' (==) [x, y] - - res'' <- lift do - statement [[x, y]] $ Rel8.prepared Rel8.run1 $ - Rel8.select @(Rel8.ListTable Rel8.Expr (Rel8.ListTable Rel8.Expr (Rel8.Expr _))) . - Rel8.many . Rel8.many . (Rel8.catListTable >=> Rel8.catListTable) - diff res'' (==) [[x, y]] - - res''' <- lift do - statement [[[x, y]]] $ Rel8.prepared Rel8.run1 $ - Rel8.select @(Rel8.ListTable Rel8.Expr (Rel8.ListTable Rel8.Expr (Rel8.ListTable Rel8.Expr (Rel8.Expr _)))) . - Rel8.many . Rel8.many . Rel8.many . (Rel8.catListTable >=> Rel8.catListTable >=> Rel8.catListTable) - diff res''' (==) [[[x, y]]] + genScientific :: Gen Scientific genScientific = (/ 10) . fromIntegral @Int @Scientific <$> Gen.integral (Range.linear (-100) 100) @@ -678,7 +534,7 @@ testDBType getTestDatabase = testGroup "DBType instances" genComposite :: Gen Composite genComposite = do bool <- Gen.bool - char <- genText + char <- Gen.unicode array <- Gen.list (Range.linear 0 10) (Gen.int32 (Range.linear (-10000) 10000)) pure Composite {..} @@ -712,13 +568,29 @@ testDBType getTestDatabase = testGroup "DBType instances" 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 ] + genIPRange :: Gen (Data.IP.IPRange) genIPRange = - Gen.choice - [ Data.IP.IPv4Range <$> (Data.IP.makeAddrRange <$> genIPv4 <*> genIP4Mask) - , Data.IP.IPv6Range <$> (Data.IP.makeAddrRange <$> genIPv6 <*> genIP6Mask) - ] - where + let genIP4Mask :: Gen Int genIP4Mask = Gen.integral (Range.linearFrom 0 0 32) @@ -731,107 +603,31 @@ testDBType getTestDatabase = testGroup "DBType instances" genIPv6 :: Gen (Data.IP.IPv6) genIPv6 = Data.IP.toIPv6w <$> ((,,,) <$> genWord32 <*> genWord32 <*> genWord32 <*> genWord32) + in Gen.choice [ Data.IP.IPv4Range <$> (Data.IP.makeAddrRange <$> genIPv4 <*> genIP4Mask), Data.IP.IPv6Range <$> (Data.IP.makeAddrRange <$> genIPv6 <*> genIP6Mask)] + genKey :: Gen Aeson.Key - genKey = Aeson.Key.fromText <$> genText + genKey = Aeson.Key.fromText <$> Gen.text (Range.linear 0 10) Gen.unicode genValue :: Gen Aeson.Value genValue = Gen.recursive Gen.choice [ pure Aeson.Null , Aeson.Bool <$> Gen.bool , Aeson.Number <$> genScientific - , Aeson.String <$> genText - ] - [ Aeson.Object <$> genObject + , Aeson.String <$> Gen.text (Range.linear 0 10) Gen.unicode] + [ Aeson.Object . Aeson.KeyMap.fromMap <$> Gen.map (Range.linear 0 10) ((,) <$> genKey <*> genValue) , Aeson.Array . Vector.fromList <$> Gen.list (Range.linear 0 10) genValue ] genJSONEncoded = Rel8.JSONEncoded <$> genValue genJSONBEncoded = Rel8.JSONBEncoded <$> genValue - genObject :: Gen Aeson.Object - genObject = Aeson.KeyMap.fromMap <$> Gen.map (Range.linear 0 10) ((,) <$> genKey <*> genValue) - - genRange :: Gen (Range Scientific) - genRange = - Gen.choice - [ pure Empty - , do - (lower, upper) <- genBounds - pure (Range lower upper) - ] - - genBound :: Gen a -> Gen (Bound a) - genBound a = - Gen.choice - [ Incl <$> a - , Excl <$> a - , pure Inf - ] - - genNum :: Gen Scientific - genNum = genNumFrom (-1000) - - genNumFrom :: Scientific -> Gen Scientific - genNumFrom x = (/ 10) . fromIntegral @Int @Scientific <$> Gen.integral (Range.linear i 10000) - where - i = round (x * 10) - - genBounds :: Gen (Bound Scientific, Bound Scientific) - genBounds = do - lower <- genBound genNum - upper <- genUpperFrom lower - pure (lower, upper) - - genUpperFrom :: Bound Scientific -> Gen (Bound Scientific) - genUpperFrom = \case - Inf -> genBound genNum - Incl x -> genBoundGT x - Excl x -> genBoundGT x - where - genBoundGT x - | x' < 1000 = genBound $ genNumFrom x' - | otherwise = pure Inf - where - x' = x + 0.1 - - genMultirange :: Gen (Multirange Scientific) - genMultirange = Multirange <$> do - n <- Gen.integral (Range.linear @Int 0 10) - if n == 0 - then pure [] - else do - (lower, upper) <- genBounds - ranges <- go (n - 1) upper - pure (Range lower upper : ranges) - where - go n bound - | n == 0 = pure [] - | otherwise = case bound of - Inf -> pure [] - Incl x -> next x - Excl x -> next x - where - next x - | x' >= 1000 = pure [] - | otherwise = do - lower <- - Gen.choice - [ Incl <$> genNumFrom x' - , Excl <$> genNumFrom x' - ] - upper <- genUpperFrom lower - ranges <- go (n - 1) upper - pure (Range lower upper : ranges) - where - x' = x + 0.1 - testDBEq :: IO TmpPostgres.DB -> TestTree testDBEq getTestDatabase = testGroup "DBEq instances" [ dbEqTest "Bool" Gen.bool , dbEqTest "Int32" $ Gen.integral @_ @Int32 Range.linearBounded , dbEqTest "Int64" $ Gen.integral @_ @Int64 Range.linearBounded - , dbEqTest "Text" $ genText + , dbEqTest "Text" $ Gen.text (Range.linear 0 10) Gen.unicode ] where @@ -855,15 +651,6 @@ testDBEq getTestDatabase = testGroup "DBEq instances" res === (x == y) -genText :: Gen Text -genText = removeNull <$> Gen.text (Range.linear 0 10) Gen.unicode - where - -- | Postgres doesn't support the NULL character (not to be confused with a NULL value) inside strings. - removeNull :: Text -> Text - removeNull = T.filter (/= '\0') - - - testTableEquality :: IO TmpPostgres.DB -> TestTree testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable @@ -891,17 +678,28 @@ testFromRational = databasePropertyTest "fromRational" \transaction -> do pure $ fromRational rational diff result (~=) double where - wholeDigits x = fromIntegral $ length $ show $ round @_ @Integer x + wholeDigits x = fromIntegral $ length $ show $ round x -- A Double gives us between 15-17 decimal digits of precision. -- It's tempting to say that two numbers are equal if they differ by less than 1e15. -- But this doesn't hold. -- The precision is split between the whole numer part and the decimal part of the number. -- For instance, a number between 10 and 99 only has around 13 digits of precision in its decimal part. -- Postgres and Haskell show differing amounts of digits in these cases, - a ~= b = abs (a - b) < 10 ** (-15 + wholeDigits a) + a ~= b = abs (a - b) < 10**(-15 + wholeDigits a) infix 4 ~= +testFromString :: IO TmpPostgres.DB -> TestTree +testFromString = databasePropertyTest "fromString" \transaction -> do + str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode + + transaction do + result <- lift do + statement () $ Rel8.run1 $ Rel8.select do + pure $ fromString str + result === pack str + + testCatMaybeTable :: IO TmpPostgres.DB -> TestTree testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable @@ -1011,7 +809,7 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction where genRows :: PropertyT IO [TestTable Result] genRows = forAll do - Gen.list (Range.linear 0 10) $ liftA2 TestTable genText (pure True) + Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True) genTestTable :: Gen (TestTable Result) @@ -1030,7 +828,7 @@ testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do statement () $ Rel8.run_ $ Rel8.insert Rel8.Insert { into = testTableSchema , rows = Rel8.values $ map Rel8.lit $ Map.keys rows - , onConflict = Rel8.DoNothing Nothing + , onConflict = Rel8.DoNothing , returning = Rel8.NoReturning } @@ -1074,7 +872,7 @@ testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do statement () $ Rel8.run_ $ Rel8.insert Rel8.Insert { into = testTableSchema , rows = Rel8.values $ map Rel8.lit rows - , onConflict = Rel8.DoNothing Nothing + , onConflict = Rel8.DoNothing , returning = Rel8.NoReturning } @@ -1114,7 +912,7 @@ testWithStatement genTestDatabase = inserted <- Rel8.insert $ Rel8.Insert { into = testTableSchema , rows = values - , onConflict = Rel8.DoNothing Nothing + , onConflict = Rel8.DoNothing , returning = Rel8.Returning id } @@ -1132,7 +930,7 @@ testWithStatement genTestDatabase = Rel8.insert $ Rel8.Insert { into = testTableSchema , rows = Rel8.values $ map Rel8.lit rows - , onConflict = Rel8.DoNothing Nothing + , onConflict = Rel8.DoNothing , returning = Rel8.NoReturning } @@ -1148,7 +946,7 @@ testWithStatement genTestDatabase = Rel8.insert $ Rel8.Insert { into = testTableSchema , rows = Rel8.values $ map Rel8.lit rows - , onConflict = Rel8.DoNothing Nothing + , onConflict = Rel8.DoNothing , returning = Rel8.Returning id } @@ -1208,7 +1006,7 @@ testUpsert = databasePropertyTest "Can UPSERT UniqueTable" \transaction -> do statement () $ Rel8.run_ $ Rel8.insert Rel8.Insert { into = uniqueTableSchema , rows = Rel8.values $ Rel8.lit <$> as - , onConflict = Rel8.DoNothing Nothing + , onConflict = Rel8.DoNothing , returning = Rel8.NoReturning } @@ -1216,12 +1014,8 @@ testUpsert = databasePropertyTest "Can UPSERT UniqueTable" \transaction -> do { into = uniqueTableSchema , rows = Rel8.values $ Rel8.lit <$> bs , onConflict = Rel8.DoUpdate Rel8.Upsert - { conflict = - Rel8.OnIndex - Rel8.Index - { columns = uniqueTableKey - , predicate = Nothing - } + { index = uniqueTableKey + , predicate = Nothing , set = \UniqueTable {uniqueTableValue} old -> old {uniqueTableValue} , updateWhere = \_ _ -> Rel8.true } @@ -1345,53 +1139,3 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect normalize :: [(x, (Int64, Int64))] -> [(x, (Int64, Int64))] normalize [] = [] normalize xs@((_, (i, _)) : _) = map (fmap (\(a, b) -> (a - i, b - i))) xs - - --- Field name is 42 chars -data LongLabelTable f = LongLabelTable - { aFieldNameDefinitelyLongerThanThirtyCharsA :: Rel8.Column f Text - , aFieldNameDefinitelyLongerThanThirtyCharsB :: Rel8.Column f Text - } - deriving stock Generic - deriving anyclass Rel8.Rel8able - -deriving stock instance Eq (LongLabelTable Result) -deriving stock instance Ord (LongLabelTable Result) -deriving stock instance Show (LongLabelTable Result) - - --- Field name is 51 chars, nested with the 42 above, we'll get more than 63, --- triggering truncation. -data NestedForLargerThan63 f = NestedForLargerThan63 - { aFieldNameDefinitelyLongerThanThirtyCharsNestedWith :: LongLabelTable f - } - deriving stock Generic - deriving anyclass Rel8.Rel8able - -deriving stock instance Eq (NestedForLargerThan63 Result) -deriving stock instance Ord (NestedForLargerThan63 Result) -deriving stock instance Show (NestedForLargerThan63 Result) - - -testSelectTruncated :: IO TmpPostgres.DB -> TestTree -testSelectTruncated = databasePropertyTest "select truncates long column aliases" \transaction -> do - rows <- forAll $ Gen.list (Range.linear 0 10) ((,) <$> genText <*> genText) - - let q = Rel8.values $ map (\(tA, tB) -> NestedForLargerThan63 (LongLabelTable (Rel8.lit tA) (Rel8.lit tB))) rows - sqlText = Rel8.showStatement (Rel8.select q) - annotate sqlText - - -- Check that long names do not exist - assert $ not $ "aFieldNameDefinitelyLongerThanThirtyCharsA" `isInfixOf` sqlText - assert $ not $ "aFieldNameDefinitelyLongerThanThirtyCharsB" `isInfixOf` sqlText - - -- Find the short names - assert $ "aFieldNameDefinitelyLongerThanThirtyCharsNestedWith/aFieldN_1_1" `isInfixOf` sqlText - assert $ "aFieldNameDefinitelyLongerThanThirtyCharsNestedWith/aFieldN_2_1" `isInfixOf` sqlText - - transaction do - selected <- lift do - statement () $ Rel8.run $ Rel8.select q - sort (map (((,) <$> aFieldNameDefinitelyLongerThanThirtyCharsA <*> aFieldNameDefinitelyLongerThanThirtyCharsB) - . aFieldNameDefinitelyLongerThanThirtyCharsNestedWith) selected) - === sort rows diff --git a/tests/Rel8/Generic/Rel8able/Test.hs b/tests/Rel8/Generic/Rel8able/Test.hs index 607bb915..7a8fc87c 100644 --- a/tests/Rel8/Generic/Rel8able/Test.hs +++ b/tests/Rel8/Generic/Rel8able/Test.hs @@ -1,4 +1,3 @@ -{-# language ScopedTypeVariables #-} {-# language DataKinds #-} {-# language DeriveAnyClass #-} {-# language DeriveGeneric #-} @@ -6,13 +5,9 @@ {-# language DuplicateRecordFields #-} {-# language FlexibleInstances #-} {-# language MultiParamTypeClasses #-} -{-# language OverloadedStrings #-} -{-# language StandaloneDeriving #-} {-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} {-# language TypeFamilies #-} {-# language TypeOperators #-} -{-# language RecordWildCards #-} {-# language UndecidableInstances #-} {-# options_ghc -O0 #-} @@ -22,106 +17,15 @@ module Rel8.Generic.Rel8able.Test ) where --- aeson -import Data.Aeson ( Value(..) ) -import qualified Data.Aeson.KeyMap as Aeson - -- base -import Data.Fixed ( Fixed ( MkFixed ), E2 ) -import Data.Foldable ( fold ) -import Data.Int ( Int16, Int32, Int64 ) -import Data.Functor.Identity ( Identity(..) ) -import qualified Data.List.NonEmpty as NonEmpty import GHC.Generics ( Generic ) import Prelude -import Control.Applicative ( liftA3 ) - --- bytestring -import Data.ByteString ( ByteString ) -import qualified Data.ByteString.Lazy as LB - --- case-insensitive -import Data.CaseInsensitive ( CI ) -import qualified Data.CaseInsensitive as CI - --- containers -import qualified Data.Map as Map - --- hedgehog -import qualified Hedgehog -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range -- rel8 -import Rel8 ( - Column, - DBType, - Expr, - HADT, - HEither, - HKD, - HList, - HMaybe, - HNonEmpty, - HThese, - KRel8able, - Lift, - Name, - QualifiedName, - Rel8able, - Result, - TableSchema (TableSchema), - ToExprs, - namesFromLabelsWith, - ) -import qualified Rel8 - --- scientific -import Data.Scientific ( Scientific, fromFloatDigits ) - --- time -import Data.Time.Calendar (Day) -import Data.Time.Clock (UTCTime(..), secondsToDiffTime, secondsToNominalDiffTime) -import Data.Time.LocalTime - ( CalendarDiffTime (CalendarDiffTime) - , LocalTime(..) - , TimeOfDay(..) - ) +import Rel8 -- text import Data.Text ( Text ) -import qualified Data.Text.Lazy as LT - --- these -import Data.These - --- uuid -import Data.UUID ( UUID ) -import qualified Data.UUID as UUID - --- vector -import qualified Data.Vector as Vector - - -makeSchema :: forall f. Rel8able f => QualifiedName -> TableSchema (f Name) -makeSchema name = TableSchema - { name = name - , columns = namesFromLabelsWith @(f Name) (fold . NonEmpty.intersperse "/") - } - - -data TableDuplicate f = TableDuplicate - { foo :: TablePair f - , bar :: TablePair f - } - deriving stock Generic - deriving anyclass Rel8able - -tableDuplicate :: TableSchema (TableDuplicate Name) -tableDuplicate = TableSchema - { name = "tableDuplicate" - , columns = namesFromLabelsWith NonEmpty.last - } data TableTest f = TableTest @@ -130,15 +34,6 @@ data TableTest f = TableTest } deriving stock Generic deriving anyclass Rel8able -deriving stock instance f ~ Result => Show (TableTest f) -deriving stock instance f ~ Result => Eq (TableTest f) -deriving stock instance f ~ Result => Ord (TableTest f) - -tableTest :: TableSchema (TableTest Name) -tableTest = makeSchema "tableTest" - -genTableTest :: Hedgehog.MonadGen m => m (TableTest Result) -genTableTest = TableTest <$> Gen.bool <*> Gen.maybe Gen.bool data TablePair f = TablePair @@ -147,17 +42,6 @@ data TablePair f = TablePair } deriving stock Generic deriving anyclass Rel8able -deriving stock instance f ~ Result => Show (TablePair f) -deriving stock instance f ~ Result => Eq (TablePair f) -deriving stock instance f ~ Result => Ord (TablePair f) - -tablePair :: TableSchema (TablePair Name) -tablePair = makeSchema "tablePair" - -genTablePair :: Hedgehog.MonadGen m => m (TablePair Result) -genTablePair = TablePair - <$> Gen.bool - <*> liftA2 (,) (Gen.text (Range.linear 0 10) Gen.alphaNum) (Gen.text (Range.linear 0 10) Gen.alphaNum) data TableMaybe f = TableMaybe @@ -166,17 +50,6 @@ data TableMaybe f = TableMaybe } deriving stock Generic deriving anyclass Rel8able -deriving stock instance f ~ Result => Show (TableMaybe f) -deriving stock instance f ~ Result => Eq (TableMaybe f) -deriving stock instance f ~ Result => Ord (TableMaybe f) - -tableMaybe :: TableSchema (TableMaybe Name) -tableMaybe = makeSchema "tableMaybe" - -genTableMaybe :: Hedgehog.MonadGen m => m (TableMaybe Result) -genTableMaybe = TableMaybe - <$> Gen.list (Range.linear 0 10) (Gen.maybe Gen.bool) - <*> Gen.maybe (liftA2 (,) genTablePair genTablePair) data TableEither f = TableEither @@ -185,17 +58,6 @@ data TableEither f = TableEither } deriving stock Generic deriving anyclass Rel8able -deriving stock instance f ~ Result => Show (TableEither f) -deriving stock instance f ~ Result => Eq (TableEither f) -deriving stock instance f ~ Result => Ord (TableEither f) - -tableEither :: TableSchema (TableEither Name) -tableEither = makeSchema "tableEither" - -genTableEither :: Hedgehog.MonadGen m => m (TableEither Result) -genTableEither = TableEither - <$> Gen.bool - <*> Gen.either (Gen.maybe $ liftA2 (,) genTablePair genTablePair) Gen.alphaNum data TableThese f = TableThese @@ -204,21 +66,6 @@ data TableThese f = TableThese } deriving stock Generic deriving anyclass Rel8able -deriving stock instance f ~ Result => Show (TableThese f) -deriving stock instance f ~ Result => Eq (TableThese f) -deriving stock instance f ~ Result => Ord (TableThese f) - -tableThese :: TableSchema (TableThese Name) -tableThese = makeSchema "tableThese" - -genTableThese :: Hedgehog.MonadGen m => m (TableThese Result) -genTableThese = TableThese - <$> Gen.bool - <*> Gen.choice - [ This <$> genTableMaybe - , That <$> genTableEither - , These <$> genTableMaybe <*> genTableEither - ] data TableList f = TableList @@ -227,17 +74,6 @@ data TableList f = TableList } deriving stock Generic deriving anyclass Rel8able -deriving stock instance f ~ Result => Show (TableList f) -deriving stock instance f ~ Result => Eq (TableList f) -deriving stock instance f ~ Result => Ord (TableList f) - -tableList :: TableSchema (TableList Name) -tableList = makeSchema "tableList" - -genTableList :: Hedgehog.MonadGen m => m (TableList Result) -genTableList = TableList - <$> Gen.bool - <*> Gen.list (Range.linear 0 10) genTableThese data TableNonEmpty f = TableNonEmpty @@ -246,17 +82,6 @@ data TableNonEmpty f = TableNonEmpty } deriving stock Generic deriving anyclass Rel8able -deriving stock instance f ~ Result => Show (TableNonEmpty f) -deriving stock instance f ~ Result => Eq (TableNonEmpty f) -deriving stock instance f ~ Result => Ord (TableNonEmpty f) - -tableNonEmpty :: TableSchema (TableNonEmpty Name) -tableNonEmpty = makeSchema "tableNonEmpty" - -genTableNonEmpty :: Hedgehog.MonadGen m => m (TableNonEmpty Result) -genTableNonEmpty = TableNonEmpty - <$> Gen.bool - <*> Gen.nonEmpty (Range.linear 0 10) (liftA2 (,) genTableList genTableMaybe) data TableNest f = TableNest @@ -265,41 +90,24 @@ data TableNest f = TableNest } deriving stock Generic deriving anyclass Rel8able -deriving stock instance f ~ Result => Show (TableNest f) -deriving stock instance f ~ Result => Eq (TableNest f) -deriving stock instance f ~ Result => Ord (TableNest f) - -tableNest :: TableSchema (TableNest Name) -tableNest = makeSchema "tableNest" - -genTableNest :: Hedgehog.MonadGen m => m (TableNest Result) -genTableNest = TableNest - <$> Gen.bool - <*> Gen.list (Range.linear 0 10) (Gen.maybe genTablePair) data S3Object = S3Object { bucketName :: Text , objectKey :: Text } - deriving stock (Generic, Show, Eq, Ord) + deriving stock Generic instance x ~ HKD S3Object Expr => ToExprs x S3Object data HKDSum = HKDSumA Text | HKDSumB Bool Char | HKDSumC - deriving stock (Generic, Show, Eq, Ord) + deriving stock Generic instance x ~ HKD HKDSum Expr => ToExprs x HKDSum -genHKDSum :: Hedgehog.MonadGen m => m HKDSum -genHKDSum = Gen.choice - [ HKDSumA <$> Gen.text (Range.linear 0 10) Gen.alpha - , HKDSumB <$> Gen.bool <*> Gen.alpha - , pure HKDSumC - ] data HKDTest f = HKDTest { s3Object :: Lift f S3Object @@ -307,14 +115,7 @@ data HKDTest f = HKDTest } deriving stock Generic deriving anyclass Rel8able -deriving stock instance f ~ Result => Show (HKDTest f) -deriving stock instance f ~ Result => Eq (HKDTest f) -deriving stock instance f ~ Result => Ord (HKDTest f) -genHKDTest :: Hedgehog.MonadGen m => m (HKDTest Result) -genHKDTest = HKDTest - <$> liftA2 S3Object (Gen.text (Range.linear 0 10) Gen.alpha) (Gen.text (Range.linear 0 10) Gen.alpha) - <*> genHKDSum data NonRecord f = NonRecord (Column f Bool) @@ -329,25 +130,6 @@ data NonRecord f = NonRecord (Column f Char) deriving stock Generic deriving anyclass Rel8able -deriving stock instance f ~ Result => Show (NonRecord f) -deriving stock instance f ~ Result => Eq (NonRecord f) -deriving stock instance f ~ Result => Ord (NonRecord f) - -nonRecord :: TableSchema (NonRecord Name) -nonRecord = makeSchema "nonRecord" - -genNonRecord :: Hedgehog.MonadGen m => m (NonRecord Result) -genNonRecord = NonRecord - <$> Gen.bool - <*> Gen.alpha - <*> Gen.alpha - <*> Gen.alpha - <*> Gen.alpha - <*> Gen.alpha - <*> Gen.alpha - <*> Gen.alpha - <*> Gen.alpha - <*> Gen.alpha data TableSum f @@ -355,17 +137,6 @@ data TableSum f | TableSumB | TableSumC (Column f Text) deriving stock Generic -deriving stock instance f ~ Result => Show (TableSum f) -deriving stock instance f ~ Result => Eq (TableSum f) -deriving stock instance f ~ Result => Ord (TableSum f) - - -genTableSum :: Hedgehog.MonadGen m => m (HADT Result TableSum) -genTableSum = Gen.choice - [ TableSumA <$> Gen.bool <*> Gen.text (Range.linear 0 10) Gen.alpha - , pure TableSumB - , TableSumC <$> Gen.text (Range.linear 0 10) Gen.alpha - ] data BarbieSum f @@ -373,17 +144,6 @@ data BarbieSum f | BarbieSumB | BarbieSumC (f Text) deriving stock Generic -deriving stock instance f ~ Result => Show (BarbieSum f) -deriving stock instance f ~ Result => Eq (BarbieSum f) -deriving stock instance f ~ Result => Ord (BarbieSum f) - - -genBarbieSum :: Hedgehog.MonadGen m => m (BarbieSum Result) -genBarbieSum = Gen.choice - [ BarbieSumA <$> fmap Identity Gen.bool <*> fmap Identity (Gen.text (Range.linear 0 10) Gen.alpha) - , pure BarbieSumB - , BarbieSumC <$> fmap Identity (Gen.text (Range.linear 0 10) Gen.alpha) - ] data TableProduct f = TableProduct @@ -393,31 +153,7 @@ data TableProduct f = TableProduct } deriving stock Generic deriving anyclass Rel8able -deriving stock instance f ~ Result => Show (TableProduct f) -deriving stock instance f ~ Result => Eq (TableProduct f) -deriving stock instance f ~ Result => Ord (TableProduct f) - -tableProduct :: TableSchema (TableProduct Name) -tableProduct = makeSchema "tableProduct" - -genTableProduct :: Hedgehog.MonadGen m => m (TableProduct Result) -genTableProduct = TableProduct - <$> genBarbieSum - <*> genTableList - <*> Gen.list (Range.linear 0 10) (liftA3 (,,) genTableSum genHKDSum genHKDTest) - --- tableProduct :: TableProduct Name --- tableProduct = makeSchema "tableProduct" - --- genTableProduct :: Hedgehog.MonadGen m => m (TableProduct Result) --- genTableProduct = TableProduct --- <$> Gen.choice --- [ BarbieSumA <$> Gen.bool <*> Gen.text (Range.linear 0 10) Gen.alpha --- , BarbieSumB --- , BarbieSumC <$> Gen.text (Range.linear 0 10) Gen.alpha --- ] --- <*> genTableList --- <*> Gen.list (Range.linear 0 10) (liftA3 (,,) genTableSum) + data TableTestB f = TableTestB { foo :: f Bool @@ -451,104 +187,3 @@ data Nest t u f = Nest } deriving stock Generic deriving anyclass Rel8able - - -data TableType f = TableType - { bool :: Column f Bool - , char :: Column f Char - , int16 :: Column f Int16 - , int32 :: Column f Int32 - , int64 :: Column f Int64 - , float :: Column f Float - , double :: Column f Double - , scientific :: Column f Scientific - , fixed :: Column f (Fixed E2) - , utctime :: Column f UTCTime - , day :: Column f Day - , localtime :: Column f LocalTime - , timeofday :: Column f TimeOfDay - , calendardifftime :: Column f CalendarDiffTime - , text :: Column f Text - , lazytext :: Column f LT.Text - , citext :: Column f (CI Text) - , cilazytext :: Column f (CI LT.Text) - , bytestring :: Column f ByteString - , lazybytestring :: Column f LB.ByteString - , uuid :: Column f UUID - , value :: Column f Value - } deriving stock (Generic) -deriving anyclass instance Rel8able TableType -deriving stock instance f ~ Result => Show (TableType f) -deriving stock instance f ~ Result => Eq (TableType f) --- deriving stock instance f ~ Result => Ord (TableType f) - -tableType :: TableSchema (TableType Name) -tableType = makeSchema "tableType" - -badTableType :: TableSchema (TableProduct Name) -badTableType = makeSchema "tableType" - -genTableType :: Hedgehog.MonadGen m => m (TableType Result) -genTableType = do - bool <- Gen.bool - char <- Gen.alpha - int16 <- Gen.int16 range - int32 <- Gen.int32 range - int64 <- Gen.int64 range - float <- Gen.float linearFrac - double <- Gen.double linearFrac - scientific <- fromFloatDigits @Double <$> Gen.realFloat linearFrac - utctime <- UTCTime <$> (toEnum <$> Gen.integral range) <*> fmap secondsToDiffTime (Gen.integral range) - day <- toEnum <$> Gen.integral range - localtime <- LocalTime <$> (toEnum <$> Gen.integral range) <*> timeOfDay - timeofday <- timeOfDay - text <- Gen.text range Gen.alpha - lazytext <- LT.fromStrict <$> Gen.text range Gen.alpha - citext <- CI.mk <$> Gen.text range Gen.alpha - cilazytext <- CI.mk <$> LT.fromStrict <$> Gen.text range Gen.alpha - bytestring <- Gen.bytes range - lazybytestring <- LB.fromStrict <$> Gen.bytes range - uuid <- UUID.fromWords <$> Gen.word32 range <*> Gen.word32 range <*> Gen.word32 range <*> Gen.word32 range - fixed <- MkFixed <$> Gen.integral range - value <- Gen.choice - [ Object <$> Aeson.fromMapText <$> Map.fromList <$> Gen.list range (liftA2 (,) (Gen.text range Gen.alpha) (pure Null)) - , Array <$> Vector.fromList <$> Gen.list range (pure Null) - , String <$> Gen.text range Gen.alpha - , Number <$> fromFloatDigits @Double <$> Gen.realFloat linearFrac - , Bool <$> Gen.bool - , pure Null - ] - calendardifftime <- CalendarDiffTime <$> Gen.integral range <*> (secondsToNominalDiffTime <$> Gen.realFrac_ linearFrac) - pure TableType {..} - where - timeOfDay :: Hedgehog.MonadGen m => m TimeOfDay - timeOfDay = TimeOfDay <$> Gen.integral range <*> Gen.integral range <*> Gen.realFrac_ linearFrac - - range :: Integral a => Range.Range a - range = Range.linear 0 10 - - linearFrac :: (Fractional a, Ord a) => Range.Range a - linearFrac = Range.linearFrac 0 10 - -data TableNumeric f = TableNumeric - { foo :: Column f (Fixed E2) - } deriving stock (Generic) -deriving anyclass instance Rel8able TableNumeric -deriving stock instance f ~ Result => Show (TableNumeric f) -deriving stock instance f ~ Result => Eq (TableNumeric f) - -tableNumeric :: TableSchema (TableNumeric Name) -tableNumeric = makeSchema "tableNumeric" - - -data TableChar f = TableChar - { foo :: Column f Char - } deriving stock (Generic) -deriving anyclass instance Rel8able TableChar -deriving stock instance f ~ Result => Show (TableChar f) -deriving stock instance f ~ Result => Eq (TableChar f) - -tableChar :: TableSchema (TableChar Name) -tableChar = makeSchema "tableChar" - -