diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index fc3fe582..ea674ba3 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -11,7 +11,7 @@ on: # A workflow run is made up of one or more jobs that can run sequentially or in parallel jobs: # This workflow contains a single job called "build" - ghc8_10: + ghc9_0: # The type of runner that the job will run on runs-on: ubuntu-latest @@ -33,10 +33,10 @@ jobs: - uses: actions/checkout@v2 - uses: haskell/actions/setup@v1 with: - ghc-version: '8.10.5' # Exact version of ghc to use - # cabal-version: 'latest'. Omitted, but defalts to 'latest' enable-stack: true stack-version: 'latest' + stack-no-global: true + stack-setup-ghc: true - name: build run: stack build --fast @@ -63,7 +63,7 @@ jobs: ".stack-work" "/root/.stack/" key: ${{ runner.os }}-${{ hashFiles('**/lockfiles') }} - ghc8_8: + ghc8_10: # The type of runner that the job will run on runs-on: ubuntu-latest @@ -85,16 +85,16 @@ jobs: - uses: actions/checkout@v2 - uses: haskell/actions/setup@v1 with: - ghc-version: '8.8.4' # Exact version of ghc to use - # cabal-version: 'latest'. Omitted, but defalts to 'latest' enable-stack: true stack-version: 'latest' + stack-no-global: true + stack-setup-ghc: true - name: build - run: stack build --fast + run: stack build --fast --stack-yaml stack-ghc8_10.yaml - name: test - run: stack test --fast + run: stack test --fast --stack-yaml stack-ghc8_10.yaml env: PG_USER: postgres PG_HOST: localhost @@ -103,10 +103,10 @@ jobs: PG_PORT: ${{ job.services.postgres.ports['5432'] }} - name: benchmark - run: stack bench --fast + run: stack bench --fast --stack-yaml stack-ghc8_10.yaml - name: documentation - run: stack haddock --fast + run: stack haddock --fast --stack-yaml stack-ghc8_10.yaml - name: cache uses: actions/cache@v2 @@ -115,7 +115,7 @@ jobs: ".stack-work" "/root/.stack/" key: ${{ runner.os }}-${{ hashFiles('**/lockfiles') }} - ghc8_6: + ghc8_8: # The type of runner that the job will run on runs-on: ubuntu-latest @@ -137,16 +137,16 @@ jobs: - uses: actions/checkout@v2 - uses: haskell/actions/setup@v1 with: - ghc-version: '8.6.5' # Exact version of ghc to use - # cabal-version: 'latest'. Omitted, but defalts to 'latest' enable-stack: true stack-version: 'latest' + stack-no-global: true + stack-setup-ghc: true - name: build - run: stack build --fast + run: stack build --fast --stack-yaml stack-ghc8_8.yaml - name: test - run: stack test --fast + run: stack test --fast --stack-yaml stack-ghc8_8.yaml env: PG_USER: postgres PG_HOST: localhost @@ -155,10 +155,10 @@ jobs: PG_PORT: ${{ job.services.postgres.ports['5432'] }} - name: benchmark - run: stack bench --fast + run: stack bench --fast --stack-yaml stack-ghc8_8.yaml - name: documentation - run: stack haddock --fast + run: stack haddock --fast --stack-yaml stack-ghc8_8.yaml - name: cache uses: actions/cache@v2 diff --git a/.gitignore b/.gitignore index a1f56f08..0afc615e 100644 --- a/.gitignore +++ b/.gitignore @@ -19,5 +19,6 @@ cabal.sandbox.config cabal.project.local .DS_Store stack.yaml.lock +*.yaml.lock tags .*.swp diff --git a/README.md b/README.md deleted file mode 100644 index cace7055..00000000 --- a/README.md +++ /dev/null @@ -1,300 +0,0 @@ -# squeal - -![squeal-icon](https://raw.githubusercontent.com/morphismtech/squeal/dev/squeal.gif) - -[![GitHub CI](https://github.com/morphismtech/squeal/workflows/CI/badge.svg)](https://github.com/morphismtech/squeal/actions) - -[Github](https://github.com/morphismtech/squeal) - -[Hackage](https://hackage.haskell.org/package/squeal-postgresql) - -[Stackage](https://www.stackage.org/package/squeal-postgresql) - -[YouTube](https://www.youtube.com/watch?v=rWfEQfAaNc4) - -## introduction - -Squeal is a deep embedding of SQL into Haskell. By "deep embedding", I am abusing the -term somewhat. What I mean is that Squeal embeds both SQL terms and SQL types -into Haskell at the term and type levels respectively. This leads to a very high level -of type-safety in Squeal. - -Squeal embeds not just the structured query language of SQL but also the -data manipulation language and the data definition language; that's `SELECT`, -`INSERT`, `UPDATE`, `DELETE`, `WITH`, `CREATE`, `DROP`, and `ALTER` commands. - -Squeal expressions closely match their corresponding SQL expressions so that -the SQL they actually generate is completely predictable. They are also highly -composable and cover a large portion of SQL. - -## features - -* generic encoding of Haskell tuples and records into query parameters - and generic decoding of query results into Haskell records - using [`generics-sop`](https://hackage.haskell.org/package/generics-sop) -* access to SQL alias system using the `OverloadedLabels` extension -* type-safe `NULL` and `DEFAULT` -* type-safe SQL constraints `CHECK`, `UNIQUE`, `PRIMARY KEY` and `FOREIGN KEY` -* type-safe aggregation -* escape hatches for writing raw SQL -* [`mtl`](https://hackage.haskell.org/package/mtl) compatible monad transformer - for executing as well as preparing queries and manipulations - and [Atkey](https://bentnib.org/paramnotions-jfp.pdf) indexed monad transformer - for executing definitions. -* linear, pure or impure, one-way or rewindable migrations -* connection pools -* transactions -* views -* array, composite and enumerated types -* json functions and operations -* multischema support -* correlated subqueries -* window functions -* text search -* time functions -* ranges -* indexes -* inlining - -## installation - -`stack install squeal-postgresql` - -## testing - -Start postgres on localhost port `5432` and create a database named `exampledb`. - -`stack test` - -## contributing - -We welcome contributors. -Please make pull requests on the `dev` branch instead of `master`. -The `Issues` page is a good place to communicate. - -## usage - -Let's see an example! - -First, we need some language extensions because Squeal uses modern GHC -features. - -```Haskell ->>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels -XFlexibleContexts ->>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators -XGADTs -``` - -We'll need some imports. - -```Haskell ->>> import Control.Monad.IO.Class (liftIO) ->>> import Data.Int (Int32) ->>> import Data.Text (Text) ->>> import Squeal.PostgreSQL -``` - -We'll use generics to easily convert between Haskell and PostgreSQL values. - -```Haskell ->>> import qualified Generics.SOP as SOP ->>> import qualified GHC.Generics as GHC -``` - -The first step is to define the schema of our database. This is where -we use `DataKinds` and `TypeOperators`. - -```Haskell ->>> :{ -type UsersColumns = - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "name" ::: 'NoDef :=> 'NotNull 'PGtext ] -type UsersConstraints = '[ "pk_users" ::: 'PrimaryKey '["id"] ] -type EmailsColumns = - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 - , "email" ::: 'NoDef :=> 'Null 'PGtext ] -type EmailsConstraints = - '[ "pk_emails" ::: 'PrimaryKey '["id"] - , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"] ] -type Schema = - '[ "users" ::: 'Table (UsersConstraints :=> UsersColumns) - , "emails" ::: 'Table (EmailsConstraints :=> EmailsColumns) ] -type DB = Public Schema -:} -``` - -Notice the use of type operators. - -`:::` is used to pair an alias `Symbol` with a `SchemasType`, a `SchemumType`, -a `TableConstraint` or a `ColumnType`. It is intended to connote Haskell's `::` -operator. - -`:=>` is used to pair `TableConstraints` with a `ColumnsType`, -yielding a `TableType`, or to pair an `Optionality` with a `NullType`, -yielding a `ColumnType`. It is intended to connote Haskell's `=>` operator - -Next, we'll write `Definition`s to set up and tear down the schema. In -Squeal, a `Definition` like `createTable`, `alterTable` or `dropTable` -has two type parameters, corresponding to the schema -before being run and the schema after. We can compose definitions using `>>>`. -Here and in the rest of our commands we make use of overloaded -labels to refer to named tables and columns in our schema. - -```Haskell ->>> :{ -let - setup :: Definition (Public '[]) DB - setup = - createTable #users - ( serial `as` #id :* - (text & notNullable) `as` #name ) - ( primaryKey #id `as` #pk_users ) >>> - createTable #emails - ( serial `as` #id :* - (int & notNullable) `as` #user_id :* - (text & nullable) `as` #email ) - ( primaryKey #id `as` #pk_emails :* - foreignKey #user_id #users #id - (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_user_id ) -:} -``` - -We can easily see the generated SQL is unsurprising looking. - -```Haskell ->>> printSQL setup -``` -```SQL -CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id")); -CREATE TABLE "emails" ("id" serial, "user_id" int NOT NULL, "email" text NULL, CONSTRAINT "pk_emails" PRIMARY KEY ("id"), CONSTRAINT "fk_user_id" FOREIGN KEY ("user_id") REFERENCES "users" ("id") ON DELETE CASCADE ON UPDATE CASCADE); -``` - -Notice that `setup` starts with an empty public schema `(Public '[])` and produces `DB`. -In our `createTable` commands we included `TableConstraint`s to define -primary and foreign keys, making them somewhat complex. Our `teardown` -`Definition` is simpler. - -```Haskell ->>> :{ -let - teardown :: Definition DB (Public '[]) - teardown = dropTable #emails >>> dropTable #users -:} - ->>> printSQL teardown -``` -```SQL -DROP TABLE "emails"; -DROP TABLE "users"; -``` - -We'll need a Haskell type for `User`s. We give the type `Generics.SOP.Generic` and -`Generics.SOP.HasDatatypeInfo` instances so that we can encode and decode `User`s. - -```Haskell ->>> :set -XDerivingStrategies -XDeriveAnyClass ->>> :{ -data User = User { userName :: Text, userEmail :: Maybe Text } - deriving stock (Show, GHC.Generic) - deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) -:} -``` - -Next, we'll write `Statement`s to insert `User`s into our two tables. -A `Statement` has three type parameters, the schemas it refers to, -input parameters and an output row. When -we insert into the users table, we will need a parameter for the `name` -field but not for the `id` field. Since it's serial, we can use a default -value. However, since the emails table refers to the users table, we will -need to retrieve the user id that the insert generates and insert it into -the emails table. We can do this in a single `Statement` by using a -`with` `manipulation`. - -```Haskell ->>> :{ -let - insertUser :: Statement DB User () - insertUser = manipulation $ with (u `as` #u) e - where - u = insertInto #users - (Values_ (Default `as` #id :* Set (param @1) `as` #name)) - OnConflictDoRaise (Returning_ (#id :* param @2 `as` #email)) - e = insertInto_ #emails $ Select - (Default `as` #id :* Set (#u ! #id) `as` #user_id :* Set (#u ! #email) `as` #email) - (from (common #u)) -:} -``` - -```Haskell ->>> printSQL insertUser -``` -```SQL -WITH "u" AS (INSERT INTO "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) RETURNING "id" AS "id", ($2 :: text) AS "email") INSERT INTO "emails" ("user_id", "email") SELECT "u"."id", "u"."email" FROM "u" AS "u" -``` - -Next we write a `Statement` to retrieve users from the database. We're not -interested in the ids here, just the usernames and email addresses. We -need to use an `innerJoin` to get the right result. - -```Haskell ->>> :{ -let - getUsers :: Statement DB () User - getUsers = query $ select_ - (#u ! #name `as` #userName :* #e ! #email `as` #userEmail) - ( from (table (#users `as` #u) - & innerJoin (table (#emails `as` #e)) - (#u ! #id .== #e ! #user_id)) ) -:} -``` - -```Haskell ->>> printSQL getUsers -``` -```SQL -SELECT "u"."name" AS "userName", "e"."email" AS "userEmail" FROM "users" AS "u" INNER JOIN "emails" AS "e" ON ("u"."id" = "e"."user_id") -``` - -Let's create some users to add to the database. - -```Haskell ->>> :{ -let - users :: [User] - users = - [ User "Alice" (Just "alice@gmail.com") - , User "Bob" Nothing - , User "Carole" (Just "carole@hotmail.com") - ] -:} -``` - -Now we can put together all the pieces into a program. The program -connects to the database, sets up the schema, inserts the user data -(using prepared statements as an optimization), queries the user -data and prints it out and finally closes the connection. We can thread -the changing schema information through by using the indexed `PQ` monad -transformer and when the schema doesn't change we can use `Monad` and -`MonadPQ` functionality. - -```Haskell ->>> :{ -let - session :: PQ DB DB IO () - session = do - executePrepared_ insertUser users - usersResult <- execute getUsers - usersRows <- getRows usersResult - liftIO $ print usersRows -in - withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ - define setup - & pqThen session - & pqThen (define teardown) -:} -[User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}] -``` - -This should get you up and running with Squeal. Once you're writing more complicated -queries and need a deeper understanding of Squeal's types and how everything -fits together, check out the [Core Concepts Handbook](squeal-core-concepts-handbook.md). diff --git a/RELEASE NOTES.md b/RELEASE NOTES.md deleted file mode 100644 index b7e3c0da..00000000 --- a/RELEASE NOTES.md +++ /dev/null @@ -1,1883 +0,0 @@ -## RELEASE NOTES - -## Version 0.8.1.1 - -Fix a bug in how the new `Has` type mismatch errors -were implemented, which made it do the expensive pretty-printing -even in the non-error case, resulting in extreme memory usage -at compile time for non-trivial cases. - -## Version 0.8.1.0 - -Improvements to type errors for `Has`/`HasErr`, `HasParameter`, -and trying to aggregate without grouping. - -### `Has` -#### Lookup failed -Now tells you specifically that lookup failed, -the kind of thing we were trying to look up and in what, -and a pretty-printed (usually, alphabetized and names-only) -version of what we were looking in. -``` -exe/Example.hs:112:11-41: error: - • Could not find table, view, typedef, index, function, or procedure (SchemumType) named "sers" - in schema (SchemaType): - Tables: - '["emails", "users"] - - - *Raw schema (SchemaType)*: - '[ '("users", - 'Table - ('["pk_users" ::: 'PrimaryKey '["id"]] - :=> '["id" ::: ('Def :=> 'NotNull 'PGint4), - "name" ::: ('NoDef :=> 'NotNull 'PGtext), - "vec" ::: ('NoDef :=> 'NotNull ('PGvararray ('Null 'PGint2)))])), - "emails" - ::: 'Table - ('["pk_emails" ::: 'PrimaryKey '["id"], - "fk_user_id" ::: 'ForeignKey '["user_id"] "user" "users" '["id"]] - :=> '["id" ::: ('Def :=> 'NotNull 'PGint4), - "user_id" ::: ('NoDef :=> 'NotNull 'PGint4), - "email" ::: ('NoDef :=> 'Null 'PGtext)])] - - • In the first argument of ‘(&)’, namely - ‘table ((#user ! #sers) `as` #u)’ - In the first argument of ‘from’, namely - ‘(table ((#user ! #sers) `as` #u) - & innerJoin - (table ((#user ! #emails) `as` #e)) (#u ! #id .== #e ! #user_id))’ - In the second argument of ‘select_’, namely - ‘(from - (table ((#user ! #sers) `as` #u) - & innerJoin - (table ((#user ! #emails) `as` #e)) (#u ! #id .== #e ! #user_id)))’ - | -112 | ( from (table ((#user ! #sers) `as` #u) - | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -exe/Example.hs:(106,15)-(107,92): error: - • Could not find schema (SchemaType) named "use" - in database (SchemasType): - '["org", "public", "user"] - - *Raw database (SchemasType)*: - '[ '("public", PublicSchema), "user" ::: UserSchema, - "org" ::: OrgSchema] - - • In the expression: - insertInto_ - (#use ! #emails) - (Values_ - (Default `as` #id - :* Set (param @1) `as` #user_id :* Set (param @2) `as` #email)) - In an equation for ‘insertEmail’: - insertEmail - = insertInto_ - (#use ! #emails) - (Values_ - (Default `as` #id - :* Set (param @1) `as` #user_id :* Set (param @2) `as` #email)) - | -106 | insertEmail = insertInto_ (#use ! #emails) - | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^... -``` -#### Lookup succeeded, but types don't match -Now specifies the lookup that the type mismatch comes from with kind -information. Does not pretty-print because the value of the key is important. -``` -exe/Example.hs:111:4-12: error: - • Type mismatch when looking up column (NullType) named "vec" - in row (RowType): - '[ '("id", 'NotNull 'PGint4), "name" ::: 'NotNull 'PGtext, - "vec" ::: 'NotNull ('PGvararray ('Null 'PGint2))] - - Expected: 'NotNull 'PGtext - But found: 'NotNull ('PGvararray ('Null 'PGint2)) - - • In the first argument of ‘as’, namely ‘#u ! #vec’ - In the first argument of ‘(:*)’, namely ‘#u ! #vec `as` #userName’ - In the first argument of ‘select_’, namely - ‘(#u ! #vec `as` #userName - :* #e ! #email `as` #userEmail :* #u ! #vec `as` #userVec)’ - | -111 | (#u ! #vec `as` #userName :* #e ! #email `as` #userEmail :* #u ! #vec `as` #userVec) - | ^^^^^^^^^ -``` -#### Ambiguous types -Generally identical, except complains about being unable to satisfy `Has` instead of exposing `HasErr` -``` - -exe/Example.hs:103:16-37: error: - • Ambiguous type variables ‘constraints0’, - ‘constraint0’ arising from a use of ‘OnConstraint’ - prevents the constraint ‘(Has - "pk_users" constraints0 constraint0)’ from being solved. - Probable fix: use a type annotation to specify what ‘constraints0’, - ‘constraint0’ should be. - These potential instances exist: - three instances involving out-of-scope types - (use -fprint-potential-instances to see them all) - • In the first argument of ‘OnConflict’, namely - ‘(OnConstraint #pk_users)’ - In the third argument of ‘insertInto’, namely - ‘(OnConflict (OnConstraint #pk_users) DoNothing)’ - In the expression: - insertInto - (#user ! #users) - (Values_ - (Default `as` #id - :* Set (param @1) `as` #name :* Set (param @2) `as` #vec)) - (OnConflict (OnConstraint #pk_users) DoNothing) - (Returning_ (#id `as` #fromOnly)) - | -103 | (OnConflict (OnConstraint #pk_users) DoNothing) (Returning_ (#id `as` #fromOnly)) - | ^^^^^^^^^^^^^^^^^^^^^^ -``` -### `HasParameter` -#### Looking up index 0 -Now gives a special error about params being 1-indexed. -``` -exe/Example.hs:118:18-25: error: - • Tried to get the param at index 0, but params are 1-indexed - • In the first argument of ‘Set’, namely ‘(param @0)’ - In the first argument of ‘as’, namely ‘Set (param @0)’ - In the first argument of ‘(:*)’, namely ‘Set (param @0) `as` #id’ - | -118 | (Values_ (Set (param @0) `as` #id :* setUser)) - | ^^^^^^^^ -``` -#### Looking up an out-of-bounds parameter -Now gives a special error, returning the entire parameter list as well. -Does not pretty-print since order is important, and there's no separate -keys and values. -``` - -exe/Example.hs:118:18-25: error: - • Index 4 is out of bounds in 1-indexed parameter list: - '[ 'NotNull 'PGint4, 'NotNull 'PGtext, - 'NotNull ('PGvararray ('Null 'PGint2))] - • In the first argument of ‘Set’, namely ‘(param @4)’ - In the first argument of ‘as’, namely ‘Set (param @4)’ - In the first argument of ‘(:*)’, namely ‘Set (param @4) `as` #id’ - | -118 | (Values_ (Set (param @4) `as` #id :* setUser)) - | ^^^^^^^^ -``` -#### Type mismatch when doing lookup -Now gives a custom error similar to the one added for `Has`. -``` -exe/Example.hs:118:18: error: - • Type mismatch when looking up param at index 2 - in 1-indexed parameter list: - '[ 'NotNull 'PGint4, 'NotNull 'PGtext, - 'NotNull ('PGvararray ('Null 'PGint2))] - - Expected: 'NotNull 'PGtext - But found: 'NotNull 'PGint4 - - • In the first argument of ‘Set’, namely ‘(param @2)’ - In the first argument of ‘as’, namely ‘Set (param @2)’ - In the first argument of ‘(:*)’, namely ‘Set (param @2) `as` #id’ - | -118 | (Values_ (Set (param @2) `as` #id :* setUser)) - | ^^^^^^^^ -``` -### Using aggregates with an `'Ungrouped` `Expression` -Now gives a custom error with some guidance. -``` -exe/Example.hs:118:4: error: - • Cannot use aggregate functions to construct an Ungrouped Expression. Add a 'groupBy' to your TableExpression. If you want to aggregate across the entire result set, use 'groupBy Nil'. - • In the first argument of ‘as’, namely ‘countStar’ - In the first argument of ‘(:*)’, namely ‘countStar `as` #count’ - In the first argument of ‘select_’, namely - ‘(countStar `as` #count :* Nil)’ - | -118 | (countStar `as` #count :* Nil) - | ^^^^^^^^^ -``` - -### Version 0.8 - -Thanks to Adam Wespiser, Cullin Poresky, Scott Fleischman -and William Yao for lots of contributions. - -### Materialized CTEs - -Scott Fleischman contributed materialization support to Squeal's -WITH statements. - -### LTrees and UUID - -New packages `squeal-postgresql-ltree` and `squeal-postgresql-uuid-ossp` -were created to offer functionality from those Postgres extensions. - -### Safe Transactions - -Previously, Squeal transactions were "unsafe", allowing for arbitrary -`IO`. Now, Squeal provides a new type `Transaction` that is a RankNType. - -```Haskell -type Transaction db x = forall m. - ( MonadPQ db m - , MonadResult m - , MonadCatch m - ) => m x -``` - -A `Transaction` only permits database operations and error handling, -no arbitrary `IO`. The class `MonadResult` is new but all of its -methods are old and used to be constrained as `MonadIO`, -now as `MonadResult`. - -Additionally, a new function `withSavepoint` was added, allowing -for a kind of nested transactions. - -### Bug fixes - -Various bugs were fixed. Most importantly, poor asynchronous exception -handling was ameliorated. - -### Version 0.7 - -Thanks to Samuel Schlesinger, Adam Wespiser, Cullin Poresky, -Matthew Doty and Mark Wotton for tons of contributions. -Version 0.7 of Squeal makes many changes. - -**Inter-schema Foreign Key Bug** -Unfortunately, there was a bug in inter-schema foreign keys in previous -versions of Squeal. Essentially, it was erroneously assumed that -foreign keys always point to tables in the public schema. To remedy this -the `ForeignKey` type has changed kind from - -```Haskell ->>> :kind 'ForeignKey -'ForeignKey :: [Symbol] - -> Symbol -> [Symbol] -> TableConstraint -``` - -to - -```Haskell ->>> :kind 'ForeignKey -'ForeignKey :: [Symbol] - -> Symbol -> Symbol -> [Symbol] -> TableConstraint -``` - -To upgrade your database schemas type, you will have to change, e.g. - -```Haskell -'ForeignKey '["foo_id1", "foo_id2"] "foo" '["id1", "id2"] -``` - -to - -```Haskell -'ForeignKey '["foo_id1", "foo_id2"] "public" "foo" '["id1", "id2"] -``` - -**Locking Clauses** - -You can now add row level locking clauses to your `select` queries - -**Polymorphic Lateral Contexts** - -Previously, lateral contexts which are used for lateral joins -and subquery expressions had to have monomorphic lateral contexts, -which greatly reduced composability of queries involving lateral -joins. Squeal 0.7 fixes this limitation, making it possible to -have polymorphic lateral context! When looking up a column heretofore, -the relevant typeclasses would search through `Join lat from`. -This is the "correct" ordering as far as the structure from -left to right in the query, making lat consistently ordered as -one goes through nested lateral joins or nested subquery expressions. -However, it doesn't really matter how the lookup orders the columns. -And if the lookup searches through Join from lat instead then thanks -to good old Haskell lazy list appending, if a query only references -columns in from then it will work no matter the lat. -With a small proviso; if you leave lat polymorphic, -then you must qualify all columns since there could be more than -one table even if from has only one table in it. - -**Decoders** - -The `DecodeRow` `Monad` now has a `MonadFail` instance. - -New row decoder combinators have been added. The functions -`appendRows` and `consRow` let you build row decoders up -from pieces. - -Previously, Squeal made it easy to decode enum types to Haskell -enum types (sum types with nullary constructors) so long as -the Haskell type exactly matches the enum type. However, because -of limitations in Haskell - constructors must be capitalized, -name conflicts are often disambiguated with extra letters, etc - -it's often the case that their constructors won't exactly match the -Postgres enum type's labels. The new function `enumValue` allows -to define typesafe custom enum decoders, similar to how `rowValue` -allows to define typesafe custom composite decoders. - -```Haskell ->>> :{ -data Dir = North | East | South | West -instance IsPG Dir where - type PG Dir = 'PGenum '["north", "south", "east", "west"] -instance FromPG Dir where - fromPG = enumValue $ - label @"north" North :* - label @"south" South :* - label @"east" East :* - label @"west" West -:} -``` - -**Definitions** - -New DDL statements have been added allowing to rename and -reset the schema of different schemum objects. Also, new DDL statements -have been added for adding comments to schemum objects. - -**Procedures** - -Squeal now supports procedure definitions and calls. - -**cmdTuples and cmdStatus** - -The `cmdTuples` and `cmdStatus` functions from `LibPQ` are now -included. - -**PQ Monad Instances** - -the `PQ` `Monad` has been given instances for `MonadCatch`, -`MonadThrow`, `MonadMask`, `MonadBase`, `MonadBaseControl`, and -`MonadTransControl`. - -**Referential Actions** - -A new type `ReferentialAction` has been factored out of -`OnDeleteClause`s and `OnUpdateClause`s. And Missing actions, -`SetNotNull` and `SetDefault` are now included. - -To upgrade, change from e.g. `OnDeleteCascade` to `OnDelete Cascade`. - -**Array functions** - -Squeal now offers typesafe indexing for fixed length arrays and matrices, -with new functions `index1` and `index2`. And new functions `arrAny` -and `arrAll` have been added to enable comparisons to any or all elements -of a variable length array. - -**Manipulations** - -Tables being manipulated are now re-aliasable, and updates can reference -"from" clauses, actually called `UsingClause`s in Squeal, similar to deletes. - -**Other changes** -New tests and bugfixes have been added. More support for encoding and decoding -of different types has been added. Time values now use `iso8601` formatting -for inlining. Also, the GitHub repo has moved from using Circle CI to using -GitHub Actions for continuous integration testing. - -### Version 0.6 - -Version 0.6 makes a number of large changes and additions to Squeal. -I want to thank folks who contributed issues and pull requests; -ilyakooo0, tuomohopia, league, Raveline, Sciencei, mwotton, and more. - -I particularly would like to thank my employer SimSpace and colleagues. -We are actively using Squeal at SimSpace which has pushed its development. - -My colleague Mark Wotton has also created a project -[squealgen](https://github.com/mwotton/squealgen) to generate -a Squeal schema directly from the database which is awesome. - -**Module hierarchy** - -Squeal had been growing some rather large modules, whereas I prefer -sub-thousand line modules. Accordingly, I split up the module -hierarchy further. This means there's 60 modules which looks a little -overwhelming, but I think it makes it easier to locate functionality. -It also makes working in a single module less overwhelming. -All relevant functionality is still being exported by `Squeal.PostgreSQL`. - -**Statement Profunctors** - -Squeal's top level queries and manipulations left something to be desired. -Because `Query_` and `Manipulation_` were type families, they could be -a bit confusing to use. For instance, - -```Haskell ->>> :{ -selectUser :: Query_ DB UserId User -selectUser = select_ - (#id `as` #userId :* #name `as` #userName) - (from (table #users) & where_ (#id .== param @1)) -:} ->>> :t selectUser -selectUser - :: Query - '[] - '[] - '["public" ::: '["users" ::: 'Table ('[] :=> UsersColumns)]] - '[ 'NotNull 'PGint4] - '["userId" ::: 'NotNull 'PGint4, "userName" ::: 'NotNull 'PGtext] -``` - -So the `UserId` and `User` types are completely replaced by corresponding -Postgres types. This means that the query can be run, for instance, -with any parameter that is a generic singleton container of `Int32`. -We've lost apparent type safety. You could accidentally run `selectUser` -with a `WidgetId` parameter instead of a `UserId` and it could typecheck. - -That's because `Query` is a pure SQL construct, with no knowledge for -how to encode or decode Haskell values. - -Another annoyance of `Query_` and `Manipulation_` is that they _must_ -be applied to Haskell types which exactly match their corresponding -Postgres types. So, in practice, you often end up with one-off -data type definitions just to have a type that exactly matches, -having the same field names, and the same ordering, etc. as the -returned row. - -Both of these issues are solved with the new `Statement` type. Let's -see its definition. - -```Haskell -data Statement db x y where - Manipulation - :: (SOP.All (OidOfNull db) params, SOP.SListI row) - => EncodeParams db params x - -> DecodeRow row y - -> Manipulation '[] db params row - -> Statement db x y - Query - :: (SOP.All (OidOfNull db) params, SOP.SListI row) - => EncodeParams db params x - -> DecodeRow row y - -> Query '[] '[] db params row - -> Statement db x y -``` - -You can see that a `Statement` bundles either a `Query` or a `Manipulation` -together with a way to `EncodeParams` and a way to `DecodeRow`. This -ties the statement to actual Haskell types. Going back to the example, - -```Haskell ->>> :{ -selectUser :: Statement DB UserId User -selectUser = query $ select_ - (#id `as` #userId :* #name `as` #userName) - (from (table #users) & where_ (#id .== param @1)) -:} -``` - -Now we really do have the type safety of only being able to `executeParams` -`selectUser` with a `UserId` parameter. Here we've used the smart -constructor `query` which automatically uses the generic instances of -`UserId` and `User` to construct a way to `EncodeParams` and a way to -`DecodeRow`. We can use the `Query` constructor to do custom encodings -and decodings. - -```Haskell ->>> :{ -selectUser :: Statement DB UserId (UserId, Text) -selectUser = Query enc dec sql where - enc = contramap getUserId aParam - dec = do - uid <- #id - uname <- #name - return (uid, uname) - sql = select Star (from (table #users) & where_ (#id .== param @1)) -:} -``` - -`EncodeParams` and `DecodeRow` both have convenient APIs. `EncodeParams` -is `Contravariant` and can be composed with combinators. `DecodeRow` -is a `Monad` and has `IsLabel` instances. Since `Statement`s bundle -both together, they form `Profunctor`s, where you can `lmap` over -parameters and `rmap` over rows. - -The `Statement` `Profunctor` is heavily influenced by -the `Statement` `Profunctor` from Nikita Volkov's excellent `hasql` library, -building on the use of `postgresql-binary` for encoding and decoding. - -**Deriving** - -Many Haskell types have corresponding Postgres types like `Double` -corresponds to `float8`. Squeal makes this an open relationship with the -`PG` type family. Squeal 0.6 makes it easy to generate `PG` of your -Haskell types, though you might have to turn on `-XUndecidableInstances`, -by deriving an `IsPG` instance. -In addition to having a corresponding Postgres type, -to fully embed your Haskell type you want instances of `ToPG db` to -encode your type as an out-of-line parameter, `FromPG` to -decode your type from a result value, and `Inline` to inline -values of your type directly in SQL statements. - -```Haskell ->>> :{ -newtype CustomerId = CustomerId {getCustomerId :: Int32} - deriving newtype (IsPG, ToPG db, FromPG, Inline) -:} - ->>> :kind! PG CustomerId -PG CustomerId :: PGType -= 'PGint4 -``` - -You can even embed your Haskell records and enum types using -deriving via. - -```Haskell ->>> :{ -data Complex = Complex {real :: Double, imaginary :: Double} - deriving stock (GHC.Generic) - deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) - deriving (IsPG, ToPG db, FromPG, Inline) via Composite Complex -:} - ->>> :kind! PG Complex -PG Complex :: PGType -= 'PGcomposite - '["real" ::: 'NotNull 'PGfloat8, - "imaginary" ::: 'NotNull 'PGfloat8] - ->>> printSQL (inline (Complex 0 1)) -ROW((0.0 :: float8), (1.0 :: float8)) - ->>> :{ -data Answer = Yes | No - deriving stock (GHC.Generic) - deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) - deriving (IsPG, ToPG db, FromPG, Inline) via Enumerated Answer -:} - ->>> :kind! PG Answer -PG Answer :: PGType -= 'PGenum '["Yes", "No"] - ->>> printSQL (inline Yes) -'Yes' -``` - -You can also embed your types encoded as `Json` or `Jsonb`. - -```Haskell ->>> :{ -data Foo = Bar Int | Baz Char Text - deriving stock (GHC.Generic) - deriving anyclass (ToJSON, FromJSON) - deriving (IsPG, ToPG db, FromPG, Inline) via Jsonb Foo -:} - ->>> :kind! PG Foo -PG Foo :: PGType -= 'PGjsonb - ->>> printSQL (inline (Baz 'a' "aaa")) -('{"tag":"Baz","contents":["a","aaa"]}' :: jsonb) -``` - -One thing to notice about `ToParam db` is that it has an -extra parameter `db` that the other classes don't have. That's -because for some types, such as arrays and composites, you -need to know the OID of the element types in order to unambiguously -encode those types. And if the element types are user defined, -then they have to be looked up in the database. The extra parameter -lets us look through the schema for a matching type, and then -look up that type's OID. - -**Migrations** - -Previously Squeal migrations could be either pure, involving only -data definitions, or impure, allowing arbitrary `IO`. But, they -had to be rewindable; that is, every migration step had to have -an inverse. Squeal 0.6 generalizes to allow both invertible and -one-way migrations. The core datatype for migrations, the free -category `Path` has been moved to its own package `free-categories`. - -**Aggregation** - -Squeal 0.6 enables filtering and ordering for aggregate -arguments and filtering for window function arguments. - -```Haskell -arrayAgg (All #col & orderBy [AscNullsFirst #col] & filterWhere (#col .< 100)) -``` - -To upgrade existing code, if you have an aggregate with multiple arguments, -use `Alls` instead of `All` or `Distincts` instead of `Distinct` -and if you have a window function, apply either `Window` or `Windows` -to its argument(s). Additionally, convenient functions `allNotNull` and -`distinctNotNull` safely filter out `NULL`. - -**Ranges** - -Squeal 0.6 adds both Haskell and corresponding Postgres range types. - -```Haskell -data Bound x - = Infinite -- ^ unbounded - | Closed x -- ^ inclusive - | Open x -- ^ exclusive - -data Range x = Empty | NonEmpty (Bound x) (Bound x) - -(<=..<=), (<..<), (<=..<), (<..<=) :: x -> x -> Range x -moreThan, atLeast, lessThan, atMost :: x -> Range x -singleton :: x -> Range x -whole :: Range x -``` - -**Indexes and functions** - -Squeal 0.6 adds support for creating and dropping user defined -indexes and functions to your schema, which can then be used -in statements. - -**Lateral joins** - -Squeal 0.6 adds support for lateral joins, which may reference previous -items. - -**Null handling** - -Some null handling functions were added such as `monoNotNull` -and `unsafeNotNull`. Because Squeal is aggressively `NULL` polymorphic, -sometimes inference errors can occur. You can apply `monoNotNull` -to fix something to be not `NULL`. You can apply `unsafeNotNull` -when you know that something can't be `NULL`, for instance if you've -filtered `NULL` out of a column. - -**Other changes** - -Lots of other things changed. `Literal` and `literal` are now called -`Inline` and `inline`. `ColumnConstraint` is called `Optionality`. -`NullityType`s are called `NullTypes`. -Squeal 0.6 adds support for domain types. It more carefully types -`CREATE _ IF NOT EXISTS` and `DROP _ IF EXISTS` definitions. The -`Exception` type was refactored to remove `Maybe`s and new pattern -synonyms were defined to easily match on a few common SQL errors. -`VarChar` and `FixChar` types were added with smart constructors. -Many bugs were fixed. Also, many more tests were added and -a new benchmark suite. A lot more things were changed that I've -probably forgotten about. - -### Version 0.5.2 - -Fixes a bug in pool API and implementation. - -### Version 0.5 - -Version 0.5 makes a number of large changes and additions to Squeal. -I want to thank folks who contributed issues and pull requests; -Raveline, rimmington, ilyakooo0, chshersh, reygoch, and more. - -**Multi-schema support** - -Previous versions of Squeal only supported definitions in the "public" -schema. Squeal 0.5 adds support for multiple schemas with the new kind - -```Haskell -type SchemasType = [(Symbol,SchemaType)] -``` - -In order to upgrade your queries, manipulations and definitions from -Squeal 0.4, you will have to apply the `Public` type family, which indicates -that your only schema is the "public" schema. - -```Haskell --- Squeal 0.4 -setup :: Definition '[] Schema - --- Squeal 0.5 -setup :: Definition (Public '[]) (Public Schema) -``` - -You can create non-public schemas using `createSchema` and inversely -remove them using `dropSchema`. There is also an idempotent -`createSchemaIfNotExists`. - -In order to handle aliases which may refer to non-public schemas, Squeal 0.5 -introduces `QualifiedAlias`es. A `QualifiedAlias` can be referred to using -the `(!)` operator from the `IsQualified` typeclass; but if you want to refer -to an alias from the "public" schema, you can continue to use a single -overloaded label, no need to write `#public ! #tab`, just write `#tab`. - -**Top-level statements** - -As a consequence of multi-schema support, common table expressions that -a `Query` or `Manipulation` may refer to had to be broken into a new parameter. -Additionally, `Query` gained another new parameter for its outer scope which -will be discussed in the next section. - -To simplify type signatures that you have to write for top-level queries -and manipulations, Squeal 0.5 introduces the `Query_` and `Manipulation_` -type families. - -``` -type family Query_ - (schemas :: SchemasType) - (parameters :: Type) - (row :: Type) where - Query_ schemas params row = - Query '[] '[] schemas (TuplePG params) (RowPG row) -``` - -As you see, a top-level `Query_` has no outer scope and no common -table expressions in scope, they are empty `'[]`. Moreover, -its parameters and row parameters are now `Type`s, which are -converted to corresponding Postgres types using the `TuplePG` -and `RowPG` type families. This means you can write the type signatures -for your top-level statements using the Haskell types that you -intend to input and retrieve when running the statements. Similar -to `Query_`, there is a `Manipulation_` type, the only difference -being that a general `Manipulation` doesn't have an outer scope, -only a scope for common table expressions. - -**Subquery expressions** - -Previous versions of Squeal offered subquery expression support -but there were issues. The common use case of using the `IN` operator -from SQL was overly complex. There was a proliferation of subquery -functions to handle different comparison operators, each with two versions -for comparing `ALL` or `ANY` of the query rows. And, most confoundedly, -there was no way to support the `EXISTS` subquery because the "outer scope" -for a query was not available. - -Squeal adds an outer scope to the `Query` type. - -```Haskell -newtype Query - (outer :: FromType) - (commons :: FromType) - (schemas :: SchemasType) - (params :: [NullityType]) - (row :: RowType) - = UnsafeQuery { renderQuery :: ByteString } -``` - -This enables a well-typed `exists` function. - -```Haskell -exists - :: Query (Join outer from) commons schemas params row - -> Condition outer commons grp schemas params from -``` - -The `in_` and `notIn` functions were simplified to handle the most -common use case of comparing to a list of values. - -```Haskell -in_ - :: Expression outer commons grp schemas params from ty -- ^ expression - -> [Expression outer commons grp schemas params from ty] - -> Condition outer commons grp schemas params from -``` - -Finally, general subquery comparisons were abstracted to work with -any comparison operators, using the `Operator` type which will be discussed in -the next section. - -```Haskell -subAll - :: Expression outer commons grp schemas params from ty1 - -> Operator ty1 ty2 ('Null 'PGbool) - -> Query (Join outer from) commons schemas params '[col ::: ty2] - -> Condition outer commons grp schemas params from - -subAny - :: Expression outer commons grp schemas params from ty1 - -> Operator ty1 ty2 ('Null 'PGbool) - -> Query (Join outer from) commons schemas params '[col ::: ty2] - -> Condition outer commons grp schemas params from -``` - -**Expression RankNTypes** - -Squeal 0.5 introduces RankNType type synonyms for common expression patterns. -The simplest example is the `Expr` type, a type for "closed" expressions -that cannot reference any aliases or parameters. - -```Haskell -type Expr x - = forall outer commons grp schemas params from - . Expression outer commons grp schemas params from x -``` - -There is also a function type `(-->)`, which is a subtype of the usual Haskell function -type `(->)`. - -```Haskell -type (-->) x y - = forall outer commons grp schemas params from - . Expression outer commons grp schemas params from x - -> Expression outer commons grp schemas params from y -``` - -We saw in the subquery section that there is an `Operator` type. - -```Haskell -type Operator x1 x2 y - = forall outer commons grp schemas params from - . Expression outer commons grp schemas params from x1 - -> Expression outer commons grp schemas params from x2 - -> Expression outer commons grp schemas params from y -``` - -There are also types `FunctionN` and `FunctionVar` for n-ary functions -and variadic functions. - -``` -type FunctionN xs y - = forall outer commons grp schemas params from - . NP (Expression outer commons grp schemas params from) xs - -> Expression outer commons grp schemas params from y -``` - -An n-ary function takes an `NP` list of `Expression`s as its argument. -Squeal 0.5 adds a helpful operator `(*:)`, to help scrap your `Nil`s. -You can construct an `NP` list now by using the operator `(:*)`, -until your last element, using `(*:)` there. For instance, the function -`atan2_` takes two arguments, `atan2_ (pi *: 2)`. - -**Selections** - -Previously, Squeal provided a couple versions of `SELECT` depending -on whether you wanted to select all columns of a unique table -in the from clause, i.e. `*`, all columns of a particular table -in the from clause, i.e. `.*`, or a list of columns from the from clause. - -Squeal 0.5 refactors this pattern into a `Selection` GADT type, allowing -for abstraction and combinations that were not possible before. - -```Haskell -data Selection outer commons grp schemas params from row where - Star - :: HasUnique tab from row - => Selection outer commons 'Ungrouped schemas params from row - DotStar - :: Has tab from row - => Alias tab - -> Selection outer commons 'Ungrouped schemas params from row - List - :: SListI row - => NP (Aliased (Expression outer commons grp schemas params from)) row - -> Selection outer commons grp schemas params from row - Over - :: SListI row - => NP (Aliased (WindowFunction outer commons grp schemas params from)) row - -> WindowDefinition outer commons grp schemas params from - -> Selection outer commons grp schemas params from row - Also - :: Selection outer commons grp schemas params from right - -> Selection outer commons grp schemas params from left - -> Selection outer commons grp schemas params from (Join left right) -``` - -In addition to the `Star`, `DotStar` and `List` constructors, there is an -`Also` constructor combinator, which enables users to combine `Selection`s. -Additionally, there is an `Over` constructor that is used to enable -window functions, described in the next section. - -To upgrade from Squeal 0.4, you will replace `selectStar` with `select Star`, -replace `selectDotStar #tab` with `select (DotStar #tab)`. The `List` -selection is such a common use case that there is a function `select_` which -automatically applies it, so to upgrade from Squeal 0.4, replace `select` -with `select_`. There are also independent `selectDistinct` and `selectDistinct_` -functions to filter out duplicate rows. - -**Query clauses** - -Previously, Squeal provided a couple versions of `INSERT` depending -on whether you wanted to insert `VALUES` or a query. - -Squeal 0.5 refactors this pattern into a `QueryClause` GADT. - -``` --- Squeal 0.4 -insertRow_ #tab (Set 2 `as` #col1 :* Default `as` #col2) -insertQuery_ #tab (selectStar (from (table #other_tab))) - --- Squeal 0.5 -insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2)) -insertInto_ #tab (Subquery (select Star (from (table #other_tab)))) -``` - -**Window functions and aggregation** - -Previous versions of Squeal provided no support for window functions. -Squeal 0.5 adds support for window functions. We saw `Over` in the -previous section. - -```Haskell -Over - :: SListI row - => NP (Aliased (WindowFunction outer commons grp schemas params from)) row - -> WindowDefinition outer commons grp schemas params from - -> Selection outer commons grp schemas params from row -``` - -`Over` combines window functions with window definitions. A `WindowDefinition` -is constructed using the `partitionBy` function, optionally with an `orderBy` -clause. For example, - -```Haskell -query :: Query_ (Public Schema) () (Row Int32 Int32) -query = select - (#col1 & Also (rank `as` #col2 `Over` (partitionBy #col1 & orderBy [#col2 & Asc]))) - (from (table #tab)) -``` - -Here the `rank` function is a `WindowFunction` - -```Haskell -rank :: WinFun0 ('NotNull 'PGint8) -rank = UnsafeWindowFunction "rank()" -``` - -`WinFun0` is a RankNType, like `Expr` was, used for no argument window functions. -Similarly, there are also `WinFun1` and `WinFunN` types for -window functions and n-ary window functions. - -In order to use the same syntax for certain window functions and aggregate functions, -a new typeclass `Aggregate` was introduced. So for instance, `sum_` can be -either a `Distinction` `Expression` or a `WindowFunction`, used either with -a `groupBy` or with a `partitionBy` in the appropriate way. - -``` -data Distinction (expr :: kind -> Type) (ty :: kind) - = All (expr ty) - | Distinct (expr ty) -``` - -Aggregate functions can be run over all rows or only over distinct rows, -while window functions bear no such distinction. - -**Migrations** - -Thanks to [https://github.com/Raveline](Raveline) Squeal 0.5 introduces -a function `defaultMain` to easily create a command line program to -run or rewind your migrations. - -Previously, Squeal's migrations were impure, allowing in addition to -running `Definition`s to run arbitrary `IO` operations, such as inserting -data into the database or printing out status messages. In order to -provide compatibility with other migration systems, Squeal 0.5 introduces -pure migrations, that is migrations that are only `Definition`s. - -```Haskell -data Migration p schemas0 schemas1 = Migration - { name :: Text -- ^ The `name` of a `Migration`. - -- Each `name` in a `Migration` should be unique. - , up :: p schemas0 schemas1 -- ^ The `up` instruction of a `Migration`. - , down :: p schemas1 schemas0 -- ^ The `down` instruction of a `Migration`. - } deriving (GHC.Generic) -``` - -A pure migration is a `Migration Definition`, a pair of inverse -`Definition`s with a unique name. To recover impure migrations, Squeal 0.5 -introduces the `Terminally` type. - -```Haskell -newtype Terminally trans monad x0 x1 = Terminally - { runTerminally :: trans x0 x1 monad () } -``` - -`Terminally` applies the indexed monad transformer and the monad it transforms -to the unit type `()`, thereby turning an indexed monad into a `Category`. An -impure migration is a `Migration (Terminally PQ IO)`. You can always cast -a pure migration into an impure migration with the functor, `pureMigration`. - -```Haskell -pureMigration - :: Migration Definition schemas0 schemas1 - -> Migration (Terminally PQ IO) schemas0 schemas1 -``` - -To run either pure or impure migrations, Squeal 0.5 introduces -a typeclass, `Migratory`. - -``` -class Category p => Migratory p where - - migrateUp - :: AlignedList (Migration p) schemas0 schemas1 - -> PQ schemas0 schemas1 IO () - - migrateDown - :: AlignedList (Migration p) schemas0 schemas1 - -> PQ schemas1 schemas0 IO () -``` - -The signatures of `migrateUp` and `migrateDown` have been changed -to make them easier to compose with other `PQ` actions. - -**Transactions** - -You can now run transactions `ephemerally`, guaranteed to roll back, -but return the result or throw the exception that the transaction -would have generated. This is useful for testing. You can also -`transactionallyRetry` computations, retrying the transaction if -a [serialization failure](https://www.postgresql.org/docs/11/transaction-iso.html#XACT-REPEATABLE-READ) occurs. - -**Types** - -Squeal now supports money via a `Money` Haskell `Type` and a `'PGmoney` -`PGType`. Squeal 0.5 also adds support for creating domain types -with `createDomain`. - -**Time** - -Squeal 0.5 adds support for new functions; `now`, `makeDate`, `makeTime`, -, `makeTimestamp`, and `makeTimestamptz`, a function `interval_` for -constructing time intervals out multiples of `TimeUnit`s, and a new -`TimeOp` class, defining affine space operators for time types and their -differences. - -**Literals** - -Squeal allows you to include Haskell values in your statements using -out of line `parameter`s, but often you want to include them inline, -as a SQL `literal`. Squeal 0.5 enables this using the `Literal` class. - -**Set returning functions** - -Squeal 0.5 adds support for set returning functions such as `unnest`, -with the `RankNType` `SetOfFunction`, which can be used as as a `FromClause`. - -**Text search** - -Squeal 0.5 adds extensive support for text search types, functions and operators. - -**Much more** - -Lots more changes went into and under the hood of the new version. -The `Expression` module was split into coherent submodules since it -had grown to immense proportions. New modules `Alias`, `PG` and `List` -were added to relieve some of the burden that the `Schema` module -had been carrying. Rendering has been better unified with a new -`RenderSQL` typeclass. Type level list concatenation with the `Additional` -typeclass has been added. `Manipulation`s `update` and `delete` -were upgraded, so you can leave out fields you don't want to update and -use `USING` clauses in deletes. Upserts which were previously broken -now work. The `IO` typeclass hierarchy was changed from `MonadBase` -and `MonadBaseControl` to `MonadIO` and `MonadUnliftIO`. A new -`withRecursive` `Manipulation` was added. `SquealException`s were -refactored and a `trySqueal` function added. Arrays were refactored. -And there was probably more I've forgotten. - -### Version 0.4 - -Version 0.4 strengthens Squeal's type system, adds -support for multidimensional arrays, improves support -for container type, improves `with` statements, -improves runtime exceptions, accomodates SQL's three-valued logic, -adds subquery expressions, and adds table and view type expressions. - -**Types** - -Squeal 0.4 renames some kinds to aid intuition: - -```Haskell -type RowType = [(Symbol, NullityType)] -- previously RelationType -type FromType = [(Symbol, RowType)] -- previously RelationsType -``` - -Null safety for array and composite types is gained by having the base -type of an array be a `NullityType` and the base type of a composite -a `RowType`. - -```Haskell -data PGType - = .. - | PGvararray NullityType - | PGfixarray Nat NullityType - | PGcomposite RowType -``` - -Squeal embeds Postgres types into Haskell using data kinds and type-in-type: - -```Haskell -data PGType = PGbool | .. -data NullityType = Null PGType | NotNull PGType -type RowType = [(Symbol, NullityType)] -- previously RelationType -type FromType = [(Symbol, RowType)] -- previously RelationsType -``` - -In another sense, we can embed Haskell types -into Postgres types by providing type families: - -```Haskell -type family PG (hask :: Type) :: PGType -type family NullPG (hask :: Type) :: NullityType -type family TuplePG (hask :: Type) :: [NullityType] -type family RowPG (hask :: Type) :: RowType -``` - -Let's look at these one by one. - -`PG` was introduced in Squeal 0.3. It was a closed type family that -associates some Haskell types to their obvious corresponding Postgres -types like `PG Double = 'PGfloat8`. It only worked on base types, -no arrays or composites. Squeal 0.4 extends it to -such container types and makes it an open type family so that -users can make their own type instances. - -`NullPG` had a different name before but it does the obvious -thing for Haskell with `Maybe`s: - -```Haskell -type family NullPG hask where - NullPG (Maybe hask) = 'Null (PG hask) - NullPG hask = 'NotNull (PG hask) -``` - -`TuplePG` uses generics to turn tuple types (including records) -into lists of `NullityType`s in the logical way, e.g. -`TuplePG (Bool, Day) = '[ 'PGbool, 'PGdate]`. - -`RowPG` also uses generics to turn record types into a `RowType` in the logical way, e.g. - -```Haskell ->>> data Person = Person { name :: Text, age :: Int32 } deriving GHC.Generic ->>> instance SOP.Generic Person ->>> instance SOP.HasDatatypeInfo Person ->>> :kind! TuplePG Person -TuplePG Person :: [NullityType] -= '['NotNull 'PGtext, 'NotNull 'PGint4] ->>> :kind! RowPG Person -RowPG Person :: [(Symbol, NullityType)] -= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4] -``` - -We've already seen a hint of why these types are useful in one construction -from Squeal 0.3. Creating composite types in Postgres directly from a Haskell -record type essentially uses `RowPG`. Another important use is in simplifying -the type signatures for a `Query` or `Manipulation`. Very often, you will have -a tuple type corresponding to the parameters and a record type corresponding -to the returned columns of a `Query` or `Manipulation`. Instead of writing -boilerplate signature you can reuse these with the help of `TuplePG` and `RowPG` - -For instance: - -```Haskell ->>> :{ -let - query :: Query '["user" ::: 'View (RowPG Person)] (TuplePG (Only Int32)) (RowPG Person) - query = selectStar (from (view #user) & where_ (#age .> param @1)) -:} -``` - -**Arrays** - -In addition to being able to encode and decode basic Haskell types -like `Int16` and `Text`, Squeal 0.4 permits you to encode and decode Haskell types to -Postgres array types. The `Vector` type corresponds to to variable length arrays. -And thanks to an idea from [Mike Ledger](https://github.com/mikeplus64), -homogeneous tuples correspond to fixed length arrays. We can even -create multi-dimensional fixed length arrays. Let's see an example. - -```Haskell ->>> :{ -data Row = Row - { col1 :: Vector Int16 - , col2 :: (Maybe Int16,Maybe Int16) - , col3 :: ((Int16,Int16),(Int16,Int16),(Int16,Int16)) - } deriving (Eq, GHC.Generic) -:} - ->>> instance Generic Row ->>> instance HasDatatypeInfo Row -``` - -Define a simple round trip query. - -```Haskell ->>> :{ -let - roundTrip :: Query '[] (TuplePG Row) (RowPG Row) - roundTrip = values_ $ - parameter @1 (int2 & vararray) `as` #col1 :* - parameter @2 (int2 & fixarray @2) `as` #col2 :* - parameter @3 (int2 & fixarray @2 & fixarray @3) `as` #col3 -:} - ->>> :set -XOverloadedLists ->>> let input = Row [1,2] (Just 1,Nothing) ((1,2),(3,4),(5,6)) ->>> :{ -void . withConnection "host=localhost port=5432 dbname=exampledb" $ do - result <- runQueryParams roundTrip input - Just output <- firstRow result - liftBase . print $ input == output -:} -True -``` - -**Containers** - -Squeal aims to provide a correspondence between Haskell types and Postgres types. -In particular, Haskell ADTs with nullary constructors can correspond to -Postgres enum types and Haskell record types can correspond to Postgres -composite types. However, it's not always obvious that that's how a user -will choose to store values of those types. So Squeal 0.4 introduces newtypes -whose purpose is to specify how a user wants to store values of a type. - -```Haskell -newtype Json hask = Json {getJson :: hask} -newtype Jsonb hask = Jsonb {getJsonb :: hask} -newtype Composite record = Composite {getComposite :: record} -newtype Enumerated enum = Enumerated {getEnumerated :: enum} -``` - -Let's see an example: - -```Haskell ->>> data Schwarma = Beef | Lamb | Chicken deriving (Eq, Show, GHC.Generic) ->>> instance SOP.Generic Schwarma ->>> instance SOP.HasDatatypeInfo Schwarma ->>> ->>> data Person = Person {name :: Text, age :: Int32} deriving (Eq, Show, GHC.Generic) ->>> instance SOP.Generic Person ->>> instance SOP.HasDatatypeInfo Person ->>> instance Aeson.FromJSON Person ->>> instance Aeson.ToJSON Person -``` - -We can create the equivalent Postgres types directly from their Haskell types. - -```Haskell ->>> :{ -type Schema = - '[ "schwarma" ::: 'Typedef (PG (Enumerated Schwarma)) - , "person" ::: 'Typedef (PG (Composite Person)) - ] -:} - ->>> :{ -let - setup :: Definition '[] Schema - setup = - createTypeEnumFrom @Schwarma #schwarma >>> - createTypeCompositeFrom @Person #person -:} -``` - -Let's demonstrate how to associate our Haskell types `Schwarma` and `Person` -with enumerated, composite or json types in Postgres. First create a Haskell -`Row` type using the `Enumerated`, `Composite` and `Json` newtypes as fields. - -```Haskell ->>> :{ -data Row = Row - { schwarma :: Enumerated Schwarma - , person1 :: Composite Person - , person2 :: Json Person - } deriving (Eq, GHC.Generic) -:} - ->>> instance Generic Row ->>> instance HasDatatypeInfo Row ->>> :{ -let - input = Row - (Enumerated Chicken) - (Composite (Person "Faisal" 24)) - (Json (Person "Ahmad" 48)) -:} -``` - -Once again, define a round trip query. - -```Haskell ->>> :{ -let - roundTrip :: Query Schema (TuplePG Row) (RowPG Row) - roundTrip = values_ $ - parameter @1 (typedef #schwarma) `as` #schwarma :* - parameter @2 (typedef #person) `as` #person1 :* - parameter @3 json `as` #person2 -:} -``` - -Finally, we can drop our type definitions. - -```Haskell ->>> :{ -let - teardown :: Definition Schema '[] - teardown = dropType #schwarma >>> dropType #person -:} -``` - -Now let's run it. - -```Haskell ->>> :{ -let - session = do - result <- runQueryParams roundTrip input - Just output <- firstRow result - liftBase . print $ input == output -in - void . withConnection "host=localhost port=5432 dbname=exampledb" $ - define setup - & pqThen session - & pqThen (define teardown) -:} -True -``` - -**With** - -Squeal 0.3 supported WITH statements but there's a couple problems with them. -Here's the type signature for `with` in Squeal 0.3. - -```Haskell -with - :: SOP.SListI commons - => NP (Aliased (Manipulation schema params)) (common ': commons) - -- ^ common table expressions - -> Manipulation (With (common ': commons) schema) params results - -> Manipulation schema params results -``` - -The first problem is that `with` only works with `Manipulations`. -It can work on `Query`s by using `queryStatement` but it still will -return a `Manipulation`. We can fix this issue by making `with` a -method of a type class with instances for both `Query` and `Manipulation`. - -The second problem is that all the common table expressions -refer the base schema, whereas in SQL, each subsequent CTE can -refer to previous CTEs as well. But this can be fixed! First define a datatype: - -```Haskell -data CommonTableExpression statement params schema0 schema1 where - CommonTableExpression - :: Aliased (statement schema params) (alias ::: cte) - -> CommonTableExpression statement params schema (alias ::: 'View cte ': schema) -``` - -It's just a wrapper around an aliased statement, where the statement -could be either a `Query` or `Manipulation`, but it augments the schema -by adding a view to it. It almost looks like a morphism between schemas -but there is no way yet to compose them. Luckily, Squeal already has -a datatype for this, which is used for migrations, the `AlignedList` -type which is really the "free category". So we can then define a `With` type class: - -```Haskell -class With statement where - with - :: AlignedList (CommonTableExpression statement params) schema0 schema1 - -> statement schema1 params row - -> statement schema0 params row -``` - -By giving `Aliasable` instances to CTEs and aligned singleton lists of CTEs (i.e. scrap-your-nils), we get a nice syntax for WITH statements in Squeal. - -Here's an example of using `with` for a `Query` and a `Manipulation`: - -```Haskell ->>> :{ -let - query :: Query - '[ "t1" ::: 'View - '[ "c1" ::: 'NotNull 'PGtext - , "c2" ::: 'NotNull 'PGtext] ] - '[] - '[ "c1" ::: 'NotNull 'PGtext - , "c2" ::: 'NotNull 'PGtext ] - query = with ( - selectStar (from (view #t1)) `as` #t2 :>> - selectStar (from (view #t2)) `as` #t3 - ) (selectStar (from (view #t3))) -in printSQL query -:} -WITH "t2" AS (SELECT * FROM "t1" AS "t1"), "t3" AS (SELECT * FROM "t2" AS "t2") SELECT * FROM "t3" AS "t3" - ->>> type ProductsTable = '[] :=> '["product" ::: 'NoDef :=> 'NotNull 'PGtext, "date" ::: 'Def :=> 'NotNull 'PGdate] - ->>> :{ -let - manipulation :: Manipulation - '[ "products" ::: 'Table ProductsTable - , "products_deleted" ::: 'Table ProductsTable - ] '[ 'NotNull 'PGdate] '[] - manipulation = with - (deleteFrom #products (#date .< param @1) ReturningStar `as` #deleted_rows) - (insertQuery_ #products_deleted (selectStar (from (view (#deleted_rows `as` #t))))) -in printSQL manipulation -:} -WITH "deleted_rows" AS (DELETE FROM "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" SELECT * FROM "deleted_rows" AS "t" -``` - -**Three Valued Logic** - -In previous versions of Squeal, conditions followed classical two valued logic -of `true` and `false`. - -```Haskell --- Squeal 0.3 -type Condition schema from grouping params = - Expression schema from grouping params ('NotNull 'PGbool) -``` - -I had thought that three valued logic, which is what SQL uses, was confusing. -However, multiple users reported being confused at being forced to do `NULL` -handling, particularly in their left joins. Since the original motivation -of being less confusing evaporated I decided to switch to three valued logic -of `true`, `false` and `null_`. - -```Haskell --- Squeal 0.4 -type Condition schema from grouping params = - Expression schema from grouping params ('Null 'PGbool) -``` - -**Subquery Expressions** - -Squeal 0.4 adds support for subquery expressions such as `IN` and `op ANY/ALL`. - -**Row Types** - -Squeal 0.4 adds functions to define type expressions from tables and views -and a type expression for user defined types, `typetable`, `typeview` and -`typedef`. - -**Runtime Exceptions** - -Squeal now has an exception type which gives details on the sort of error -encountered and handler functions. - -```Haskell -data SquealException - = PQException - { sqlExecStatus :: LibPQ.ExecStatus - , sqlStateCode :: Maybe ByteString - -- ^ https://www.postgresql.org/docs/current/static/errcodes-appendix.html - , sqlErrorMessage :: Maybe ByteString - } - | ResultException Text - | ParseException Text - deriving (Eq, Show) -instance Exception SquealException - -catchSqueal - :: MonadBaseControl IO io - => io a - -> (SquealException -> io a) -- ^ handler - -> io a - -handleSqueal - :: MonadBaseControl IO io - => (SquealException -> io a) -- ^ handler - -> io a -> io a -``` - -**Additional Changes** - -Squeal 0.4 adds `field` and `index` functions to get components of composite -and array expressions. - -Squeal 0.4 adds a dependency on `records-sop` to offload a lot of boilerplate -type family logic that was needed for `RowPG`. - -The above changes required major and minor changes to Squeal DSL functions. -Please consult the documentation. - -### Version 0.3.2 - August 4, 2018 - -Version 0.3.2 features extensive support for `JSON` functionality with -more than 50 new functions. -This work is entirely due to [Mike Ledger](https://github.com/mikeplus64) -who has been making terrific contributions to Squeal. Thanks! -We also got some examples in the documentation for pools submitted by -[Raveline](https://github.com/Raveline). I'm so pleased to be -getting pull requests and issue submissions from you all! - -### Version 0.3.1 - July 7, 2018 - -Version 0.3.1 of Squeal enables the "Scrap your Nils" trick for -heterogeneous lists of `Alias`es, `Aliased` expressions, `PGlabel`s and `By`s -with the typeclasses `IsLabel`, `IsQualified`, `IsPGlabel`, -and the new `Aliasable` typeclass, to eliminate all need of using `Nil` in a list. -There were a couple minor name changes, i.e. the function `group` was renamed to `groupBy`. -Please consult the documentation. - -### Version 0.3 - June 26, 2018 - -Version 0.3 of Squeal adds views as well as composite and enumerated types to Squeal. -To support these features, a new kind `SchemumType` was added. - -```Haskell -data SchemumType - = Table TableType - | View RelationType - | Typedef PGType -``` - -As a consequence, you will have to update your schema definitions like so: - -```Haskell --- Squeal 0.2 -type Schema = - '[ "users" ::: - '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "name" ::: 'NoDef :=> 'NotNull 'PGtext - ] - ] - --- Squeal 0.3 -type Schema = - '[ "users" ::: 'Table ( - '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "name" ::: 'NoDef :=> 'NotNull 'PGtext - ]) - ] -``` - -**Views** - -You can now create, drop, and query views. - -```Haskell ->>> :{ -type ABC = - ('[] :: TableConstraints) :=> - '[ "a" ::: 'NoDef :=> 'Null 'PGint4 - , "b" ::: 'NoDef :=> 'Null 'PGint4 - , "c" ::: 'NoDef :=> 'Null 'PGint4 - ] -type BC = - '[ "b" ::: 'Null 'PGint4 - , "c" ::: 'Null 'PGint4 - ] -:} - ->>> :{ -let - definition :: Definition '["abc" ::: 'Table ABC ] '["abc" ::: 'Table ABC, "bc" ::: 'View BC] - definition = createView #bc (select (#b :* #c :* Nil) (from (table #abc))) -in printSQL definition -:} -CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc"; - ->>> :{ -let - definition :: Definition '["abc" ::: 'Table ABC, "bc" ::: 'View BC] '["abc" ::: 'Table ABC] - definition = dropView #bc -in printSQL definition -:} -DROP VIEW "bc"; - ->>> :{ -let - query :: Query '["abc" ::: 'Table ABC, "bc" ::: 'View BC] '[] BC - query = selectStar (from (view #bc)) -in printSQL query -:} -SELECT * FROM "bc" AS "bc" -``` - -**Enumerated Types** - -PostgreSQL has a powerful type system. It even allows for user defined types. -For instance, you can define enumerated types which are data types that comprise -a static, ordered set of values. They are equivalent to Haskell algebraic data -types whose constructors are nullary. An example of an enum type might be the days of the week, -or a set of status values for a piece of data. - -Enumerated types are created using the `createTypeEnum` command, for example: - -```Haskell ->>> :{ -let - definition :: Definition '[] '["mood" ::: 'Typedef ('PGenum '["sad", "ok", "happy"])] - definition = createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy" :* Nil) -:} ->>> printSQL definition -CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy'); -``` - -Enumerated types can also be generated from a Haskell algebraic data type with nullary constructors, for example: - -```Haskell ->>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic ->>> instance SOP.Generic Schwarma ->>> instance SOP.HasDatatypeInfo Schwarma - ->>> :kind! EnumFrom Schwarma -EnumFrom Schwarma :: PGType -= 'PGenum '["Beef", "Lamb", "Chicken"] - ->>> :{ -let - definition :: Definition '[] '["schwarma" ::: 'Typedef (EnumFrom Schwarma)] - definition = createTypeEnumFrom @Schwarma #schwarma -:} ->>> printSQL definition -CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken'); -``` - -You can express values of an enum type using `label`, which is an overloaded method -of the `IsPGlabel` typeclass. - -```Haskell ->>> :{ -let - expression :: Expression sch rels grp params ('NotNull (EnumFrom Schwarma)) - expression = label @"Chicken" -in printSQL expression -:} -'Chicken' -``` - -**Composite Types** - -In addition to enum types, you can define composite types. -A composite type represents the structure of a row or record; -it is essentially just a list of field names and their data types. - - -`createTypeComposite` creates a composite type. The composite type is -specified by a list of attribute names and data types. - -```Haskell ->>> :{ -let - definition :: Definition '[] '["complex" ::: 'Typedef ('PGcomposite '["real" ::: 'PGfloat8, "imaginary" ::: 'PGfloat8])] - definition = createTypeComposite #complex (float8 `As` #real :* float8 `As` #imaginary :* Nil) -:} ->>> printSQL definition -CREATE TYPE "complex" AS ("real" float8, "imaginary" float8); -``` - -Composite types are almost equivalent to Haskell record types. -However, because of the potential presence of `NULL` -all the record fields must be `Maybe`s of basic types. -Composite types can be generated from a Haskell record type, for example: - -```Haskell ->>> data Complex = Complex {real :: Maybe Double, imaginary :: Maybe Double} deriving GHC.Generic ->>> instance SOP.Generic Complex ->>> instance SOP.HasDatatypeInfo Complex - ->>> :kind! CompositeFrom Complex -CompositeFrom Complex :: PGType -= 'PGcomposite '['("real", 'PGfloat8), '("imaginary", 'PGfloat8)] - ->>> :{ -let - definition :: Definition '[] '["complex" ::: 'Typedef (CompositeFrom Complex)] - definition = createTypeCompositeFrom @Complex #complex -in printSQL definition -:} -CREATE TYPE "complex" AS ("real" float8, "imaginary" float8); -``` - -A row constructor is an expression that builds a row value -(also called a composite value) using values for its member fields. - -```Haskell ->>> :{ -let - i :: Expression '[] '[] 'Ungrouped '[] ('NotNull (CompositeFrom Complex)) - i = row (0 `As` #real :* 1 `As` #imaginary :* Nil) -:} ->>> printSQL i -ROW(0, 1) -``` - -You can also use `(&)` to apply a field label to a composite value. - -```Haskell ->>> :{ -let - expr :: Expression '[] '[] 'Ungrouped '[] ('Null 'PGfloat8) - expr = i & #imaginary -in printSQL expr -:} -(ROW(0, 1)).imaginary -``` - -Both composite and enum types can be automatically encoded from and decoded to their equivalent Haskell types. -And they can be dropped. - -```Haskell ->>> :{ -let - definition :: Definition '["mood" ::: 'Typedef ('PGenum '["sad", "ok", "happy"])] '[] - definition = dropType #mood -:} ->>> printSQL definition -DROP TYPE "mood"; -``` - -**Additional Changes** - -Squeal 0.3 also introduces a typeclass `HasAll` similar to `Has` but for a list of aliases. -This makes it possible to clean up some unfortunately messy Squeal 0.2 definitions. - -```Haskell --- Squeal 0.2 ->>> unique (Column #a :* Column #b :* Nil) - --- Squeal 0.3 ->>> unique (#a :* #b :* Nil) -``` - -Squeal 0.3 also adds `IsLabel` instances for `Aliased` expressions and tables as well as -heterogeneous lists, allowing for some more economy of code. - -```Haskell --- Squeal 0.2 (or 0.3) ->>> select (#a `As` #a :* Nil) (from (table (#t `As` #t))) - --- Squeal 0.3 ->>> select #a (from (table #t)) -``` - -Squeal 0.3 also fixes a bug that prevented joined queries on self-referencing tables. - -The above changes required major and minor changes to Squeal DSL functions. -Please consult the documentation. - -### Version 0.2.1 - April 7, 2018 - -This minor update fixes an issue where alias identifiers could conflict with -reserved words in PostgreSQL. To fix the issue, alias identifiers are now -quoted. Thanks to Petter Rasmussen for the fix. - -### Version 0.2 - March 26, 2018 - -**Changes** -- **Constraints** - Type level table constraints like primary and foreign keys and column constraints like having `DEFAULT`. -- **Migrations** - Support for linear, invertible migrations tracked in an auxiliary table -- **Arrays** - Support for fixed- and variable-length arrays -- **Aliases** - Generalized `Has` constraint -- **Pools** - Support for pooled connections -- **Transactions** - Support for transaction control language -- **Queries, Manipulations, Definitions** - Small and large changes to Squeal's DSL - -Well, a lot of things changed! - -**Constraints** - -An important request was to bring constraints to the type level. -This means that more of the schema is statically known. In `0.1` column constraints - which boil down -to having `DEFAULT` or not - were at the type level, but they were confusingly named. - -```haskell -0.1: 'Optional ('NotNull 'PGInt4) -0.2: 'Def :=> 'NotNull 'PGInt4 -0.1: 'Required ('NotNull 'PGInt4) -0.2: 'NoDef :=> 'NotNull 'PGInt4 -``` - -The `:=>` type operator is intended to helpfully connote a constraint relation. -It's also used for table constraints which are new in `0.2`. - -```haskell -"emails" ::: - '[ "pk_emails" ::: 'PrimaryKey '["id"] - , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"] - ] :=> - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 - , "email" ::: 'NoDef :=> 'Null 'PGtext - ] -``` - -Another change in the constraint system was the removal of column constraints from -query and manipulation results, as result columns don't support a notion of `DEFAULT`. -This necessitates a distinction between `TableType`s which have both column and table -constraints and `RelationType`s which have neither. - -**Migrations** - -Migrations are a hot topic and many people have requested this feature. Squeal `0.2` -adds support for linear, invertible migrations. That is, a migration is a named, -invertible, schema-tracking computation: - -```haskell -data Migration io schema0 schema1 = Migration - { name :: Text -- ^ The `name` of a `Migration`. - -- Each `name` in a `Migration` should be unique. - , up :: PQ schema0 schema1 io () -- ^ The `up` instruction of a `Migration`. - , down :: PQ schema1 schema0 io () -- ^ The `down` instruction of a `Migration`. - } -``` - -And, `Migration`s can be put together in an "aligned" list: - -```haskell -data AlignedList p x0 x1 where - Done :: AlignedList p x x - (:>>) :: p x0 x1 -> AlignedList p x1 x2 -> AlignedList p x0 x2 -``` - -These aligned lists are free categories and might look familiar from -the [reflections without remorse](http://okmij.org/ftp/Haskell/zseq.pdf) technique, -which uses their cousins, aligned sequences. - -In the context of migration, they allow one to chain new migrations as a -schema evolves over time. `Migration`s' execution is tracked in an auxiliary -migrations table. Migration lists can then be run or rewinded. - -```haskell -migrateUp - :: MonadBaseControl IO io - => AlignedList (Migration io) schema0 schema1 -- ^ migrations to run - -> PQ - ("schema_migrations" ::: MigrationsTable ': schema0) - ("schema_migrations" ::: MigrationsTable ': schema1) - io () - -migrateDown - :: MonadBaseControl IO io - => AlignedList (Migration io) schema0 schema1 -- ^ migrations to rewind - -> PQ - ("schema_migrations" ::: MigrationsTable ': schema1) - ("schema_migrations" ::: MigrationsTable ': schema0) - io () -``` - -**Aliases** - -In Squeal `0.1`, we had different typeclasses `HasColumn` and `HasTable` to indicate -that a table has a column or that a schema has a table. In Squeal `0.2` this has been -unified to a single typeclass, - -```haskell -class KnownSymbol alias => - Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind) - | alias fields -> field where -``` - -**Arrays** - -Support for array types has been added to Squeal `0.2` through -the `'PGfixarray` and `'PGvararray` `PGType`s. Array values can be -constructed using the `array` function and can be encoded from and decoded to -Haskell `Vector`s. - -**Pools** - -Squeal `0.2` provides a monad transformer `PoolPQ` that's an instance of `MonadPQ`. -The `resource-pool` library is leveraged to provide striped pools of `Connection`s. -`PoolPQ` should be a drop in replacement for running `Manipulation`s and `Query`s with -`PQ`. - -**Transactions** - -Squeal `0.2` supports a simple transaction control language. A computation in -`MonadPQ` can be called `transactionally` with different levels of isolation. -Additionally, a schema changing computation, a data definition, can be run in a -transaction. Running a computation in a transaction means that all SQL statements -will be rolled back if an exception is encountered. - -**Queries, Manipulations and Definitions** - -The above changes required major and minor changes to Squeal DSL functions. -Please consult the documentation. diff --git a/scrap-your-nils.md b/scrap-your-nils.md deleted file mode 100644 index 04a0188d..00000000 --- a/scrap-your-nils.md +++ /dev/null @@ -1,60 +0,0 @@ -## Scrap your Nils - -One of the most useful types I've come across in Haskell is the type of -"heterogeneous lists". This is the same as the [Rec](http://hackage.haskell.org/package/vinyl-0.8.1.1/docs/Data-Vinyl-Core.html) -datatype from the [vinyl](http://hackage.haskell.org/package/vinyl) library. -It's also the same as the [NP](http://hackage.haskell.org/package/generics-sop-0.3.2.0/docs/Generics-SOP-NP.html) -datatype from the [generics-sop](http://hackage.haskell.org/package/generics-sop) library. -Squeal makes heavy use of this type. - -```Haskell ->>> import Generics.SOP (NP(..)) ->>> :i NP -type role NP representational nominal -data NP (a :: k -> *) (b :: [k]) where - Nil :: forall k (a :: k -> *). NP a '[] - (:*) :: forall k (a :: k -> *) (x :: k) (xs :: [k]). - (a x) -> (NP a xs) -> NP a (x : xs) - -- Defined in ‘Generics.SOP.NP’ -``` - -This type allows us to construct "product" types, where the types of the individual -"terms" are hosted at the type level. - -```Haskell ->>> :set -XDataKinds ->>> import Generics.SOP (I(..)) ->>> let example = I "foo" :* I pi :* Nil :: NP I '[String, Double] ->>> example -I "foo" :* I 3.141592653589793 :* Nil -``` - -One thing Squeal uses `NP` for is to form lists of aliases, -using GHC's `OverloadedLabels` extension, hosting the names -of the aliases themselves at the type level. - -```Haskell ->>> :set -XKindSignatures -XOverloadedLabels -XFlexibleInstances -XMultiParamTypeClasses ->>> import GHC.TypeLits ->>> import GHC.OverloadedLabels ->>> data Alias (alias :: Symbol) = Alias deriving (Eq,Ord,Show) ->>> instance IsLabel label (Alias label) where fromLabel = Alias ->>> let aliases = #foo :* #bar :* Nil :: NP Alias '["foo", "bar"] -``` - -However, it's very ugly to have to end every list with `:* Nil`. -When I announced the release of Squeal, people rightly [complained](https://www.reddit.com/r/haskell/comments/6yr5v6/announcing_squeal_a_deep_embedding_of_sql_in/dmq8vvn) -about the syntactic noise. Luckily, there's a neat trick we can use to get rid of it. -Making an `IsLabel` instance not only for elements of our list -but also for lists of length 1, we can ask GHC to interpret -the last label as a list. - -```Haskell ->>> instance IsLabel label (NP Alias '[label]) where fromLabel = Alias :* Nil ->>> let aliases' = #foo :* #bar :: NP Alias '["foo", "bar"] -``` - -Version 0.3.1 of Squeal enables the "Scrap your Nils" trick for -heterogeneous lists of `Alias`es, `Aliased` expressions, `PGlabel`s and `By`s -with the typeclasses `IsLabel`, `IsQualified`, `IsPGlabel`, -and the new `Aliasable` typeclass, to eliminate all need of using `Nil` in a list. diff --git a/squeal-core-concepts-handbook.md b/squeal-core-concepts-handbook.md deleted file mode 100644 index 0176f8eb..00000000 --- a/squeal-core-concepts-handbook.md +++ /dev/null @@ -1,980 +0,0 @@ -# Squeal Core Concepts Handbook - -This handbook isn't intended as a comprehensive reference to Squeal; that's what -the Haddock is for. Instead, this is meant to give you an understanding of the -fundamental parts of Squeal: its core types and typeclasses, as well as its -heavy use of phantom types. Once you understand these, which are the most -complicated part of learning to use Squeal, you should have a solid base to -figure out everything else. - -At its core, you can view Squeal as a small group of easy-to-understand types -(`Query`, `Manipulation`, `Statement`, `Expression`, `FromClause`, and -`TableExpression`) that have hard-to-understand type parameters (`Expression -grouping lat with db params from ty`). The former map to your existing -understanding of SQL in a fairly obvious way; the latter make sure that your -queries are actually valid. - -We can get our first, most basic understanding of Squeal by ignoring the type -parameters entirely and looking specifically at those core types. - -## Squeal's Core Types - -Imagine, if you would, a world where we only had those six types above, with no -type parameters attached to them. - -That would be possible, right? And you can see how they could fit together to -form larger queries. That gives us the composability we wanted. - -[`Query`](https://hackage.haskell.org/package/squeal-postgresql-0.7.0.1/docs/Squeal-PostgreSQL-Query.html#t:Query) and [`Manipulation`](https://hackage.haskell.org/package/squeal-postgresql-0.7.0.1/docs/Squeal-PostgreSQL-Manipulation.html#t:Manipulation) -line up cleanly with what we expect a SQL query to look like, so let's start by -looking at those two types. - -`Query`s represent mainly SQL **SELECT**. `Manipulation`s represent **UPDATE**, -**INSERT INTO**, and **DELETE FROM**. - -```haskell -query = select - (List $ #u ! #name `as` #userName :* #e ! #email `as` #userEmail) - ( from (table (#users `as` #u) - & innerJoin (table (#emails `as` #e)) - (#u ! #id .== #e ! #user_id)) ) -``` - -`Query`s have two parts, the description of the columns selected, and the -`TableExpression` that describes where to select those columns from. - -```text -query = select - - (List $ #u ! #name `as` #userName } the column selection - :* #e ! #email `as` #userEmail) } - - ( from (table (#users `as` #u) } - & innerJoin (table (#emails `as` #e)) } the TableExpression - (#u ! #id .== #e ! #user_id)) ) } -``` - -A [`TableExpression`](https://hackage.haskell.org/package/squeal-postgresql-0.7.0.1/docs/Squeal-PostgreSQL-Query-Table.html#t:TableExpression) -is generated from a [`FromClause`](https://hackage.haskell.org/package/squeal-postgresql-0.7.0.1/docs/Squeal-PostgreSQL-Query-From.html#t:FromClause), -which only describes the joins. You convert a `FromClause` to a `TableExpression` using `from`. Once you -have a TableExpression, that's where functions like [`where_`](https://hackage.haskell.org/package/squeal-postgresql-0.7.0.1/docs/Squeal-PostgreSQL-Query-Table.html#v:where_) -and [`having`](https://hackage.haskell.org/package/squeal-postgresql-0.7.0.1/docs/Squeal-PostgreSQL-Query-Table.html#v:having) -let you restrict the rows you get back. - -```text -( from } - ( table (#users `as` #u) } } - & innerJoin } a FromClause } the whole thing is - (table (#emails `as` #e)) } } a TableExpression - (#u ! #id .== #e ! #user_id)) } } -& where_ ... } -) } -``` - -Manipulations aren't particularly different from Querys. The one thing that -should be pointed out is that all of them specify a table using an `Aliased -(QualifiedAlias sch) (tab ::: tab0)`, and that UPDATE and DELETE have a -[`UsingClause`](https://hackage.haskell.org/package/squeal-postgresql-0.7.0.1/docs/Squeal-PostgreSQL-Manipulation.html#t:UsingClause) -instead of a `TableExpression` to specify additional joins. `UsingClause` specifically -takes a `FromClause`, to prevent you from doing things like putting `WHERE` or `HAVING` on them. - -```haskell -manip = deleteFrom - #users - (Using (table #emails)) - (#users ! #id .== #emails ! #user_id) - (Returning_ Nil) -``` - -Once you get into specifying the actual bits of data you care about, you're -primarily concerned with generating values of type [`Expression`](https://hackage.haskell.org/package/squeal-postgresql-0.7.0.1/docs/Squeal-PostgreSQL-Expression.html#t:Expression). -We're still ignoring most of the type parameters in Squeal's types, but in the case of -Expression the very last one, `ty`, is of interest to us. - -```haskell --- imagine a stripped-down version of Expression -data Expr ty - --- this is for teaching purposes; will not typecheck -foo :: Expr ('NotNull 'PGint4) -foo = #table ! #field1 -``` - -You'll construct Expressions (and `Condition`, which is just an alias for -`Expression (null 'PGbool)`) everywhere. - -The one last piece of the puzzle that we haven't explained yet: how do you -specify which columns in a Query that you're returning? How do you specify -which columns you're updating in an UPDATE Manipulation? The key here is the -[`NP`](https://hackage.haskell.org/package/squeal-postgresql-0.7.0.1/docs/Squeal-PostgreSQL-Type-List.html#t:NP) -type, which Squeal reexports from `generics-sop`. You'll see this type in a -lot of different places. It will also confuse the hell out of you the first time -you see it in documentation. - -```haskell -selectedColumns :: NP '[ "userName" ::: 'NotNull 'PGtext, "userEmail" ::: 'Null 'PGtext ] -selectedColumns = - #users ! #name `as` #userName - :* #emails ! #email `as` #userEmail -``` - -It's a way for Squeal to have heterogeneous lists that also typecheck against the -DB schema. We'll talk about how that typechecking works later, once we -understand Squeal's type parameters. From a practical perspective, mainly -you need to know that you construct them using `(:*)`. - -All of the types we've talked about so far live in "Postgres-land;" they only -know about Postgres types, and have no knowledge of how to translate those types -into actual in-memory Haskell data. That translation lives inside the -[`Statement`](https://hackage.haskell.org/package/squeal-postgresql-0.7.0.1/docs/Squeal-PostgreSQL-Type-List.html#t:NP) -type, which lives one level above Query and Manipulation. Both -Query and Manipulation can be converted to Statement by providing an encoder to -convert the query's params from Haskell types to Postgres types, and a decoder -to do the opposite for the query's results. We'll look at encoding and decoding -to/from PG later; just remember that conceptually the Statement type is there to -combine a raw query with an associated Haskell <=> PG codec. - -Let's put all this together in a concrete example. Say we had the following -typical query: - -```haskell -getUsers :: Statement DB () User -getUsers = query $ select - (List $ #u ! #name `as` #userName :* #e ! #email `as` #userEmail) - ( from (table (#users `as` #u) - & innerJoin (table (#emails `as` #e)) - (#u ! #id .== #e ! #user_id)) ) -``` - -Since all this is is an expression built out of the smaller types we've looked -at above, we can expand this out into its constituent parts and see just -how everything fits together. Ignore the amount of noise in the type -parameters; focus on the type heads like Query, Expression etc. that we -talked about. - -```haskell -getUsersQuery :: Query with lat DB params '[ "userName" ::: 'NotNull 'PGtext, "userEmail" ::: 'Null 'PGtext ] -getUsersQuery = - select - (List getUsersSelection) - ( from (table (#users `as` #u) - & innerJoin (table (#emails `as` #e)) - (#u ! #id .== #e ! #user_id)) ) - -getUsersSelection :: NP (Aliased (Expression 'Ungrouped with lat DB params - '[ "u" ::: '[ "id" ::: 'NotNull 'PGint4 - , "name" ::: 'NotNull 'PGtext - ] - , "e" ::: '[ "id" ::: 'NotNull 'PGint4 - , "user_id" ::: 'NotNull 'PGint4 - , "email" ::: 'Null 'PGtext - ] - ])) - '[ "userName" ::: 'NotNull 'PGtext, "userEmail" ::: 'Null 'PGtext ] -getUsersSelection = - #u ! #name `as` #userName :* #e ! #email `as` #userEmail - -getUsersFrom :: TableExpression 'Ungrouped lat with DB params - '[ "u" ::: '[ "id" ::: 'NotNull 'PGint4 - , "name" ::: 'NotNull 'PGtext - ] - , "e" ::: '[ "id" ::: 'NotNull 'PGint4 - , "user_id" ::: 'NotNull 'PGint4 - , "email" ::: 'Null 'PGtext - ] - ] -getUsersFrom = - ( from (table (#users `as` #u) - & innerJoin (table (#emails `as` #e)) - getUsersJoinExpr)) - -getUsersJoinExpr :: Expression 'Ungrouped lat with DB params - (Join - '[ "u" ::: '[ "id" ::: 'NotNull 'PGint4 - , "name" ::: 'NotNull 'PGtext - ] - ] - '[ "e" ::: '[ "id" ::: 'NotNull 'PGint4 - , "user_id" ::: 'NotNull 'PGint4 - , "email" ::: 'Null 'PGtext - ] - ]) - ('Null 'PGbool) -getUsersJoinExpr = - #u ! #id .== #e ! #user_id -``` - -These definitions can be loaded into the REPL. You can try playing around with -them if you'd like to get a feel for how the types work. You'll need the -following DB schema type in scope: - -```haskell -type UsersColumns = - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "name" ::: 'NoDef :=> 'NotNull 'PGtext - ] - -type UsersConstraints = '[ "pk_users" ::: 'PrimaryKey '["id"] ] - -type EmailsColumns = - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 - , "email" ::: 'NoDef :=> 'Null 'PGtext ] - -type EmailsConstraints = - '[ "pk_emails" ::: 'PrimaryKey '["id"] - , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"] - ] - -type Schema = - '[ "users" ::: 'Table (UsersConstraints :=> UsersColumns) - , "emails" ::: 'Table (EmailsConstraints :=> EmailsColumns) - ] - -type DB = Public Schema -``` - -## Where's the polymorphism? Actually constructing Expressions - -So far we've been using `(!)` and `as` without really understanding them; we -just use them as if they're equivalent to SQL `.` and `AS`, and assuming that -they'll do the right thing. - -But what's the actual type of this fragment? - -```haskell -#some_table ! #yay -``` - -When we were writing simple queries, we didn't particularly have to care about -what type this is. But as we write more complicated queries and start to think -about making our queries more modular, we need to be able to express the types -of values like this. - -For instance, depending on where you use it, it might be an Expression: - -```haskell -foo :: Expression 'Ungrouped lat with db '[] '[ "some_table" ::: '[ "yay" ::: 'NotNull 'PGint4 ] ] ('NotNull 'PGint4) -foo = #some_table ! #yay -``` - -But it can also be an NP: - -```haskell -bar :: NP (Expression 'Ungrouped lat with db '[] '[ "some_table" ::: '[ "yay" ::: 'NotNull 'PGint4 ] ]) '[ 'NotNull 'PGint4 ] -bar = #some_table ! #yay -``` - -It can even become a table name: - -```haskell -baz :: Aliased (QualifiedAlias "some_table") ("yay" ::: "yay") -baz = #some_table ! #yay - -fromClause :: FromClause lat with - '[ "some_table" ::: - '[ "yay" ::: 'Table - ('[] :=> '[ "a" ::: 'NoDef :=> 'NotNull 'PGint4 ]) - ] - ] - '[] - '[ "yay" ::: '[ "a" ::: 'NotNull 'PGint4 ] ] -fromClause = table baz -``` - -The key here is that both `(!)` and `as` are polymorphic in their return -type. This polymorphism is key to making Squeal convenient to write, but it can -be very confusing when first starting to use the library, as it makes it hard to -understand how to construct a certain Squeal type. This misunderstanding seems -like a consequence of how we usually use polymorphic returns. Usually the -polymorphic return is on a function that does some kind of conversion or -processing; canonical examples are things like `read` from Base, or `fromJSON` -from Aeson. In Squeal, that type conversion happens when you *name* things. It -accomplishes the goal of embedded SQL in Haskell in a relatively easy-to-read -way, but it takes some getting used to. - -What `(!)` can return is defined by the typeclass [`IsQualified`](https://hackage.haskell.org/package/squeal-postgresql-0.7.0.1/docs/Squeal-PostgreSQL-Type-Alias.html#t:IsQualified); -similarly, `as` uses a typeclass called [`Aliasable`](https://hackage.haskell.org/package/squeal-postgresql-0.7.0.1/docs/Squeal-PostgreSQL-Type-Alias.html#t:Aliasable). -If you squint through the mess of type parameter noise, you can see that this -is how certain types are constructed (for instance, our NP lists of expressions -in select lists, and expressions themselves): - -![IsQualified/Aliasable allows us to construct many different types with labels](squeal-core-concepts-handbook/isqualified-intro.png) - -and thus, how you can use `(!)` and `as` in so many places. - -This is especially important around uses of NP and update lists; a common -mistake is writing something like this while doing SELECTs: - -```haskell -select - (List $ - #table ! #field1 - :* #table ! #field2 - :* Nil) - (from ...) -``` - -But this final `Nil` is actually unnecessary! The NP cons operator `:*` takes -another NP as its second argument, which is why you might think you need Nil to -terminate the NP list. But if you look at the instances of `IsQualified`, it can -polymorphically return an NP already! - -![IsQualified allows us to directly create a value of type NP](squeal-core-concepts-handbook/isqualified-can-be-np.png) - -So we can simplify our definition a bit: - -```haskell --- this typechecks -select - (List $ - -- note that these two lines have different types - (#table ! #field1 :: Aliased (Expression _ _ _ _ _) _) - :* (#table ! #field2 :: NP (Aliased (Expression _ _ _ _ _) _))) - (from ...) -``` - -We'll see later that this is also Squeal's preferred way to handle things like -CTEs. - -What does all this mean for us? It gives us the type signatures we'd need when -we want to, say, have a common query that's parameterized by a table name, or a -query that needs to be parameterized by which column to run a WHERE on. For -instance, for a table name as a parameter, we'd want an `Aliased (QualifiedAlias -sch) tab`, since that's the parameter for `table`. We can then be assured that -callers can construct values of this type, since we can see an instance for -`IsQualified` for it. - -![Table names can be constructed through IsQualified as well](squeal-core-concepts-handbook/isqualified-alias.png) - -Following the typeclasses, we see that we can do something similar for -Expression, since there are instances for `IsQualified` and `Aliasable` for -generating Expressions as well. - -If you wanted to be completely general and allow a Squeal identifier to be used -in, say, both an expression and table name position, you could use the -IsQualified and Aliasable constraints directly. In general this doesn't seem to -be very useful though. - -One last thing is that while the return type of `(!)` is polymorphic, its -arguments are not; it takes two [`Alias`](https://hackage.haskell.org/package/squeal-postgresql-0.7.0.1/docs/Squeal-PostgreSQL-Type-Alias.html#t:Alias)es, which are essentially renamed -`Proxy`'s. Since you can also generate Aliases from labels like `#table`, this -provides another avenue you can use to make your queries more general and -modular; take in Aliases as parameters and use `(!)` to convert to the type you -need on-demand. - -## Squeal's type parameters - -It's finally time to talk about the heart and soul of Squeal, what makes it -tick: the plethora of type parameters on all of its core types. - -This is where Squeal handles the heavy lifting of ensuring that all of your -queries are well-formed, that they reference columns that actually exist, that -your SQL comparisons are well-typed, that the columns that you insert as DEFAULT -actually have default values, and so on. - -To refresh your memory, here's the full type signature of `Expression`, in all of -its phantomly-typed glory: - -```haskell -newtype Expression grp lat with db params from ty -``` - -One quick note before we dive into these. Throughout Squeal you'll see the -type operator `(:::)`. For instance, Squeal uses type-level specifications of -table columns that look like so: - -```haskell -type Columns = - '[ "col1" ::: 'NotNull 'PGbool - , "col2" ::: 'NotNull 'PGint4 - ] -``` - -In the Squeal ecosystem, this essentially means "type of." Note that it's *3* -colons, not 2 like for normal type signatures. Underneath the hood, `(:::)` is -just an alias for type-level tuples, so the above type is equivalent to the -following: - -```haskell -type Columns = - '[ '("col1", 'NotNull 'PGbool) - , '("col2", 'NotNull 'PGint4) - ] -``` - -With that out of the way, let's go through Squeal's type parameters one-by-one, -shall we? - -### `grp` - -In SQL, an expression is either a "normal" value or an aggregate value. You probably -already understand this intuitively, even if you never put a name on it. For -instance, let's say you wrote a query like the following: - -```SQL -CREATE TABLE foo - ( user_id INT4 NOT NULL - , value INT4 NOT NULL - ); - -SELECT user_id, SUM(value) - FROM foo - GROUP BY user_id; -``` - -In the select list of the above query, `user_id` and `SUM(value)` are both -"aggregate" values; **user_id** because it's included in the GROUP BY, and -**SUM(value)** since it's directly calling an aggregate function. - -If we don't call any aggregating functions or do a GROUP BY, we have "normal" -values instead: - -```SQL -SELECT user_id, value - FROM foo; -``` - -It's important to understand the distinction, because you can't mix normal and -aggregate values in the same query: - -```SQL -SELECT user_id, SUM(value) - FROM foo; - --- ERROR: column "foo.user_id" must appear in the GROUP BY clause or be used in an aggregate function --- LINE 1: SELECT user_id, SUM(value) -``` - -Postgres barfs, because SUM constrains it to only produce one row, but then what -should the `user_id` of that row be? The complicated part is that an identifier -like `user_id` could be either a normal or an aggregate value, depending on the -surrounding context. So Squeal is obligated to keep track of whether an -expression was generated from an aggregate function or is part of the GROUP BY, -which it does using the `grp` type parameter on an Expression. - -It can either be `'Ungrouped`, meaning a normal value, or `'Grouped bys`, which -indicates that Expression is valid in any context where the columns `bys` are -grouped. - -For instance, selecting `#table ! #field1` in an aggregated context -would want a type like `Expression ('Grouped '[ "table" ::: "field1" ]) ...`, -indicating that this selection isn't valid without that field grouped. Calling -a function like Squeal's [`count`](https://hackage.haskell.org/package/squeal-postgresql-0.7.0.1/docs/Squeal-PostgreSQL-Expression-Aggregate.html#v:count) -would return a type like `Expression ('Grouped bys) ...`, where the type variable -being abstract means that it doesn't care *what* columns the query is grouped by, -just that it's grouped in *some* way. - -However, if you use an aggregate function, the query *does* have to be grouped, -which can cause a confusing error the first time you see it. If you're used -to writing things like `SELECT COUNT(id) FROM ...` in SQL, you might try to -naively translate this into Squeal like so: - -```haskell -foo :: Query lat with - '[ "public" ::: - '[ "table" ::: 'Table - ('[] :=> '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4 ]) - ] - ] - '[] - '[ "a" ::: 'NotNull 'PGint8 ] -foo = select - (count (All $ #table ! #id) `as` #a) - (from (table #table)) -``` - -Which will promptly fail with a type error: - -```haskell - • No instance for (Aggregate AggregateArg (Expression 'Ungrouped)) - arising from a use of ‘count’ - • In the first argument of ‘as’, namely - ‘count (All $ #table ! #id)’ - In the first argument of ‘select’, namely - ‘(count (All $ #table ! #id) `as` #a)’ - In the expression: - select (count (All $ #table ! #id) `as` #a) (from (table #table)) -``` - -What this is *essentially* telling you is that you forgot to group your query, -which you need to do **even if you're running your aggregate on all rows**. We -do this by explicitly telling Squeal to group on no columns, which is one of the -few legitimate uses of `Nil`: - -```haskell -foo :: Query lat with - '[ "public" ::: - '[ "table" ::: 'Table - ('[] :=> '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4 ]) - ] - ] - '[] - '[ "a" ::: 'NotNull 'PGint8 ] -foo = select - (count (All $ #table ! #id) `as` #a) - ( from (table #table) - & groupBy Nil -- group by nothing! - ) -``` - -You will mess this up at least 2 times. - -### `from` - -When a column is specified in the selection list, how do you know when it's -valid? This may seem like a silly question, but consider the following -(stupid) query: - -```SQL -SELECT bar.id FROM foo; -``` - -No one would write a query like this. Syntactically it seems fine. But it's -nonsense, because we haven't pulled in the `bar` table to our query! And -Postgres agrees with us. - -``` -ERROR: missing FROM-clause entry for table "bar" -LINE 1: SELECT bar.id -``` - -Every query creates a *scope* for identifiers, separate from the database scope -of table names and schemas, and each join adds a new name to this scope. This is -plain to see if we use AS to rename a table that we pull in. - -```haskell -SELECT f.user_id FROM foo AS f; --- ok - -SELECT foo.user_id FROM foo AS f; --- ERROR: invalid reference to FROM-clause entry for table "foo" --- LINE 1: SELECT foo.user_id FROM foo AS f; -``` - -The name `f` is only in scope for this query. Even when you *don't* specify -an alias in the SQL, it works as if you had specified the alias as the table's -name, which we can see since the latter query gets rejected by Postgres. - -In order to figure out whether identifiers like `#table ! #field` are valid, -Squeal needs to track this scope as well. It does so using the `from` type -variable. - -In fact, this type variable is all you need to write standalone expressions. - -```haskell --- doesn't typecheck -badExpr :: Expression 'Ungrouped '[] with db params from ('NotNull 'PGint4) -badExpr = #table ! #field - --- does typecheck -goodExpr :: Expression 'Ungrouped '[] with db params - '[ "table" ::: '[ "field" ::: 'NotNull 'PGint4 ] ] - ('NotNull 'PGint4) -goodExpr = #table ! #field -``` - -Whenever you create an expression by referring to a column by name, it's this -scope inside the `from` type variable that Squeal checks to ensure that the -reference is valid. If you're getting `HasErr` constraint violations, it's -likely that the contents of this variable aren't in the right form. - -The only way to add things to `from` is by using joins. If you look at the type -signature of the various join functions that Squeal provides, they take an -existing `FromClause` and add an extra table to it. - -```haskell -table - :: (Has sch db schema, Has tab schema (Table table)) - => Aliased (QualifiedAlias sch) (alias ::: tab) - -> FromClause lat with db params '[alias ::: TableToRow table] - -- `table` (and `view`, `common`, `subquery`) produce a FromClause - -- containing a single set of columns... - -innerJoin - :: FromClause lat with db params right - -> Condition Ungrouped lat with db params (Join left right) - -> FromClause lat with db params left - -> FromClause lat with db params (Join left right) - -- ...which the join functions append to the tables already in `from` -``` - -For a more complicated query, here's what the value of `from` may end up -looking like: - -```haskell -type QueryFrom = - '[ "table1" ::: - '[ "id" ::: 'NotNull 'PGuuid - , "field1" ::: 'Null 'PGint4 - , "field2" ::: 'NotNull 'PGtext - ] - , "table2" ::: - '[ "id" ::: 'NotNull 'PGuuid - , "field1" ::: 'NotNull 'PGbool - ] - , "table3" ::: - '[ "id" ::: 'NotNull 'PGuuid - , "table2_id" ::: 'NotNull 'PGuuid - , "created_at" ::: 'NotNull 'PGtimestamptz - ] - ] - -type DB = -- ... some schema with the appropriate tables ... - -froms :: FromClause lat with DB params QueryFrom -froms = - ( table (#table1 `as` #table1) - & innerJoin (table (#table2 `as` #table2)) - (#table2 ! #id .== #table1 ! #id) - & innerJoin (table #table3) - (#table3 ! #table2_id .== #table2 ! #id) - ) -``` - -Note that the order of tables in `from` needs to be the same order in which they -were joined. - -Explicitly providing a type alias for which tables a query has access to -like this is often useful, especially when you want to allow callers of your -query to pass in custom expressions. For instance, if you wanted to allow -callers to pass in a filtering condition, you could do that by ensuring that -the `from` in the passed-in Expression is valid for the tables that the query -joins on. - -```haskell -parameterized :: - Expression 'Ungrouped lat with db params QueryFrom ('NotNull 'PGbool) - -> Query lat with db params '[ "a" ::: 'NotNull 'PGint4 ] -parameterized cond = - select - (#table1 ! #field1) - ( from froms - & where_ cond - ) -``` - -Then, as you'd expect, any callsite could use any columns specified in that -query scope, while rejecting any references that aren't in scope. - -```haskell --- these typecheck -qry1 = parameterized (#table1 ! #field2 .== "mobile") -qry2 = parameterized (#table2 ! #field1) - --- these don't -qry3 = parameterized (#table4 ! #id .== "SimSpace") -qry4 = parameterized (#table1 ! #nonfield) -``` - -Note the "flow" of type-level data going on here: we start off with existing -table definitions in `db`, which get pulled into the value of `from` by using -`innerJoin`, `leftOuterJoin`, etc. Once `from` has the right type-level value, -now expressions like `#table1 ! #field2` will satisfy their `IsQualified` -constraint and typecheck. - -### `lat` - -Remember when I said that `from` was the only place that Squeal looked when -it was checking whether column references were valid? That was a slight lie. -Squeal actually checks one other place, the `lat` type param. - -You can see this in the various IsQualified instances for Expression, Aliased Expression, -etc. - -![IsQualified looks in both lat and from for scoping expressions](squeal-core-concepts-handbook/isqualified-join-constraint.png) - -Other than joins, there's one other place where identifiers can come into scope -for a query: a Postgres-specific feature called lateral joins. If you've used -Microsoft SQL Server before, you might know these as CROSS APPLYs, but if not, -it's totally understandable if you've never seen a lateral join before. - -To understand what a lateral join does, it's helpful to compare it to a normal -subquery join. When you do a normal subquery join, the subquery is a completely -different query from the one it's being joined into, which means that the subquery -can't access anything that's in scope from the parent query. - -```SQL -SELECT * - FROM some_table st - JOIN (SELECT * FROM some_other_table sot WHERE st.id = sot.table_id) - -- error: st is not in scope in the subquery -``` - -But sometimes having those values in scope would be extremely useful. Say you -have a table for your users, and another table containing login events. - -```SQL -CREATE TABLE "user" - ( id SERIAL PRIMARY KEY NOT NULL - , username TEXT NOT NULL - , email TEXT NOT NULL - , created_at TIMESTAMPTZ NOT NULL - ); - -CREATE TABLE "login_event" - ( user_id INT4 NOT NULL REFERENCES "user" (id) - , source TEXT NOT NULL -- web|mobile|embed - , timestamp TIMESTAMPTZ NOT NULL - ); -``` - -How would you write a query to get, for each user, the latest login, including -all the username/email information, and the source information? It's possible -using normal subqueries, albeit somewhat painful to write. If you don't believe -me, stop reading and try writing a raw SQL query to get this data. - -Lateral joins give you a more convenient way to write "dependent" queries like -this. They act more like a "foreach" loop: Postgres will run the lateral -subquery for each row being joined to, and calculate separate sets of rows to -join with. - -```SQL -SELECT u.id, u.username, u.email, u.created_at, - le.source, le.timestamp - FROM public.user AS u - INNER JOIN LATERAL - (SELECT le.source, le.timestamp - FROM public.login_event AS le - WHERE le.user_id = u.id - ORDER BY le.timestamp DESC - LIMIT 1) AS le - ON TRUE; -``` - -Helpful, right? But since it's another way in which identifiers can come into -scope for a query, Squeal needs a way to represent it. - -Structurally, `lat` looks exactly like `from`; it's a mapping of table -names to lists of columns and their types. You'll never have to worry about it -unless you're using lateral joins; Squeal provides explicit lateral versions -of all the normal join functions which are there if you need them. Since most -of the time you won't be using these, well... - -### `db` - -We saw in the discussion of `from` how that type parameter gets populated by -usages of functions like `innerJoin`, `leftOuterJoin`, and so on. But the -table types that get joined on have to *come* from `db`, which we can see -happening in the type signatures for `table` and `view`: - -```haskell -table - :: (Has sch db schema, Has tab schema (Table table)) - => Aliased (QualifiedAlias sch) (alias ::: tab) - -> FromClause lat with db params '[alias ::: TableToRow table] - -view - :: (Has sch db schema, Has vw schema (View view)) - => Aliased (QualifiedAlias sch) (alias ::: vw) - -> FromClause lat with db params '[alias ::: view] -``` - -It can be a little easier to see what's going on here if we have an explicit -DB type. Let's define one. - -```haskell -type DB = '[ "public" ::: Schema ] - -type Schema = '[ "users" ::: Table UsersTable ] - -type UsersTable = - '[] :=> '[ "id" ::: 'NotNull 'PGuuid ] - --- using our new type -table (#public ! #users) -``` - -Walk through the constraints being discharged: the first `Has sch db schema` -becomes `Has "public" DB schema`, checking whether the "public" schema exists -within our database type. The second `Has` becomes `Has "users" schema (Table table)`, -checking whether there's a correctly named table within the schema found by -the first constraint. Once those constraints are discharged, the compiler -is happy to give us a `FromClause` which we can use in our joins and queries, -thus bringing columns into scope. - -That's all `db` is: a type-level tree structure representing your entire -database schema, such that downstream code can figure out what tables and -columns exists, and thus, whether your queries are reasonable. You can think -of it as the source of truth about column types that everything starts from. - -In practice most of the compilation errors you encounter won't be caused by your -`db` type. It's not usually a go-to type parameter to put constraints on for -abstraction, either. Squeal does not provide any functionality for keeping -your top-level DB type definition in sync with your actual Postgres schema, -however. Ensuring that your DB type reflects reality is your responsibility. - -### `with` - -You've probably seen SQL queries of the form `WITH AS SELECT ...`, -like a let-binding but for a subquery. Squeal has support for these sorts of -queries as well, using the [`with`](https://hackage.haskell.org/package/squeal-postgresql-0.7.0.1/docs/Squeal-PostgreSQL-Query-With.html#v:with) function. - -```haskell -qry :: Query lat with DB params '[ "a" ::: 'NotNull 'PGbool ] -qry = with - (select (true `as` #a) (from (table #users)) `as` #cte) - (select Star - (from (common #cte))) -- note the use of `common` to bring the CTE into scope - -- for this query -``` - -Since these subqueries are scoped to each individual query, Squeal needs some -way of keeping track of them so that it can check that usages of `common` are -valid. As you might guess, that storage is happening in the `with` type -parameter. - -```haskell -with - ( select (true `as` #a) (from (table #users)) `as` #subq1 - :>> select (false `as`#b) (from (table #users)) `as` #subq2 - ) - - --- :: Query ... with ... --- where `with` = '[ "subq1" ::: '[ "a" ::: 'NotNull 'PGbool ], "subq2" ::: '[ "b" ::: 'NotNull 'PGbool ] ] -``` - -Note that when passing the CTEs to `with`, we use `(:>>)` to construct the list. -When constructing select lists and such, we were using `(:*)`, but here the -argument has a different type. Instead of a value of type `NP`, `with` takes in -a value of type [`Path`](https://hackage.haskell.org/package/squeal-postgresql-0.7.0.1/docs/Squeal-PostgreSQL-Type-List.html#t:Path). -The practical difference is that subqueries further in the list can use subqueries -earlier in the list. Just remember that you need to use this pointier list -constructor when using CTEs. - -In theory `with` can be a useful point of abstraction, by specifying that some -query needs a subquery of some other type in scope. In practice you can -usually just pass that subquery as a Haskell parameter. - -One small trick about using CTEs in Squeal: `with` requires its subqueries to -all be the same type, either all `Query`'s or all `Manipulation`s. That's -a little annoying, since it seems like you couldn't, say, run an update and -then do a query on the updated rows; you'd have a `Manipulation` and a `Query` -in the same CTE expression. But Squeal provides a convenient function -[`queryStatement`](https://hackage.haskell.org/package/squeal-postgresql-0.7.0.1/docs/Squeal-PostgreSQL-Manipulation.html#v:queryStatement) -to convert from a `Query` to a `Manipulation` (since any query is just a manipulation -that touches no rows). That'll allow you to implement cases like these. - -A caution about the queries in a CTE block: Squeal represents them as a -sequential path, but [Postgres actually runs them concurrently, so their order is -unpredictable.](https://www.postgresql.org/docs/12/queries-with.html#QUERIES-WITH-MODIFYING) -So you may not be able to rely on them to, say, run an update statement and a query in the order -they're written. You can resolve this by having one statement in the query -depend on a value returned by another one. - -### `params` - -When generating queries, it's possible to write normal Haskell functions that -take in values and inline those values into your queries. However, Squeal also -provides a built-in hole for parameters, which you use through the `param` -function instead of inlining them. - -```haskell -qry - :: params ~ '[ 'NotNull 'PGint4, 'NotNull 'PGtext ] - => Query lat with DB params '[ "email" ::: 'Null 'PGtext ] -qry = select - (#e ! #email) - ( from (table (#users `as` #u) - & innerJoin (table (#emails `as` #e)) - (#e ! #user_id .== #u ! #id)) - & where_ (#u ! #id .== param @1) -- specify which param with TypeApplications - & where_ (#u ! #name .== param @2) -- note that the params are 1-indexed - ) -``` - -The main reason to specify the `params` variable and pass values in this way -is to make some common value available to all the components of a query, without -needing to explicitly pass it around. For instance, when writing a query with -CTEs, you'll probably have some common ID that all parts of the query need. - -```haskell -qry - :: params ~ '[ 'NotNull 'PGuuid ] - => Query lat with DB params ... -qry = with - ( ... -- all CTE definitions here can make use of the UUID param - ) - ... -- as can the main query -``` - -Another distinction between inlining and parameters is that parameters are -supplied to the DB using Postgres' binary format, and thus aren't susceptible -to SQL injection attacks. Inlined values are, as the name implies, directly -inlined in the SQL string that gets sent to the database, and thus quite a bit -more dangerous. - -Because of this, you should prefer passing data into a query using parameters -whenever possible. - -There isn't much else to say about the `params` type variable; this is all it's -used for. - -### `ty` - -Nothing special here, it's just the Postgres type and nullity of the expression. - -You can see the possible nullities on the constructors of [`NullType`](https://hackage.haskell.org/package/squeal-postgresql-0.7.0.1/docs/Squeal-PostgreSQL-Type-Schema.html#t:NullType), -and the possible types on the constructors of [`PGType`](https://hackage.haskell.org/package/squeal-postgresql-0.7.0.1/docs/Squeal-PostgreSQL-Type-Schema.html#t:PGType). - -## Encoding and decoding - -Despite everything we've looked at, we still don't know how to bridge the gap -between Haskell-land and Postgres-land. How do we get the data from the database -into a form that our program can understand? - -As mentioned earlier, the type that bridges this gap is `Statement`, as it -combines some query with encoders for parameters, and decoders for PG rows. - -Squeal provides the [`query`](https://hackage.haskell.org/package/squeal-postgresql-0.7.0.1/docs/Squeal-PostgreSQL-Session-Statement.html#v:query) -and [`manipulation`](https://hackage.haskell.org/package/squeal-postgresql-0.7.0.1/docs/Squeal-PostgreSQL-Session-Statement.html#v:manipulation) -functions for converting Query's and Manipulations into Statement, but note -that these rely on Squeal's generic encoding/decoding, which takes away control -of the translation. Sometimes it works, but most of the time you're not doing -1-to-1 translation between a record type and rows with *exactly* the same number -of columns, where the column names are *exactly* the same as the record fields. -For those cases, it's better to write your codecs manually. - -My recommendation is to use the constructors of [`Statement`](https://hackage.haskell.org/package/squeal-postgresql-0.7.0.1/docs/Squeal-PostgreSQL-Session-Statement.html#t:Statement) -directly: `Query` and `Manipulation`. You can see that these take in -arguments of type [`EncodeParams`](https://hackage.haskell.org/package/squeal-postgresql-0.7.0.1/docs/Squeal-PostgreSQL-Session-Encode.html#t:EncodeParams) -and [`DecodeRow`](https://hackage.haskell.org/package/squeal-postgresql-0.7.0.1/docs/Squeal-PostgreSQL-Session-Decode.html#t:DecodeRow). - -For `EncodeParams`, you need to turn the parameter type into a list of functions -for pulling the individual values using `(.*)` and `(*.)`. `(*.)` is for the -very last element of the list, `(.*)` is for everything else. - -```haskell -data SomeType = SomeType { a :: Bool, b :: Int32, c :: Int64 } - --- Notice how we don't actually take in a value of SomeType, --- we just create a list of accessor functions -enc :: EncodeParams db '[ 'NotNull 'PGbool, 'NotNull 'PGint4, 'NotNull 'PGint8 ] SomeType -enc = a .* b *. c -``` - -You will mix up these operators and get a confusing type error at least once. - -`DecodeRow` implements both `Monad` and `IsLabel`, which lets you construct -decoders like the following: - -```haskell --- Note how we can decode from a row with completely different --- column names from our record type -dec :: DecodeRow - '[ "a_bool" ::: 'NotNull 'PGbool - , "a_4byteint" ::: 'NotNull 'PGint4 - , "an_8byteint" ::: 'NotNull 'PGint8 - ] - SomeType -dec = do - a <- #a_bool - b <- #a_4byteint - c <- #an_8byteint - pure $ SomeType { a = a, b = b, c = c } -``` - -Since it implements `Monad`, you can implement complicated conditional parsers, -key off of certain columns being null or non-null to parse further columns, -construct intermediate data structures from groups of fields, etc. diff --git a/squeal-core-concepts-handbook/isqualified-alias.png b/squeal-core-concepts-handbook/isqualified-alias.png deleted file mode 100644 index 8d211148..00000000 Binary files a/squeal-core-concepts-handbook/isqualified-alias.png and /dev/null differ diff --git a/squeal-core-concepts-handbook/isqualified-can-be-np.png b/squeal-core-concepts-handbook/isqualified-can-be-np.png deleted file mode 100644 index 6788eb62..00000000 Binary files a/squeal-core-concepts-handbook/isqualified-can-be-np.png and /dev/null differ diff --git a/squeal-core-concepts-handbook/isqualified-intro.png b/squeal-core-concepts-handbook/isqualified-intro.png deleted file mode 100644 index 004d26e6..00000000 Binary files a/squeal-core-concepts-handbook/isqualified-intro.png and /dev/null differ diff --git a/squeal-core-concepts-handbook/isqualified-join-constraint.png b/squeal-core-concepts-handbook/isqualified-join-constraint.png deleted file mode 100644 index 26254ccd..00000000 Binary files a/squeal-core-concepts-handbook/isqualified-join-constraint.png and /dev/null differ diff --git a/squeal-postgresql-ltree/LICENSE b/squeal-postgresql-ltree/LICENSE deleted file mode 100644 index d71d6fe7..00000000 --- a/squeal-postgresql-ltree/LICENSE +++ /dev/null @@ -1,31 +0,0 @@ -Copyright (c) 2020 Morphism, LLC - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the names of the copyright holders nor the names of the - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/squeal-postgresql-ltree/README.md b/squeal-postgresql-ltree/README.md deleted file mode 100644 index ad88be59..00000000 --- a/squeal-postgresql-ltree/README.md +++ /dev/null @@ -1 +0,0 @@ -# squeal-postgresql-ltree diff --git a/squeal-postgresql-ltree/squeal-postgresql-ltree.cabal b/squeal-postgresql-ltree/squeal-postgresql-ltree.cabal deleted file mode 100644 index 019f1ca7..00000000 --- a/squeal-postgresql-ltree/squeal-postgresql-ltree.cabal +++ /dev/null @@ -1,35 +0,0 @@ -name: squeal-postgresql-ltree -version: 0.1.0.0 -synopsis: LTree extension for Squeal -description: LTree extension for Squeal -homepage: https://github.com/morphismtech/squeal/ltree -bug-reports: https://github.com/morphismtech/squeal/issues -license: BSD3 -license-file: LICENSE -author: Eitan Chatav -maintainer: eitan.chatav@gmail.com -copyright: Copyright (c) 2021 Morphism, LLC -category: Database -build-type: Simple -cabal-version: >=1.18 -extra-doc-files: README.md - -source-repository head - type: git - location: https://github.com/morphismtech/squeal.git - -library - hs-source-dirs: src - exposed-modules: - Squeal.PostgreSQL.LTree - default-language: Haskell2010 - ghc-options: -Wall - build-depends: - base >= 4.12.0.0 && < 5.0 - , bytestring >= 0.10.10.0 - , generics-sop >= 0.5.1.0 - , mtl >= 2.2.2 - , postgresql-binary >= 0.12.2 - , postgresql-libpq >= 0.9.4.2 - , squeal-postgresql >= 0.7.0.1 - , text >= 1.2.3.2 diff --git a/squeal-postgresql-ltree/src/Squeal/PostgreSQL/LTree.hs b/squeal-postgresql-ltree/src/Squeal/PostgreSQL/LTree.hs deleted file mode 100644 index f22e6af0..00000000 --- a/squeal-postgresql-ltree/src/Squeal/PostgreSQL/LTree.hs +++ /dev/null @@ -1,477 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.LTree -Description: ltree -Copyright: (c) Eitan Chatav, 2020 -Maintainer: eitan@morphism.tech -Stability: experimental - -This module implements a data type ltree for representing -labels of data stored in a hierarchical tree-like structure. --} - -{-# LANGUAGE - DataKinds - , DeriveGeneric - , DerivingStrategies - , FlexibleInstances - , GeneralizedNewtypeDeriving - , MultiParamTypeClasses - , OverloadedStrings - , PolyKinds - , TypeFamilies - , TypeOperators - , TypeSynonymInstances - , UndecidableInstances -#-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Squeal.PostgreSQL.LTree - ( -- * Definition - createLTree - -- * Types - , LTree(..), LQuery(..), LTxtQuery(..) - , PGltree, PGlquery, PGltxtquery - , ltree, lquery, ltxtquery - -- * Functions - , subltree, subpath, subpathEnd - , nlevel, indexLTree, indexOffset - , text2ltree, ltree2text, lca - -- * Operators - , (%~), (~%), (%?), (?%), (%@), (@%) - , (@>%), (%<@), (<@%), (%@>) - , (&~), (~&), (&?), (?&), (&@), (@&) - , (?@>), (?<@), (?~), (?@) - ) where - -import Control.Exception hiding (TypeError) -import Control.Monad.Reader -import Data.String -import Data.Text -import GHC.Generics -import GHC.TypeLits (ErrorMessage(Text), TypeError) -import Squeal.PostgreSQL -import Squeal.PostgreSQL.Render - -import qualified Database.PostgreSQL.LibPQ as LibPQ -import qualified Generics.SOP as SOP -import qualified PostgreSQL.Binary.Decoding as Decoding -import qualified PostgreSQL.Binary.Encoding as Encoding - --- | Postgres ltree type -type PGltree = 'UnsafePGType "ltree" --- | Postgres lquery type -type PGlquery = 'UnsafePGType "lquery" --- | Postgres ltxtquery type -type PGltxtquery = 'UnsafePGType "ltxtquery" - --- | Loads ltree extension into the current database. -createLTree :: Definition db db -createLTree = UnsafeDefinition "CREATE EXTENSION \"ltree\";" - --- | Postgres ltree type expression -ltree :: TypeExpression db (null PGltree) -ltree = UnsafeTypeExpression "ltree" - --- | Postgres lquery type expression -lquery :: TypeExpression db (null PGlquery) -lquery = UnsafeTypeExpression "lquery" - --- | Postgres ltxtquery type expression -ltxtquery :: TypeExpression db (null PGltxtquery) -ltxtquery = UnsafeTypeExpression "ltxtquery" - -instance PGTyped db PGltree where pgtype = ltree -instance PGTyped db PGlquery where pgtype = lquery -instance PGTyped db PGltxtquery where pgtype = ltxtquery - -instance OidOf db PGltree where - oidOf = oidLtreeLookup "oid" "ltree" -instance OidOf db PGlquery where - oidOf = oidLtreeLookup "oid" "lquery" -instance OidOf db PGltxtquery where - oidOf = oidLtreeLookup "oid" "ltxtquery" -instance OidOfArray db PGltree where - oidOfArray = oidLtreeLookup "typarray" "ltree" -instance OidOfArray db PGlquery where - oidOfArray = oidLtreeLookup "typarray" "lquery" -instance OidOfArray db PGltxtquery where - oidOfArray = oidLtreeLookup "typarray" "ltxtquery" - -oidLtreeLookup - :: String - -> String - -> ReaderT (SOP.K LibPQ.Connection db) IO LibPQ.Oid -oidLtreeLookup tyOrArr name = ReaderT $ \(SOP.K conn) -> do - resultMaybe <- LibPQ.execParams conn q [] LibPQ.Binary - case resultMaybe of - Nothing -> throwIO $ ConnectionException oidErr - Just result -> do - numRows <- LibPQ.ntuples result - when (numRows /= 1) $ throwIO $ RowsException oidErr 1 numRows - valueMaybe <- LibPQ.getvalue result 0 0 - case valueMaybe of - Nothing -> throwIO $ ConnectionException oidErr - Just value -> case Decoding.valueParser Decoding.int value of - Left err -> throwIO $ DecodingException oidErr err - Right oid' -> return $ LibPQ.Oid oid' - where - oidErr = "oidOf " <> fromString (name <> tyOrArr) - q = "SELECT " <> fromString tyOrArr - <> " FROM pg_type WHERE typname = \'" - <> fromString name <> "\';" - -{- | -A label is a sequence of alphanumeric characters and underscores -(for example, in C locale the characters A-Za-z0-9_ are allowed). -Labels must be less than 256 bytes long. - -@ -Examples: 42, Personal_Services -@ - -A label path is a sequence of zero or more labels separated by dots, -for example L1.L2.L3, representing a path from the root of a -hierarchical tree to a particular node. The length of a label path -must be less than 65Kb, but keeping it under 2Kb is preferable. -In practice this is not a major limitation; for example, -the longest label path in the DMOZ catalogue -(http://www.dmoz.org) is about 240 bytes. - -@ -Example: Top.Countries.Europe.Russia -@ - -ltree stores a label path. --} -newtype LTree = UnsafeLTree {getLTree :: Text} - deriving stock (Eq,Ord,Show,Read,Generic) --- | `PGltree` -instance IsPG LTree where type PG LTree = PGltree -instance TypeError ('Text "LTree binary instances not yet implemented.") - => FromPG LTree where - fromPG = UnsafeLTree <$> devalue Decoding.text_strict -instance TypeError ('Text "LTree binary instances not yet implemented.") - => ToPG db LTree where - toPG = pure . Encoding.text_strict . getLTree -instance Inline LTree where - inline - = UnsafeExpression - . parenthesized - . (<> " :: ltree") - . escapeQuotedText - . getLTree - -{- | -lquery represents a regular-expression-like pattern for matching ltree values. -A simple word matches that label within a path. -A star symbol (*) matches zero or more labels. For example: - -@ -foo Match the exact label path foo -*.foo.* Match any label path containing the label foo -*.foo Match any label path whose last label is foo -@ - -Star symbols can also be quantified to restrict how many labels they can match: - -@ -*{n} Match exactly n labels -*{n,} Match at least n labels -*{n,m} Match at least n but not more than m labels -*{,m} Match at most m labels — same as *{0,m} -@ - -There are several modifiers that can be put at the end of a non-star label -in lquery to make it match more than just the exact match: - -@ -\@ Match case-insensitively, for example a@ matches A -* Match any label with this prefix, for example foo* matches foobar -% Match initial underscore-separated words -@ - -The behavior of % is a bit complicated. -It tries to match words rather than the entire label. -For example foo_bar% matches foo_bar_baz but not foo_barbaz. -If combined with *, prefix matching applies to each word separately, -for example foo_bar%* matches foo1_bar2_baz but not foo1_br2_baz. - -Also, you can write several possibly-modified labels separated with -| (OR) to match any of those labels, -and you can put ! (NOT) at the start to match any label -that doesn't match any of the alternatives. - -Here's an annotated example of lquery: - -@ -Top.*{0,2}.sport*@.!football|tennis.Russ*|Spain -1. 2. 3. 4. 5. -@ - -This query will match any label path that: - -1. begins with the label Top -2. and next has zero to two labels before -3. a label beginning with the case-insensitive prefix sport -4. then a label not matching football nor tennis -5. and then ends with a label beginning with Russ or exactly matching Spain. --} -newtype LQuery = UnsafeLQuery {getLQuery :: Text} - deriving stock (Eq,Ord,Show,Read,Generic) --- | `PGlquery` -instance IsPG LQuery where type PG LQuery = PGlquery -instance TypeError ('Text "LQuery binary instances not yet implemented.") - => FromPG LQuery where - fromPG = UnsafeLQuery <$> devalue Decoding.text_strict -instance TypeError ('Text "LQuery binary instances not yet implemented.") - => ToPG db LQuery where - toPG = pure . Encoding.text_strict . getLQuery -instance Inline LQuery where - inline - = UnsafeExpression - . parenthesized - . (<> " :: lquery") - . escapeQuotedText - . getLQuery - -{- | -ltxtquery represents a full-text-search-like pattern for matching ltree values. -An ltxtquery value contains words, -possibly with the modifiers @, *, % at the end; -the modifiers have the same meanings as in lquery. -Words can be combined with & (AND), | (OR), ! (NOT), and parentheses. -The key difference from lquery is that ltxtquery matches words -without regard to their position in the label path. - -Here's an example ltxtquery: - -@ -Europe & Russia*@ & !Transportation -@ - -This will match paths that contain the label Europe and any label -beginning with Russia (case-insensitive), but not paths containing -the label Transportation. The location of these words within the -path is not important. Also, when % is used, the word can be matched -to any underscore-separated word within a label, regardless of position. - -Note: ltxtquery allows whitespace between symbols, but ltree and lquery do not. --} -newtype LTxtQuery = UnsafeLTxtQuery {getLTxtQuery :: Text} - deriving stock (Eq,Ord,Show,Read,Generic) --- | `PGltxtquery` -instance IsPG LTxtQuery where type PG LTxtQuery = PGltxtquery -instance TypeError ('Text "LTxtQuery binary instances not yet implemented.") - => FromPG LTxtQuery where - fromPG = UnsafeLTxtQuery <$> devalue Decoding.text_strict -instance TypeError ('Text "LTxtQuery binary instances not yet implemented.") - => ToPG db LTxtQuery where - toPG = pure . Encoding.text_strict . getLTxtQuery -instance Inline LTxtQuery where - inline - = UnsafeExpression - . parenthesized - . (<> " :: ltxtquery") - . escapeQuotedText - . getLTxtQuery - -instance IsString - (Expression grp lat with db params from (null PGltree)) where - fromString - = UnsafeExpression - . parenthesized - . (<> " :: ltree") - . escapeQuotedString -instance IsString - (Expression grp lat with db params from (null PGlquery)) where - fromString - = UnsafeExpression - . parenthesized - . (<> " :: lquery") - . escapeQuotedString -instance IsString - (Expression grp lat with db params from (null PGltxtquery)) where - fromString - = UnsafeExpression - . parenthesized - . (<> " :: ltxtquery") - . escapeQuotedString - --- | Returns subpath of ltree from position start to position end-1 (counting from 0). -subltree :: '[null PGltree, null 'PGint4, null 'PGint4] ---> null PGltree -subltree = unsafeFunctionN "subltree" - --- | Returns subpath of ltree starting at position offset, with length len. --- If offset is negative, subpath starts that far from the end of the path. --- If len is negative, leaves that many labels off the end of the path. -subpath :: '[null PGltree, null 'PGint4, null 'PGint4] ---> null PGltree -subpath = unsafeFunctionN "subpath" - --- | Returns subpath of ltree starting at position offset, --- extending to end of path. If offset is negative, --- subpath starts that far from the end of the path. -subpathEnd :: '[null PGltree, null 'PGint4] ---> null PGltree -subpathEnd = unsafeFunctionN "subpath" - --- | Returns number of labels in path. -nlevel :: null PGltree --> null 'PGint4 -nlevel = unsafeFunction "nlevel" - --- | Returns position of first occurrence of b in a, or -1 if not found. -indexLTree :: '[null PGltree, null PGltree] ---> null 'PGint4 -indexLTree = unsafeFunctionN "index" - --- | Returns position of first occurrence of b in a, or -1 if not found. --- The search starts at position offset; --- negative offset means start -offset labels from the end of the path. -indexOffset :: '[null PGltree, null PGltree, null 'PGint4] ---> null 'PGint4 -indexOffset = unsafeFunctionN "index" - --- | Casts text to ltree. -text2ltree :: null 'PGtext --> null PGltree -text2ltree = unsafeFunction "text2ltree" - --- | Casts ltree to text. -ltree2text :: null PGltree --> null 'PGtext -ltree2text = unsafeFunction "ltree2text" - --- | Computes longest common ancestor of paths in array. -lca :: null ('PGvararray ('NotNull PGltree)) --> null PGltree -lca = unsafeFunction "lca" - -{- | -`(@>)` Is left argument an ancestor of right (or equal)? - -`(<@)` Is left argument a descendant of right (or equal)? --} -instance PGSubset PGltree - --- | Does ltree match lquery? -(%~) :: Operator (null0 PGltree) (null1 PGlquery) ('Null 'PGbool) -(%~) = unsafeBinaryOp "~" -infix 4 %~ - --- | Does ltree match lquery? -(~%) :: Operator (null1 PGlquery) (null0 PGltree) ('Null 'PGbool) -(~%) = unsafeBinaryOp "~" -infix 4 ~% - --- | Does ltree match any lquery in array? -(%?) :: Operator - (null0 PGltree) (null1 ('PGvararray ('NotNull PGlquery))) ('Null 'PGbool) -(%?) = unsafeBinaryOp "?" -infix 4 %? - --- | Does ltree match any lquery in array? -(?%) :: Operator - (null0 ('PGvararray ('NotNull PGlquery))) (null1 PGltree) ('Null 'PGbool) -(?%) = unsafeBinaryOp "?" -infix 4 ?% - --- | Does ltree match ltxtquery? -(%@) :: Operator (null0 PGltree) (null1 PGltxtquery) ('Null 'PGbool) -(%@) = unsafeBinaryOp "@" -infix 4 %@ - --- | Does ltree match ltxtquery? -(@%) :: Operator (null0 PGltxtquery) (null1 PGltree) ('Null 'PGbool) -(@%) = unsafeBinaryOp "@" -infix 4 @% - --- | `(<>)` Concatenates ltree paths. -instance Semigroup - (Expression grp lat with db params from (null PGltree)) where - (<>) = unsafeBinaryOp "||" -instance Monoid - (Expression grp lat with db params from (null PGltree)) where - mempty = fromString "" - mappend = (<>) - --- | Does array contain an ancestor of ltree? -(@>%) :: Operator - (null0 ('PGvararray ('NotNull PGltree))) (null1 PGltree) ('Null 'PGbool) -(@>%) = unsafeBinaryOp "@>" -infix 4 @>% - --- | Does array contain an ancestor of ltree? -(%<@) :: Operator - (null0 PGltree) (null1 ('PGvararray ('NotNull PGltree))) ('Null 'PGbool) -(%<@) = unsafeBinaryOp "<@" -infix 4 %<@ - --- | Does array contain a descendant of ltree? -(<@%) :: Operator - (null0 ('PGvararray ('NotNull PGltree))) (null1 PGltree) ('Null 'PGbool) -(<@%) = unsafeBinaryOp "<@" -infix 4 <@% - --- | Does array contain a descendant of ltree? -(%@>) :: Operator - (null0 PGltree) (null1 ('PGvararray ('NotNull PGltree))) ('Null 'PGbool) -(%@>) = unsafeBinaryOp "@>" -infix 4 %@> - --- | Does array contain any path matching lquery? -(&~) :: Operator - (null0 ('PGvararray ('NotNull PGltree))) (null1 PGlquery) ('Null 'PGbool) -(&~) = unsafeBinaryOp "~" -infix 4 &~ - --- | Does array contain any path matching lquery? -(~&) :: Operator - (null0 PGlquery) (null1 ('PGvararray ('NotNull PGltree))) ('Null 'PGbool) -(~&) = unsafeBinaryOp "~" -infix 4 ~& - --- | Does ltree array contain any path matching any lquery? -(&?) :: Operator - (null0 ('PGvararray ('NotNull PGltree))) - (null1 ('PGvararray ('NotNull PGlquery))) - ('Null 'PGbool) -(&?) = unsafeBinaryOp "?" -infix 4 &? - --- | Does ltree array contain any path matching any lquery? -(?&) :: Operator - (null0 ('PGvararray ('NotNull PGlquery))) - (null1 ('PGvararray ('NotNull PGltree))) - ('Null 'PGbool) -(?&) = unsafeBinaryOp "?" -infix 4 ?& - --- | Does array contain any path matching ltxtquery? -(&@) :: Operator - (null0 ('PGvararray ('NotNull PGltree))) (null1 PGltxtquery) ('Null 'PGbool) -(&@) = unsafeBinaryOp "@" -infix 4 &@ - --- | Does array contain any path matching ltxtquery? -(@&) :: Operator - (null0 PGltxtquery) (null1 ('PGvararray ('NotNull PGltree))) ('Null 'PGbool) -(@&) = unsafeBinaryOp "@" -infix 4 @& - --- | Returns first array entry that is an ancestor of ltree, or NULL if none. -(?@>) :: Operator - (null0 ('PGvararray ('NotNull PGltree))) (null1 PGltree) ('Null PGltree) -(?@>) = unsafeBinaryOp "?@>" -infix 4 ?@> - --- | Returns first array entry that is a descendant of ltree, or NULL if none. -(?<@) :: Operator - (null0 ('PGvararray ('NotNull PGltree))) (null1 PGltree) ('Null PGltree) -(?<@) = unsafeBinaryOp "?<@" -infix 4 ?<@ - --- | Returns first array entry that matches lquery, or NULL if none. -(?~) :: Operator - (null0 ('PGvararray ('NotNull PGltree))) (null1 PGlquery) ('Null PGltree) -(?~) = unsafeBinaryOp "?~" -infix 4 ?~ - --- | Returns first array entry that matches ltxtquery, or NULL if none. -(?@) :: Operator - (null0 ('PGvararray ('NotNull PGltree))) (null1 PGltxtquery) ('Null PGltree) -(?@) = unsafeBinaryOp "?@" -infix 4 ?@ diff --git a/squeal-postgresql-uuid-ossp/LICENSE b/squeal-postgresql-uuid-ossp/LICENSE deleted file mode 100644 index d71d6fe7..00000000 --- a/squeal-postgresql-uuid-ossp/LICENSE +++ /dev/null @@ -1,31 +0,0 @@ -Copyright (c) 2020 Morphism, LLC - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the names of the copyright holders nor the names of the - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/squeal-postgresql-uuid-ossp/README.md b/squeal-postgresql-uuid-ossp/README.md deleted file mode 100644 index 32a05d5a..00000000 --- a/squeal-postgresql-uuid-ossp/README.md +++ /dev/null @@ -1 +0,0 @@ -# squeal-postgresql-uuid-ossp diff --git a/squeal-postgresql-uuid-ossp/squeal-postgresql-uuid-ossp.cabal b/squeal-postgresql-uuid-ossp/squeal-postgresql-uuid-ossp.cabal deleted file mode 100644 index 48b167a4..00000000 --- a/squeal-postgresql-uuid-ossp/squeal-postgresql-uuid-ossp.cabal +++ /dev/null @@ -1,29 +0,0 @@ -name: squeal-postgresql-uuid-ossp -version: 0.1.0.0 -synopsis: UUID OSSP extension for Squeal -description: UUID OSSP extension for Squeal -homepage: https://github.com/morphismtech/squeal/uuid-ossp -bug-reports: https://github.com/morphismtech/squeal/issues -license: BSD3 -license-file: LICENSE -author: Eitan Chatav -maintainer: eitan.chatav@gmail.com -copyright: Copyright (c) 2021 Morphism, LLC -category: Database -build-type: Simple -cabal-version: >=1.18 -extra-doc-files: README.md - -source-repository head - type: git - location: https://github.com/morphismtech/squeal.git - -library - hs-source-dirs: src - exposed-modules: - Squeal.PostgreSQL.UUID.OSSP - default-language: Haskell2010 - ghc-options: -Wall - build-depends: - base >= 4.12.0.0 && < 5.0 - , squeal-postgresql >= 0.7.0.1 diff --git a/squeal-postgresql-uuid-ossp/src/Squeal/PostgreSQL/UUID/OSSP.hs b/squeal-postgresql-uuid-ossp/src/Squeal/PostgreSQL/UUID/OSSP.hs deleted file mode 100644 index 039c09b9..00000000 --- a/squeal-postgresql-uuid-ossp/src/Squeal/PostgreSQL/UUID/OSSP.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.UUID.OSSP -Description: uuid-ossp -Copyright: (c) Eitan Chatav, 2020 -Maintainer: eitan@morphism.tech -Stability: experimental - -This module provides functions to generate universally -unique identifiers (UUIDs) using one of several standard algorithms. -There are also functions to produce certain special UUID constants. --} - -{-# LANGUAGE - DataKinds - , OverloadedStrings - , TypeOperators -#-} - -module Squeal.PostgreSQL.UUID.OSSP - ( -- * Definition - createUuidOssp - -- * Generation - , uuidGenerateV1 - , uuidGenerateV1mc - , uuidGenerateV3 - , uuidGenerateV4 - , uuidGenerateV5 - -- * Constants - , uuidNil - , uuidNSUrl - , uuidNSDns - , uuidNSOid - , uuidNSX500 - ) where - -import Squeal.PostgreSQL - --- | Loads ltree extension into the current database. -createUuidOssp :: Definition db db -createUuidOssp = UnsafeDefinition "CREATE EXTENSION \"uuid-ossp\";" - --- | This function generates a version 1 UUID. --- This involves the MAC address of the computer and a time stamp. --- Note that UUIDs of this kind reveal the identity of the computer --- that created the identifier and the time at which it did so, --- which might make it unsuitable for certain security-sensitive applications. -uuidGenerateV1 :: Expr (null 'PGuuid) -uuidGenerateV1 = UnsafeExpression "uuid_generate_v1()" - --- | This function generates a version 1 UUID but uses a random multicast --- MAC address instead of the real MAC address of the computer. -uuidGenerateV1mc :: Expr (null 'PGuuid) -uuidGenerateV1mc = UnsafeExpression "uuid_generate_v1mc()" - -{- | This function generates a version 3 UUID in the given namespace -using the specified input name. The namespace should be one of the -special constants produced by the uuidNS* functions. -(It could be any UUID in theory.) -The name is an identifier in the selected namespace. -For example: -@ -uuidGenerateV3 (uuidNSUrl *: "http://www.postgresql.org") -@ - -The name parameter will be MD5-hashed, -so the cleartext cannot be derived from the generated UUID. -The generation of UUIDs by this method has no random or -environment-dependent element and is therefore reproducible. --} -uuidGenerateV3 :: '[null 'PGuuid, null 'PGtext] ---> null 'PGuuid -uuidGenerateV3 = unsafeFunctionN "uuid_generate_v3" - -{- | This function generates a version 4 UUID, -which is derived entirely from random numbers. --} -uuidGenerateV4 :: Expr (null 'PGuuid) -uuidGenerateV4 = UnsafeExpression "uuid_generate_v4()" - -{- | This function generates a version 5 UUID, -which works like a version 3 UUID except that -SHA-1 is used as a hashing method. -Version 5 should be preferred over version 3 because -SHA-1 is thought to be more secure than MD5. --} -uuidGenerateV5 :: '[null 'PGuuid, null 'PGtext] ---> null 'PGuuid -uuidGenerateV5 = unsafeFunctionN "uuid_generate_v5" - --- | A "nil" UUID constant, which does not occur as a real UUID. -uuidNil :: Expr (null 'PGuuid) -uuidNil = UnsafeExpression "uuid_nil()" - --- | Constant designating the DNS namespace for UUIDs. -uuidNSDns :: Expr (null 'PGuuid) -uuidNSDns = UnsafeExpression "uuid_ns_dns()" - --- | Constant designating the URL namespace for UUIDs. -uuidNSUrl :: Expr (null 'PGuuid) -uuidNSUrl = UnsafeExpression "uuid_ns_url()" - --- | Constant designating the ISO object identifier (OID) namespace for UUIDs. --- (This pertains to ASN.1 OIDs, --- which are unrelated to the OIDs used in PostgreSQL.) -uuidNSOid :: Expr (null 'PGuuid) -uuidNSOid = UnsafeExpression "uuid_ns_oid()" - --- | Constant designating the X.500 distinguished --- name (DN) namespace for UUIDs. -uuidNSX500 :: Expr (null 'PGuuid) -uuidNSX500 = UnsafeExpression "uuid_ns_x500()" diff --git a/squeal-postgresql/LICENSE b/squeal-postgresql/LICENSE deleted file mode 100644 index a905e6f1..00000000 --- a/squeal-postgresql/LICENSE +++ /dev/null @@ -1,31 +0,0 @@ -Copyright (c) 2017 Morphism, LLC - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the names of the copyright holders nor the names of the - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/squeal-postgresql/README.md b/squeal-postgresql/README.md deleted file mode 100644 index 1cd89548..00000000 --- a/squeal-postgresql/README.md +++ /dev/null @@ -1,11 +0,0 @@ -# squeal-postgresql - -![squeal-icon](https://raw.githubusercontent.com/morphismtech/squeal/dev/squeal.gif) - -[![CircleCI](https://circleci.com/gh/echatav/squeal.svg?style=svg&circle-token=a699a654ef50db2c3744fb039cf2087c484d1226)](https://circleci.com/gh/morphismtech/squeal) - -[Github](https://github.com/morphismtech/squeal) - -[Hackage](https://hackage.haskell.org/package/squeal-postgresql) - -[Stackage](https://www.stackage.org/package/squeal-postgresql) diff --git a/squeal-postgresql/bench/Gauge.hs b/squeal-postgresql/bench/Gauge.hs deleted file mode 100644 index 17243723..00000000 --- a/squeal-postgresql/bench/Gauge.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Main where - -import Squeal.PostgreSQL hiding ( defaultMain ) -import Gauge.Main -import Gauge.Main.Options ( defaultConfig - , Config(..) - , Verbosity(..) - , DisplayMode(..) - , Mode(..) - ) -import GHC.Generics -import qualified Generics.SOP as SOP -import Test.QuickCheck --- For CI -import Main.Utf8 ( withUtf8 ) --- For keeping a track of which question ID to query -import Data.Int ( Int64 ) -import Data.IORef --- Project imports -import Gauge.Schema -import Gauge.Queries -import Gauge.DBSetup ( teardownDB ) -import Gauge.DBHelpers ( initDBWithPool - , getRandomUser - , runDbWithPool - , SquealPool - ) - -main :: IO () -main = do - -- A mutable hack here to keep track of - -- pulling a new user by ID from the db instead of the same id - currentId <- newIORef (1 :: UserId) - - -- Define benchmarks - let - queryRenderGroup :: Benchmark - queryRenderGroup = bgroup - "Render Queries" - [ bench "createUser: weak head normal form" $ whnf renderSQL createUser - , bench "createUser: normal form" $ nf renderSQL createUser - , bench "userDetails: weak head normal form" $ whnf renderSQL userDetails - , bench "userDetails: normal form" $ nf renderSQL userDetails - , bench "insertDeviceDetails: weak head normal form" - $ whnf renderSQL insertDeviceDetails - , bench "insertDeviceDetails: normal form" - $ nf renderSQL insertDeviceDetails - ] - - -- Queries against an actual DB - - -- 1. Initialize Schema to DB - -- 2. Make connection pool and pass it to tests - -- 3. Generate users on the fly and add them to DB - -- 4. Tear the Schema down from the DB - - dbInsertsGroup :: Benchmark - dbInsertsGroup = - envWithCleanup initDBWithPool (const teardownDB) $ \pool -> bgroup - "Run individual INSERTs against DB using a connection pool" - [ bgroup - "INSERT: add users to the table users" - [ bench "Run individual INSERT statement" $ makeRunOnce $ perRunEnv - getRandomUser - -- The actual action to benchmark - (\(user :: InsertUser) -> - runDbWithPool pool $ createUserSession user - ) - ] - ] - - dbSelectsGroup :: Benchmark - dbSelectsGroup = - envWithCleanup initDBWithPool (const teardownDB) $ \pool -> bgroup - "Run individual SELECTs against DB using a connection pool" - [ bgroup - "SELECT: fetch users from the table users individually" - [ bench "Fetch a single user" $ makeRunOnce $ perRunEnv - (insertAndIncrement pool currentId) - (\(id_ :: UserId) -> runDbWithPool pool $ userDetailsSession id_ - ) - ] - ] - - withUtf8 $ defaultMain [queryRenderGroup, dbInsertsGroup, dbSelectsGroup] - - --- | Configure the benchmark to run only once (per IO action) -makeRunOnce :: Benchmarkable -> Benchmarkable -makeRunOnce current = current { perRun = True } - -getAndIncrementId :: (IORef UserId) -> IO UserId -getAndIncrementId currentId = do - current <- readIORef currentId - writeIORef currentId (current + 1) - return current - --- | This INSERTs a row in the db so that there's always a row to query. --- Otherwise 'getRow 0' throws an exception. --- NOTE: will make benchmark time slower but does not affect results. -insertAndIncrement :: SquealPool -> (IORef UserId) -> IO UserId -insertAndIncrement pool currentId = do - user <- getRandomUser - _ <- runDbWithPool pool $ createUserSession user - getAndIncrementId currentId diff --git a/squeal-postgresql/bench/Gauge/DBHelpers.hs b/squeal-postgresql/bench/Gauge/DBHelpers.hs deleted file mode 100644 index 5c591386..00000000 --- a/squeal-postgresql/bench/Gauge/DBHelpers.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} - -module Gauge.DBHelpers where - -import qualified Data.ByteString.Char8 as C -import qualified Data.Text as T -import Control.Monad ( void ) -import Control.Monad.IO.Class ( liftIO ) -import Control.Monad.Loops ( iterateWhile ) -import GHC.Generics ( Generic ) -import Test.QuickCheck -import Squeal.PostgreSQL -import qualified Squeal.PostgreSQL.Session.Transaction.Unsafe as Unsafe -import Control.DeepSeq --- Project imports -import Gauge.Schema ( Schemas ) -import Gauge.Queries ( InsertUser(..) ) -import Gauge.DBSetup - -newtype SquealPool = SquealPool {getSquealPool :: Pool (K Connection Schemas)} deriving (Generic) --- Below may be wrong - it may screw up the whole connection pool using in tests -instance NFData SquealPool where - rnf = rwhnf - -runDbErr - :: SquealPool -> PQ Schemas Schemas IO b -> IO (Either SquealException b) -runDbErr pool session = do - liftIO . runUsingConnPool pool $ trySqueal (Unsafe.transactionally_ session) - -runDbWithPool :: SquealPool -> PQ Schemas Schemas IO b -> IO b -runDbWithPool pool session = do - errOrResult <- runDbErr pool session - case errOrResult of - Left err -> throwSqueal err - Right result -> return result - --- | Helper -runUsingConnPool :: SquealPool -> PQ Schemas Schemas IO x -> IO x -runUsingConnPool (SquealPool pool) = usingConnectionPool pool - -makePool :: C.ByteString -> IO SquealPool -makePool connStr = do - pool <- createConnectionPool connStr 1 0.5 10 - return $ SquealPool pool - -initDBWithPool :: IO SquealPool -initDBWithPool = do - void initDB - pool <- makePool connectionString - return pool - -getRandomUser :: IO InsertUser -getRandomUser = iterateWhile noEmptyEmail $ generate arbitrary - where - noEmptyEmail InsertUser { userEmail = userEmail } = T.length userEmail < 5 diff --git a/squeal-postgresql/bench/Gauge/DBSetup.hs b/squeal-postgresql/bench/Gauge/DBSetup.hs deleted file mode 100644 index b7a5529d..00000000 --- a/squeal-postgresql/bench/Gauge/DBSetup.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Gauge.DBSetup where - -import Data.ByteString ( ByteString ) -import qualified Data.ByteString.Char8 as C -import Control.Monad ( void ) -import GHC.Generics -import Squeal.PostgreSQL --- Project imports -import Gauge.Schema ( Schemas - , DeviceOS - , IPLocation - ) - - --- First create enums as they're needed in the Schema -setup :: Definition (Public '[]) Schemas -setup = - createTypeEnumFrom @DeviceOS #device_os - >>> createTypeCompositeFrom @IPLocation #ip_location - >>> createTable - #users - ( serial8 - `as` #id - :* (text & notNullable) - `as` #email - :* (text & notNullable) - `as` #password - :* (text & nullable) - `as` #first_name - :* (int2 & nullable) - `as` #birthyear - ) - (primaryKey #id `as` #pk_users :* unique #email `as` #email) - >>> createTable - #user_devices - ( serial8 - `as` #id - :* notNullable int8 - `as` #user_id - :* (text & notNullable) - `as` #token - :* (typedef #device_os & notNullable) - `as` #os - ) - ( primaryKey #id - `as` #pk_user_devices - :* foreignKey #user_id #users #id (OnDelete Cascade) (OnUpdate Cascade) - `as` #fk_user_id - :* unique #token - `as` #token - ) - --- Drop types last because tables depend on them -teardown :: Definition Schemas (Public '[]) -teardown = - dropTableCascade #user_devices - >>> dropTableCascade #users - >>> dropType #ip_location - >>> dropType #device_os - --- With env vars, we could use the commented keys -data PGConfig = PGConfig - { pgHost :: String -- "PG_HOST" - , pgPort :: Int -- "PG_PORT" - , pgDbname :: String -- "PG_DBNAME" - , pgUser :: String -- "PG_USER" - , pgPassword :: String -- "PG_PASSWORD" - } - deriving (Generic, Show) - --- | Helper: unused now, but primarily for testing locally -makeConnStr :: PGConfig -> ByteString -makeConnStr PGConfig { pgHost = host, pgPort = portNumber, pgDbname = dbName, pgUser = user, pgPassword = pw } - = C.pack - $ "host=" - <> host - <> " dbname=" - <> dbName - <> " user=" - <> user - <> " password=" - <> pw - <> " port=" - <> show portNumber - -connectionString :: ByteString -connectionString = "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" - -performDBAction :: Definition a b -> String -> IO () -performDBAction action message = do - void - $ withConnection connectionString - $ manipulate_ (UnsafeManipulation "SET client_min_messages TO WARNING;") - & pqThen (define action) - putStrLn message - -initDB :: IO () -initDB = - performDBAction setup "Initialized Schema & corresponding tables for Database" - -teardownDB :: IO () -teardownDB = performDBAction teardown "Dropped all database tables" - -dbSchema :: Definition '["public" ::: '[]] (Drop "public" '["public" ::: '[]]) -dbSchema = dropSchemaCascade #public - -dropDBSchema :: IO () -dropDBSchema = performDBAction dbSchema "Dropped Public schema from database" - --- | Concatenate two `ByteString`s with a space between. -(<+>) :: ByteString -> ByteString -> ByteString -infixr 7 <+> -str1 <+> str2 = str1 <> " " <> str2 - --- | Drop table custom SQL statement with 'cascade' -dropTableCascade - :: (Has sch schemas schema, Has tab schema ( 'Table table)) - => QualifiedAlias sch tab -- ^ table to remove - -> Definition schemas (Alter sch (Drop tab schema) schemas) -dropTableCascade tab = - UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> " cascade;" diff --git a/squeal-postgresql/bench/Gauge/Queries.hs b/squeal-postgresql/bench/Gauge/Queries.hs deleted file mode 100644 index 0f38e690..00000000 --- a/squeal-postgresql/bench/Gauge/Queries.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} - -module Gauge.Queries where - -import Squeal.PostgreSQL -import GHC.Generics ( Generic ) -import qualified Generics.SOP as SOP --- Need below for deriving instances -import Control.DeepSeq -import Data.Text ( Text ) -import Data.Int ( Int16 - , Int64 - ) -import Test.QuickCheck ( Arbitrary(..) ) -import Generic.Random ( genericArbitrarySingle ) --- Import Orphan instances -import Test.QuickCheck.Instances ( ) --- Project imports -import Gauge.Schema - --- Types - -type UserId = Int64 --- Insert user -data InsertUser = InsertUser - { userEmail :: Text - , userPassword :: Text - , userFirstName :: Maybe Text - , userBirthyear :: Maybe Int16 - } - deriving (Show, Eq, Generic, NFData) -instance SOP.Generic InsertUser -instance SOP.HasDatatypeInfo InsertUser --- Arbitrary instances for producing values with quickcheck -instance Arbitrary InsertUser where - arbitrary = genericArbitrarySingle - -sampleInsertUser :: InsertUser -sampleInsertUser = InsertUser { userEmail = "mark@gmail.com" - , userPassword = "MySecretPassword" - , userFirstName = Just "Mark" - , userBirthyear = Just 1980 - } - -data APIDBUser_ = APIDBUser_ - { userId :: UserId - , email :: Text - , first_name :: Maybe Text - , birthyear :: Maybe Int16 - } - deriving (Show, Eq, Generic, NFData) -instance SOP.Generic APIDBUser_ -instance SOP.HasDatatypeInfo APIDBUser_ --- Arbitrary instances for producing values with quickcheck -instance Arbitrary APIDBUser_ where - arbitrary = genericArbitrarySingle - -data Row3 a b c = Row4 - { col1 :: a - , col2 :: b - , col3 :: c - } - deriving stock Generic - deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) - --- (UserId, Token, OS) -type DeviceDetailsRow = Row3 UserId Text (Enumerated DeviceOS) - --- -- Queries - -createUserSession :: InsertUser -> PQ Schemas Schemas IO APIDBUser_ -createUserSession insertUser = - getRow 0 =<< manipulateParams createUser insertUser - -createUser :: Manipulation_ Schemas InsertUser APIDBUser_ -createUser = insertInto - #users - (Values_ - ( Default - `as` #id - :* Set (param @1) - `as` #email - :* Set (param @2) - `as` #password - :* Set (param @3) - `as` #first_name - :* Set (param @4 & cast int2) - `as` #birthyear - ) - ) - OnConflictDoRaise - (Returning_ - ( #id - `as` #userId - :* #email - `as` #email - :* #first_name - `as` #first_name - :* #birthyear - `as` #birthyear - ) - ) - -userDetailsSession :: UserId -> PQ Schemas Schemas IO APIDBUser_ -userDetailsSession uID = getRow 0 =<< runQueryParams userDetails (Only uID) - -userDetails :: Query_ Schemas (Only UserId) APIDBUser_ -userDetails = select_ - ( #id - `as` #userId - :* #email - `as` #email - :* #first_name - `as` #first_name - :* #birthyear - `as` #birthyear - ) - (from (table #users) & where_ (#id .== (param @1 & cast int8))) - -insertDeviceDetails :: Manipulation_ Schemas DeviceDetailsRow () -insertDeviceDetails = insertInto - #user_devices - (Values_ - ( Default - `as` #id - :* Set (param @1) - `as` #user_id - :* Set (param @2) - `as` #token - :* Set (parameter @3 (typedef #device_os)) - `as` #os - ) - ) - OnConflictDoRaise - (Returning_ Nil) diff --git a/squeal-postgresql/bench/Gauge/Schema.hs b/squeal-postgresql/bench/Gauge/Schema.hs deleted file mode 100644 index e0fd6aa4..00000000 --- a/squeal-postgresql/bench/Gauge/Schema.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DeriveGeneric #-} - -module Gauge.Schema where - -import Squeal.PostgreSQL -import GHC.Generics -import qualified Generics.SOP as SOP - - --- Type - -data DeviceOS = Android | IOS - deriving (Show, Read, Eq, Generic) --- DeviceOS is converted to PG Enum type -instance SOP.Generic DeviceOS -instance SOP.HasDatatypeInfo DeviceOS - --- Defined extra types for the database --- Operating system enum -type PGDeviceOS = PG (Enumerated DeviceOS) -type DeviceOSType = 'Typedef PGDeviceOS - --- For composite type -data IPLocation = IPLocation - { countryShort :: String - , region :: String - , city :: String - } - deriving (Show, Read, Eq, Generic) - -instance SOP.Generic IPLocation -instance SOP.HasDatatypeInfo IPLocation - --- IPLocation Composite type -type PGIPLocation = PG (Composite IPLocation) -type IPLocationType = 'Typedef PGIPLocation - --- SCHEMA - --- Users - -type UsersColumns = '[ - "id" ::: 'Def :=> 'NotNull 'PGint8 - , "email" ::: 'NoDef :=> 'NotNull 'PGtext - , "password" ::: 'NoDef :=> 'NotNull 'PGtext - , "first_name" ::: 'NoDef :=> 'Null 'PGtext - , "birthyear" ::: 'NoDef :=> 'Null 'PGint2 - ] - -type UsersConstraints = '[ - "pk_users" ::: 'PrimaryKey '["id"] - , "email" ::: 'Unique '["email"] - ] - -type UsersTable = 'Table (UsersConstraints :=> UsersColumns) - --- User devices -type UserDevicesColumns = '[ - "id" ::: 'Def :=> 'NotNull 'PGint8 -- ID as PK because user might have many same OS devices - , "user_id" ::: 'NoDef :=> 'NotNull 'PGint8 - , "token" ::: 'NoDef :=> 'NotNull 'PGtext - , "os" ::: 'NoDef :=> 'NotNull PGDeviceOS - ] - -type UserDevicesConstraints = '[ - "pk_user_devices" ::: 'PrimaryKey '["id"] - , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"] - , "token" ::: 'Unique '["token"] - ] - -type UserDevicesTable = 'Table (UserDevicesConstraints :=> UserDevicesColumns) - --- Schema --- Make sure to put types before tables, otherwise won't compile -type Schema = '[ - -- Enum types: - "device_os" ::: DeviceOSType - -- Composite types: - , "ip_location" ::: IPLocationType - -- Tables: - , "users" ::: UsersTable - , "user_devices" ::: UserDevicesTable - ] - -type Schemas = '["public" ::: Schema] diff --git a/squeal-postgresql/bench/README.md b/squeal-postgresql/bench/README.md deleted file mode 100644 index 4ad3847c..00000000 --- a/squeal-postgresql/bench/README.md +++ /dev/null @@ -1,9 +0,0 @@ -# Microbenchark suite for Squeal -> Benchmarking & profiling query rendering performance - -## Running - -Run benchmark suite with: -``` -stack bench -``` diff --git a/squeal-postgresql/docs-upload.sh b/squeal-postgresql/docs-upload.sh deleted file mode 100755 index ca4acf79..00000000 --- a/squeal-postgresql/docs-upload.sh +++ /dev/null @@ -1,18 +0,0 @@ -#!/bin/bash - -# Run this script in the top-level of your package directory -# (where the .cabal file is) to compile documentation and -# upload it to hackage. - -# Requirements: -# cabal-install-1.24 (for --for-hackage) -# haddock 2.17 (for the hyperlinked source) - -set -e - -dir=$(mktemp -d dist-docs.XXXXXX) -trap 'rm -r "$dir"' EXIT - -cabal configure --builddir="$dir" -cabal haddock --builddir="$dir" --for-hackage --haddock-option=--hyperlinked-source -cabal upload -d $dir/*-docs.tar.gz diff --git a/squeal-postgresql/exe/Example.hs b/squeal-postgresql/exe/Example.hs deleted file mode 100644 index 6fe3cd9d..00000000 --- a/squeal-postgresql/exe/Example.hs +++ /dev/null @@ -1,170 +0,0 @@ -{-# LANGUAGE - DataKinds - , DeriveGeneric - , FlexibleContexts - , OverloadedLabels - , OverloadedStrings - , OverloadedLists - , TypeApplications - , TypeOperators -#-} - -module Main (main, main2, upsertUser) where - -import Control.Monad.IO.Class (MonadIO (..)) -import Data.Int (Int16, Int32) -import Data.Text (Text) -import Data.Vector (Vector) - -import Squeal.PostgreSQL - -import qualified Data.ByteString.Char8 as Char8 -import qualified Generics.SOP as SOP -import qualified GHC.Generics as GHC - -type UserSchema = - '[ "users" ::: 'Table ( - '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "name" ::: 'NoDef :=> 'NotNull 'PGtext - , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray ('Null 'PGint2)) - ]) - , "emails" ::: 'Table ( - '[ "pk_emails" ::: 'PrimaryKey '["id"] - , "fk_user_id" ::: 'ForeignKey '["user_id"] "user" "users" '["id"] - ] :=> - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 - , "email" ::: 'NoDef :=> 'Null 'PGtext - ]) - ] - -type PublicSchema = '[ "positive" ::: 'Typedef 'PGfloat4 ] - -type OrgSchema = - '[ "organizations" ::: 'Table ( - '[ "pk_organizations" ::: 'PrimaryKey '["id"] ] :=> - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "name" ::: 'NoDef :=> 'NotNull 'PGtext - ]) - , "members" ::: 'Table ( - '[ "fk_member" ::: 'ForeignKey '["member"] "user" "users" '["id"] - , "fk_organization" ::: 'ForeignKey '["organization"] "org" "organizations" '["id"] ] :=> - '[ "member" ::: 'NoDef :=> 'NotNull 'PGint4 - , "organization" ::: 'NoDef :=> 'NotNull 'PGint4 ]) - ] - -type Schemas - = '[ "public" ::: PublicSchema, "user" ::: UserSchema, "org" ::: OrgSchema ] - -setup :: Definition (Public '[]) Schemas -setup = - createDomain #positive real (#value .> 0 .&& (#value & isNotNull)) - >>> - createSchema #user - >>> - createSchema #org - >>> - createTable (#user ! #jokers) - ( serial `as` #id :* - (text & notNullable) `as` #name :* - (vararray int2 & notNullable) `as` #vec ) - ( primaryKey #id `as` #pk_users ) - >>> - alterTableRename (#user ! #jokers) #users - >>> - createTable (#user ! #emails) - ( serial `as` #id :* - columntypeFrom @Int32 `as` #user_id :* - columntypeFrom @(Maybe Text) `as` #email ) - ( primaryKey #id `as` #pk_emails :* - foreignKey #user_id (#user ! #users) #id - (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_user_id ) - >>> - createTable (#org ! #organizations) - ( serial `as` #id :* - (text & notNullable) `as` #name ) - ( primaryKey #id `as` #pk_organizations ) - >>> - createTable (#org ! #members) - ( notNullable int4 `as` #member :* - notNullable int4 `as` #organization ) - ( foreignKey #member (#user ! #users) #id - (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_member :* - foreignKey #organization (#org ! #organizations) #id - (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_organization ) - -teardown :: Definition Schemas (Public '[]) -teardown = dropType #positive >>> dropSchemaCascade #user >>> dropSchemaCascade #org - -insertUser :: Manipulation_ Schemas (Text, VarArray (Vector (Maybe Int16))) (Only Int32) -insertUser = insertInto (#user ! #users) - (Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec)) - (OnConflict (OnConstraint #pk_users) DoNothing) (Returning_ (#id `as` #fromOnly)) - -insertEmail :: Manipulation_ Schemas (Int32, Maybe Text) () -insertEmail = insertInto_ (#user ! #emails) - (Values_ (Default `as` #id :* Set (param @1) `as` #user_id :* Set (param @2) `as` #email)) - -getUsers :: Query_ Schemas () User -getUsers = select_ - (#u ! #name `as` #userName :* #e ! #email `as` #userEmail :* #u ! #vec `as` #userVec) - ( from (table ((#user ! #users) `as` #u) - & innerJoin (table ((#user ! #emails) `as` #e)) - (#u ! #id .== #e ! #user_id)) ) - -upsertUser :: Manipulation_ Schemas (Int32, String, VarArray [Maybe Int16]) () -upsertUser = insertInto (#user ! #users `as` #u) - (Values_ (Set (param @1) `as` #id :* setUser)) - (OnConflict (OnConstraint #pk_users) (DoUpdate setUser [#u ! #id .== param @1])) - (Returning_ Nil) - where - setUser = Set (param @2) `as` #name :* Set (param @3) `as` #vec :* Nil - -data User - = User - { userName :: Text - , userEmail :: Maybe Text - , userVec :: VarArray (Vector (Maybe Int16)) - } deriving (Show, GHC.Generic) -instance SOP.Generic User -instance SOP.HasDatatypeInfo User - -users :: [User] -users = - [ User "Alice" (Just "alice@gmail.com") (VarArray [Just 1,Just 2,Nothing]) - , User "Bob" Nothing (VarArray [Nothing,Just (-3)]) - , User "Carole" (Just "carole@hotmail.com") (VarArray [Just 3,Nothing, Just 4]) - ] - -session :: (MonadIO pq, MonadPQ Schemas pq) => pq () -session = do - liftIO $ Char8.putStrLn "manipulating" - idResults <- traversePrepared insertUser ([(userName user, userVec user) | user <- users]) - ids <- traverse (fmap fromOnly . getRow 0) (idResults :: [Result (Only Int32)]) - traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users)) - liftIO $ Char8.putStrLn "querying" - usersResult <- runQuery getUsers - usersRows <- getRows usersResult - liftIO $ print (usersRows :: [User]) - -main :: IO () -main = do - Char8.putStrLn "squeal" - connectionString <- pure - "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" - Char8.putStrLn $ "connecting to " <> connectionString - connection0 <- connectdb connectionString - Char8.putStrLn "setting up schema" - connection1 <- execPQ (define setup) connection0 - connection2 <- execPQ session connection1 - Char8.putStrLn "tearing down schema" - connection3 <- execPQ (define teardown) connection2 - finish connection3 - -main2 :: IO () -main2 = - withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ - define setup - & pqThen session - & pqThen (define teardown) diff --git a/squeal-postgresql/squeal-postgresql.cabal b/squeal-postgresql/squeal-postgresql.cabal index 30eb09f9..221f9310 100644 --- a/squeal-postgresql/squeal-postgresql.cabal +++ b/squeal-postgresql/squeal-postgresql.cabal @@ -5,14 +5,12 @@ description: Squeal is a type-safe embedding of PostgreSQL in Haskell homepage: https://github.com/morphismtech/squeal bug-reports: https://github.com/morphismtech/squeal/issues license: BSD3 -license-file: LICENSE author: Eitan Chatav maintainer: eitan.chatav@gmail.com copyright: Copyright (c) 2021 Morphism, LLC category: Database build-type: Simple cabal-version: >=1.18 -extra-doc-files: README.md source-repository head type: git @@ -21,100 +19,11 @@ source-repository head library hs-source-dirs: src exposed-modules: - Squeal.PostgreSQL - Squeal.PostgreSQL.Definition - Squeal.PostgreSQL.Definition.Comment - Squeal.PostgreSQL.Definition.Constraint - Squeal.PostgreSQL.Definition.Function - Squeal.PostgreSQL.Definition.Index - Squeal.PostgreSQL.Definition.Table - Squeal.PostgreSQL.Definition.Type - Squeal.PostgreSQL.Definition.Procedure - Squeal.PostgreSQL.Definition.Schema - Squeal.PostgreSQL.Definition.View - Squeal.PostgreSQL.Expression - Squeal.PostgreSQL.Expression.Aggregate - Squeal.PostgreSQL.Expression.Array - Squeal.PostgreSQL.Expression.Comparison - Squeal.PostgreSQL.Expression.Composite - Squeal.PostgreSQL.Expression.Default - Squeal.PostgreSQL.Expression.Json - Squeal.PostgreSQL.Expression.Inline - Squeal.PostgreSQL.Expression.Logic - Squeal.PostgreSQL.Expression.Math - Squeal.PostgreSQL.Expression.Null - Squeal.PostgreSQL.Expression.Parameter - Squeal.PostgreSQL.Expression.Range - Squeal.PostgreSQL.Expression.Sort - Squeal.PostgreSQL.Expression.Subquery - Squeal.PostgreSQL.Expression.Text - Squeal.PostgreSQL.Expression.TextSearch - Squeal.PostgreSQL.Expression.Time - Squeal.PostgreSQL.Expression.Type - Squeal.PostgreSQL.Expression.Window - Squeal.PostgreSQL.Manipulation - Squeal.PostgreSQL.Manipulation.Call - Squeal.PostgreSQL.Manipulation.Delete - Squeal.PostgreSQL.Manipulation.Insert - Squeal.PostgreSQL.Manipulation.Update - Squeal.PostgreSQL.Render - Squeal.PostgreSQL.Query - Squeal.PostgreSQL.Query.From - Squeal.PostgreSQL.Query.From.Join - Squeal.PostgreSQL.Query.From.Set - Squeal.PostgreSQL.Query.Select - Squeal.PostgreSQL.Query.Table - Squeal.PostgreSQL.Query.Values - Squeal.PostgreSQL.Query.With - Squeal.PostgreSQL.Session - Squeal.PostgreSQL.Session.Connection - Squeal.PostgreSQL.Session.Decode - Squeal.PostgreSQL.Session.Encode - Squeal.PostgreSQL.Session.Exception - Squeal.PostgreSQL.Session.Indexed - Squeal.PostgreSQL.Session.Migration - Squeal.PostgreSQL.Session.Monad - Squeal.PostgreSQL.Session.Oid - Squeal.PostgreSQL.Session.Pool - Squeal.PostgreSQL.Session.Result - Squeal.PostgreSQL.Session.Statement - Squeal.PostgreSQL.Session.Transaction - Squeal.PostgreSQL.Session.Transaction.Unsafe - Squeal.PostgreSQL.Type - Squeal.PostgreSQL.Type.Alias - Squeal.PostgreSQL.Type.List - Squeal.PostgreSQL.Type.PG Squeal.PostgreSQL.Type.Schema default-language: Haskell2010 ghc-options: -Wall build-depends: - aeson >= 1.4.7.1 - , base >= 4.12.0.0 && < 5.0 - , binary >= 0.8.7.0 - , binary-parser >= 0.5.5 - , bytestring >= 0.10.10.0 - , bytestring-strict-builder >= 0.4.5.3 - , deepseq >= 1.4.4.0 - , exceptions >= 0.10.3 - , free-categories >= 0.2.0.0 - , generics-sop >= 0.5.1.0 - , mmorph >= 1.1.3 - , monad-control >= 1.0.2.3 - , mtl >= 2.2.2 - , network-ip >= 0.3.0.3 - , postgresql-binary >= 0.12.2 - , postgresql-libpq >= 0.9.4.2 - , profunctors >= 5.5.2 - , records-sop >= 0.1.0.3 - , resource-pool >= 0.2.3.2 - , scientific >= 0.3.6.2 - , text >= 1.2.3.2 - , time >= 1.9.3 - , transformers >= 0.5.6.2 - , transformers-base >= 0.4.5.2 - , unliftio >= 0.2.12.1 - , uuid-types >= 1.0.3 - , vector >= 0.12.1.2 + base >= 4.12.0.0 && < 5.0 test-suite doctest default-language: Haskell2010 @@ -126,84 +35,3 @@ test-suite doctest base >= 4.12.0.0 && < 5.0 , doctest >= 0.16.3 , squeal-postgresql - -test-suite properties - default-language: Haskell2010 - type: exitcode-stdio-1.0 - hs-source-dirs: test - ghc-options: -Wall - main-is: Property.hs - build-depends: - base >= 4.12.0.0 && < 5.0 - , bytestring >= 0.10.10.0 - , hedgehog >= 1.0.2 - , generics-sop >= 0.5.1.0 - , mtl >= 2.2.2 - , scientific >= 0.3.6.2 - , squeal-postgresql - , time >= 1.9.3 - , with-utf8 >= 1.0 - -test-suite spec - default-language: Haskell2010 - type: exitcode-stdio-1.0 - hs-source-dirs: test - ghc-options: -Wall - main-is: Spec.hs - build-depends: - async >= 2.2.2 - , base >= 4.12.0.0 && < 5.0 - , bytestring >= 0.10.10.0 - , generics-sop >= 0.5.1.0 - , hspec >= 2.7.1 - , mtl >= 2.2.2 - , squeal-postgresql - , text >= 1.2.3.2 - , vector >= 0.12.1.2 - -benchmark gauge - type: exitcode-stdio-1.0 - hs-source-dirs: bench - main-is: Gauge.hs - other-modules: - Gauge.DBHelpers - , Gauge.DBSetup - , Gauge.Queries - , Gauge.Schema - default-language: Haskell2010 - ghc-options: - -O2 - -threaded - "-with-rtsopts=-N" - -rtsopts - -funbox-strict-fields - build-depends: - base >= 4.12.0.0 && < 5.0 - , bytestring >= 0.10.10.0 - , deepseq >= 1.4.4.0 - , gauge >= 0.2.5 - , generic-random >= 1.3.0.1 - , generics-sop >= 0.5.1.0 - , monad-loops >= 0.4.3 - , mtl >= 2.2.2 - , QuickCheck >= 2.13.2 - , quickcheck-instances >= 0.3.22 - , scientific >= 0.3.6.2 - , squeal-postgresql - , text >= 1.2.3.2 - , with-utf8 >= 1.0 - -executable example - default-language: Haskell2010 - hs-source-dirs: exe - ghc-options: -Wall - main-is: Example.hs - build-depends: - base >= 4.10.0.0 && < 5.0 - , bytestring >= 0.10.10.0 - , generics-sop >= 0.5.1.0 - , mtl >= 2.2.2 - , squeal-postgresql - , text >= 1.2.3.2 - , transformers >= 0.5.6.2 - , vector >= 0.12.1.2 diff --git a/squeal-postgresql/src/Squeal/PostgreSQL.hs b/squeal-postgresql/src/Squeal/PostgreSQL.hs deleted file mode 100644 index 8deaa911..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL.hs +++ /dev/null @@ -1,266 +0,0 @@ -{-| -Module: Squeal.PostgreSQL -Description: export module -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -Squeal is a deep embedding of [PostgreSQL](https://www.postgresql.org) in Haskell. -Let's see an example! - -First, we need some language extensions because Squeal uses modern GHC -features. - ->>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels -XFlexibleContexts ->>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators -XGADTs - -We'll need some imports. - ->>> import Control.Monad.IO.Class (liftIO) ->>> import Data.Int (Int32) ->>> import Data.Text (Text) ->>> import Squeal.PostgreSQL - -We'll use generics to easily convert between Haskell and PostgreSQL values. - ->>> import qualified Generics.SOP as SOP ->>> import qualified GHC.Generics as GHC - -The first step is to define the schema of our database. This is where -we use @DataKinds@ and @TypeOperators@. - ->>> :{ -type UsersColumns = - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "name" ::: 'NoDef :=> 'NotNull 'PGtext ] -type UsersConstraints = '[ "pk_users" ::: 'PrimaryKey '["id"] ] -type EmailsColumns = - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 - , "email" ::: 'NoDef :=> 'Null 'PGtext ] -type EmailsConstraints = - '[ "pk_emails" ::: 'PrimaryKey '["id"] - , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"] ] -type Schema = - '[ "users" ::: 'Table (UsersConstraints :=> UsersColumns) - , "emails" ::: 'Table (EmailsConstraints :=> EmailsColumns) ] -type DB = Public Schema -:} - -Notice the use of type operators. - -`:::` is used to pair an alias `GHC.TypeLits.Symbol` with a `SchemasType`, a `SchemumType`, -a `TableConstraint` or a `ColumnType`. It is intended to connote Haskell's @::@ -operator. - -`:=>` is used to pair `TableConstraints` with a `ColumnsType`, -yielding a `TableType`, or to pair an `Optionality` with a `NullType`, -yielding a `ColumnType`. It is intended to connote Haskell's @=>@ operator - -Next, we'll write `Definition`s to set up and tear down the schema. In -Squeal, a `Definition` like `createTable`, `alterTable` or `dropTable` -has two type parameters, corresponding to the schema -before being run and the schema after. We can compose definitions using `>>>`. -Here and in the rest of our commands we make use of overloaded -labels to refer to named tables and columns in our schema. - ->>> :{ -let - setup :: Definition (Public '[]) DB - setup = - createTable #users - ( serial `as` #id :* - (text & notNullable) `as` #name ) - ( primaryKey #id `as` #pk_users ) >>> - createTable #emails - ( serial `as` #id :* - (int & notNullable) `as` #user_id :* - (text & nullable) `as` #email ) - ( primaryKey #id `as` #pk_emails :* - foreignKey #user_id #users #id - (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_user_id ) -:} - -We can easily see the generated SQL is unsurprising looking. - ->>> printSQL setup -CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id")); -CREATE TABLE "emails" ("id" serial, "user_id" int NOT NULL, "email" text NULL, CONSTRAINT "pk_emails" PRIMARY KEY ("id"), CONSTRAINT "fk_user_id" FOREIGN KEY ("user_id") REFERENCES "users" ("id") ON DELETE CASCADE ON UPDATE CASCADE); - -Notice that @setup@ starts with an empty public schema @(Public '[])@ and produces @DB@. -In our `createTable` commands we included `TableConstraint`s to define -primary and foreign keys, making them somewhat complex. Our @teardown@ -`Definition` is simpler. - ->>> :{ -let - teardown :: Definition DB (Public '[]) - teardown = dropTable #emails >>> dropTable #users -:} - ->>> printSQL teardown -DROP TABLE "emails"; -DROP TABLE "users"; - -We'll need a Haskell type for @User@s. We give the type `Generics.SOP.Generic` and -`Generics.SOP.HasDatatypeInfo` instances so that we can encode and decode @User@s. - ->>> :set -XDerivingStrategies -XDeriveAnyClass ->>> :{ -data User = User { userName :: Text, userEmail :: Maybe Text } - deriving stock (Show, GHC.Generic) - deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) -:} - -Next, we'll write `Statement`s to insert @User@s into our two tables. -A `Statement` has three type parameters, the schemas it refers to, -input parameters and an output row. When -we insert into the users table, we will need a parameter for the @name@ -field but not for the @id@ field. Since it's serial, we can use a default -value. However, since the emails table refers to the users table, we will -need to retrieve the user id that the insert generates and insert it into -the emails table. We can do this in a single `Statement` by using a -`with` `manipulation`. - ->>> :{ -let - insertUser :: Statement DB User () - insertUser = manipulation $ with (u `as` #u) e - where - u = insertInto #users - (Values_ (Default `as` #id :* Set (param @1) `as` #name)) - OnConflictDoRaise (Returning_ (#id :* param @2 `as` #email)) - e = insertInto_ #emails $ Select - (Default `as` #id :* Set (#u ! #id) `as` #user_id :* Set (#u ! #email) `as` #email) - (from (common #u)) -:} - ->>> printSQL insertUser -WITH "u" AS (INSERT INTO "users" AS "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) RETURNING "id" AS "id", ($2 :: text) AS "email") INSERT INTO "emails" AS "emails" ("user_id", "email") SELECT "u"."id", "u"."email" FROM "u" AS "u" - -Next we write a `Statement` to retrieve users from the database. We're not -interested in the ids here, just the usernames and email addresses. We -need to use an `innerJoin` to get the right result. - ->>> :{ -let - getUsers :: Statement DB () User - getUsers = query $ select_ - (#u ! #name `as` #userName :* #e ! #email `as` #userEmail) - ( from (table (#users `as` #u) - & innerJoin (table (#emails `as` #e)) - (#u ! #id .== #e ! #user_id)) ) -:} - ->>> printSQL getUsers -SELECT "u"."name" AS "userName", "e"."email" AS "userEmail" FROM "users" AS "u" INNER JOIN "emails" AS "e" ON ("u"."id" = "e"."user_id") - -Let's create some users to add to the database. - ->>> :{ -let - users :: [User] - users = - [ User "Alice" (Just "alice@gmail.com") - , User "Bob" Nothing - , User "Carole" (Just "carole@hotmail.com") - ] -:} - -Now we can put together all the pieces into a program. The program -connects to the database, sets up the schema, inserts the user data -(using prepared statements as an optimization), queries the user -data and prints it out and finally closes the connection. We can thread -the changing schema information through by using the indexed `PQ` monad -transformer and when the schema doesn't change we can use `Monad` and -`MonadPQ` functionality. - ->>> :{ -let - session :: PQ DB DB IO () - session = do - executePrepared_ insertUser users - usersResult <- execute getUsers - usersRows <- getRows usersResult - liftIO $ print usersRows -in - withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ - define setup - & pqThen session - & pqThen (define teardown) -:} -[User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}] - -This should get you up and running with Squeal. Once you're writing more complicated -queries and need a deeper understanding of Squeal's types and how everything -fits together, check out the -in the toplevel of Squeal's Git repo. --} -module Squeal.PostgreSQL - ( module X - , RenderSQL (..) - , printSQL - ) where - -import Squeal.PostgreSQL.Definition as X -import Squeal.PostgreSQL.Definition.Comment as X -import Squeal.PostgreSQL.Definition.Constraint as X -import Squeal.PostgreSQL.Definition.Function as X -import Squeal.PostgreSQL.Definition.Index as X -import Squeal.PostgreSQL.Definition.Procedure as X -import Squeal.PostgreSQL.Definition.Schema as X -import Squeal.PostgreSQL.Definition.Table as X -import Squeal.PostgreSQL.Definition.Type as X -import Squeal.PostgreSQL.Definition.View as X -import Squeal.PostgreSQL.Expression as X -import Squeal.PostgreSQL.Expression.Aggregate as X -import Squeal.PostgreSQL.Expression.Array as X -import Squeal.PostgreSQL.Expression.Comparison as X -import Squeal.PostgreSQL.Expression.Composite as X -import Squeal.PostgreSQL.Expression.Default as X -import Squeal.PostgreSQL.Expression.Json as X -import Squeal.PostgreSQL.Expression.Inline as X -import Squeal.PostgreSQL.Expression.Logic as X -import Squeal.PostgreSQL.Expression.Math as X -import Squeal.PostgreSQL.Expression.Null as X -import Squeal.PostgreSQL.Expression.Parameter as X -import Squeal.PostgreSQL.Expression.Range as X -import Squeal.PostgreSQL.Expression.Sort as X -import Squeal.PostgreSQL.Expression.Subquery as X -import Squeal.PostgreSQL.Expression.Text as X -import Squeal.PostgreSQL.Expression.TextSearch as X -import Squeal.PostgreSQL.Expression.Time as X -import Squeal.PostgreSQL.Expression.Type as X -import Squeal.PostgreSQL.Expression.Window as X -import Squeal.PostgreSQL.Manipulation as X -import Squeal.PostgreSQL.Manipulation.Call as X -import Squeal.PostgreSQL.Manipulation.Delete as X -import Squeal.PostgreSQL.Manipulation.Insert as X -import Squeal.PostgreSQL.Manipulation.Update as X -import Squeal.PostgreSQL.Query as X -import Squeal.PostgreSQL.Query.From as X -import Squeal.PostgreSQL.Query.From.Join as X -import Squeal.PostgreSQL.Query.From.Set as X -import Squeal.PostgreSQL.Query.Select as X -import Squeal.PostgreSQL.Query.Table as X -import Squeal.PostgreSQL.Query.Values as X -import Squeal.PostgreSQL.Query.With as X -import Squeal.PostgreSQL.Render (RenderSQL(..), printSQL) -import Squeal.PostgreSQL.Session as X -import Squeal.PostgreSQL.Session.Connection as X -import Squeal.PostgreSQL.Session.Decode as X -import Squeal.PostgreSQL.Session.Encode as X -import Squeal.PostgreSQL.Session.Exception as X -import Squeal.PostgreSQL.Session.Indexed as X -import Squeal.PostgreSQL.Session.Migration as X -import Squeal.PostgreSQL.Session.Monad as X -import Squeal.PostgreSQL.Session.Oid as X -import Squeal.PostgreSQL.Session.Pool as X -import Squeal.PostgreSQL.Session.Result as X -import Squeal.PostgreSQL.Session.Statement as X -import Squeal.PostgreSQL.Session.Transaction as X -import Squeal.PostgreSQL.Type as X -import Squeal.PostgreSQL.Type.Alias as X -import Squeal.PostgreSQL.Type.List as X -import Squeal.PostgreSQL.Type.PG as X -import Squeal.PostgreSQL.Type.Schema as X diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs deleted file mode 100644 index 8bf94edd..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Definition -Description: data definition language -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -data definition language --} - -{-# LANGUAGE - AllowAmbiguousTypes - , ConstraintKinds - , DeriveAnyClass - , DeriveGeneric - , DerivingStrategies - , FlexibleContexts - , FlexibleInstances - , GADTs - , LambdaCase - , MultiParamTypeClasses - , OverloadedLabels - , OverloadedStrings - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeInType - , TypeOperators - , UndecidableSuperClasses - , UndecidableInstances -#-} - -module Squeal.PostgreSQL.Definition - ( -- * Definition - Definition (..) - , (>>>) - , manipulation_ - ) where - -import Control.Category -import Control.DeepSeq -import Data.ByteString -import Data.Monoid -import Prelude hiding ((.), id) - -import qualified GHC.Generics as GHC - -import Squeal.PostgreSQL.Manipulation -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL - -{----------------------------------------- -statements ------------------------------------------} - --- | A `Definition` is a statement that changes the schemas of the --- database, like a `Squeal.PostgreSQL.Definition.Table.createTable`, --- `Squeal.PostgreSQL.Definition.Table.dropTable`, --- or `Squeal.PostgreSQL.Definition.Table.alterTable` command. --- `Definition`s may be composed using the `>>>` operator. -newtype Definition - (db0 :: SchemasType) - (db1 :: SchemasType) - = UnsafeDefinition { renderDefinition :: ByteString } - deriving (GHC.Generic,Show,Eq,Ord,NFData) - -instance RenderSQL (Definition db0 db1) where - renderSQL = renderDefinition - -instance Category Definition where - id = UnsafeDefinition ";" - ddl1 . ddl0 = UnsafeDefinition $ - renderSQL ddl0 <> "\n" <> renderSQL ddl1 - -instance db0 ~ db1 => Semigroup (Definition db0 db1) where (<>) = (>>>) -instance db0 ~ db1 => Monoid (Definition db0 db1) where mempty = id - --- | A `Manipulation` without input or output can be run as a statement --- along with other `Definition`s, by embedding it using `manipulation_`. -manipulation_ - :: Manipulation '[] db '[] '[] - -- ^ no input or output - -> Definition db db -manipulation_ = UnsafeDefinition . (<> ";") . renderSQL diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition/Comment.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition/Comment.hs deleted file mode 100644 index 18a616bb..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition/Comment.hs +++ /dev/null @@ -1,165 +0,0 @@ -{- | -Module: Squeal.PostgreSQL.Definition.Constraint -Description: comments -Copyright: (c) Eitan Chatav, 2020 -Maintainer: eitan@morphism.tech -Stability: experimental - -comments --} - -{-# LANGUAGE - AllowAmbiguousTypes - , ConstraintKinds - , DeriveAnyClass - , DeriveGeneric - , DerivingStrategies - , FlexibleContexts - , FlexibleInstances - , GADTs - , LambdaCase - , MultiParamTypeClasses - , OverloadedLabels - , OverloadedStrings - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeInType - , TypeOperators - , UndecidableSuperClasses - #-} - -module Squeal.PostgreSQL.Definition.Comment - ( commentOnTable - , commentOnType - , commentOnView - , commentOnFunction - , commentOnIndex - , commentOnColumn - , commentOnSchema - ) where - -import Squeal.PostgreSQL.Definition -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema -import GHC.TypeLits (KnownSymbol) -import Data.Text (Text) - -{----------------------------------------- -COMMENT statements ------------------------------------------} - -{- | -When a user views a table in the database (i.e. with \d+ ), it is useful -to be able to read a description of the table. --} -commentOnTable - :: ( KnownSymbol sch - , KnownSymbol tab - , Has sch db schema - , Has tab schema ('Table table) - ) - => QualifiedAlias sch tab -- ^ table - -> Text -- ^ comment - -> Definition db db -commentOnTable alias comm = UnsafeDefinition $ - "COMMENT ON TABLE" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";" - -{- | -When a user views a type in the database (i.e with \dT ), it is useful to -be able to read a description of the type. --} -commentOnType - :: ( KnownSymbol sch - , KnownSymbol typ - , Has sch db schema - , Has typ schema ('Typedef type_) - ) - => QualifiedAlias sch typ -- ^ type - -> Text -- ^ comment - -> Definition db db -commentOnType alias comm = UnsafeDefinition $ - "COMMENT ON TYPE" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";" - -{- | -When a user views a view in the database (i.e. with \dv ), it is useful -to be able to read a description of the view. --} -commentOnView - :: ( KnownSymbol sch - , KnownSymbol vie - , Has sch db schema - , Has vie schema ('View view) - ) - => QualifiedAlias sch vie -- ^ view - -> Text -- ^ comment - -> Definition db db -commentOnView alias comm = UnsafeDefinition $ - "COMMENT ON VIEW" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";" - -{- | -When a user views an index in the database (i.e. with \di+ ), it is -useful to be able to read a description of the index. --} -commentOnIndex - :: ( KnownSymbol sch - , KnownSymbol ind - , Has sch db schema - , Has ind schema ('Index index) - ) - => QualifiedAlias sch ind -- ^ index - -> Text -- ^ comment - -> Definition db db -commentOnIndex alias comm = UnsafeDefinition $ - "COMMENT ON INDEX" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";" - -{- | -When a user views a function in the database (i.e. with \df+ ), it is -useful to be able to read a description of the function. --} -commentOnFunction - :: ( KnownSymbol sch - , KnownSymbol fun - , Has sch db schema - , Has fun schema ('Function function) - ) - => QualifiedAlias sch fun -- ^ function - -> Text -- ^ comment - -> Definition db db -commentOnFunction alias comm = UnsafeDefinition $ - "COMMENT ON FUNCTION" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";" - -{- | -When a user views a table in the database (i.e. with \d+
), it is useful -to be able to view descriptions of the columns in that table. --} -commentOnColumn - :: ( KnownSymbol sch - , KnownSymbol tab - , KnownSymbol col - , Has sch db schema - , Has tab schema ('Table '(cons, cols)) - , Has col cols '(def, nulltyp) - ) - => QualifiedAlias sch tab -- ^ table - -> Alias col -- ^ column - -> Text -- ^ comment - -> Definition db db -commentOnColumn table col comm = UnsafeDefinition $ - "COMMENT ON COLUMN" <+> renderSQL table <> "." <> renderSQL col <+> "IS" - <+> singleQuotedText comm <> ";" - -{- | -When a user views a schema in the database (i.e. with \dn+ ), it is -useful to be able to read a description. --} -commentOnSchema - :: ( KnownSymbol sch - , Has sch db schema - ) - => Alias sch -- ^ schema - -> Text -- ^ comment - -> Definition db db -commentOnSchema schema comm = UnsafeDefinition $ - "COMMENT ON SCHEMA" <+> renderSQL schema <> "IS" <+> singleQuotedText comm <> ";" diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition/Constraint.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition/Constraint.hs deleted file mode 100644 index 173cd5ca..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition/Constraint.hs +++ /dev/null @@ -1,351 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Definition.Constraint -Description: constraint expressions -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -constraint expressions --} - -{-# LANGUAGE - AllowAmbiguousTypes - , ConstraintKinds - , DeriveAnyClass - , DeriveGeneric - , DerivingStrategies - , FlexibleContexts - , FlexibleInstances - , GADTs - , LambdaCase - , MultiParamTypeClasses - , OverloadedLabels - , OverloadedStrings - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeInType - , TypeOperators - , UndecidableSuperClasses -#-} - -module Squeal.PostgreSQL.Definition.Constraint - ( -- * Table Constraints - TableConstraintExpression (..) - , check - , unique - , primaryKey - -- ** Foreign Keys - , foreignKey - , ForeignKeyed - , OnDeleteClause (..) - , OnUpdateClause (..) - , ReferentialAction (..) - ) where - -import Control.DeepSeq -import Data.ByteString -import GHC.TypeLits - -import qualified Generics.SOP as SOP -import qualified GHC.Generics as GHC - -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Expression.Logic -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL - --- | Data types are a way to limit the kind of data that can be stored in a --- table. For many applications, however, the constraint they provide is --- too coarse. For example, a column containing a product price should --- probably only accept positive values. But there is no standard data type --- that accepts only positive numbers. Another issue is that you might want --- to constrain column data with respect to other columns or rows. --- For example, in a table containing product information, --- there should be only one row for each product number. --- `TableConstraint`s give you as much control over the data in your tables --- as you wish. If a user attempts to store data in a column that would --- violate a constraint, an error is raised. This applies --- even if the value came from the default value definition. -newtype TableConstraintExpression - (sch :: Symbol) - (tab :: Symbol) - (db :: SchemasType) - (constraint :: TableConstraint) - = UnsafeTableConstraintExpression - { renderTableConstraintExpression :: ByteString } - deriving (GHC.Generic,Show,Eq,Ord,NFData) -instance RenderSQL - (TableConstraintExpression sch tab db constraint) where - renderSQL = renderTableConstraintExpression - -{-| A `check` constraint is the most generic `TableConstraint` type. -It allows you to specify that the value in a certain column must satisfy -a Boolean (truth-value) expression. - ->>> :{ -type Schema = '[ - "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[ - "a" ::: 'NoDef :=> 'NotNull 'PGint4, - "b" ::: 'NoDef :=> 'NotNull 'PGint4 - ])] -:} - ->>> :{ -let - definition :: Definition (Public '[]) (Public Schema) - definition = createTable #tab - ( (int & notNullable) `as` #a :* - (int & notNullable) `as` #b ) - ( check (#a :* #b) (#a .> #b) `as` #inequality ) -:} - ->>> printSQL definition -CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b"))); --} -check - :: ( Has sch db schema - , Has tab schema ('Table table) - , HasAll aliases (TableToRow table) subcolumns ) - => NP Alias aliases - -- ^ specify the subcolumns which are getting checked - -> (forall t. Condition 'Ungrouped '[] '[] db '[] '[t ::: subcolumns]) - -- ^ a closed `Condition` on those subcolumns - -> TableConstraintExpression sch tab db ('Check aliases) -check _cols condition = UnsafeTableConstraintExpression $ - "CHECK" <+> parenthesized (renderSQL condition) - -{-| A `unique` constraint ensure that the data contained in a column, -or a group of columns, is unique among all the rows in the table. - ->>> :{ -type Schema = '[ - "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[ - "a" ::: 'NoDef :=> 'Null 'PGint4, - "b" ::: 'NoDef :=> 'Null 'PGint4 - ])] -:} - ->>> :{ -let - definition :: Definition (Public '[]) (Public Schema) - definition = createTable #tab - ( (int & nullable) `as` #a :* - (int & nullable) `as` #b ) - ( unique (#a :* #b) `as` #uq_a_b ) -:} - ->>> printSQL definition -CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b")); --} -unique - :: ( Has sch db schema - , Has tab schema ('Table table) - , HasAll aliases (TableToRow table) subcolumns ) - => NP Alias aliases - -- ^ specify subcolumns which together are unique for each row - -> TableConstraintExpression sch tab db ('Unique aliases) -unique columns = UnsafeTableConstraintExpression $ - "UNIQUE" <+> parenthesized (renderSQL columns) - -{-| A `primaryKey` constraint indicates that a column, or group of columns, -can be used as a unique identifier for rows in the table. -This requires that the values be both unique and not null. - ->>> :{ -type Schema = '[ - "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[ - "id" ::: 'Def :=> 'NotNull 'PGint4, - "name" ::: 'NoDef :=> 'NotNull 'PGtext - ])] -:} - ->>> :{ -let - definition :: Definition (Public '[]) (Public Schema) - definition = createTable #tab - ( serial `as` #id :* - (text & notNullable) `as` #name ) - ( primaryKey #id `as` #pk_id ) -:} - ->>> printSQL definition -CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id")); --} -primaryKey - :: ( Has sch db schema - , Has tab schema ('Table table) - , HasAll aliases (TableToColumns table) subcolumns - , AllNotNull subcolumns ) - => NP Alias aliases - -- ^ specify the subcolumns which together form a primary key. - -> TableConstraintExpression sch tab db ('PrimaryKey aliases) -primaryKey columns = UnsafeTableConstraintExpression $ - "PRIMARY KEY" <+> parenthesized (renderSQL columns) - -{-| A `foreignKey` specifies that the values in a column -(or a group of columns) must match the values appearing in some row of -another table. We say this maintains the referential integrity -between two related tables. - ->>> :{ -type Schema = - '[ "users" ::: 'Table ( - '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "name" ::: 'NoDef :=> 'NotNull 'PGtext - ]) - , "emails" ::: 'Table ( - '[ "pk_emails" ::: 'PrimaryKey '["id"] - , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"] - ] :=> - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 - , "email" ::: 'NoDef :=> 'Null 'PGtext - ]) - ] -:} - ->>> :{ -let - setup :: Definition (Public '[]) (Public Schema) - setup = - createTable #users - ( serial `as` #id :* - (text & notNullable) `as` #name ) - ( primaryKey #id `as` #pk_users ) >>> - createTable #emails - ( serial `as` #id :* - (int & notNullable) `as` #user_id :* - (text & nullable) `as` #email ) - ( primaryKey #id `as` #pk_emails :* - foreignKey #user_id #users #id - (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_user_id ) -in printSQL setup -:} -CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id")); -CREATE TABLE "emails" ("id" serial, "user_id" int NOT NULL, "email" text NULL, CONSTRAINT "pk_emails" PRIMARY KEY ("id"), CONSTRAINT "fk_user_id" FOREIGN KEY ("user_id") REFERENCES "users" ("id") ON DELETE CASCADE ON UPDATE CASCADE); - -A `foreignKey` can even be a table self-reference. - ->>> :{ -type Schema = - '[ "employees" ::: 'Table ( - '[ "employees_pk" ::: 'PrimaryKey '["id"] - , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "public" "employees" '["id"] - ] :=> - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "name" ::: 'NoDef :=> 'NotNull 'PGtext - , "employer_id" ::: 'NoDef :=> 'Null 'PGint4 - ]) - ] -:} - ->>> :{ -let - setup :: Definition (Public '[]) (Public Schema) - setup = - createTable #employees - ( serial `as` #id :* - (text & notNullable) `as` #name :* - (integer & nullable) `as` #employer_id ) - ( primaryKey #id `as` #employees_pk :* - foreignKey #employer_id #employees #id - (OnDelete Cascade) (OnUpdate Cascade) `as` #employees_employer_fk ) -in printSQL setup -:} -CREATE TABLE "employees" ("id" serial, "name" text NOT NULL, "employer_id" integer NULL, CONSTRAINT "employees_pk" PRIMARY KEY ("id"), CONSTRAINT "employees_employer_fk" FOREIGN KEY ("employer_id") REFERENCES "employees" ("id") ON DELETE CASCADE ON UPDATE CASCADE); --} -foreignKey - :: (ForeignKeyed db - sch0 sch1 - schema0 schema1 - child parent - table reftable - columns refcolumns - constraints cols - reftys tys ) - => NP Alias columns - -- ^ column or columns in the table - -> QualifiedAlias sch0 parent - -- ^ reference table - -> NP Alias refcolumns - -- ^ reference column or columns in the reference table - -> OnDeleteClause - -- ^ what to do when reference is deleted - -> OnUpdateClause - -- ^ what to do when reference is updated - -> TableConstraintExpression sch1 child db - ('ForeignKey columns sch0 parent refcolumns) -foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $ - "FOREIGN KEY" <+> parenthesized (renderSQL keys) - <+> "REFERENCES" <+> renderSQL parent - <+> parenthesized (renderSQL refs) - <+> renderSQL ondel - <+> renderSQL onupd - --- | A constraint synonym between types involved in a foreign key constraint. -type ForeignKeyed db - sch0 sch1 - schema0 schema1 - child parent - table reftable - columns refcolumns - constraints cols - reftys tys = - ( Has sch0 db schema0 - , Has sch1 db schema1 - , Has parent schema0 ('Table reftable) - , Has child schema1 ('Table table) - , HasAll columns (TableToColumns table) tys - , reftable ~ (constraints :=> cols) - , HasAll refcolumns cols reftys - , SOP.AllZip SamePGType tys reftys - , Uniquely refcolumns constraints ) - --- | `OnDeleteClause` indicates what to do with rows that reference a deleted row. -newtype OnDeleteClause = OnDelete ReferentialAction - deriving (GHC.Generic,Show,Eq,Ord) -instance NFData OnDeleteClause -instance RenderSQL OnDeleteClause where - renderSQL (OnDelete action) = "ON DELETE" <+> renderSQL action - --- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked --- when a referenced column is changed (updated). -newtype OnUpdateClause = OnUpdate ReferentialAction - deriving (GHC.Generic,Show,Eq,Ord) -instance NFData OnUpdateClause -instance RenderSQL OnUpdateClause where - renderSQL (OnUpdate action) = "ON UPDATE" <+> renderSQL action - -{- | When the data in the referenced columns is changed, -certain actions are performed on the data in this table's columns.-} -data ReferentialAction - = NoAction - {- ^ Produce an error indicating that the deletion or update - would create a foreign key constraint violation. - If the constraint is deferred, this error will be produced - at constraint check time if there still exist any referencing rows.-} - | Restrict - {- ^ Produce an error indicating that the deletion or update - would create a foreign key constraint violation. - This is the same as `NoAction` except that the check is not deferrable.-} - | Cascade - {- ^ Delete any rows referencing the deleted row, - or update the value of the referencing column - to the new value of the referenced column, respectively.-} - | SetNull {- ^ Set the referencing column(s) to null.-} - | SetDefault {- ^ Set the referencing column(s) to their default values.-} - deriving (GHC.Generic,Show,Eq,Ord) -instance NFData ReferentialAction -instance RenderSQL ReferentialAction where - renderSQL = \case - NoAction -> "NO ACTION" - Restrict -> "RESTRICT" - Cascade -> "CASCADE" - SetNull -> "SET NULL" - SetDefault -> "SET DEFAULT" diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition/Function.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition/Function.hs deleted file mode 100644 index 90b4f80f..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition/Function.hs +++ /dev/null @@ -1,249 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Definition.Function -Description: create and drop functions -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -create and drop functions --} - -{-# LANGUAGE - AllowAmbiguousTypes - , ConstraintKinds - , DeriveAnyClass - , DeriveGeneric - , DerivingStrategies - , FlexibleContexts - , FlexibleInstances - , GADTs - , LambdaCase - , MultiParamTypeClasses - , OverloadedLabels - , OverloadedStrings - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeInType - , TypeOperators - , UndecidableSuperClasses -#-} - -module Squeal.PostgreSQL.Definition.Function - ( -- * Create - createFunction - , createOrReplaceFunction - , createSetFunction - , createOrReplaceSetFunction - -- * Drop - , dropFunction - , dropFunctionIfExists - -- * Function Definition - , FunctionDefinition(..) - , languageSqlExpr - , languageSqlQuery - ) where - -import Control.DeepSeq -import Data.ByteString -import GHC.TypeLits - -import qualified Generics.SOP as SOP -import qualified GHC.Generics as GHC - -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Definition -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Expression.Type -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Query -import Squeal.PostgreSQL.Query.Values -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL - -{- | Create a function. - ->>> type Fn = 'Function ( '[ 'Null 'PGint4, 'Null 'PGint4] :=> 'Returns ( 'Null 'PGint4)) ->>> :{ -let - definition :: Definition (Public '[]) (Public '["fn" ::: Fn]) - definition = createFunction #fn (int4 *: int4) int4 $ - languageSqlExpr (param @1 * param @2 + 1) -in printSQL definition -:} -CREATE FUNCTION "fn" (int4, int4) RETURNS int4 language sql as $$ SELECT * FROM (VALUES (((($1 :: int4) * ($2 :: int4)) + (1 :: int4)))) AS t ("ret") $$; --} -createFunction - :: ( Has sch db schema - , KnownSymbol fun - , SOP.SListI args ) - => QualifiedAlias sch fun -- ^ function alias - -> NP (TypeExpression db) args -- ^ arguments - -> TypeExpression db ret -- ^ return type - -> FunctionDefinition db args ('Returns ret) -- ^ function definition - -> Definition db (Alter sch (Create fun ('Function (args :=> 'Returns ret)) schema) db) -createFunction fun args ret fundef = UnsafeDefinition $ - "CREATE" <+> "FUNCTION" <+> renderSQL fun - <+> parenthesized (renderCommaSeparated renderSQL args) - <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";" - -{- | Create or replace a function. -It is not possible to change the name or argument types -or return type of a function this way. - ->>> type Fn = 'Function ( '[ 'Null 'PGint4, 'Null 'PGint4] :=> 'Returns ( 'Null 'PGint4)) ->>> :{ -let - definition :: Definition (Public '["fn" ::: Fn]) (Public '["fn" ::: Fn]) - definition = - createOrReplaceFunction #fn - (int4 *: int4) int4 $ - languageSqlExpr (param @1 @('Null 'PGint4) * param @2 @('Null 'PGint4) + 1) -in printSQL definition -:} -CREATE OR REPLACE FUNCTION "fn" (int4, int4) RETURNS int4 language sql as $$ SELECT * FROM (VALUES (((($1 :: int4) * ($2 :: int4)) + (1 :: int4)))) AS t ("ret") $$; --} -createOrReplaceFunction - :: ( Has sch db schema - , KnownSymbol fun - , SOP.SListI args ) - => QualifiedAlias sch fun -- ^ function alias - -> NP (TypeExpression db) args -- ^ arguments - -> TypeExpression db ret -- ^ return type - -> FunctionDefinition db args ('Returns ret) -- ^ function definition - -> Definition db (Alter sch (CreateOrReplace fun ('Function (args :=> 'Returns ret)) schema) db) -createOrReplaceFunction fun args ret fundef = UnsafeDefinition $ - "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun - <+> parenthesized (renderCommaSeparated renderSQL args) - <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";" - --- | Use a parameterized `Expression` as a function body -languageSqlExpr - :: Expression 'Ungrouped '[] '[] db args '[] ret - -- ^ function body - -> FunctionDefinition db args ('Returns ret) -languageSqlExpr expr = UnsafeFunctionDefinition $ - "language sql as" - <+> "$$" <+> renderSQL (values_ (expr `as` #ret)) <+> "$$" - --- | Use a parametrized `Query` as a function body -languageSqlQuery - :: Query '[] '[] db args rets - -- ^ function body - -> FunctionDefinition db args ('ReturnsTable rets) -languageSqlQuery qry = UnsafeFunctionDefinition $ - "language sql as" <+> "$$" <+> renderSQL qry <+> "$$" - -{- | Create a set function. - ->>> type Tab = 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]) ->>> type Fn = 'Function ('[ 'Null 'PGint4, 'Null 'PGint4] :=> 'ReturnsTable '["ret" ::: 'Null 'PGint4]) ->>> :{ -let - definition :: Definition (Public '["tab" ::: Tab]) (Public '["tab" ::: Tab, "fn" ::: Fn]) - definition = createSetFunction #fn (int4 *: int4) (int4 `as` #ret) $ - languageSqlQuery (select_ ((param @1 * param @2 + #col) `as` #ret) (from (table #tab))) -in printSQL definition -:} -CREATE FUNCTION "fn" (int4, int4) RETURNS TABLE ("ret" int4) language sql as $$ SELECT ((($1 :: int4) * ($2 :: int4)) + "col") AS "ret" FROM "tab" AS "tab" $$; --} -createSetFunction - :: ( Has sch db schema - , KnownSymbol fun - , SOP.SListI args - , SOP.SListI rets ) - => QualifiedAlias sch fun -- ^ function alias - -> NP (TypeExpression db) args -- ^ arguments - -> NP (Aliased (TypeExpression db)) rets -- ^ return type - -> FunctionDefinition db args ('ReturnsTable rets) -- ^ function definition - -> Definition db (Alter sch (Create fun ('Function (args :=> 'ReturnsTable rets)) schema) db) -createSetFunction fun args rets fundef = UnsafeDefinition $ - "CREATE" <+> "FUNCTION" <+> renderSQL fun - <+> parenthesized (renderCommaSeparated renderSQL args) - <+> "RETURNS" <+> "TABLE" - <+> parenthesized (renderCommaSeparated renderRet rets) - <+> renderSQL fundef <> ";" - where - renderRet :: Aliased (TypeExpression s) r -> ByteString - renderRet (ty `As` col) = renderSQL col <+> renderSQL ty - -{- | Create or replace a set function. - ->>> type Tab = 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]) ->>> type Fn = 'Function ('[ 'Null 'PGint4, 'Null 'PGint4] :=> 'ReturnsTable '["ret" ::: 'Null 'PGint4]) ->>> :{ -let - definition :: Definition (Public '["tab" ::: Tab, "fn" ::: Fn]) (Public '["tab" ::: Tab, "fn" ::: Fn]) - definition = createOrReplaceSetFunction #fn (int4 *: int4) (int4 `as` #ret) $ - languageSqlQuery (select_ ((param @1 * param @2 + #col) `as` #ret) (from (table #tab))) -in printSQL definition -:} -CREATE OR REPLACE FUNCTION "fn" (int4, int4) RETURNS TABLE ("ret" int4) language sql as $$ SELECT ((($1 :: int4) * ($2 :: int4)) + "col") AS "ret" FROM "tab" AS "tab" $$; --} -createOrReplaceSetFunction - :: ( Has sch db schema - , KnownSymbol fun - , SOP.SListI args - , SOP.SListI rets ) - => QualifiedAlias sch fun -- ^ function alias - -> NP (TypeExpression db) args -- ^ arguments - -> NP (Aliased (TypeExpression db)) rets -- ^ return type - -> FunctionDefinition db args ('ReturnsTable rets) -- ^ function definition - -> Definition db (Alter sch (CreateOrReplace fun ('Function (args :=> 'ReturnsTable rets)) schema) db) -createOrReplaceSetFunction fun args rets fundef = UnsafeDefinition $ - "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun - <+> parenthesized (renderCommaSeparated renderSQL args) - <+> "RETURNS" <+> "TABLE" - <+> parenthesized (renderCommaSeparated renderRet rets) - <+> renderSQL fundef <> ";" - where - renderRet :: Aliased (TypeExpression s) r -> ByteString - renderRet (ty `As` col) = renderSQL col <+> renderSQL ty - -{- | Drop a function. - ->>> type Fn = 'Function ( '[ 'Null 'PGint4, 'Null 'PGint4] :=> 'Returns ( 'Null 'PGint4)) ->>> :{ -let - definition :: Definition (Public '["fn" ::: Fn]) (Public '[]) - definition = dropFunction #fn -in printSQL definition -:} -DROP FUNCTION "fn"; --} -dropFunction - :: (Has sch db schema, KnownSymbol fun) - => QualifiedAlias sch fun - -- ^ function alias - -> Definition db (Alter sch (DropSchemum fun 'Function schema) db) -dropFunction fun = UnsafeDefinition $ - "DROP FUNCTION" <+> renderSQL fun <> ";" - -{- | Drop a function. - ->>> type Fn = 'Function ( '[ 'Null 'PGint4, 'Null 'PGint4] :=> 'Returns ( 'Null 'PGint4)) ->>> :{ -let - definition :: Definition (Public '[]) (Public '[]) - definition = dropFunctionIfExists #fn -in printSQL definition -:} -DROP FUNCTION IF EXISTS "fn"; --} -dropFunctionIfExists - :: (Has sch db schema, KnownSymbol fun) - => QualifiedAlias sch fun - -- ^ function alias - -> Definition db (Alter sch (DropSchemumIfExists fun 'Function schema) db) -dropFunctionIfExists fun = UnsafeDefinition $ - "DROP FUNCTION IF EXISTS" <+> renderSQL fun <> ";" - -{- | Body of a user defined function-} -newtype FunctionDefinition db args ret = UnsafeFunctionDefinition - { renderFunctionDefinition :: ByteString } - deriving (Eq,Show,GHC.Generic,NFData) -instance RenderSQL (FunctionDefinition db args ret) where - renderSQL = renderFunctionDefinition diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition/Index.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition/Index.hs deleted file mode 100644 index 68d80545..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition/Index.hs +++ /dev/null @@ -1,186 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Definition.Index -Description: create and drop indexes -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -create and drop indexes --} - -{-# LANGUAGE - AllowAmbiguousTypes - , ConstraintKinds - , DeriveAnyClass - , DeriveGeneric - , DerivingStrategies - , FlexibleContexts - , FlexibleInstances - , GADTs - , LambdaCase - , MultiParamTypeClasses - , OverloadedLabels - , OverloadedStrings - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeInType - , TypeOperators - , UndecidableSuperClasses -#-} - -module Squeal.PostgreSQL.Definition.Index - ( -- * Create - createIndex - , createIndexIfNotExists - -- * Drop - , dropIndex - , dropIndexIfExists - -- * Index Method - , IndexMethod (..) - , btree - , hash - , gist - , spgist - , gin - , brin - ) where - -import Data.ByteString -import GHC.TypeLits - -import qualified GHC.Generics as GHC - -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Definition -import Squeal.PostgreSQL.Expression.Sort -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL --- >>> :set -XPolyKinds - -{- | Create an index. - ->>> :{ -type Table = '[] :=> - '[ "a" ::: 'NoDef :=> 'Null 'PGint4 - , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ] -:} - ->>> :{ -let - setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table, "ix" ::: 'Index 'Btree]) - setup = - createTable #tab (nullable int `as` #a :* nullable real `as` #b) Nil >>> - createIndex #ix #tab btree [#a & AscNullsFirst, #b & AscNullsLast] -in printSQL setup -:} -CREATE TABLE "tab" ("a" int NULL, "b" real NULL); -CREATE INDEX "ix" ON "tab" USING btree (("a") ASC NULLS FIRST, ("b") ASC NULLS LAST); --} -createIndex - :: (Has sch db schema, Has tab schema ('Table table), KnownSymbol ix) - => Alias ix -- ^ index alias - -> QualifiedAlias sch tab -- ^ table alias - -> IndexMethod method -- ^ index method - -> [SortExpression 'Ungrouped '[] '[] db '[] '[tab ::: TableToRow table]] - -- ^ sorted columns - -> Definition db (Alter sch (Create ix ('Index method) schema) db) -createIndex ix tab method cols = UnsafeDefinition $ - "CREATE" <+> "INDEX" <+> renderSQL ix <+> "ON" <+> renderSQL tab - <+> "USING" <+> renderSQL method - <+> parenthesized (commaSeparated (renderIndex <$> cols)) - <> ";" - where - renderIndex = \case - Asc expression -> parenthesized (renderSQL expression) <+> "ASC" - Desc expression -> parenthesized (renderSQL expression) <+> "DESC" - AscNullsFirst expression -> parenthesized (renderSQL expression) - <+> "ASC NULLS FIRST" - DescNullsFirst expression -> parenthesized (renderSQL expression) - <+> "DESC NULLS FIRST" - AscNullsLast expression -> parenthesized (renderSQL expression) - <+> "ASC NULLS LAST" - DescNullsLast expression -> parenthesized (renderSQL expression) - <+> "DESC NULLS LAST" - --- | Create an index if it doesn't exist. -createIndexIfNotExists - :: (Has sch db schema, Has tab schema ('Table table), KnownSymbol ix) - => Alias ix -- ^ index alias - -> QualifiedAlias sch tab -- ^ table alias - -> IndexMethod method -- ^ index method - -> [SortExpression 'Ungrouped '[] '[] db '[] '[tab ::: TableToRow table]] - -- ^ sorted columns - -> Definition db (Alter sch (CreateIfNotExists ix ('Index method) schema) db) -createIndexIfNotExists ix tab method cols = UnsafeDefinition $ - "CREATE INDEX IF NOT EXISTS" <+> renderSQL ix <+> "ON" <+> renderSQL tab - <+> "USING" <+> renderSQL method - <+> parenthesized (commaSeparated (renderIndex <$> cols)) - <> ";" - where - renderIndex = \case - Asc expression -> parenthesized (renderSQL expression) <+> "ASC" - Desc expression -> parenthesized (renderSQL expression) <+> "DESC" - AscNullsFirst expression -> parenthesized (renderSQL expression) - <+> "ASC NULLS FIRST" - DescNullsFirst expression -> parenthesized (renderSQL expression) - <+> "DESC NULLS FIRST" - AscNullsLast expression -> parenthesized (renderSQL expression) - <+> "ASC NULLS LAST" - DescNullsLast expression -> parenthesized (renderSQL expression) - <+> "DESC NULLS LAST" - -{- | -PostgreSQL provides several index types: -B-tree, Hash, GiST, SP-GiST, GIN and BRIN. -Each index type uses a different algorithm -that is best suited to different types of queries. --} -newtype IndexMethod ty = UnsafeIndexMethod {renderIndexMethod :: ByteString} - deriving stock (Eq, Ord, Show, GHC.Generic) -instance RenderSQL (IndexMethod ty) where renderSQL = renderIndexMethod --- | B-trees can handle equality and range queries on data --- that can be sorted into some ordering. -btree :: IndexMethod 'Btree -btree = UnsafeIndexMethod "btree" --- | Hash indexes can only handle simple equality comparisons. -hash :: IndexMethod 'Hash -hash = UnsafeIndexMethod "hash" --- | GiST indexes are not a single kind of index, --- but rather an infrastructure within which many different --- indexing strategies can be implemented. -gist :: IndexMethod 'Gist -gist = UnsafeIndexMethod "gist" --- | SP-GiST indexes, like GiST indexes, --- offer an infrastructure that supports various kinds of searches. -spgist :: IndexMethod 'Spgist -spgist = UnsafeIndexMethod "spgist" --- | GIN indexes are “inverted indexes” which are appropriate for --- data values that contain multiple component values, such as arrays. -gin :: IndexMethod 'Gin -gin = UnsafeIndexMethod "gin" --- | BRIN indexes (a shorthand for Block Range INdexes) store summaries --- about the values stored in consecutive physical block ranges of a table. -brin :: IndexMethod 'Brin -brin = UnsafeIndexMethod "brin" - --- | Drop an index. --- --- >>> printSQL (dropIndex #ix :: Definition (Public '["ix" ::: 'Index 'Btree]) (Public '[])) --- DROP INDEX "ix"; -dropIndex - :: (Has sch db schema, KnownSymbol ix) - => QualifiedAlias sch ix -- ^ index alias - -> Definition db (Alter sch (DropSchemum ix 'Index schema) db) -dropIndex ix = UnsafeDefinition $ "DROP INDEX" <+> renderSQL ix <> ";" - --- | Drop an index if it exists. -dropIndexIfExists - :: (Has sch db schema, KnownSymbol ix) - => QualifiedAlias sch ix -- ^ index alias - -> Definition db (Alter sch (DropSchemumIfExists ix 'Index schema) db) -dropIndexIfExists ix = UnsafeDefinition $ - "DROP INDEX IF EXISTS" <+> renderSQL ix <> ";" diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition/Procedure.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition/Procedure.hs deleted file mode 100644 index a1d12bb0..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition/Procedure.hs +++ /dev/null @@ -1,171 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Definition.Procedure -Description: create and drop procedures -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -create and drop procedures --} - -{-# LANGUAGE - AllowAmbiguousTypes - , ConstraintKinds - , DeriveAnyClass - , DeriveGeneric - , DerivingStrategies - , FlexibleContexts - , FlexibleInstances - , GADTs - , LambdaCase - , MultiParamTypeClasses - , OverloadedLabels - , OverloadedStrings - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeInType - , TypeOperators - , UndecidableSuperClasses -#-} - -module Squeal.PostgreSQL.Definition.Procedure - ( -- * Create - createProcedure - , createOrReplaceProcedure - -- * Drop - , dropProcedure - , dropProcedureIfExists - -- * Procedure Definition - , ProcedureDefinition(..) - , languageSqlManipulation - ) where - -import Control.DeepSeq -import Data.ByteString -import GHC.TypeLits - -import qualified Generics.SOP as SOP -import qualified GHC.Generics as GHC - -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Definition -import Squeal.PostgreSQL.Expression.Type -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Manipulation -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL - -{- | Create a procedure. - ->>> type Proc = 'Procedure '[ 'NotNull 'PGint4 ] ->>> type Thing = 'Table ('[] :=> '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4 ]) ->>> :{ -let - definition :: Definition (Public '["things" ::: Thing ]) (Public '["things" ::: Thing, "proc" ::: Proc]) - definition = createProcedure #proc (one int4) - . languageSqlManipulation - $ [deleteFrom_ #things (#id .== param @1)] -in printSQL definition -:} -CREATE PROCEDURE "proc" (int4) language sql as $$ DELETE FROM "things" AS "things" WHERE ("id" = ($1 :: int4)); $$; --} -createProcedure - :: ( Has sch db schema - , KnownSymbol pro - , SOP.SListI args ) - => QualifiedAlias sch pro -- ^ procedure alias - -> NP (TypeExpression db) args -- ^ arguments - -> ProcedureDefinition db args -- ^ procedure definition - -> Definition db (Alter sch (Create pro ('Procedure args) schema) db) -createProcedure pro args prodef = UnsafeDefinition $ - "CREATE" <+> "PROCEDURE" <+> renderSQL pro - <+> parenthesized (renderCommaSeparated renderSQL args) - <+> renderSQL prodef <> ";" - -{- | Create or replace a procedure. -It is not possible to change the name or argument types -of a procedure this way. - ->>> type Proc = 'Procedure '[ 'NotNull 'PGint4 ] ->>> type Thing = 'Table ('[] :=> '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4 ]) ->>> :{ -let - definition :: Definition (Public '["things" ::: Thing ]) (Public '["things" ::: Thing, "proc" ::: Proc]) - definition = createOrReplaceProcedure #proc (one int4) - . languageSqlManipulation - $ [deleteFrom_ #things (#id .== param @1)] -in printSQL definition -:} -CREATE OR REPLACE PROCEDURE "proc" (int4) language sql as $$ DELETE FROM "things" AS "things" WHERE ("id" = ($1 :: int4)); $$; --} -createOrReplaceProcedure - :: ( Has sch db schema - , KnownSymbol pro - , SOP.SListI args ) - => QualifiedAlias sch pro -- ^ procedure alias - -> NP (TypeExpression db) args -- ^ arguments - -> ProcedureDefinition db args -- ^ procedure definition - -> Definition db (Alter sch (CreateOrReplace pro ('Procedure args) schema) db) -createOrReplaceProcedure pro args prodef = UnsafeDefinition $ - "CREATE" <+> "OR" <+> "REPLACE" <+> "PROCEDURE" <+> renderSQL pro - <+> parenthesized (renderCommaSeparated renderSQL args) - <+> renderSQL prodef <> ";" - --- | Use a parameterized `Manipulation` as a procedure body -languageSqlManipulation - :: [Manipulation '[] db args '[]] - -- ^ procedure body - -> ProcedureDefinition db args -languageSqlManipulation mnps = UnsafeProcedureDefinition $ - "language sql as" <+> "$$" <+> Prelude.foldr (<+>) "" (Prelude.map ((<> ";") . renderSQL) mnps) <> "$$" - --- | - -{- | Drop a procedure. - ->>> type Proc = 'Procedure '[ 'Null 'PGint4, 'Null 'PGint4] ->>> :{ -let - definition :: Definition (Public '["proc" ::: Proc]) (Public '[]) - definition = dropProcedure #proc -in printSQL definition -:} -DROP PROCEDURE "proc"; --} -dropProcedure - :: (Has sch db schema, KnownSymbol pro) - => QualifiedAlias sch pro - -- ^ procedure alias - -> Definition db (Alter sch (DropSchemum pro 'Procedure schema) db) -dropProcedure pro = UnsafeDefinition $ - "DROP PROCEDURE" <+> renderSQL pro <> ";" - -{- | Drop a procedure. - ->>> type Proc = 'Procedure '[ 'Null 'PGint4, 'Null 'PGint4 ] ->>> :{ -let - definition :: Definition (Public '[]) (Public '[]) - definition = dropProcedureIfExists #proc -in printSQL definition -:} -DROP PROCEDURE IF EXISTS "proc"; --} -dropProcedureIfExists - :: (Has sch db schema, KnownSymbol pro) - => QualifiedAlias sch pro - -- ^ procedure alias - -> Definition db (Alter sch (DropSchemumIfExists pro 'Procedure schema) db) -dropProcedureIfExists pro = UnsafeDefinition $ - "DROP PROCEDURE IF EXISTS" <+> renderSQL pro <> ";" - -{- | Body of a user defined procedure-} -newtype ProcedureDefinition db args = UnsafeProcedureDefinition - { renderProcedureDefinition :: ByteString } - deriving (Eq,Show,GHC.Generic,NFData) -instance RenderSQL (ProcedureDefinition db args) where - renderSQL = renderProcedureDefinition diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition/Schema.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition/Schema.hs deleted file mode 100644 index b04ff422..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition/Schema.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Definition.Schema -Description: create and drop schemas -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -create and drop schemas --} - -{-# LANGUAGE - AllowAmbiguousTypes - , ConstraintKinds - , DeriveAnyClass - , DeriveGeneric - , DerivingStrategies - , FlexibleContexts - , FlexibleInstances - , GADTs - , LambdaCase - , MultiParamTypeClasses - , OverloadedLabels - , OverloadedStrings - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeInType - , TypeOperators - , UndecidableSuperClasses -#-} - -module Squeal.PostgreSQL.Definition.Schema - ( -- * Create - createSchema - , createSchemaIfNotExists - -- * Drop - , dropSchemaCascade - , dropSchemaCascadeIfExists - ) where - -import GHC.TypeLits - -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Definition -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL - -{- | -`createSchema` enters a new schema into the current database. -The schema name must be distinct from the name of any existing schema -in the current database. - -A schema is essentially a namespace: it contains named objects -(tables, data types, functions, and operators) whose names -can duplicate those of other objects existing in other schemas. -Named objects are accessed by `QualifiedAlias`es with the schema -name as a prefix. - ->>> :{ -let - definition :: Definition '["public" ::: '[]] '["public" ::: '[], "my_schema" ::: '[]] - definition = createSchema #my_schema -in printSQL definition -:} -CREATE SCHEMA "my_schema"; --} -createSchema - :: KnownSymbol sch - => Alias sch -- ^ schema alias - -> Definition db (Create sch '[] db) -createSchema sch = UnsafeDefinition $ - "CREATE" <+> "SCHEMA" <+> renderSQL sch <> ";" - -{- | Create a schema if it does not yet exist.-} -createSchemaIfNotExists - :: (KnownSymbol sch, Has sch db schema) - => Alias sch -- ^ schema alias - -> Definition db (CreateIfNotExists sch '[] db) -createSchemaIfNotExists sch = UnsafeDefinition $ - "CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS" - <+> renderSQL sch <> ";" - --- | Drop a schema. --- Automatically drop objects (tables, functions, etc.) --- that are contained in the schema. --- --- >>> :{ --- let --- definition :: Definition '["muh_schema" ::: schema, "public" ::: public] '["public" ::: public] --- definition = dropSchemaCascade #muh_schema --- :} --- --- >>> printSQL definition --- DROP SCHEMA "muh_schema" CASCADE; -dropSchemaCascade - :: KnownSymbol sch - => Alias sch -- ^ schema alias - -> Definition db (Drop sch db) -dropSchemaCascade sch = UnsafeDefinition $ - "DROP SCHEMA" <+> renderSQL sch <+> "CASCADE;" - --- | Drop a schema if it exists. --- Automatically drop objects (tables, functions, etc.) --- that are contained in the schema. -dropSchemaCascadeIfExists - :: KnownSymbol sch - => Alias sch -- ^ schema alias - -> Definition db (DropIfExists sch db) -dropSchemaCascadeIfExists sch = UnsafeDefinition $ - "DROP SCHEMA IF EXISTS" <+> renderSQL sch <+> "CASCADE;" diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table.hs deleted file mode 100644 index f18fd1a9..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table.hs +++ /dev/null @@ -1,536 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Definition.Table -Description: create, drop and alter tables -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -create, drop and alter tables --} - -{-# LANGUAGE - AllowAmbiguousTypes - , ConstraintKinds - , DeriveAnyClass - , DeriveGeneric - , DerivingStrategies - , FlexibleContexts - , FlexibleInstances - , GADTs - , LambdaCase - , MultiParamTypeClasses - , OverloadedLabels - , OverloadedStrings - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeInType - , TypeOperators - , UndecidableSuperClasses -#-} - -module Squeal.PostgreSQL.Definition.Table - ( -- * Create - createTable - , createTableIfNotExists - -- * Drop - , dropTable - , dropTableIfExists - -- * Alter - , alterTable - , alterTableIfExists - , alterTableRename - , alterTableIfExistsRename - , alterTableSetSchema - , AlterTable (..) - -- ** Constraints - , addConstraint - , dropConstraint - -- ** Columns - , AddColumn (..) - , dropColumn - , renameColumn - , alterColumn - , AlterColumn (..) - , setDefault - , dropDefault - , setNotNull - , dropNotNull - , alterType - ) where - -import Control.DeepSeq -import Data.ByteString -import GHC.TypeLits - -import qualified Generics.SOP as SOP -import qualified GHC.Generics as GHC - -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Definition -import Squeal.PostgreSQL.Definition.Constraint -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Expression.Type -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL - -{- | `createTable` adds a table to the schema. - ->>> :set -XOverloadedLabels ->>> :{ -type Table = '[] :=> - '[ "a" ::: 'NoDef :=> 'Null 'PGint4 - , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ] -:} - ->>> :{ -let - setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table]) - setup = createTable #tab - (nullable int `as` #a :* nullable real `as` #b) Nil -in printSQL setup -:} -CREATE TABLE "tab" ("a" int NULL, "b" real NULL); --} -createTable - :: ( KnownSymbol sch - , KnownSymbol tab - , columns ~ (col ': cols) - , SOP.SListI columns - , SOP.SListI constraints - , Has sch db0 schema0 - , db1 ~ Alter sch (Create tab ('Table (constraints :=> columns)) schema0) db0 ) - => QualifiedAlias sch tab -- ^ the name of the table to add - -> NP (Aliased (ColumnTypeExpression db0)) columns - -- ^ the names and datatype of each column - -> NP (Aliased (TableConstraintExpression sch tab db1)) constraints - -- ^ constraints that must hold for the table - -> Definition db0 db1 -createTable tab columns constraints = UnsafeDefinition $ - "CREATE TABLE" <+> renderCreation tab columns constraints - -{-| `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema. -Instead, the schema already has the table so if the table did not yet exist, the schema was wrong. -`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in -the `Control.Category.Category` of `Definition`s. - ->>> :set -XOverloadedLabels -XTypeApplications ->>> :{ -type Table = '[] :=> - '[ "a" ::: 'NoDef :=> 'Null 'PGint4 - , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ] -:} - ->>> type Schemas = Public '["tab" ::: 'Table Table] - ->>> :{ -let - setup :: Definition Schemas Schemas - setup = createTableIfNotExists #tab - (nullable int `as` #a :* nullable real `as` #b) Nil -in printSQL setup -:} -CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL); --} -createTableIfNotExists - :: ( KnownSymbol sch - , KnownSymbol tab - , columns ~ (col ': cols) - , SOP.SListI columns - , SOP.SListI constraints - , Has sch db0 schema0 - , db1 ~ Alter sch (CreateIfNotExists tab ('Table (constraints :=> columns)) schema0) db0 ) - => QualifiedAlias sch tab -- ^ the name of the table to add - -> NP (Aliased (ColumnTypeExpression db0)) columns - -- ^ the names and datatype of each column - -> NP (Aliased (TableConstraintExpression sch tab db1)) constraints - -- ^ constraints that must hold for the table - -> Definition db0 db1 -createTableIfNotExists tab columns constraints = UnsafeDefinition $ - "CREATE TABLE IF NOT EXISTS" - <+> renderCreation tab columns constraints - --- helper function for `createTable` and `createTableIfNotExists` -renderCreation - :: ( KnownSymbol sch - , KnownSymbol tab - , SOP.SListI columns - , SOP.SListI constraints ) - => QualifiedAlias sch tab -- ^ the name of the table to add - -> NP (Aliased (ColumnTypeExpression db0)) columns - -- ^ the names and datatype of each column - -> NP (Aliased (TableConstraintExpression sch tab db1)) constraints - -- ^ constraints that must hold for the table - -> ByteString -renderCreation tab columns constraints = renderSQL tab - <+> parenthesized - ( renderCommaSeparated renderColumnDef columns - <> ( case constraints of - Nil -> "" - _ -> ", " <> - renderCommaSeparated renderConstraint constraints ) ) - <> ";" - where - renderColumnDef :: Aliased (ColumnTypeExpression db) x -> ByteString - renderColumnDef (ty `As` column) = - renderSQL column <+> renderColumnTypeExpression ty - renderConstraint - :: Aliased (TableConstraintExpression sch tab db) constraint - -> ByteString - renderConstraint (constraint `As` alias) = - "CONSTRAINT" <+> renderSQL alias <+> renderSQL constraint - --- | `dropTable` removes a table from the schema. --- --- >>> :{ --- let --- definition :: Definition '["public" ::: '["muh_table" ::: 'Table t]] (Public '[]) --- definition = dropTable #muh_table --- :} --- --- >>> printSQL definition --- DROP TABLE "muh_table"; -dropTable - :: ( Has sch db schema - , KnownSymbol tab ) - => QualifiedAlias sch tab -- ^ table to remove - -> Definition db (Alter sch (DropSchemum tab 'Table schema) db) -dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> ";" - --- | Drop a table if it exists. -dropTableIfExists - :: ( Has sch db schema - , KnownSymbol tab) - => QualifiedAlias sch tab -- ^ table to remove - -> Definition db (Alter sch (DropSchemumIfExists tab 'Table schema) db) -dropTableIfExists tab = UnsafeDefinition $ - "DROP TABLE IF EXISTS" <+> renderSQL tab <> ";" - --- | `alterTable` changes the definition of a table from the schema. -alterTable - :: (Has sch db schema, KnownSymbol tab) - => QualifiedAlias sch tab -- ^ table to alter - -> AlterTable sch tab db table -- ^ alteration to perform - -> Definition db (Alter sch (Alter tab ('Table table) schema) db) -alterTable tab alteration = UnsafeDefinition $ - "ALTER TABLE" - <+> renderSQL tab - <+> renderAlterTable alteration - <> ";" - --- | `alterTable` changes the definition of a table from the schema. -alterTableIfExists - :: (Has sch db schema, KnownSymbol tab) - => QualifiedAlias sch tab -- ^ table to alter - -> AlterTable sch tab db table -- ^ alteration to perform - -> Definition db (Alter sch (AlterIfExists tab ('Table table) schema) db) -alterTableIfExists tab alteration = UnsafeDefinition $ - "ALTER TABLE IF EXISTS" - <+> renderSQL tab - <+> renderAlterTable alteration - <> ";" - --- | `alterTableRename` changes the name of a table from the schema. --- --- >>> type Schemas = '[ "public" ::: '[ "foo" ::: 'Table ('[] :=> '[]) ] ] --- >>> :{ --- let migration :: Definition Schemas '["public" ::: '["bar" ::: 'Table ('[] :=> '[]) ] ] --- migration = alterTableRename #foo #bar --- in printSQL migration --- :} --- ALTER TABLE "foo" RENAME TO "bar"; -alterTableRename - :: ( Has sch db schema - , KnownSymbol tab1 - , Has tab0 schema ('Table table)) - => QualifiedAlias sch tab0 -- ^ table to rename - -> Alias tab1 -- ^ what to rename it - -> Definition db (Alter sch (Rename tab0 tab1 schema) db ) -alterTableRename tab0 tab1 = UnsafeDefinition $ - "ALTER TABLE" <+> renderSQL tab0 - <+> "RENAME TO" <+> renderSQL tab1 <> ";" - --- | `alterTableIfExistsRename` changes the name of a table from the schema if it exists. --- --- >>> type Schemas = '[ "public" ::: '[ "foo" ::: 'Table ('[] :=> '[]) ] ] --- >>> :{ --- let migration :: Definition Schemas Schemas --- migration = alterTableIfExistsRename #goo #gar --- in printSQL migration --- :} --- ALTER TABLE IF EXISTS "goo" RENAME TO "gar"; -alterTableIfExistsRename - :: ( Has sch db schema - , KnownSymbol tab0 - , KnownSymbol tab1 ) - => QualifiedAlias sch tab0 -- ^ table to rename - -> Alias tab1 -- ^ what to rename it - -> Definition db (Alter sch (RenameIfExists tab0 tab1 schema) db ) -alterTableIfExistsRename tab0 tab1 = UnsafeDefinition $ - "ALTER TABLE IF EXISTS" <+> renderSQL tab0 - <+> "RENAME TO" <+> renderSQL tab1 <> ";" - -{- | This form moves the table into another schema. - ->>> type DB0 = '[ "sch0" ::: '[ "tab" ::: 'Table ('[] :=> '[]) ], "sch1" ::: '[] ] ->>> type DB1 = '[ "sch0" ::: '[], "sch1" ::: '[ "tab" ::: 'Table ('[] :=> '[]) ] ] ->>> :{ -let def :: Definition DB0 DB1 - def = alterTableSetSchema (#sch0 ! #tab) #sch1 -in printSQL def -:} -ALTER TABLE "sch0"."tab" SET SCHEMA "sch1"; --} -alterTableSetSchema - :: ( Has sch0 db schema0 - , Has tab schema0 ('Table table) - , Has sch1 db schema1 ) - => QualifiedAlias sch0 tab -- ^ table to move - -> Alias sch1 -- ^ where to move it - -> Definition db (SetSchema sch0 sch1 schema0 schema1 tab 'Table table db) -alterTableSetSchema tab sch = UnsafeDefinition $ - "ALTER TABLE" <+> renderSQL tab <+> "SET SCHEMA" <+> renderSQL sch <> ";" - --- | An `AlterTable` describes the alteration to perform on the columns --- of a table. -newtype AlterTable - (sch :: Symbol) - (tab :: Symbol) - (db :: SchemasType) - (table :: TableType) = - UnsafeAlterTable {renderAlterTable :: ByteString} - deriving (GHC.Generic,Show,Eq,Ord,NFData) - --- | An `addConstraint` adds a table constraint. --- --- >>> :{ --- let --- definition :: Definition --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]] --- '["public" ::: '["tab" ::: 'Table ('["positive" ::: 'Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]] --- definition = alterTable #tab (addConstraint #positive (check #col (#col .> 0))) --- in printSQL definition --- :} --- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > (0 :: int4))); -addConstraint - :: ( KnownSymbol alias - , Has sch db schema - , Has tab schema ('Table (constraints :=> columns)) ) - => Alias alias - -> TableConstraintExpression sch tab db constraint - -- ^ constraint to add - -> AlterTable sch tab db (Create alias constraint constraints :=> columns) -addConstraint alias constraint = UnsafeAlterTable $ - "ADD" <+> "CONSTRAINT" <+> renderSQL alias - <+> renderSQL constraint - --- | A `dropConstraint` drops a table constraint. --- --- >>> :{ --- let --- definition :: Definition --- '["public" ::: '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]] --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]] --- definition = alterTable #tab (dropConstraint #positive) --- in printSQL definition --- :} --- ALTER TABLE "tab" DROP CONSTRAINT "positive"; -dropConstraint - :: ( KnownSymbol constraint - , Has sch db schema - , Has tab schema ('Table (constraints :=> columns)) ) - => Alias constraint - -- ^ constraint to drop - -> AlterTable sch tab db (Drop constraint constraints :=> columns) -dropConstraint constraint = UnsafeAlterTable $ - "DROP" <+> "CONSTRAINT" <+> renderSQL constraint - --- | An `AddColumn` is either @NULL@ or has @DEFAULT@. -class AddColumn ty where - -- | `addColumn` adds a new column, initially filled with whatever - -- default value is given or with @NULL@. - -- - -- >>> :{ - -- let - -- definition :: Definition - -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]] - -- '["public" ::: '["tab" ::: 'Table ('[] :=> - -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4 - -- , "col2" ::: 'Def :=> 'Null 'PGtext ])]] - -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo")) - -- in printSQL definition - -- :} - -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT (E'foo' :: text); - -- - -- >>> :{ - -- let - -- definition :: Definition - -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]] - -- '["public" ::: '["tab" ::: 'Table ('[] :=> - -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4 - -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]] - -- definition = alterTable #tab (addColumn #col2 (text & nullable)) - -- in printSQL definition - -- :} - -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL; - addColumn - :: ( KnownSymbol column - , Has sch db schema - , Has tab schema ('Table (constraints :=> columns)) ) - => Alias column -- ^ column to add - -> ColumnTypeExpression db ty -- ^ type of the new column - -> AlterTable sch tab db (constraints :=> Create column ty columns) - addColumn column ty = UnsafeAlterTable $ - "ADD COLUMN" <+> renderSQL column <+> renderColumnTypeExpression ty -instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty) -instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty) - --- | A `dropColumn` removes a column. Whatever data was in the column --- disappears. Table constraints involving the column are dropped, too. --- However, if the column is referenced by a foreign key constraint of --- another table, PostgreSQL will not silently drop that constraint. --- --- >>> :{ --- let --- definition :: Definition --- '["public" ::: '["tab" ::: 'Table ('[] :=> --- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4 --- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]] --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]] --- definition = alterTable #tab (dropColumn #col2) --- in printSQL definition --- :} --- ALTER TABLE "tab" DROP COLUMN "col2"; -dropColumn - :: ( KnownSymbol column - , Has sch db schema - , Has tab schema ('Table (constraints :=> columns)) ) - => Alias column -- ^ column to remove - -> AlterTable sch tab db (constraints :=> Drop column columns) -dropColumn column = UnsafeAlterTable $ - "DROP COLUMN" <+> renderSQL column - --- | A `renameColumn` renames a column. --- --- >>> :{ --- let --- definition :: Definition --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]] --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]] --- definition = alterTable #tab (renameColumn #foo #bar) --- in printSQL definition --- :} --- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar"; -renameColumn - :: ( KnownSymbol column0 - , KnownSymbol column1 - , Has sch db schema - , Has tab schema ('Table (constraints :=> columns)) ) - => Alias column0 -- ^ column to rename - -> Alias column1 -- ^ what to rename the column - -> AlterTable sch tab db (constraints :=> Rename column0 column1 columns) -renameColumn column0 column1 = UnsafeAlterTable $ - "RENAME COLUMN" <+> renderSQL column0 <+> "TO" <+> renderSQL column1 - --- | An `alterColumn` alters a single column. -alterColumn - :: ( KnownSymbol column - , Has sch db schema - , Has tab schema ('Table (constraints :=> columns)) - , Has column columns ty0 ) - => Alias column -- ^ column to alter - -> AlterColumn db ty0 ty1 -- ^ alteration to perform - -> AlterTable sch tab db (constraints :=> Alter column ty1 columns) -alterColumn column alteration = UnsafeAlterTable $ - "ALTER COLUMN" <+> renderSQL column <+> renderAlterColumn alteration - --- | An `AlterColumn` describes the alteration to perform on a single column. -newtype AlterColumn (db :: SchemasType) (ty0 :: ColumnType) (ty1 :: ColumnType) = - UnsafeAlterColumn {renderAlterColumn :: ByteString} - deriving (GHC.Generic,Show,Eq,Ord,NFData) - --- | A `setDefault` sets a new default for a column. Note that this doesn't --- affect any existing rows in the table, it just changes the default for --- future insert and update commands. --- --- >>> :{ --- let --- definition :: Definition --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]] --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]] --- definition = alterTable #tab (alterColumn #col (setDefault 5)) --- in printSQL definition --- :} --- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT (5 :: int4); -setDefault - :: Expression 'Ungrouped '[] '[] db '[] '[] ty -- ^ default value to set - -> AlterColumn db (constraint :=> ty) ('Def :=> ty) -setDefault expression = UnsafeAlterColumn $ - "SET DEFAULT" <+> renderExpression expression - --- | A `dropDefault` removes any default value for a column. --- --- >>> :{ --- let --- definition :: Definition --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]] --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]] --- definition = alterTable #tab (alterColumn #col dropDefault) --- in printSQL definition --- :} --- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT; -dropDefault :: AlterColumn db ('Def :=> ty) ('NoDef :=> ty) -dropDefault = UnsafeAlterColumn $ "DROP DEFAULT" - --- | A `setNotNull` adds a @NOT NULL@ constraint to a column. --- The constraint will be checked immediately, so the table data must satisfy --- the constraint before it can be added. --- --- >>> :{ --- let --- definition :: Definition --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]] --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]] --- definition = alterTable #tab (alterColumn #col setNotNull) --- in printSQL definition --- :} --- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL; -setNotNull - :: AlterColumn db (constraint :=> 'Null ty) (constraint :=> 'NotNull ty) -setNotNull = UnsafeAlterColumn $ "SET NOT NULL" - --- | A `dropNotNull` drops a @NOT NULL@ constraint from a column. --- --- >>> :{ --- let --- definition :: Definition --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]] --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]] --- definition = alterTable #tab (alterColumn #col dropNotNull) --- in printSQL definition --- :} --- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL; -dropNotNull - :: AlterColumn db (constraint :=> 'NotNull ty) (constraint :=> 'Null ty) -dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL" - --- | An `alterType` converts a column to a different data type. --- This will succeed only if each existing entry in the column can be --- converted to the new type by an implicit cast. --- --- >>> :{ --- let --- definition :: Definition --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]] --- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]] --- definition = --- alterTable #tab (alterColumn #col (alterType (numeric & notNullable))) --- in printSQL definition --- :} --- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL; -alterType :: ColumnTypeExpression db ty -> AlterColumn db ty0 ty -alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition/Type.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition/Type.hs deleted file mode 100644 index ee29254d..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition/Type.hs +++ /dev/null @@ -1,291 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Definition.Type -Description: create and drop types -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -create and drop types --} - -{-# LANGUAGE - AllowAmbiguousTypes - , ConstraintKinds - , DeriveAnyClass - , DeriveGeneric - , DerivingStrategies - , FlexibleContexts - , FlexibleInstances - , GADTs - , LambdaCase - , MultiParamTypeClasses - , OverloadedLabels - , OverloadedStrings - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeInType - , TypeOperators - , UndecidableSuperClasses -#-} - -module Squeal.PostgreSQL.Definition.Type - ( -- * Create - createTypeEnum - , createTypeEnumFrom - , createTypeComposite - , createTypeCompositeFrom - , createTypeRange - , createDomain - -- * Drop - , dropType - , dropTypeIfExists - -- * Alter - , alterTypeRename - , alterTypeSetSchema - ) where - -import Data.ByteString -import Data.Monoid -import GHC.TypeLits -import Prelude hiding ((.), id) - -import qualified Generics.SOP as SOP - -import Squeal.PostgreSQL.Expression.Logic -import Squeal.PostgreSQL.Expression.Type -import Squeal.PostgreSQL.Definition -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Type.PG -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL --- >>> import qualified GHC.Generics as GHC --- >>> import qualified Generics.SOP as SOP - --- | Enumerated types are created using the `createTypeEnum` command, for example --- --- >>> printSQL $ (createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy") :: Definition (Public '[]) '["public" ::: '["mood" ::: 'Typedef ('PGenum '["sad","ok","happy"])]]) --- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy'); -createTypeEnum - :: (KnownSymbol enum, Has sch db schema, SOP.All KnownSymbol labels) - => QualifiedAlias sch enum - -- ^ name of the user defined enumerated type - -> NP PGlabel labels - -- ^ labels of the enumerated type - -> Definition db (Alter sch (Create enum ('Typedef ('PGenum labels)) schema) db) -createTypeEnum enum labels = UnsafeDefinition $ - "CREATE" <+> "TYPE" <+> renderSQL enum <+> "AS" <+> "ENUM" <+> - parenthesized (renderSQL labels) <> ";" - --- | Enumerated types can also be generated from a Haskell type, for example --- --- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic --- >>> instance SOP.Generic Schwarma --- >>> instance SOP.HasDatatypeInfo Schwarma --- >>> :{ --- let --- createSchwarma :: Definition (Public '[]) '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] --- createSchwarma = createTypeEnumFrom @Schwarma #schwarma --- in --- printSQL createSchwarma --- :} --- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken'); -createTypeEnumFrom - :: forall hask sch enum db schema. - ( SOP.Generic hask - , SOP.All KnownSymbol (LabelsPG hask) - , KnownSymbol enum - , Has sch db schema ) - => QualifiedAlias sch enum - -- ^ name of the user defined enumerated type - -> Definition db (Alter sch (Create enum ('Typedef (PG (Enumerated hask))) schema) db) -createTypeEnumFrom enum = createTypeEnum enum - (SOP.hpure label :: NP PGlabel (LabelsPG hask)) - -{- | `createTypeComposite` creates a composite type. The composite type is -specified by a list of attribute names and data types. - ->>> :{ -type PGcomplex = 'PGcomposite - '[ "real" ::: 'NotNull 'PGfloat8 - , "imaginary" ::: 'NotNull 'PGfloat8 ] -:} - ->>> :{ -let - setup :: Definition (Public '[]) '["public" ::: '["complex" ::: 'Typedef PGcomplex]] - setup = createTypeComposite #complex - (float8 `as` #real :* float8 `as` #imaginary) -in printSQL setup -:} -CREATE TYPE "complex" AS ("real" float8, "imaginary" float8); --} -createTypeComposite - :: (KnownSymbol ty, Has sch db schema, SOP.SListI fields) - => QualifiedAlias sch ty - -- ^ name of the user defined composite type - -> NP (Aliased (TypeExpression db)) fields - -- ^ list of attribute names and data types - -> Definition db (Alter sch (Create ty ('Typedef ('PGcomposite fields)) schema) db) -createTypeComposite ty fields = UnsafeDefinition $ - "CREATE" <+> "TYPE" <+> renderSQL ty <+> "AS" <+> parenthesized - (renderCommaSeparated renderField fields) <> ";" - where - renderField :: Aliased (TypeExpression db) x -> ByteString - renderField (typ `As` alias) = - renderSQL alias <+> renderSQL typ - --- | Composite types can also be generated from a Haskell type, for example --- --- >>> data Complex = Complex {real :: Double, imaginary :: Double} deriving GHC.Generic --- >>> instance SOP.Generic Complex --- >>> instance SOP.HasDatatypeInfo Complex --- >>> type Schema = '["complex" ::: 'Typedef (PG (Composite Complex))] --- >>> :{ --- let --- createComplex :: Definition (Public '[]) (Public Schema) --- createComplex = createTypeCompositeFrom @Complex #complex --- in --- printSQL createComplex --- :} --- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8); -createTypeCompositeFrom - :: forall hask sch ty db schema. - ( SOP.All (FieldTyped db) (RowPG hask) - , KnownSymbol ty - , Has sch db schema ) - => QualifiedAlias sch ty - -- ^ name of the user defined composite type - -> Definition db (Alter sch (Create ty ( 'Typedef (PG (Composite hask))) schema) db) -createTypeCompositeFrom ty = createTypeComposite ty - (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped db)) fieldtype - :: NP (Aliased (TypeExpression db)) (RowPG hask)) - -{-| -`createDomain` creates a new domain. A domain is essentially a data type -with constraints (restrictions on the allowed set of values). - -Domains are useful for abstracting common constraints on fields -into a single location for maintenance. For example, several tables might -contain email address columns, all requiring the same -`Squeal.PostgreSQL.Definition.Table.Constraint.check` constraint -to verify the address syntax. Define a domain rather than setting up -each table's constraint individually. - ->>> :{ -let - createPositive :: Definition (Public '[]) (Public '["positive" ::: 'Typedef 'PGfloat4]) - createPositive = createDomain #positive real (#value .> 0) -in printSQL createPositive -:} -CREATE DOMAIN "positive" AS real CHECK (("value" > (0.0 :: float4))); --} -createDomain - :: (Has sch db schema, KnownSymbol dom) - => QualifiedAlias sch dom -- ^ domain alias - -> (forall null. TypeExpression db (null ty)) -- ^ underlying type - -> (forall tab. Condition 'Ungrouped '[] '[] db '[] '[tab ::: '["value" ::: 'Null ty]]) - -- ^ constraint on type - -> Definition db (Alter sch (Create dom ('Typedef ty) schema) db) -createDomain dom ty condition = - UnsafeDefinition $ "CREATE DOMAIN" <+> renderSQL dom - <+> "AS" <+> renderTypeExpression ty - <+> "CHECK" <+> parenthesized (renderSQL condition) <> ";" - -{- | Range types are data types representing a range of values -of some element type (called the range's subtype). -The subtype must have a total order so that it is well-defined -whether element values are within, before, or after a range of values. - -Range types are useful because they represent many element values -in a single range value, and because concepts such as overlapping ranges -can be expressed clearly. -The use of time and date ranges for scheduling purposes -is the clearest example; but price ranges, -measurement ranges from an instrument, and so forth can also be useful. - ->>> :{ -let - createSmallIntRange :: Definition (Public '[]) (Public '["int2range" ::: 'Typedef ('PGrange 'PGint2)]) - createSmallIntRange = createTypeRange #int2range int2 -in printSQL createSmallIntRange -:} -CREATE TYPE "int2range" AS RANGE (subtype = int2); --} -createTypeRange - :: (Has sch db schema, KnownSymbol range) - => QualifiedAlias sch range -- ^ range alias - -> (forall null. TypeExpression db (null ty)) -- ^ underlying type - -> Definition db (Alter sch (Create range ('Typedef ('PGrange ty)) schema) db) -createTypeRange range ty = UnsafeDefinition $ - "CREATE" <+> "TYPE" <+> renderSQL range <+> "AS" <+> "RANGE" <+> - parenthesized ("subtype" <+> "=" <+> renderTypeExpression ty) <> ";" - --- | Drop a type. --- --- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic --- >>> instance SOP.Generic Schwarma --- >>> instance SOP.HasDatatypeInfo Schwarma --- >>> printSQL (dropType #schwarma :: Definition '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] (Public '[])) --- DROP TYPE "schwarma"; -dropType - :: (Has sch db schema, KnownSymbol td) - => QualifiedAlias sch td - -- ^ name of the user defined type - -> Definition db (Alter sch (DropSchemum td 'Typedef schema) db) -dropType tydef = UnsafeDefinition $ "DROP TYPE" <+> renderSQL tydef <> ";" - --- | Drop a type if it exists. -dropTypeIfExists - :: (Has sch db schema, KnownSymbol td) - => QualifiedAlias sch td - -- ^ name of the user defined type - -> Definition db (Alter sch (DropSchemumIfExists td 'Typedef schema) db) -dropTypeIfExists tydef = UnsafeDefinition $ - "DROP TYPE IF EXISTS" <+> renderSQL tydef <> ";" - --- | `alterTypeRename` changes the name of a type from the schema. --- --- >>> type DB = '[ "public" ::: '[ "foo" ::: 'Typedef 'PGbool ] ] --- >>> :{ --- let def :: Definition DB '["public" ::: '["bar" ::: 'Typedef 'PGbool ] ] --- def = alterTypeRename #foo #bar --- in printSQL def --- :} --- ALTER TYPE "foo" RENAME TO "bar"; -alterTypeRename - :: ( Has sch db schema - , KnownSymbol ty1 - , Has ty0 schema ('Typedef ty)) - => QualifiedAlias sch ty0 -- ^ type to rename - -> Alias ty1 -- ^ what to rename it - -> Definition db (Alter sch (Rename ty0 ty1 schema) db ) -alterTypeRename ty0 ty1 = UnsafeDefinition $ - "ALTER TYPE" <+> renderSQL ty0 - <+> "RENAME TO" <+> renderSQL ty1 <> ";" - -{- | This form moves the type into another schema. - ->>> type DB0 = '[ "sch0" ::: '[ "ty" ::: 'Typedef 'PGfloat8 ], "sch1" ::: '[] ] ->>> type DB1 = '[ "sch0" ::: '[], "sch1" ::: '[ "ty" ::: 'Typedef 'PGfloat8 ] ] ->>> :{ -let def :: Definition DB0 DB1 - def = alterTypeSetSchema (#sch0 ! #ty) #sch1 -in printSQL def -:} -ALTER TYPE "sch0"."ty" SET SCHEMA "sch1"; --} -alterTypeSetSchema - :: ( Has sch0 db schema0 - , Has ty schema0 ('Typedef td) - , Has sch1 db schema1 ) - => QualifiedAlias sch0 ty -- ^ type to move - -> Alias sch1 -- ^ where to move it - -> Definition db (SetSchema sch0 sch1 schema0 schema1 ty 'Typedef td db) -alterTypeSetSchema ty sch = UnsafeDefinition $ - "ALTER TYPE" <+> renderSQL ty <+> "SET SCHEMA" <+> renderSQL sch <> ";" diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Definition/View.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Definition/View.hs deleted file mode 100644 index 668b27cd..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Definition/View.hs +++ /dev/null @@ -1,179 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Definition.View -Description: create and drop views -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -create and drop views --} - -{-# LANGUAGE - AllowAmbiguousTypes - , ConstraintKinds - , DeriveAnyClass - , DeriveGeneric - , DerivingStrategies - , FlexibleContexts - , FlexibleInstances - , GADTs - , LambdaCase - , MultiParamTypeClasses - , OverloadedLabels - , OverloadedStrings - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeInType - , TypeOperators - , UndecidableSuperClasses -#-} - -module Squeal.PostgreSQL.Definition.View - ( -- * Create - createView - , createOrReplaceView - -- * Drop - , dropView - , dropViewIfExists - -- * Alter - , alterViewRename - , alterViewSetSchema - ) where - -import GHC.TypeLits - -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Definition -import Squeal.PostgreSQL.Query -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL - -{- | Create a view. - ->>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4] ->>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4] ->>> :{ -let - definition :: Definition - '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]] - '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]] - definition = - createView #bc (select_ (#b :* #c) (from (table #abc))) -in printSQL definition -:} -CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc"; --} -createView - :: (Has sch db schema, KnownSymbol vw) - => QualifiedAlias sch vw -- ^ the name of the view to add - -> Query '[] '[] db '[] view -- ^ query - -> Definition db (Alter sch (Create vw ('View view) schema) db) -createView alias query = UnsafeDefinition $ - "CREATE" <+> "VIEW" <+> renderSQL alias <+> "AS" - <+> renderQuery query <> ";" - -{- | Create or replace a view. - ->>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4] ->>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4] ->>> :{ -let - definition :: Definition - '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]] - '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]] - definition = - createOrReplaceView #bc (select_ (#b :* #c) (from (table #abc))) -in printSQL definition -:} -CREATE OR REPLACE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc"; --} -createOrReplaceView - :: (Has sch db schema, KnownSymbol vw) - => QualifiedAlias sch vw -- ^ the name of the view to add - -> Query '[] '[] db '[] view -- ^ query - -> Definition db (Alter sch (CreateOrReplace vw ('View view) schema) db) -createOrReplaceView alias query = UnsafeDefinition $ - "CREATE OR REPLACE VIEW" <+> renderSQL alias <+> "AS" - <+> renderQuery query <> ";" - --- | Drop a view. --- --- >>> :{ --- let --- definition :: Definition --- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]) --- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]] --- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]] --- definition = dropView #bc --- in printSQL definition --- :} --- DROP VIEW "bc"; -dropView - :: (Has sch db schema, KnownSymbol vw) - => QualifiedAlias sch vw -- ^ view to remove - -> Definition db (Alter sch (DropSchemum vw 'View schema) db) -dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderSQL vw <> ";" - --- | Drop a view if it exists. --- --- >>> :{ --- let --- definition :: Definition --- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]) --- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]] --- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]] --- definition = dropViewIfExists #bc --- in printSQL definition --- :} --- DROP VIEW IF EXISTS "bc"; -dropViewIfExists - :: (Has sch db schema, KnownSymbol vw) - => QualifiedAlias sch vw -- ^ view to remove - -> Definition db (Alter sch (DropIfExists vw schema) db) -dropViewIfExists vw = UnsafeDefinition $ - "DROP VIEW IF EXISTS" <+> renderSQL vw <> ";" - --- | `alterViewRename` changes the name of a view from the schema. --- --- >>> type DB = '[ "public" ::: '[ "foo" ::: 'View '[] ] ] --- >>> :{ --- let def :: Definition DB '["public" ::: '["bar" ::: 'View '[] ] ] --- def = alterViewRename #foo #bar --- in printSQL def --- :} --- ALTER VIEW "foo" RENAME TO "bar"; -alterViewRename - :: ( Has sch db schema - , KnownSymbol ty1 - , Has ty0 schema ('View vw)) - => QualifiedAlias sch ty0 -- ^ view to rename - -> Alias ty1 -- ^ what to rename it - -> Definition db (Alter sch (Rename ty0 ty1 schema) db ) -alterViewRename vw0 vw1 = UnsafeDefinition $ - "ALTER VIEW" <+> renderSQL vw0 - <+> "RENAME TO" <+> renderSQL vw1 <> ";" - -{- | This form moves the view into another schema. - ->>> type DB0 = '[ "sch0" ::: '[ "vw" ::: 'View '[] ], "sch1" ::: '[] ] ->>> type DB1 = '[ "sch0" ::: '[], "sch1" ::: '[ "vw" ::: 'View '[] ] ] ->>> :{ -let def :: Definition DB0 DB1 - def = alterViewSetSchema (#sch0 ! #vw) #sch1 -in printSQL def -:} -ALTER VIEW "sch0"."vw" SET SCHEMA "sch1"; --} -alterViewSetSchema - :: ( Has sch0 db schema0 - , Has vw schema0 ('View view) - , Has sch1 db schema1 ) - => QualifiedAlias sch0 vw -- ^ view to move - -> Alias sch1 -- ^ where to move it - -> Definition db (SetSchema sch0 sch1 schema0 schema1 vw 'View view db) -alterViewSetSchema ty sch = UnsafeDefinition $ - "ALTER VIEW" <+> renderSQL ty <+> "SET SCHEMA" <+> renderSQL sch <> ";" diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs deleted file mode 100644 index 8bcf8bfa..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs +++ /dev/null @@ -1,644 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Expression -Description: expressions -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -Expressions are the atoms used to build statements. --} - -{-# LANGUAGE - AllowAmbiguousTypes - , ConstraintKinds - , DeriveGeneric - , DerivingStrategies - , FlexibleContexts - , FlexibleInstances - , FunctionalDependencies - , GADTs - , GeneralizedNewtypeDeriving - , LambdaCase - , MagicHash - , OverloadedStrings - , ScopedTypeVariables - , StandaloneDeriving - , TypeApplications - , TypeFamilies - , TypeInType - , TypeOperators - , UndecidableInstances - , RankNTypes -#-} - -module Squeal.PostgreSQL.Expression - ( -- * Expression - Expression (..) - , Expr - -- * Function - , type (-->) - , Fun - , unsafeFunction - , function - , unsafeLeftOp - , unsafeRightOp - -- * Operator - , Operator - , OperatorDB - , unsafeBinaryOp - , PGSubset (..) - , PGIntersect (..) - -- * Multivariable Function - , FunctionVar - , unsafeFunctionVar - , type (--->) - , FunN - , unsafeFunctionN - , functionN - -- * Re-export - , (&) - ) where - -import Control.Category -import Control.DeepSeq -import Data.Binary.Builder (toLazyByteString) -import Data.ByteString (ByteString) -import Data.ByteString.Builder (doubleDec, floatDec, int16Dec, int32Dec, int64Dec) -import Data.ByteString.Builder.Scientific (scientificBuilder) -import Data.ByteString.Lazy (toStrict) -import Data.Function ((&)) -import Data.Semigroup hiding (All) -import Data.String -import Generics.SOP hiding (All, from) -import GHC.OverloadedLabels -import GHC.TypeLits -import Numeric -import Prelude hiding (id, (.)) - -import qualified GHC.Generics as GHC - -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL - -{----------------------------------------- -column expressions ------------------------------------------} - -{- | `Expression`s are used in a variety of contexts, -such as in the target `Squeal.PostgreSQL.Query.List` of the -`Squeal.PostgreSQL.Query.select` command, -as new column values in `Squeal.PostgreSQL.Manipulation.insertInto` or -`Squeal.PostgreSQL.Manipulation.update`, -or in search `Squeal.PostgreSQL.Expression.Logic.Condition`s -in a number of commands. - -The expression syntax allows the calculation of -values from primitive expression using arithmetic, logical, -and other operations. - -The type parameters of `Expression` are - -* @lat :: @ `FromType`, the @from@ clauses of any lat queries in which - the `Expression` is a correlated subquery expression; -* @with :: @ `FromType`, the `Squeal.PostgreSQL.Query.CommonTableExpression`s - that are in scope for the `Expression`; -* @grp :: @ `Grouping`, the `Grouping` of the @from@ clause which may limit - which columns may be referenced by alias; -* @db :: @ `SchemasType`, the schemas of your database that are in - scope for the `Expression`; -* @from :: @ `FromType`, the @from@ clause which the `Expression` may use - to reference columns by alias; -* @ty :: @ `NullType`, the type of the `Expression`. --} -newtype Expression - (grp :: Grouping) - (lat :: FromType) - (with :: FromType) - (db :: SchemasType) - (params :: [NullType]) - (from :: FromType) - (ty :: NullType) - = UnsafeExpression { renderExpression :: ByteString } - deriving stock (GHC.Generic,Show,Eq,Ord) - deriving newtype (NFData) -instance RenderSQL (Expression grp lat with db params from ty) where - renderSQL = renderExpression - --- | An `Expr` is a closed `Expression`. --- It is a F@RankNType@ but don't be scared. --- Think of it as an expression which sees no --- namespaces, so you can't use parameters --- or alias references. It can be used as --- a simple piece of more complex `Expression`s. -type Expr x - = forall grp lat with db params from - . Expression grp lat with db params from x - -- ^ cannot reference aliases - --- | A @RankNType@ for binary operators. -type Operator x1 x2 y = forall db. OperatorDB db x1 x2 y - --- | Like `Operator` but depends on the schemas of the database -type OperatorDB db x1 x2 y - = forall grp lat with params from - . Expression grp lat with db params from x1 - -- ^ left input - -> Expression grp lat with db params from x2 - -- ^ right input - -> Expression grp lat with db params from y - -- ^ output - --- | A @RankNType@ for functions with a single argument. --- These could be either function calls or unary operators. --- This is a subtype of the usual Haskell function type `Prelude.->`, --- indeed a subcategory as it is closed under the usual --- `Prelude..` and `Prelude.id`. -type (-->) x y = forall db. Fun db x y - --- | Like `-->` but depends on the schemas of the database -type Fun db x y - = forall grp lat with params from - . Expression grp lat with db params from x - -- ^ input - -> Expression grp lat with db params from y - -- ^ output - -{- | A @RankNType@ for functions with a fixed-length list of heterogeneous arguments. -Use the `*:` operator to end your argument lists, like so. - ->>> printSQL (unsafeFunctionN "fun" (true :* false :* localTime *: true)) -fun(TRUE, FALSE, LOCALTIME, TRUE) --} -type (--->) xs y = forall db. FunN db xs y - --- | Like `--->` but depends on the schemas of the database -type FunN db xs y - = forall grp lat with params from - . NP (Expression grp lat with db params from) xs - -- ^ inputs - -> Expression grp lat with db params from y - -- ^ output - -{- | A @RankNType@ for functions with a variable-length list of -homogeneous arguments and at least 1 more argument. --} -type FunctionVar x0 x1 y - = forall grp lat with db params from - . [Expression grp lat with db params from x0] - -- ^ inputs - -> Expression grp lat with db params from x1 - -- ^ must have at least 1 input - -> Expression grp lat with db params from y - -- ^ output - -{- | >>> printSQL (unsafeFunctionVar "greatest" [true, null_] false) -greatest(TRUE, NULL, FALSE) --} -unsafeFunctionVar :: ByteString -> FunctionVar x0 x1 y -unsafeFunctionVar fun xs x = UnsafeExpression $ fun <> parenthesized - (commaSeparated (renderSQL <$> xs) <> ", " <> renderSQL x) - -instance (HasUnique tab (Join from lat) row, Has col row ty) - => IsLabel col (Expression 'Ungrouped lat with db params from ty) where - fromLabel = UnsafeExpression $ renderSQL (Alias @col) -instance (HasUnique tab (Join from lat) row, Has col row ty, tys ~ '[ty]) - => IsLabel col (NP (Expression 'Ungrouped lat with db params from) tys) where - fromLabel = fromLabel @col :* Nil -instance (HasUnique tab (Join from lat) row, Has col row ty, column ~ (col ::: ty)) - => IsLabel col - (Aliased (Expression 'Ungrouped lat with db params from) column) where - fromLabel = fromLabel @col `As` Alias -instance (HasUnique tab (Join from lat) row, Has col row ty, columns ~ '[col ::: ty]) - => IsLabel col - (NP (Aliased (Expression 'Ungrouped lat with db params from)) columns) where - fromLabel = fromLabel @col :* Nil - -instance (Has tab (Join from lat) row, Has col row ty) - => IsQualified tab col (Expression 'Ungrouped lat with db params from ty) where - tab ! col = UnsafeExpression $ - renderSQL tab <> "." <> renderSQL col -instance (Has tab (Join from lat) row, Has col row ty, tys ~ '[ty]) - => IsQualified tab col (NP (Expression 'Ungrouped lat with db params from) tys) where - tab ! col = tab ! col :* Nil -instance (Has tab (Join from lat) row, Has col row ty, column ~ (col ::: ty)) - => IsQualified tab col - (Aliased (Expression 'Ungrouped lat with db params from) column) where - tab ! col = tab ! col `As` col -instance (Has tab (Join from lat) row, Has col row ty, columns ~ '[col ::: ty]) - => IsQualified tab col - (NP (Aliased (Expression 'Ungrouped lat with db params from)) columns) where - tab ! col = tab ! col :* Nil - -instance - ( HasUnique tab (Join from lat) row - , Has col row ty - , GroupedBy tab col bys - ) => IsLabel col - (Expression ('Grouped bys) lat with db params from ty) where - fromLabel = UnsafeExpression $ renderSQL (Alias @col) -instance - ( HasUnique tab (Join from lat) row - , Has col row ty - , GroupedBy tab col bys - , tys ~ '[ty] - ) => IsLabel col - (NP (Expression ('Grouped bys) lat with db params from) tys) where - fromLabel = fromLabel @col :* Nil -instance - ( HasUnique tab (Join from lat) row - , Has col row ty - , GroupedBy tab col bys - , column ~ (col ::: ty) - ) => IsLabel col - (Aliased (Expression ('Grouped bys) lat with db params from) column) where - fromLabel = fromLabel @col `As` Alias -instance - ( HasUnique tab (Join from lat) row - , Has col row ty - , GroupedBy tab col bys - , columns ~ '[col ::: ty] - ) => IsLabel col - (NP (Aliased (Expression ('Grouped bys) lat with db params from)) columns) where - fromLabel = fromLabel @col :* Nil - -instance - ( Has tab (Join from lat) row - , Has col row ty - , GroupedBy tab col bys - ) => IsQualified tab col - (Expression ('Grouped bys) lat with db params from ty) where - tab ! col = UnsafeExpression $ - renderSQL tab <> "." <> renderSQL col -instance - ( Has tab (Join from lat) row - , Has col row ty - , GroupedBy tab col bys - , tys ~ '[ty] - ) => IsQualified tab col - (NP (Expression ('Grouped bys) lat with db params from) tys) where - tab ! col = tab ! col :* Nil -instance - ( Has tab (Join from lat) row - , Has col row ty - , GroupedBy tab col bys - , column ~ (col ::: ty) - ) => IsQualified tab col - (Aliased (Expression ('Grouped bys) lat with db params from) column) where - tab ! col = tab ! col `As` col -instance - ( Has tab (Join from lat) row - , Has col row ty - , GroupedBy tab col bys - , columns ~ '[col ::: ty] - ) => IsQualified tab col - (NP (Aliased (Expression ('Grouped bys) lat with db params from)) columns) where - tab ! col = tab ! col :* Nil - -instance (KnownSymbol label, label `In` labels) => IsPGlabel label - (Expression grp lat with db params from (null ('PGenum labels))) where - label = UnsafeExpression $ renderSQL (PGlabel @label) - --- | >>> printSQL $ unsafeBinaryOp "OR" true false --- (TRUE OR FALSE) -unsafeBinaryOp :: ByteString -> Operator ty0 ty1 ty2 -unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $ - renderSQL x <+> op <+> renderSQL y - --- | >>> printSQL $ unsafeLeftOp "NOT" true --- (NOT TRUE) -unsafeLeftOp :: ByteString -> x --> y -unsafeLeftOp op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x - --- | >>> printSQL $ true & unsafeRightOp "IS NOT TRUE" --- (TRUE IS NOT TRUE) -unsafeRightOp :: ByteString -> x --> y -unsafeRightOp op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op - --- | >>> printSQL $ unsafeFunction "f" true --- f(TRUE) -unsafeFunction :: ByteString -> x --> y -unsafeFunction fun x = UnsafeExpression $ - fun <> parenthesized (renderSQL x) - -{- | Call a user defined function of a single variable - ->>> type Fn = '[ 'Null 'PGint4] :=> 'Returns ('NotNull 'PGnumeric) ->>> type Schema = '["fn" ::: 'Function Fn] ->>> :{ -let - fn :: Fun (Public Schema) ('Null 'PGint4) ('NotNull 'PGnumeric) - fn = function #fn -in - printSQL (fn 1) -:} -"fn"((1 :: int4)) --} -function - :: (Has sch db schema, Has fun schema ('Function ('[x] :=> 'Returns y))) - => QualifiedAlias sch fun -- ^ function name - -> Fun db x y -function = unsafeFunction . renderSQL - --- | >>> printSQL $ unsafeFunctionN "f" (currentTime :* localTimestamp :* false *: inline 'a') --- f(CURRENT_TIME, LOCALTIMESTAMP, FALSE, (E'a' :: char(1))) -unsafeFunctionN :: SListI xs => ByteString -> xs ---> y -unsafeFunctionN fun xs = UnsafeExpression $ - fun <> parenthesized (renderCommaSeparated renderSQL xs) - -{- | Call a user defined multivariable function - ->>> type Fn = '[ 'Null 'PGint4, 'Null 'PGbool] :=> 'Returns ('NotNull 'PGnumeric) ->>> type Schema = '["fn" ::: 'Function Fn] ->>> :{ -let - fn :: FunN (Public Schema) '[ 'Null 'PGint4, 'Null 'PGbool] ('NotNull 'PGnumeric) - fn = functionN #fn -in - printSQL (fn (1 *: true)) -:} -"fn"((1 :: int4), TRUE) --} -functionN - :: ( Has sch db schema - , Has fun schema ('Function (xs :=> 'Returns y)) - , SListI xs ) - => QualifiedAlias sch fun -- ^ function alias - -> FunN db xs y -functionN = unsafeFunctionN . renderSQL - -instance - Num (Expression grp lat with db params from (null 'PGint2)) where - (+) = unsafeBinaryOp "+" - (-) = unsafeBinaryOp "-" - (*) = unsafeBinaryOp "*" - abs = unsafeFunction "abs" - signum = unsafeFunction "sign" - fromInteger - = UnsafeExpression - . parenthesized - . (<> " :: int2") - . toStrict - . toLazyByteString - . int16Dec - . fromInteger -instance - Num (Expression grp lat with db params from (null 'PGint4)) where - (+) = unsafeBinaryOp "+" - (-) = unsafeBinaryOp "-" - (*) = unsafeBinaryOp "*" - abs = unsafeFunction "abs" - signum = unsafeFunction "sign" - fromInteger - = UnsafeExpression - . parenthesized - . (<> " :: int4") - . toStrict - . toLazyByteString - . int32Dec - . fromInteger -instance - Num (Expression grp lat with db params from (null 'PGint8)) where - (+) = unsafeBinaryOp "+" - (-) = unsafeBinaryOp "-" - (*) = unsafeBinaryOp "*" - abs = unsafeFunction "abs" - signum = unsafeFunction "sign" - fromInteger x = - let - y = fromInteger x - in - if y == minBound - -- For some reason Postgres throws an error with - -- (-9223372036854775808 :: int8) - -- even though it's a valid lowest value for int8 - then fromInteger (x+1) - 1 - else UnsafeExpression - . parenthesized - . (<> " :: int8") - . toStrict - . toLazyByteString - $ int64Dec y -instance - Num (Expression grp lat with db params from (null 'PGfloat4)) where - (+) = unsafeBinaryOp "+" - (-) = unsafeBinaryOp "-" - (*) = unsafeBinaryOp "*" - abs = unsafeFunction "abs" - signum = unsafeFunction "sign" - fromInteger x - = UnsafeExpression - . parenthesized - . (<> " :: float4") $ - let - y = fromInteger x - decimal = toStrict . toLazyByteString . floatDec - in - if isNaN y || isInfinite y - then singleQuotedUtf8 (decimal y) - else decimal y -instance - Num (Expression grp lat with db params from (null 'PGfloat8)) where - (+) = unsafeBinaryOp "+" - (-) = unsafeBinaryOp "-" - (*) = unsafeBinaryOp "*" - abs = unsafeFunction "abs" - signum = unsafeFunction "sign" - fromInteger x - = UnsafeExpression - . parenthesized - . (<> " :: float8") $ - let - y = fromInteger x - decimal = toStrict . toLazyByteString . doubleDec - in - if isNaN y || isInfinite y - then singleQuotedUtf8 (decimal y) - else decimal y -instance - Num (Expression grp lat with db params from (null 'PGnumeric)) where - (+) = unsafeBinaryOp "+" - (-) = unsafeBinaryOp "-" - (*) = unsafeBinaryOp "*" - abs = unsafeFunction "abs" - signum = unsafeFunction "sign" - fromInteger - = UnsafeExpression - . parenthesized - . (<> " :: numeric") - . toStrict - . toLazyByteString - . scientificBuilder - . fromInteger - -instance Fractional - (Expression grp lat with db params from (null 'PGfloat4)) where - (/) = unsafeBinaryOp "/" - fromRational x - = UnsafeExpression - . parenthesized - . (<> " :: float4") $ - let - y = fromRational x - decimal = toStrict . toLazyByteString . floatDec - in - if isNaN y || isInfinite y - then singleQuotedUtf8 (decimal y) - else decimal y -instance Fractional - (Expression grp lat with db params from (null 'PGfloat8)) where - (/) = unsafeBinaryOp "/" - fromRational x - = UnsafeExpression - . parenthesized - . (<> " :: float8") $ - let - y = fromRational x - decimal = toStrict . toLazyByteString . doubleDec - in - if isNaN y || isInfinite y - then singleQuotedUtf8 (decimal y) - else decimal y -instance Fractional - (Expression grp lat with db params from (null 'PGnumeric)) where - (/) = unsafeBinaryOp "/" - fromRational - = UnsafeExpression - . parenthesized - . (<> " :: numeric") - . toStrict - . toLazyByteString - . scientificBuilder - . fromRational - -instance Floating - (Expression grp lat with db params from (null 'PGfloat4)) where - pi = UnsafeExpression "pi()" - exp = unsafeFunction "exp" - log = unsafeFunction "ln" - sqrt = unsafeFunction "sqrt" - b ** x = UnsafeExpression $ - "power(" <> renderSQL b <> ", " <> renderSQL x <> ")" - logBase b y = log y / log b - sin = unsafeFunction "sin" - cos = unsafeFunction "cos" - tan = unsafeFunction "tan" - asin = unsafeFunction "asin" - acos = unsafeFunction "acos" - atan = unsafeFunction "atan" - sinh x = (exp x - exp (-x)) / 2 - cosh x = (exp x + exp (-x)) / 2 - tanh x = sinh x / cosh x - asinh x = log (x + sqrt (x*x + 1)) - acosh x = log (x + sqrt (x*x - 1)) - atanh x = log ((1 + x) / (1 - x)) / 2 -instance Floating - (Expression grp lat with db params from (null 'PGfloat8)) where - pi = UnsafeExpression "pi()" - exp = unsafeFunction "exp" - log = unsafeFunction "ln" - sqrt = unsafeFunction "sqrt" - b ** x = UnsafeExpression $ - "power(" <> renderSQL b <> ", " <> renderSQL x <> ")" - logBase b y = log y / log b - sin = unsafeFunction "sin" - cos = unsafeFunction "cos" - tan = unsafeFunction "tan" - asin = unsafeFunction "asin" - acos = unsafeFunction "acos" - atan = unsafeFunction "atan" - sinh x = (exp x - exp (-x)) / 2 - cosh x = (exp x + exp (-x)) / 2 - tanh x = sinh x / cosh x - asinh x = log (x + sqrt (x*x + 1)) - acosh x = log (x + sqrt (x*x - 1)) - atanh x = log ((1 + x) / (1 - x)) / 2 -instance Floating - (Expression grp lat with db params from (null 'PGnumeric)) where - pi = UnsafeExpression "pi()" - exp = unsafeFunction "exp" - log = unsafeFunction "ln" - sqrt = unsafeFunction "sqrt" - b ** x = UnsafeExpression $ - "power(" <> renderSQL b <> ", " <> renderSQL x <> ")" - logBase b y = log y / log b - sin = unsafeFunction "sin" - cos = unsafeFunction "cos" - tan = unsafeFunction "tan" - asin = unsafeFunction "asin" - acos = unsafeFunction "acos" - atan = unsafeFunction "atan" - sinh x = (exp x - exp (-x)) / 2 - cosh x = (exp x + exp (-x)) / 2 - tanh x = sinh x / cosh x - asinh x = log (x + sqrt (x*x + 1)) - acosh x = log (x + sqrt (x*x - 1)) - atanh x = log ((1 + x) / (1 - x)) / 2 - --- | Contained by operators -class PGSubset ty where - (@>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool) - (@>) = unsafeBinaryOp "@>" - (<@) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool) - (<@) = unsafeBinaryOp "<@" -infix 4 @> -infix 4 <@ -instance PGSubset 'PGjsonb -instance PGSubset 'PGtsquery -instance PGSubset ('PGvararray ty) -instance PGSubset ('PGrange ty) - --- | Intersection operator -class PGIntersect ty where - (@&&) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool) - (@&&) = unsafeBinaryOp "&&" -instance PGIntersect ('PGvararray ty) -instance PGIntersect ('PGrange ty) - -instance IsString - (Expression grp lat with db params from (null 'PGtext)) where - fromString - = UnsafeExpression - . parenthesized - . (<> " :: text") - . escapeQuotedString -instance IsString - (Expression grp lat with db params from (null 'PGtsvector)) where - fromString - = UnsafeExpression - . parenthesized - . (<> " :: tsvector") - . escapeQuotedString -instance IsString - (Expression grp lat with db params from (null 'PGtsquery)) where - fromString - = UnsafeExpression - . parenthesized - . (<> " :: tsquery") - . escapeQuotedString - -instance Semigroup - (Expression grp lat with db params from (null ('PGvararray ty))) where - (<>) = unsafeBinaryOp "||" -instance Semigroup - (Expression grp lat with db params from (null 'PGjsonb)) where - (<>) = unsafeBinaryOp "||" -instance Semigroup - (Expression grp lat with db params from (null 'PGtext)) where - (<>) = unsafeBinaryOp "||" -instance Semigroup - (Expression grp lat with db params from (null 'PGtsvector)) where - (<>) = unsafeBinaryOp "||" - -instance Monoid - (Expression grp lat with db params from (null 'PGtext)) where - mempty = fromString "" - mappend = (<>) -instance Monoid - (Expression grp lat with db params from (null 'PGtsvector)) where - mempty = fromString "" - mappend = (<>) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Aggregate.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Aggregate.hs deleted file mode 100644 index ccf689a1..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Aggregate.hs +++ /dev/null @@ -1,644 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Expression.Aggregate -Description: aggregate functions and arguments -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -aggregate functions and arguments --} - -{-# LANGUAGE - DataKinds - , DeriveGeneric - , FlexibleContexts - , FlexibleInstances - , FunctionalDependencies - , LambdaCase - , MultiParamTypeClasses - , OverloadedStrings - , PatternSynonyms - , PolyKinds - , ScopedTypeVariables - , StandaloneDeriving - , TypeApplications - , TypeFamilies - , TypeOperators - , UndecidableInstances -#-} - -module Squeal.PostgreSQL.Expression.Aggregate - ( -- * Aggregate - Aggregate (..) - -- * Aggregate Arguments - , AggregateArg (..) - , pattern All - , pattern Alls - , allNotNull - , pattern Distinct - , pattern Distincts - , distinctNotNull - , FilterWhere (..) - -- * Aggregate Types - , PGSum - , PGAvg - ) where - -import Data.ByteString (ByteString) -import GHC.TypeLits - -import qualified Generics.SOP as SOP - -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Expression.Logic -import Squeal.PostgreSQL.Expression.Null -import Squeal.PostgreSQL.Expression.Sort -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL - -{- | -`Aggregate` functions compute a single result from a set of input values. -`Aggregate` functions can be used as `Grouped` `Expression`s as well -as `Squeal.PostgreSQL.Expression.Window.WindowFunction`s. --} -class Aggregate arg expr | expr -> arg where - - -- | A special aggregation that does not require an input - -- - -- >>> :{ - -- let - -- expression :: Expression ('Grouped bys) '[] with db params from ('NotNull 'PGint8) - -- expression = countStar - -- in printSQL expression - -- :} - -- count(*) - countStar :: expr lat with db params from ('NotNull 'PGint8) - - -- | >>> :{ - -- let - -- expression :: Expression ('Grouped bys) '[] with db params '[tab ::: '["col" ::: null ty]] ('NotNull 'PGint8) - -- expression = count (All #col) - -- in printSQL expression - -- :} - -- count(ALL "col") - count - :: arg '[ty] lat with db params from - -- ^ argument - -> expr lat with db params from ('NotNull 'PGint8) - - -- | >>> :{ - -- let - -- expression :: Expression ('Grouped bys) '[] with db params '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Null 'PGnumeric) - -- expression = sum_ (Distinct #col & filterWhere (#col .< 100)) - -- in printSQL expression - -- :} - -- sum(DISTINCT "col") FILTER (WHERE ("col" < (100.0 :: numeric))) - sum_ - :: arg '[null ty] lat with db params from - -- ^ argument - -> expr lat with db params from ('Null (PGSum ty)) - - -- | input values, including nulls, concatenated into an array - -- - -- >>> :{ - -- let - -- expression :: Expression ('Grouped bys) '[] with db params '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Null ('PGvararray ('Null 'PGnumeric))) - -- expression = arrayAgg (All #col & orderBy [AscNullsFirst #col] & filterWhere (#col .< 100)) - -- in printSQL expression - -- :} - -- array_agg(ALL "col" ORDER BY "col" ASC NULLS FIRST) FILTER (WHERE ("col" < (100.0 :: numeric))) - arrayAgg - :: arg '[ty] lat with db params from - -- ^ argument - -> expr lat with db params from ('Null ('PGvararray ty)) - - -- | aggregates values as a JSON array - jsonAgg - :: arg '[ty] lat with db params from - -- ^ argument - -> expr lat with db params from ('Null 'PGjson) - - -- | aggregates values as a JSON array - jsonbAgg - :: arg '[ty] lat with db params from - -- ^ argument - -> expr lat with db params from ('Null 'PGjsonb) - - {- | - the bitwise AND of all non-null input values, or null if none - - >>> :{ - let - expression :: Expression ('Grouped bys) '[] with db params '[tab ::: '["col" ::: null 'PGint4]] ('Null 'PGint4) - expression = bitAnd (Distinct #col) - in printSQL expression - :} - bit_and(DISTINCT "col") - -} - bitAnd - :: int `In` PGIntegral - => arg '[null int] lat with db params from - -- ^ argument - -> expr lat with db params from ('Null int) - - {- | - the bitwise OR of all non-null input values, or null if none - - >>> :{ - let - expression :: Expression ('Grouped bys) '[] with db params '[tab ::: '["col" ::: null 'PGint4]] ('Null 'PGint4) - expression = bitOr (All #col) - in printSQL expression - :} - bit_or(ALL "col") - -} - bitOr - :: int `In` PGIntegral - => arg '[null int] lat with db params from - -- ^ argument - -> expr lat with db params from ('Null int) - - {- | - true if all input values are true, otherwise false - - >>> :{ - let - winFun :: WindowFunction 'Ungrouped '[] with db params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool) - winFun = boolAnd (Window #col) - in printSQL winFun - :} - bool_and("col") - -} - boolAnd - :: arg '[null 'PGbool] lat with db params from - -- ^ argument - -> expr lat with db params from ('Null 'PGbool) - - {- | - true if at least one input value is true, otherwise false - - >>> :{ - let - expression :: Expression ('Grouped bys) '[] with db params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool) - expression = boolOr (All #col) - in printSQL expression - :} - bool_or(ALL "col") - -} - boolOr - :: arg '[null 'PGbool] lat with db params from - -- ^ argument - -> expr lat with db params from ('Null 'PGbool) - - {- | - equivalent to `boolAnd` - - >>> :{ - let - expression :: Expression ('Grouped bys) '[] with db params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool) - expression = every (Distinct #col) - in printSQL expression - :} - every(DISTINCT "col") - -} - every - :: arg '[null 'PGbool] lat with db params from - -- ^ argument - -> expr lat with db params from ('Null 'PGbool) - - {- |maximum value of expression across all input values-} - max_ - :: arg '[null ty] lat with db params from - -- ^ argument - -> expr lat with db params from ('Null ty) - - -- | minimum value of expression across all input values - min_ - :: arg '[null ty] lat with db params from - -- ^ argument - -> expr lat with db params from ('Null ty) - - -- | the average (arithmetic mean) of all input values - avg - :: arg '[null ty] lat with db params from - -- ^ argument - -> expr lat with db params from ('Null (PGAvg ty)) - - {- | correlation coefficient - - >>> :{ - let - expression :: Expression ('Grouped g) '[] c s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8) - expression = corr (Alls (#y *: #x)) - in printSQL expression - :} - corr(ALL "y", "x") - -} - corr - :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from - -- ^ arguments - -> expr lat with db params from ('Null 'PGfloat8) - - {- | population covariance - - >>> :{ - let - expression :: Expression ('Grouped g) '[] c s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8) - expression = covarPop (Alls (#y *: #x)) - in printSQL expression - :} - covar_pop(ALL "y", "x") - -} - covarPop - :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from - -- ^ arguments - -> expr lat with db params from ('Null 'PGfloat8) - - {- | sample covariance - - >>> :{ - let - winFun :: WindowFunction 'Ungrouped '[] c s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8) - winFun = covarSamp (Windows (#y *: #x)) - in printSQL winFun - :} - covar_samp("y", "x") - -} - covarSamp - :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from - -- ^ arguments - -> expr lat with db params from ('Null 'PGfloat8) - - {- | average of the independent variable (sum(X)/N) - - >>> :{ - let - expression :: Expression ('Grouped g) '[] c s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8) - expression = regrAvgX (Alls (#y *: #x)) - in printSQL expression - :} - regr_avgx(ALL "y", "x") - -} - regrAvgX - :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from - -- ^ arguments - -> expr lat with db params from ('Null 'PGfloat8) - - {- | average of the dependent variable (sum(Y)/N) - - >>> :{ - let - winFun :: WindowFunction 'Ungrouped '[] c s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8) - winFun = regrAvgY (Windows (#y *: #x)) - in printSQL winFun - :} - regr_avgy("y", "x") - -} - regrAvgY - :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from - -- ^ arguments - -> expr lat with db params from ('Null 'PGfloat8) - - {- | number of input rows in which both expressions are nonnull - - >>> :{ - let - winFun :: WindowFunction 'Ungrouped '[] c s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGint8) - winFun = regrCount (Windows (#y *: #x)) - in printSQL winFun - :} - regr_count("y", "x") - -} - regrCount - :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from - -- ^ arguments - -> expr lat with db params from ('Null 'PGint8) - - {- | y-intercept of the least-squares-fit linear equation determined by the (X, Y) pairs - - >>> :{ - let - expression :: Expression ('Grouped g) '[] c s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8) - expression = regrIntercept (Alls (#y *: #x)) - in printSQL expression - :} - regr_intercept(ALL "y", "x") - -} - regrIntercept - :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from - -- ^ arguments - -> expr lat with db params from ('Null 'PGfloat8) - - -- | @regr_r2(Y, X)@, square of the correlation coefficient - regrR2 - :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from - -- ^ arguments - -> expr lat with db params from ('Null 'PGfloat8) - - -- | @regr_slope(Y, X)@, slope of the least-squares-fit linear equation - -- determined by the (X, Y) pairs - regrSlope - :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from - -- ^ arguments - -> expr lat with db params from ('Null 'PGfloat8) - - -- | @regr_sxx(Y, X)@, sum(X^2) - sum(X)^2/N - -- (“sum of squares” of the independent variable) - regrSxx - :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from - -- ^ arguments - -> expr lat with db params from ('Null 'PGfloat8) - - -- | @regr_sxy(Y, X)@, sum(X*Y) - sum(X) * sum(Y)/N - -- (“sum of products” of independent times dependent variable) - regrSxy - :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from - -- ^ arguments - -> expr lat with db params from ('Null 'PGfloat8) - - -- | @regr_syy(Y, X)@, sum(Y^2) - sum(Y)^2/N - -- (“sum of squares” of the dependent variable) - regrSyy - :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from - -- ^ arguments - -> expr lat with db params from ('Null 'PGfloat8) - - -- | historical alias for `stddevSamp` - stddev - :: arg '[null ty] lat with db params from - -- ^ argument - -> expr lat with db params from ('Null (PGAvg ty)) - - -- | population standard deviation of the input values - stddevPop - :: arg '[null ty] lat with db params from - -- ^ argument - -> expr lat with db params from ('Null (PGAvg ty)) - - -- | sample standard deviation of the input values - stddevSamp - :: arg '[null ty] lat with db params from - -- ^ argument - -> expr lat with db params from ('Null (PGAvg ty)) - - -- | historical alias for `varSamp` - variance - :: arg '[null ty] lat with db params from - -- ^ argument - -> expr lat with db params from ('Null (PGAvg ty)) - - -- | population variance of the input values - -- (square of the population standard deviation) - varPop - :: arg '[null ty] lat with db params from - -- ^ argument - -> expr lat with db params from ('Null (PGAvg ty)) - - -- | sample variance of the input values - -- (square of the sample standard deviation) - varSamp - :: arg '[null ty] lat with db params from - -- ^ argument - -> expr lat with db params from ('Null (PGAvg ty)) - -{- | -`AggregateArg`s are used for the input of `Aggregate` `Expression`s. --} -data AggregateArg - (xs :: [NullType]) - (lat :: FromType) - (with :: FromType) - (db :: SchemasType) - (params :: [NullType]) - (from :: FromType) - = AggregateAll - { aggregateArgs :: NP (Expression 'Ungrouped lat with db params from) xs - , aggregateOrder :: [SortExpression 'Ungrouped lat with db params from] - -- ^ `orderBy` - , aggregateFilter :: [Condition 'Ungrouped lat with db params from] - -- ^ `filterWhere` - } - | AggregateDistinct - { aggregateArgs :: NP (Expression 'Ungrouped lat with db params from) xs - , aggregateOrder :: [SortExpression 'Ungrouped lat with db params from] - -- ^ `orderBy` - , aggregateFilter :: [Condition 'Ungrouped lat with db params from] - -- ^ `filterWhere` - } - -instance (HasUnique tab (Join from lat) row, Has col row ty) - => IsLabel col (AggregateArg '[ty] lat with db params from) where - fromLabel = All (fromLabel @col) -instance (Has tab (Join from lat) row, Has col row ty) - => IsQualified tab col (AggregateArg '[ty] lat with db params from) where - tab ! col = All (tab ! col) - -instance SOP.SListI xs => RenderSQL (AggregateArg xs lat with db params from) where - renderSQL = \case - AggregateAll args sorts filters -> - parenthesized - ("ALL" <+> renderCommaSeparated renderSQL args<> renderSQL sorts) - <> renderFilters filters - AggregateDistinct args sorts filters -> - parenthesized - ("DISTINCT" <+> renderCommaSeparated renderSQL args <> renderSQL sorts) - <> renderFilters filters - where - renderFilter wh = "FILTER" <+> parenthesized ("WHERE" <+> wh) - renderFilters = \case - [] -> "" - wh:whs -> " " <> renderFilter (renderSQL (foldr (.&&) wh whs)) - -instance OrderBy (AggregateArg xs) 'Ungrouped where - orderBy sorts1 = \case - AggregateAll xs sorts0 whs -> AggregateAll xs (sorts0 ++ sorts1) whs - AggregateDistinct xs sorts0 whs -> AggregateDistinct xs (sorts0 ++ sorts1) whs - --- | `All` invokes the aggregate on a single --- argument once for each input row. -pattern All - :: Expression 'Ungrouped lat with db params from x - -- ^ argument - -> AggregateArg '[x] lat with db params from -pattern All x = Alls (x :* Nil) - --- | `All` invokes the aggregate on multiple --- arguments once for each input row. -pattern Alls - :: NP (Expression 'Ungrouped lat with db params from) xs - -- ^ arguments - -> AggregateArg xs lat with db params from -pattern Alls xs = AggregateAll xs [] [] - --- | `allNotNull` invokes the aggregate on a single --- argument once for each input row where the argument --- is not null -allNotNull - :: Expression 'Ungrouped lat with db params from ('Null x) - -- ^ argument - -> AggregateArg '[ 'NotNull x] lat with db params from -allNotNull x = All (unsafeNotNull x) & filterWhere (not_ (isNull x)) - -{- | -`Distinct` invokes the aggregate once for each -distinct value of the expression found in the input. --} -pattern Distinct - :: Expression 'Ungrouped lat with db params from x - -- ^ argument - -> AggregateArg '[x] lat with db params from -pattern Distinct x = Distincts (x :* Nil) - -{- | -`Distincts` invokes the aggregate once for each -distinct set of values, for multiple expressions, found in the input. --} -pattern Distincts - :: NP (Expression 'Ungrouped lat with db params from) xs - -- ^ arguments - -> AggregateArg xs lat with db params from -pattern Distincts xs = AggregateDistinct xs [] [] - -{- | -`distinctNotNull` invokes the aggregate once for each -distinct, not null value of the expression found in the input. --} -distinctNotNull - :: Expression 'Ungrouped lat with db params from ('Null x) - -- ^ argument - -> AggregateArg '[ 'NotNull x] lat with db params from -distinctNotNull x = Distinct (unsafeNotNull x) & filterWhere (not_ (isNull x)) - --- | Permits filtering --- `Squeal.PostgreSQL.Expression.Window.WindowArg`s and `AggregateArg`s -class FilterWhere arg grp | arg -> grp where - {- | - If `filterWhere` is specified, then only the input rows for which - the `Condition` evaluates to true are fed to the aggregate function; - other rows are discarded. - -} - filterWhere - :: Condition grp lat with db params from - -- ^ include rows which evaluate to true - -> arg xs lat with db params from - -> arg xs lat with db params from -instance FilterWhere AggregateArg 'Ungrouped where - filterWhere wh = \case - AggregateAll xs sorts whs -> AggregateAll xs sorts (wh : whs) - AggregateDistinct xs sorts whs -> AggregateDistinct xs sorts (wh : whs) - -instance Aggregate AggregateArg (Expression ('Grouped bys)) where - countStar = UnsafeExpression "count(*)" - count = unsafeAggregate "count" - sum_ = unsafeAggregate "sum" - arrayAgg = unsafeAggregate "array_agg" - jsonAgg = unsafeAggregate "json_agg" - jsonbAgg = unsafeAggregate "jsonb_agg" - bitAnd = unsafeAggregate "bit_and" - bitOr = unsafeAggregate "bit_or" - boolAnd = unsafeAggregate "bool_and" - boolOr = unsafeAggregate "bool_or" - every = unsafeAggregate "every" - max_ = unsafeAggregate "max" - min_ = unsafeAggregate "min" - avg = unsafeAggregate "avg" - corr = unsafeAggregate "corr" - covarPop = unsafeAggregate "covar_pop" - covarSamp = unsafeAggregate "covar_samp" - regrAvgX = unsafeAggregate "regr_avgx" - regrAvgY = unsafeAggregate "regr_avgy" - regrCount = unsafeAggregate "regr_count" - regrIntercept = unsafeAggregate "regr_intercept" - regrR2 = unsafeAggregate "regr_r2" - regrSlope = unsafeAggregate "regr_slope" - regrSxx = unsafeAggregate "regr_sxx" - regrSxy = unsafeAggregate "regr_sxy" - regrSyy = unsafeAggregate "regr_syy" - stddev = unsafeAggregate "stddev" - stddevPop = unsafeAggregate "stddev_pop" - stddevSamp = unsafeAggregate "stddev_samp" - variance = unsafeAggregate "variance" - varPop = unsafeAggregate "var_pop" - varSamp = unsafeAggregate "var_samp" - --- provides a nicer type error when we forget to group by --- note that we need to make our 'a' polymorphic so that we can still match when it's ambiguous -instance ( TypeError ('Text "Cannot use aggregate functions to construct an Ungrouped Expression. Add a 'groupBy' to your TableExpression. If you want to aggregate across the entire result set, use 'groupBy Nil'.") - , a ~ AggregateArg - ) => Aggregate a (Expression 'Ungrouped) where - countStar = impossibleAggregateError - count = impossibleAggregateError - sum_ = impossibleAggregateError - arrayAgg = impossibleAggregateError - jsonAgg = impossibleAggregateError - jsonbAgg = impossibleAggregateError - bitAnd = impossibleAggregateError - bitOr = impossibleAggregateError - boolAnd = impossibleAggregateError - boolOr = impossibleAggregateError - every = impossibleAggregateError - max_ = impossibleAggregateError - min_ = impossibleAggregateError - avg = impossibleAggregateError - corr = impossibleAggregateError - covarPop = impossibleAggregateError - covarSamp = impossibleAggregateError - regrAvgX = impossibleAggregateError - regrAvgY = impossibleAggregateError - regrCount = impossibleAggregateError - regrIntercept = impossibleAggregateError - regrR2 = impossibleAggregateError - regrSlope = impossibleAggregateError - regrSxx = impossibleAggregateError - regrSxy = impossibleAggregateError - regrSyy = impossibleAggregateError - stddev = impossibleAggregateError - stddevPop = impossibleAggregateError - stddevSamp = impossibleAggregateError - variance = impossibleAggregateError - varPop = impossibleAggregateError - varSamp = impossibleAggregateError - --- | helper function for our errors above -impossibleAggregateError :: a -impossibleAggregateError = error "impossible; called aggregate function for Ungrouped even though the Aggregate instance has a type error constraint." - --- | escape hatch to define aggregate functions -unsafeAggregate - :: SOP.SListI xs - => ByteString -- ^ function - -> AggregateArg xs lat with db params from - -> Expression ('Grouped bys) lat with db params from y -unsafeAggregate fun xs = UnsafeExpression $ fun <> renderSQL xs - --- | A type family that calculates `PGSum` `PGType` of --- a given argument `PGType`. -type family PGSum ty where - PGSum 'PGint2 = 'PGint8 - PGSum 'PGint4 = 'PGint8 - PGSum 'PGint8 = 'PGnumeric - PGSum 'PGfloat4 = 'PGfloat4 - PGSum 'PGfloat8 = 'PGfloat8 - PGSum 'PGnumeric = 'PGnumeric - PGSum 'PGinterval = 'PGinterval - PGSum 'PGmoney = 'PGmoney - PGSum pg = TypeError - ( 'Text "Squeal type error: Cannot sum with argument type " - ':<>: 'ShowType pg ) - --- | A type family that calculates `PGAvg` type of a `PGType`. -type family PGAvg ty where - PGAvg 'PGint2 = 'PGnumeric - PGAvg 'PGint4 = 'PGnumeric - PGAvg 'PGint8 = 'PGnumeric - PGAvg 'PGnumeric = 'PGnumeric - PGAvg 'PGfloat4 = 'PGfloat8 - PGAvg 'PGfloat8 = 'PGfloat8 - PGAvg 'PGinterval = 'PGinterval - PGAvg pg = TypeError - ('Text "Squeal type error: No average for " ':<>: 'ShowType pg) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Array.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Array.hs deleted file mode 100644 index f78f9558..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Array.hs +++ /dev/null @@ -1,242 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Expression.Array -Description: array functions -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -array functions --} - -{-# LANGUAGE - AllowAmbiguousTypes - , DataKinds - , FlexibleContexts - , FlexibleInstances - , MultiParamTypeClasses - , OverloadedLabels - , OverloadedStrings - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeFamilies - , TypeOperators - , UndecidableInstances -#-} - -module Squeal.PostgreSQL.Expression.Array - ( -- * Array Functions - array - , array0 - , array1 - , array2 - , cardinality - , index - , index1 - , index2 - , unnest - , arrAny - , arrAll - ) where - -import Data.String -import Data.Word (Word64) -import GHC.TypeNats - -import qualified Generics.SOP as SOP - -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Expression.Logic -import Squeal.PostgreSQL.Expression.Type -import Squeal.PostgreSQL.Query.From.Set -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL - --- | Construct an array. --- --- >>> printSQL $ array [null_, false, true] --- ARRAY[NULL, FALSE, TRUE] -array - :: [Expression grp lat with db params from ty] - -- ^ array elements - -> Expression grp lat with db params from (null ('PGvararray ty)) -array xs = UnsafeExpression $ "ARRAY" <> - bracketed (commaSeparated (renderSQL <$> xs)) - --- | Safely construct an empty array. --- --- >>> printSQL $ array0 text --- (ARRAY[] :: text[]) -array0 - :: TypeExpression db ty - -> Expression grp lat with db params from (null ('PGvararray ty)) -array0 ty = array [] & astype (vararray ty) - -{- | Construct a fixed length array. - ->>> printSQL $ array1 (null_ :* false *: true) -ARRAY[NULL, FALSE, TRUE] - ->>> :type array1 (null_ :* false *: true) -array1 (null_ :* false *: true) - :: Expression - grp - lat - with - db - params - from - (null ('PGfixarray '[3] ('Null 'PGbool))) --} -array1 - :: (n ~ Length tys, SOP.All ((~) ty) tys) - => NP (Expression grp lat with db params from) tys - -- ^ array elements - -> Expression grp lat with db params from (null ('PGfixarray '[n] ty)) -array1 xs = UnsafeExpression $ "ARRAY" <> - bracketed (renderCommaSeparated renderSQL xs) - -{- | Construct a fixed size matrix. - ->>> printSQL $ array2 ((null_ :* false *: true) *: (false :* null_ *: true)) -ARRAY[[NULL, FALSE, TRUE], [FALSE, NULL, TRUE]] - ->>> :type array2 ((null_ :* false *: true) *: (false :* null_ *: true)) -array2 ((null_ :* false *: true) *: (false :* null_ *: true)) - :: Expression - grp - lat - with - db - params - from - (null ('PGfixarray '[2, 3] ('Null 'PGbool))) --} -array2 - :: ( SOP.All ((~) tys) tyss - , SOP.All SOP.SListI tyss - , Length tyss ~ n1 - , SOP.All ((~) ty) tys - , Length tys ~ n2 ) - => NP (NP (Expression grp lat with db params from)) tyss - -- ^ matrix elements - -> Expression grp lat with db params from (null ('PGfixarray '[n1,n2] ty)) -array2 xss = UnsafeExpression $ "ARRAY" <> - bracketed (renderCommaSeparatedConstraint @SOP.SListI (bracketed . renderCommaSeparated renderSQL) xss) - --- | >>> printSQL $ cardinality (array [null_, false, true]) --- cardinality(ARRAY[NULL, FALSE, TRUE]) -cardinality :: null ('PGvararray ty) --> null 'PGint8 -cardinality = unsafeFunction "cardinality" - --- | >>> printSQL $ array [null_, false, true] & index 2 --- (ARRAY[NULL, FALSE, TRUE])[2] -index - :: Word64 -- ^ index - -> null ('PGvararray ty) --> NullifyType ty -index i arr = UnsafeExpression $ - parenthesized (renderSQL arr) <> "[" <> fromString (show i) <> "]" - --- | Typesafe indexing of fixed length arrays. --- --- >>> printSQL $ array1 (true *: false) & index1 @1 --- (ARRAY[TRUE, FALSE])[1] -index1 - :: forall i n ty - . (1 <= i, i <= n, KnownNat i) - => 'NotNull ('PGfixarray '[n] ty) --> ty - -- ^ vector index -index1 arr = UnsafeExpression $ - parenthesized (renderSQL arr) - <> "[" <> fromString (show (natVal (SOP.Proxy @i))) <> "]" - --- | Typesafe indexing of fixed size matrices. --- --- >>> printSQL $ array2 ((true *: false) *: (false *: true)) & index2 @1 @2 --- (ARRAY[[TRUE, FALSE], [FALSE, TRUE]])[1][2] -index2 - :: forall i j m n ty - . ( 1 <= i, i <= m, KnownNat i - , 1 <= j, j <= n, KnownNat j - ) - => 'NotNull ('PGfixarray '[m,n] ty) --> ty - -- ^ matrix index -index2 arr = UnsafeExpression $ - parenthesized (renderSQL arr) - <> "[" <> fromString (show (natVal (SOP.Proxy @i))) <> "]" - <> "[" <> fromString (show (natVal (SOP.Proxy @j))) <> "]" - --- | Expand an array to a set of rows --- --- >>> printSQL $ unnest (array [null_, false, true]) --- unnest(ARRAY[NULL, FALSE, TRUE]) -unnest :: null ('PGvararray ty) -|-> ("unnest" ::: '["unnest" ::: ty]) -unnest = unsafeSetFunction "unnest" - -{- | -The right-hand side is a parenthesized expression, -which must yield an array value. The left-hand expression -is evaluated and compared to each element of the array using -the given `Operator`, which must yield a Boolean result. -The result of `arrAll` is `true` if all comparisons yield true -(including the case where the array has zero elements). -The result is `false` if any false result is found. - -If the array expression yields a null array, -the result of `arrAll` will be null. If the left-hand expression yields null, -the result of `arrAll` is ordinarily null -(though a non-strict comparison `Operator` -could possibly yield a different result). -Also, if the right-hand array contains any null -elements and no false comparison result is obtained, -the result of `arrAll` will be null, not true -(again, assuming a strict comparison `Operator`). -This is in accordance with SQL's normal rules for Boolean -combinations of null values. - ->>> printSQL $ arrAll true (.==) (array [true, false, null_]) -(TRUE = ALL (ARRAY[TRUE, FALSE, NULL])) ->>> printSQL $ arrAll "hi" like (array ["bi","hi"]) -((E'hi' :: text) LIKE ALL (ARRAY[(E'bi' :: text), (E'hi' :: text)])) --} -arrAll - :: Expression grp lat with db params from ty1 -- ^ expression - -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator - -> Expression grp lat with db params from ('Null ('PGvararray ty2)) -- ^ array - -> Condition grp lat with db params from -arrAll x (?) xs = x ? (UnsafeExpression $ "ALL" <+> parenthesized (renderSQL xs)) - -{- | -The right-hand side is a parenthesized expression, which must yield an array -value. The left-hand expression is evaluated and compared to each element of -the array using the given `Operator`, which must yield a Boolean result. The -result of `arrAny` is `true` if any true result is obtained. The result is -`false` if no true result is found (including the case where the array -has zero elements). - -If the array expression yields a null array, the result of `arrAny` will -be null. If the left-hand expression yields null, the result of `arrAny` is -ordinarily null (though a non-strict comparison `Operator` could possibly -yield a different result). Also, if the right-hand array contains any -null elements and no true comparison result is obtained, the result of -`arrAny` will be null, not false -(again, assuming a strict comparison `Operator`). -This is in accordance with SQL's normal rules for -Boolean combinations of null values. - ->>> printSQL $ arrAny true (.==) (array [true, false, null_]) -(TRUE = ANY (ARRAY[TRUE, FALSE, NULL])) ->>> printSQL $ arrAny "hi" like (array ["bi","hi"]) -((E'hi' :: text) LIKE ANY (ARRAY[(E'bi' :: text), (E'hi' :: text)])) --} -arrAny - :: Expression grp lat with db params from ty1 -- ^ expression - -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator - -> Expression grp lat with db params from ('Null ('PGvararray ty2)) -- ^ array - -> Condition grp lat with db params from -arrAny x (?) xs = x ? (UnsafeExpression $ "ANY" <+> parenthesized (renderSQL xs)) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Comparison.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Comparison.hs deleted file mode 100644 index 41c016a9..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Comparison.hs +++ /dev/null @@ -1,210 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Expression.Comparison -Description: comparison functions and operators -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -comparison functions and operators --} - -{-# LANGUAGE - OverloadedStrings - , RankNTypes - , TypeInType - , TypeOperators -#-} - -module Squeal.PostgreSQL.Expression.Comparison - ( -- * Comparison Operators - (.==) - , (./=) - , (.>=) - , (.<) - , (.<=) - , (.>) - -- * Comparison Functions - , greatest - , least - -- * Between - , BetweenExpr - , between - , notBetween - , betweenSymmetric - , notBetweenSymmetric - -- * Null Comparison - , isDistinctFrom - , isNotDistinctFrom - , isTrue - , isNotTrue - , isFalse - , isNotFalse - , isUnknown - , isNotUnknown - ) where - -import Data.ByteString - -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Expression.Logic -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL - --- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=` --- will produce @NULL@s if one of their arguments is @NULL@. --- --- >>> printSQL $ true .== null_ --- (TRUE = NULL) -(.==) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool) -(.==) = unsafeBinaryOp "=" -infix 4 .== - --- | >>> printSQL $ true ./= null_ --- (TRUE <> NULL) -(./=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool) -(./=) = unsafeBinaryOp "<>" -infix 4 ./= - --- | >>> printSQL $ true .>= null_ --- (TRUE >= NULL) -(.>=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool) -(.>=) = unsafeBinaryOp ">=" -infix 4 .>= - --- | >>> printSQL $ true .< null_ --- (TRUE < NULL) -(.<) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool) -(.<) = unsafeBinaryOp "<" -infix 4 .< - --- | >>> printSQL $ true .<= null_ --- (TRUE <= NULL) -(.<=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool) -(.<=) = unsafeBinaryOp "<=" -infix 4 .<= - --- | >>> printSQL $ true .> null_ --- (TRUE > NULL) -(.>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool) -(.>) = unsafeBinaryOp ">" -infix 4 .> - --- | >>> let expr = greatest [param @1] currentTimestamp --- >>> printSQL expr --- GREATEST(($1 :: timestamp with time zone), CURRENT_TIMESTAMP) -greatest :: FunctionVar ty ty ty -greatest = unsafeFunctionVar "GREATEST" - --- | >>> printSQL $ least [null_] currentTimestamp --- LEAST(NULL, CURRENT_TIMESTAMP) -least :: FunctionVar ty ty ty -least = unsafeFunctionVar "LEAST" - -{- | -A @RankNType@ for comparison expressions like `between`. --} -type BetweenExpr - = forall grp lat with db params from ty - . Expression grp lat with db params from ty - -> ( Expression grp lat with db params from ty - , Expression grp lat with db params from ty ) -- ^ bounds - -> Condition grp lat with db params from - -unsafeBetweenExpr :: ByteString -> BetweenExpr -unsafeBetweenExpr fun a (x,y) = UnsafeExpression $ - renderSQL a <+> fun <+> renderSQL x <+> "AND" <+> renderSQL y - -{- | >>> printSQL $ true `between` (null_, false) -TRUE BETWEEN NULL AND FALSE --} -between :: BetweenExpr -between = unsafeBetweenExpr "BETWEEN" - -{- | >>> printSQL $ true `notBetween` (null_, false) -TRUE NOT BETWEEN NULL AND FALSE --} -notBetween :: BetweenExpr -notBetween = unsafeBetweenExpr "NOT BETWEEN" - -{- | between, after sorting the comparison values - ->>> printSQL $ true `betweenSymmetric` (null_, false) -TRUE BETWEEN SYMMETRIC NULL AND FALSE --} -betweenSymmetric :: BetweenExpr -betweenSymmetric = unsafeBetweenExpr "BETWEEN SYMMETRIC" - -{- | not between, after sorting the comparison values - ->>> printSQL $ true `notBetweenSymmetric` (null_, false) -TRUE NOT BETWEEN SYMMETRIC NULL AND FALSE --} -notBetweenSymmetric :: BetweenExpr -notBetweenSymmetric = unsafeBetweenExpr "NOT BETWEEN SYMMETRIC" - -{- | not equal, treating null like an ordinary value - ->>> printSQL $ true `isDistinctFrom` null_ -(TRUE IS DISTINCT FROM NULL) --} -isDistinctFrom :: Operator (null0 ty) (null1 ty) (null 'PGbool) -isDistinctFrom = unsafeBinaryOp "IS DISTINCT FROM" - -{- | equal, treating null like an ordinary value - ->>> printSQL $ true `isNotDistinctFrom` null_ -(TRUE IS NOT DISTINCT FROM NULL) --} -isNotDistinctFrom :: Operator (null0 ty) (null1 ty) (null 'PGbool) -isNotDistinctFrom = unsafeBinaryOp "IS NOT DISTINCT FROM" - -{- | is true - ->>> printSQL $ true & isTrue -(TRUE IS TRUE) --} -isTrue :: null0 'PGbool --> null1 'PGbool -isTrue = unsafeRightOp "IS TRUE" - -{- | is false or unknown - ->>> printSQL $ true & isNotTrue -(TRUE IS NOT TRUE) --} -isNotTrue :: null0 'PGbool --> null1 'PGbool -isNotTrue = unsafeRightOp "IS NOT TRUE" - -{- | is false - ->>> printSQL $ true & isFalse -(TRUE IS FALSE) --} -isFalse :: null0 'PGbool --> null1 'PGbool -isFalse = unsafeRightOp "IS FALSE" - -{- | is true or unknown - ->>> printSQL $ true & isNotFalse -(TRUE IS NOT FALSE) --} -isNotFalse :: null0 'PGbool --> null1 'PGbool -isNotFalse = unsafeRightOp "IS NOT FALSE" - -{- | is unknown - ->>> printSQL $ true & isUnknown -(TRUE IS UNKNOWN) --} -isUnknown :: null0 'PGbool --> null1 'PGbool -isUnknown = unsafeRightOp "IS UNKNOWN" - -{- | is true or false - ->>> printSQL $ true & isNotUnknown -(TRUE IS NOT UNKNOWN) --} -isNotUnknown :: null0 'PGbool --> null1 'PGbool -isNotUnknown = unsafeRightOp "IS NOT UNKNOWN" diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Composite.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Composite.hs deleted file mode 100644 index 7afef55e..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Composite.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Expression.Composite -Description: composite functions -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -composite functions --} - -{-# LANGUAGE - AllowAmbiguousTypes - , DataKinds - , FlexibleContexts - , FlexibleInstances - , MultiParamTypeClasses - , OverloadedLabels - , OverloadedStrings - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeFamilies - , TypeOperators - , UndecidableInstances -#-} - -module Squeal.PostgreSQL.Expression.Composite - ( -- * Composite Functions - row - , rowStar - , field - ) where - -import qualified Generics.SOP as SOP - -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL - --- | A row constructor is an expression that builds a row value --- (also called a composite value) using values for its member fields. --- --- >>> :{ --- type Complex = 'PGcomposite --- '[ "real" ::: 'NotNull 'PGfloat8 --- , "imaginary" ::: 'NotNull 'PGfloat8 ] --- :} --- --- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression grp lat with db params from ('NotNull Complex) --- >>> printSQL i --- ROW((0.0 :: float8), (1.0 :: float8)) -row - :: SOP.SListI row - => NP (Aliased (Expression grp lat with db params from)) row - -- ^ zero or more expressions for the row field values - -> Expression grp lat with db params from (null ('PGcomposite row)) -row exprs = UnsafeExpression $ "ROW" <> parenthesized - (renderCommaSeparated (\ (expr `As` _) -> renderSQL expr) exprs) - --- | A row constructor on all columns in a table expression. -rowStar - :: Has tab from row - => Alias tab -- ^ intermediate table - -> Expression grp lat with db params from (null ('PGcomposite row)) -rowStar tab = UnsafeExpression $ "ROW" <> - parenthesized (renderSQL tab <> ".*") - --- | >>> :{ --- type Complex = 'PGcomposite --- '[ "real" ::: 'NotNull 'PGfloat8 --- , "imaginary" ::: 'NotNull 'PGfloat8 ] --- type Schema = '["complex" ::: 'Typedef Complex] --- :} --- --- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression lat '[] grp (Public Schema) from params ('NotNull Complex) --- >>> printSQL $ i & field #complex #imaginary --- (ROW((0.0 :: float8), (1.0 :: float8))::"complex")."imaginary" -field - :: ( relss ~ DbRelations db - , Has sch relss rels - , Has rel rels row - , Has field row ty - ) - => QualifiedAlias sch rel -- ^ row type - -> Alias field -- ^ field name - -> Expression grp lat with db params from ('NotNull ('PGcomposite row)) - -> Expression grp lat with db params from ty -field rel fld expr = UnsafeExpression $ - parenthesized (renderSQL expr <> "::" <> renderSQL rel) - <> "." <> renderSQL fld diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Default.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Default.hs deleted file mode 100644 index 0dc36863..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Default.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Expression.Default -Description: optional expressions -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -optional expressions --} - -{-# LANGUAGE - DataKinds - , GADTs - , LambdaCase - , OverloadedStrings - , PatternSynonyms - , PolyKinds - , QuantifiedConstraints - , RankNTypes - , TypeOperators -#-} - -module Squeal.PostgreSQL.Expression.Default - ( -- * Default - Optional (..) - , mapOptional - , pattern NotDefault - ) where - -import Data.Kind -import Generics.SOP - -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema - --- | `Optional` is either `Default` or `Set`ting of a value, --- parameterized by an appropriate `Optionality`. -data Optional (expr :: k -> Type) (ty :: (Optionality, k)) where - -- | Use the `Default` value for a column. - Default :: Optional expr ('Def :=> ty) - -- | `Set` a value for a column. - Set :: expr ty -> Optional expr (def :=> ty) - -instance (forall x. RenderSQL (expr x)) => RenderSQL (Optional expr ty) where - renderSQL = \case - Default -> "DEFAULT" - Set x -> renderSQL x - --- | Map a function over an `Optional` expression. -mapOptional - :: (expr x -> expr y) - -> Optional expr (def :=> x) - -> Optional expr (def :=> y) -mapOptional f = \case - Default -> Default - Set x -> Set (f x) - --- | `NotDefault` pattern analagous to `Just`. -pattern NotDefault :: ty -> Optional I ('Def :=> ty) -pattern NotDefault x = Set (I x) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Inline.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Inline.hs deleted file mode 100644 index 5fde4cbb..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Inline.hs +++ /dev/null @@ -1,342 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Expression.Inline -Description: inline expressions -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -inline expressions --} - -{-# LANGUAGE - DataKinds - , FlexibleContexts - , FlexibleInstances - , LambdaCase - , MultiParamTypeClasses - , MultiWayIf - , OverloadedStrings - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeFamilies - , TypeOperators - , TypeSynonymInstances - , UndecidableInstances -#-} - -module Squeal.PostgreSQL.Expression.Inline - ( -- * Inline - Inline (..) - , InlineParam (..) - , InlineField (..) - , inlineFields - , InlineColumn (..) - , inlineColumns - ) where - -import Data.Binary.Builder (toLazyByteString) -import Data.ByteString.Lazy (toStrict) -import Data.ByteString.Builder (doubleDec, floatDec, int16Dec, int32Dec, int64Dec) -import Data.ByteString.Builder.Scientific (scientificBuilder) -import Data.Coerce (coerce) -import Data.Functor.Const (Const(Const)) -import Data.Functor.Constant (Constant(Constant)) -import Data.Int (Int16, Int32, Int64) -import Data.Kind (Type) -import Data.Scientific (Scientific) -import Data.String -import Data.Text (Text) -import Data.Time.Clock (DiffTime, diffTimeToPicoseconds, UTCTime) -import Data.Time.Format.ISO8601 (formatShow, timeOfDayAndOffsetFormat, FormatExtension(ExtendedFormat), iso8601Show) -import Data.Time.Calendar (Day) -import Data.Time.LocalTime (LocalTime, TimeOfDay, TimeZone) -import Data.UUID.Types (UUID, toASCIIBytes) -import Data.Vector (Vector, toList) -import Database.PostgreSQL.LibPQ (Oid(Oid)) -import GHC.TypeLits - -import qualified Data.Aeson as JSON -import qualified Data.Text as Text -import qualified Data.Text.Lazy as Lazy (Text) -import qualified Data.Text.Lazy as Lazy.Text -import qualified Generics.SOP as SOP -import qualified Generics.SOP.Record as SOP - -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Expression.Array -import Squeal.PostgreSQL.Expression.Default -import Squeal.PostgreSQL.Expression.Composite -import Squeal.PostgreSQL.Expression.Logic -import Squeal.PostgreSQL.Expression.Null -import Squeal.PostgreSQL.Expression.Range -import Squeal.PostgreSQL.Expression.Time -import Squeal.PostgreSQL.Expression.Type -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Type.PG -import Squeal.PostgreSQL.Type.Schema - -{- | -The `Inline` class allows embedding a Haskell value directly -as an `Expression` using `inline`. - ->>> printSQL (inline 'a') -(E'a' :: char(1)) - ->>> printSQL (inline (1 :: Double)) -(1.0 :: float8) - ->>> printSQL (inline (Json ([1, 2] :: [Double]))) -('[1.0,2.0]' :: json) - ->>> printSQL (inline (Enumerated GT)) -'GT' --} -class Inline x where inline :: x -> Expr (null (PG x)) -instance Inline Bool where - inline = \case - True -> true - False -> false -instance JSON.ToJSON x => Inline (Json x) where - inline = inferredtype . UnsafeExpression - . singleQuotedUtf8 . toStrict . JSON.encode . getJson -instance JSON.ToJSON x => Inline (Jsonb x) where - inline = inferredtype . UnsafeExpression - . singleQuotedUtf8 . toStrict . JSON.encode . getJsonb -instance Inline Char where - inline chr = inferredtype . UnsafeExpression $ - "E\'" <> fromString (escape chr) <> "\'" -instance Inline String where inline = fromString -instance Inline Int16 where - inline - = inferredtype - . UnsafeExpression - . toStrict - . toLazyByteString - . int16Dec -instance Inline Int32 where - inline - = inferredtype - . UnsafeExpression - . toStrict - . toLazyByteString - . int32Dec -instance Inline Int64 where - inline x = - if x == minBound - -- For some reason Postgres throws an error with - -- (-9223372036854775808 :: int8) - -- even though it's a valid lowest value for int8 - then inline (x+1) - 1 - else inferredtype - . UnsafeExpression - . toStrict - . toLazyByteString - $ int64Dec x -instance Inline Float where - inline x = inferredtype . UnsafeExpression $ - if isNaN x || isInfinite x - then singleQuotedUtf8 (decimal x) - else decimal x - where - decimal = toStrict . toLazyByteString . floatDec -instance Inline Double where - inline x = inferredtype . UnsafeExpression $ - if isNaN x || isInfinite x - then singleQuotedUtf8 (decimal x) - else decimal x - where - decimal = toStrict . toLazyByteString . doubleDec -instance Inline Scientific where - inline - = inferredtype - . UnsafeExpression - . toStrict - . toLazyByteString - . scientificBuilder -instance Inline Text where inline = fromString . Text.unpack -instance Inline Lazy.Text where inline = fromString . Lazy.Text.unpack -instance (KnownNat n, 1 <= n) => Inline (VarChar n) where - inline - = inferredtype - . UnsafeExpression - . escapeQuotedText - . getVarChar -instance (KnownNat n, 1 <= n) => Inline (FixChar n) where - inline - = inferredtype - . UnsafeExpression - . escapeQuotedText - . getFixChar -instance Inline x => Inline (Const x tag) where inline = inline @x . coerce -instance Inline x => Inline (SOP.K x tag) where inline = inline @x . coerce -instance Inline x => Inline (Constant x tag) where inline = inline @x . coerce -instance Inline DiffTime where - inline dt = - let - picosecs = diffTimeToPicoseconds dt - (secs,leftover) = picosecs `quotRem` 1000000000000 - microsecs = leftover `quot` 1000000 - in - inferredtype $ - interval_ (fromIntegral secs) Seconds - +! interval_ (fromIntegral microsecs) Microseconds -instance Inline Day where - inline - = inferredtype - . UnsafeExpression - . singleQuotedUtf8 - . fromString - . iso8601Show -instance Inline UTCTime where - inline - = inferredtype - . UnsafeExpression - . singleQuotedUtf8 - . fromString - . iso8601Show -instance Inline (TimeOfDay, TimeZone) where - inline - = inferredtype - . UnsafeExpression - . singleQuotedUtf8 - . fromString - . formatShow (timeOfDayAndOffsetFormat ExtendedFormat) -instance Inline TimeOfDay where - inline - = inferredtype - . UnsafeExpression - . singleQuotedUtf8 - . fromString - . iso8601Show -instance Inline LocalTime where - inline - = inferredtype - . UnsafeExpression - . singleQuotedUtf8 - . fromString - . iso8601Show -instance Inline (Range Int32) where - inline = range int4range . fmap inline -instance Inline (Range Int64) where - inline = range int8range . fmap inline -instance Inline (Range Scientific) where - inline = range numrange . fmap inline -instance Inline (Range LocalTime) where - inline = range tsrange . fmap inline -instance Inline (Range UTCTime) where - inline = range tstzrange . fmap inline -instance Inline (Range Day) where - inline = range daterange . fmap inline -instance Inline UUID where - inline - = inferredtype - . UnsafeExpression - . singleQuotedUtf8 - . toASCIIBytes -instance Inline Money where - inline moolah = inferredtype . UnsafeExpression $ - fromString (show dollars) - <> "." <> fromString (show pennies) - where - (dollars,pennies) = cents moolah `divMod` 100 -instance InlineParam x (NullPG x) - => Inline (VarArray [x]) where - inline (VarArray xs) = array (inlineParam <$> xs) -instance InlineParam x (NullPG x) - => Inline (VarArray (Vector x)) where - inline (VarArray xs) = array (inlineParam <$> toList xs) -instance Inline Oid where - inline (Oid o) = inferredtype . UnsafeExpression . fromString $ show o -instance - ( SOP.IsEnumType x - , SOP.HasDatatypeInfo x - ) => Inline (Enumerated x) where - inline = - let - gshowConstructor - :: NP SOP.ConstructorInfo xss - -> SOP.SOP SOP.I xss - -> String - gshowConstructor Nil _ = "" - gshowConstructor (constructor :* _) (SOP.SOP (SOP.Z _)) = - SOP.constructorName constructor - gshowConstructor (_ :* constructors) (SOP.SOP (SOP.S xs)) = - gshowConstructor constructors (SOP.SOP xs) - in - UnsafeExpression - . singleQuotedUtf8 - . fromString - . gshowConstructor - (SOP.constructorInfo (SOP.datatypeInfo (SOP.Proxy @x))) - . SOP.from - . getEnumerated -instance - ( SOP.IsRecord x xs - , SOP.AllZip InlineField xs (RowPG x) - ) => Inline (Composite x) where - inline - = row - . SOP.htrans (SOP.Proxy @InlineField) inlineField - . SOP.toRecord - . getComposite - --- | Lifts `Inline` to `NullType`s. -class InlineParam x ty where inlineParam :: x -> Expr ty -instance (Inline x, pg ~ PG x) => InlineParam x ('NotNull pg) where inlineParam = inline -instance (Inline x, pg ~ PG x) => InlineParam (Maybe x) ('Null pg) where - inlineParam = maybe null_ inline - --- | Lifts `Inline` to fields. -class InlineField - (field :: (Symbol, Type)) - (fieldpg :: (Symbol, NullType)) where - inlineField - :: SOP.P field - -> Aliased (Expression grp lat with db params from) fieldpg -instance (KnownSymbol alias, InlineParam x ty) - => InlineField (alias ::: x) (alias ::: ty) where - inlineField (SOP.P x) = inlineParam x `as` Alias @alias - --- | Inline a Haskell record as a row of expressions. -inlineFields - :: ( SOP.IsRecord hask fields - , SOP.AllZip InlineField fields row ) - => hask -- ^ record - -> NP (Aliased (Expression 'Ungrouped '[] with db params '[])) row -inlineFields - = SOP.htrans (SOP.Proxy @InlineField) inlineField - . SOP.toRecord - - --- | Lifts `Inline` to a column entry -class InlineColumn - (field :: (Symbol, Type)) - (column :: (Symbol, ColumnType)) where - -- | Haskell record field as a inline column - inlineColumn - :: SOP.P field - -> Aliased (Optional (Expression grp lat with db params from)) column -instance (KnownSymbol col, InlineParam x ty) - => InlineColumn (col ::: x) (col ::: 'NoDef :=> ty) where - inlineColumn (SOP.P x) = Set (inlineParam x) `as` (Alias @col) -instance (KnownSymbol col, InlineParam x ty) - => InlineColumn - (col ::: Optional SOP.I ('Def :=> x)) - (col ::: 'Def :=> ty) where - inlineColumn (SOP.P optional) = case optional of - Default -> Default `as` (Alias @col) - Set (SOP.I x) -> Set (inlineParam x) `as` (Alias @col) - --- | Inline a Haskell record as a list of columns. -inlineColumns - :: ( SOP.IsRecord hask xs - , SOP.AllZip InlineColumn xs columns ) - => hask -- ^ record - -> NP (Aliased (Optional (Expression 'Ungrouped '[] with db params '[]))) columns -inlineColumns - = SOP.htrans (SOP.Proxy @InlineColumn) inlineColumn - . SOP.toRecord diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Json.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Json.hs deleted file mode 100644 index b91ccc08..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Json.hs +++ /dev/null @@ -1,484 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Expression.Json -Description: json and jsonb functions and operators -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -json and jsonb functions and operators --} - -{-# LANGUAGE - DataKinds - , FlexibleContexts - , FlexibleInstances - , GADTs - , OverloadedLabels - , OverloadedStrings - , PolyKinds - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeOperators - , UndecidableInstances - , UndecidableSuperClasses -#-} - -module Squeal.PostgreSQL.Expression.Json - ( -- * Json and Jsonb Operators - (.->) - , (.->>) - , (.#>) - , (.#>>) - -- * Jsonb Operators - , (.?) - , (.?|) - , (.?&) - , (.-.) - , (#-.) - -- * Json and Jsonb Functions - , toJson - , toJsonb - , arrayToJson - , rowToJson - , jsonBuildArray - , jsonbBuildArray - , JsonBuildObject (..) - , jsonObject - , jsonbObject - , jsonZipObject - , jsonbZipObject - , jsonArrayLength - , jsonbArrayLength - , jsonTypeof - , jsonbTypeof - , jsonStripNulls - , jsonbStripNulls - , jsonbSet - , jsonbInsert - , jsonbPretty - -- * Json and Jsonb Set Functions - , jsonEach - , jsonbEach - , jsonEachText - , jsonArrayElementsText - , jsonbEachText - , jsonbArrayElementsText - , jsonObjectKeys - , jsonbObjectKeys - , JsonPopulateFunction - , jsonPopulateRecord - , jsonbPopulateRecord - , jsonPopulateRecordSet - , jsonbPopulateRecordSet - , JsonToRecordFunction - , jsonToRecord - , jsonbToRecord - , jsonToRecordSet - , jsonbToRecordSet - ) where - -import Data.ByteString (ByteString) -import GHC.TypeLits - -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Expression.Type -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Query.From -import Squeal.PostgreSQL.Query.From.Set -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema - -import qualified Generics.SOP as SOP - --- $setup --- >>> import Squeal.PostgreSQL --- >>> import Data.Aeson - -{----------------------------------------- - -- json and jsonb support - -See https://www.postgresql.org/docs/10/static/functions-json.html -- most -comments lifted directly from this page. - -Table 9.44: json and jsonb operators ------------------------------------------} - --- | Get JSON value (object field or array element) at a key. -(.->) - :: (json `In` PGJsonType, key `In` PGJsonKey) - => Operator (null json) (null key) ('Null json) -infixl 8 .-> -(.->) = unsafeBinaryOp "->" - --- | Get JSON value (object field or array element) at a key, as text. -(.->>) - :: (json `In` PGJsonType, key `In` PGJsonKey) - => Operator (null json) (null key) ('Null 'PGtext) -infixl 8 .->> -(.->>) = unsafeBinaryOp "->>" - --- | Get JSON value at a specified path. -(.#>) - :: json `In` PGJsonType - => Operator (null json) (null ('PGvararray ('NotNull 'PGtext))) ('Null json) -infixl 8 .#> -(.#>) = unsafeBinaryOp "#>" - --- | Get JSON value at a specified path as text. -(.#>>) - :: json `In` PGJsonType - => Operator (null json) (null ('PGvararray ('NotNull 'PGtext))) ('Null 'PGtext) -infixl 8 .#>> -(.#>>) = unsafeBinaryOp "#>>" - --- Additional jsonb operators - --- | Does the string exist as a top-level key within the JSON value? -(.?) :: Operator (null 'PGjsonb) (null 'PGtext) ('Null 'PGbool) -infixl 9 .? -(.?) = unsafeBinaryOp "?" - --- | Do any of these array strings exist as top-level keys? -(.?|) :: Operator - (null 'PGjsonb) - (null ('PGvararray ('NotNull 'PGtext))) - ('Null 'PGbool) -infixl 9 .?| -(.?|) = unsafeBinaryOp "?|" - --- | Do all of these array strings exist as top-level keys? -(.?&) :: Operator - (null 'PGjsonb) - (null ('PGvararray ('NotNull 'PGtext))) - ('Null 'PGbool) -infixl 9 .?& -(.?&) = unsafeBinaryOp "?&" - --- | Delete a key or keys from a JSON object, or remove an array element. --- --- If the right operand is --- --- @ text @: Delete key / value pair or string element from left operand. --- Key / value pairs are matched based on their key value, --- --- @ text[] @: Delete multiple key / value pairs or string elements --- from left operand. Key / value pairs are matched based on their key value, --- --- @ integer @: Delete the array element with specified index (Negative integers --- count from the end). Throws an error if top level container is not an array. -(.-.) - :: key `In` '[ 'PGtext, 'PGvararray ('NotNull 'PGtext), 'PGint4, 'PGint2 ] - => Operator (null 'PGjsonb) (null key) (null 'PGjsonb) -infixl 6 .-. -(.-.) = unsafeBinaryOp "-" - --- | Delete the field or element with specified path (for JSON arrays, negative --- integers count from the end) -(#-.) :: Operator (null 'PGjsonb) (null ('PGvararray ('NotNull 'PGtext))) (null 'PGjsonb) -infixl 6 #-. -(#-.) = unsafeBinaryOp "#-" - -{----------------------------------------- -Table 9.45: JSON creation functions ------------------------------------------} - --- | Returns the value as json. Arrays and composites are converted --- (recursively) to arrays and objects; otherwise, if there is a cast from the --- type to json, the cast function will be used to perform the conversion; --- otherwise, a scalar value is produced. For any scalar type other than a --- number, a Boolean, or a null value, the text representation will be used, in --- such a fashion that it is a valid json value. -toJson :: null ty --> null 'PGjson -toJson = unsafeFunction "to_json" - --- | Returns the value as jsonb. Arrays and composites are converted --- (recursively) to arrays and objects; otherwise, if there is a cast from the --- type to json, the cast function will be used to perform the conversion; --- otherwise, a scalar value is produced. For any scalar type other than a --- number, a Boolean, or a null value, the text representation will be used, in --- such a fashion that it is a valid jsonb value. -toJsonb :: null ty --> null 'PGjsonb -toJsonb = unsafeFunction "to_jsonb" - --- | Returns the array as a JSON array. A PostgreSQL multidimensional array --- becomes a JSON array of arrays. -arrayToJson :: null ('PGvararray ty) --> null 'PGjson -arrayToJson = unsafeFunction "array_to_json" - --- | Returns the row as a JSON object. -rowToJson :: null ('PGcomposite ty) --> null 'PGjson -rowToJson = unsafeFunction "row_to_json" - --- | Builds a possibly-heterogeneously-typed JSON array out of a variadic --- argument list. -jsonBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjson -jsonBuildArray = unsafeFunctionN "json_build_array" - --- | Builds a possibly-heterogeneously-typed (binary) JSON array out of a --- variadic argument list. -jsonbBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjsonb -jsonbBuildArray = unsafeFunctionN "jsonb_build_array" - --- | Builds a possibly-heterogeneously-typed JSON object out of a variadic --- argument list. The elements of the argument list must alternate between text --- and values. -class SOP.SListI tys => JsonBuildObject tys where - - jsonBuildObject :: tys ---> null 'PGjson - jsonBuildObject = unsafeFunctionN "json_build_object" - - jsonbBuildObject :: tys ---> null 'PGjsonb - jsonbBuildObject = unsafeFunctionN "jsonb_build_object" - -instance JsonBuildObject '[] -instance (JsonBuildObject tys, key `In` PGJsonKey) - => JsonBuildObject ('NotNull key ': value ': tys) - --- | Builds a JSON object out of a text array. --- The array must have two dimensions --- such that each inner array has exactly two elements, --- which are taken as a key/value pair. -jsonObject - :: null ('PGfixarray '[n,2] ('NotNull 'PGtext)) - --> null 'PGjson -jsonObject = unsafeFunction "json_object" - --- | Builds a binary JSON object out of a text array. --- The array must have two dimensions --- such that each inner array has exactly two elements, --- which are taken as a key/value pair. -jsonbObject - :: null ('PGfixarray '[n,2] ('NotNull 'PGtext)) - --> null 'PGjsonb -jsonbObject = unsafeFunction "jsonb_object" - --- | This is an alternate form of 'jsonObject' that takes two arrays; one for --- keys and one for values, that are zipped pairwise to create a JSON object. -jsonZipObject :: - '[ null ('PGvararray ('NotNull 'PGtext)) - , null ('PGvararray ('NotNull 'PGtext)) ] - ---> null 'PGjson -jsonZipObject = unsafeFunctionN "json_object" - --- | This is an alternate form of 'jsonbObject' that takes two arrays; one for --- keys and one for values, that are zipped pairwise to create a binary JSON --- object. -jsonbZipObject :: - '[ null ('PGvararray ('NotNull 'PGtext)) - , null ('PGvararray ('NotNull 'PGtext)) ] - ---> null 'PGjsonb -jsonbZipObject = unsafeFunctionN "jsonb_object" - -{----------------------------------------- -Table 9.46: JSON processing functions ------------------------------------------} - --- | Returns the number of elements in the outermost JSON array. -jsonArrayLength :: null 'PGjson --> null 'PGint4 -jsonArrayLength = unsafeFunction "json_array_length" - --- | Returns the number of elements in the outermost binary JSON array. -jsonbArrayLength :: null 'PGjsonb --> null 'PGint4 -jsonbArrayLength = unsafeFunction "jsonb_array_length" - --- | Returns the type of the outermost JSON value as a text string. Possible --- types are object, array, string, number, boolean, and null. -jsonTypeof :: null 'PGjson --> null 'PGtext -jsonTypeof = unsafeFunction "json_typeof" - --- | Returns the type of the outermost binary JSON value as a text string. --- Possible types are object, array, string, number, boolean, and null. -jsonbTypeof :: null 'PGjsonb --> null 'PGtext -jsonbTypeof = unsafeFunction "jsonb_typeof" - --- | Returns its argument with all object fields that have null values omitted. --- Other null values are untouched. -jsonStripNulls :: null 'PGjson --> null 'PGjson -jsonStripNulls = unsafeFunction "json_strip_nulls" - --- | Returns its argument with all object fields that have null values omitted. --- Other null values are untouched. -jsonbStripNulls :: null 'PGjsonb --> null 'PGjsonb -jsonbStripNulls = unsafeFunction "jsonb_strip_nulls" - --- | @ jsonbSet target path new_value create_missing @ --- --- Returns target with the section designated by path replaced by @new_value@, --- or with @new_value@ added if create_missing is --- `Squeal.PostgreSQL.Expression.Logic.true` and the --- item designated by path does not exist. As with the path orientated --- operators, negative integers that appear in path count from the end of JSON --- arrays. -jsonbSet :: - '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext)) - , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb -jsonbSet = unsafeFunctionN "jsonbSet" - --- | @ jsonbInsert target path new_value insert_after @ --- --- Returns target with @new_value@ inserted. If target section designated by --- path is in a JSONB array, @new_value@ will be inserted before target or after --- if @insert_after@ is `Squeal.PostgreSQL.Expression.Logic.true`. --- If target section designated by --- path is in JSONB object, @new_value@ will be inserted only if target does not --- exist. As with the path orientated operators, negative integers that appear --- in path count from the end of JSON arrays. -jsonbInsert :: - '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext)) - , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb -jsonbInsert = unsafeFunctionN "jsonb_insert" - --- | Returns its argument as indented JSON text. -jsonbPretty :: null 'PGjsonb --> null 'PGtext -jsonbPretty = unsafeFunction "jsonb_pretty" - -{- | Expands the outermost JSON object into a set of key/value pairs. - ->>> printSQL (select Star (from (jsonEach (inline (Json (object ["a" .= "foo", "b" .= "bar"])))))) -SELECT * FROM json_each(('{"a":"foo","b":"bar"}' :: json)) --} -jsonEach :: null 'PGjson -|-> - ("json_each" ::: '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]) -jsonEach = unsafeSetFunction "json_each" - -{- | Expands the outermost binary JSON object into a set of key/value pairs. - ->>> printSQL (select Star (from (jsonbEach (inline (Jsonb (object ["a" .= "foo", "b" .= "bar"])))))) -SELECT * FROM jsonb_each(('{"a":"foo","b":"bar"}' :: jsonb)) --} -jsonbEach - :: null 'PGjsonb -|-> - ("jsonb_each" ::: '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]) -jsonbEach = unsafeSetFunction "jsonb_each" - -{- | Expands the outermost JSON object into a set of key/value pairs. - ->>> printSQL (select Star (from (jsonEachText (inline (Json (object ["a" .= "foo", "b" .= "bar"])))))) -SELECT * FROM json_each_text(('{"a":"foo","b":"bar"}' :: json)) --} -jsonEachText - :: null 'PGjson -|-> - ("json_each_text" ::: '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]) -jsonEachText = unsafeSetFunction "json_each_text" - -{- | Returns a set of text values from a JSON array - ->>> printSQL (select Star (from (jsonArrayElementsText (inline (Json (toJSON ["monkey", "pony", "bear"] )))))) -SELECT * FROM json_array_elements_text(('["monkey","pony","bear"]' :: json)) --} -jsonArrayElementsText - :: null 'PGjson -|-> - ("json_array_elements_text" ::: '["value" ::: 'NotNull 'PGtext]) -jsonArrayElementsText = unsafeSetFunction "json_array_elements_text" - -{- | Expands the outermost binary JSON object into a set of key/value pairs. - ->>> printSQL (select Star (from (jsonbEachText (inline (Jsonb (object ["a" .= "foo", "b" .= "bar"])))))) -SELECT * FROM jsonb_each_text(('{"a":"foo","b":"bar"}' :: jsonb)) --} -jsonbEachText - :: null 'PGjsonb -|-> - ("jsonb_each_text" ::: '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]) -jsonbEachText = unsafeSetFunction "jsonb_each_text" - -{- | Returns set of keys in the outermost JSON object. - ->>> printSQL (jsonObjectKeys (inline (Json (object ["a" .= "foo", "b" .= "bar"])))) -json_object_keys(('{"a":"foo","b":"bar"}' :: json)) --} -jsonObjectKeys - :: null 'PGjson -|-> - ("json_object_keys" ::: '["json_object_keys" ::: 'NotNull 'PGtext]) -jsonObjectKeys = unsafeSetFunction "json_object_keys" - -{- | Returns set of keys in the outermost JSON object. - ->>> printSQL (jsonbObjectKeys (inline (Jsonb (object ["a" .= "foo", "b" .= "bar"])))) -jsonb_object_keys(('{"a":"foo","b":"bar"}' :: jsonb)) --} -jsonbObjectKeys - :: null 'PGjsonb -|-> - ("jsonb_object_keys" ::: '["jsonb_object_keys" ::: 'NotNull 'PGtext]) -jsonbObjectKeys = unsafeSetFunction "jsonb_object_keys" - -{- | Returns a set of text values from a binary JSON array - ->>> printSQL (select Star (from (jsonbArrayElementsText (inline (Jsonb (toJSON ["red", "green", "cyan"] )))))) -SELECT * FROM jsonb_array_elements_text(('["red","green","cyan"]' :: jsonb)) --} -jsonbArrayElementsText - :: null 'PGjsonb -|-> - ("jsonb_array_elements_text" ::: '["value" ::: 'NotNull 'PGtext]) -jsonbArrayElementsText = unsafeSetFunction "jsonb_array_elements_text" - --- | Build rows from Json types. -type JsonPopulateFunction fun json - = forall db row lat with params - . json `In` PGJsonType - => TypeExpression db ('NotNull ('PGcomposite row)) -- ^ row type - -> Expression 'Ungrouped lat with db params '[] ('NotNull json) - -- ^ json type - -> FromClause lat with db params '[fun ::: row] - -unsafePopulateFunction - :: forall fun ty - . KnownSymbol fun => Alias fun -> JsonPopulateFunction fun ty -unsafePopulateFunction _fun ty expr = UnsafeFromClause $ renderSymbol @fun - <> parenthesized ("null::" <> renderSQL ty <> ", " <> renderSQL expr) - --- | Expands the JSON expression to a row whose columns match the record --- type defined by the given table. -jsonPopulateRecord :: JsonPopulateFunction "json_populate_record" 'PGjson -jsonPopulateRecord = unsafePopulateFunction #json_populate_record - --- | Expands the binary JSON expression to a row whose columns match the record --- type defined by the given table. -jsonbPopulateRecord :: JsonPopulateFunction "jsonb_populate_record" 'PGjsonb -jsonbPopulateRecord = unsafePopulateFunction #jsonb_populate_record - --- | Expands the outermost array of objects in the given JSON expression to a --- set of rows whose columns match the record type defined by the given table. -jsonPopulateRecordSet :: JsonPopulateFunction "json_populate_record_set" 'PGjson -jsonPopulateRecordSet = unsafePopulateFunction #json_populate_record_set - --- | Expands the outermost array of objects in the given binary JSON expression --- to a set of rows whose columns match the record type defined by the given --- table. -jsonbPopulateRecordSet :: JsonPopulateFunction "jsonb_populate_record_set" 'PGjsonb -jsonbPopulateRecordSet = unsafePopulateFunction #jsonb_populate_record_set - --- | Build rows from Json types. -type JsonToRecordFunction json - = forall lat with db params tab row - . (SOP.SListI row, json `In` PGJsonType) - => Expression 'Ungrouped lat with db params '[] ('NotNull json) - -- ^ json type - -> Aliased (NP (Aliased (TypeExpression db))) (tab ::: row) - -- ^ row type - -> FromClause lat with db params '[tab ::: row] - -unsafeRecordFunction :: ByteString -> JsonToRecordFunction json -unsafeRecordFunction fun expr (types `As` tab) = UnsafeFromClause $ - fun <> parenthesized (renderSQL expr) <+> "AS" <+> renderSQL tab - <> parenthesized (renderCommaSeparated renderTy types) - where - renderTy :: Aliased (TypeExpression db) ty -> ByteString - renderTy (ty `As` alias) = renderSQL alias <+> renderSQL ty - --- | Builds an arbitrary record from a JSON object. -jsonToRecord :: JsonToRecordFunction 'PGjson -jsonToRecord = unsafeRecordFunction "json_to_record" - --- | Builds an arbitrary record from a binary JSON object. -jsonbToRecord :: JsonToRecordFunction 'PGjsonb -jsonbToRecord = unsafeRecordFunction "jsonb_to_record" - --- | Builds an arbitrary set of records from a JSON array of objects. -jsonToRecordSet :: JsonToRecordFunction 'PGjson -jsonToRecordSet = unsafeRecordFunction "json_to_record_set" - --- | Builds an arbitrary set of records from a binary JSON array of objects. -jsonbToRecordSet :: JsonToRecordFunction 'PGjsonb -jsonbToRecordSet = unsafeRecordFunction "jsonb_to_record_set" diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Logic.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Logic.hs deleted file mode 100644 index 9b405865..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Logic.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Expression.Logic -Description: logical expressions and operators -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -logical expressions and operators --} - -{-# LANGUAGE - DataKinds - , OverloadedStrings - , TypeOperators -#-} - -module Squeal.PostgreSQL.Expression.Logic - ( -- * Condition - Condition - , true - , false - -- * Logic - , not_ - , (.&&) - , (.||) - -- * Conditional - , caseWhenThenElse - , ifThenElse - ) where - -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema - --- | A `Condition` is an `Expression`, which can evaluate --- to `true`, `false` or `Squeal.PostgreSQL.Null.null_`. This is because SQL uses --- a three valued logic. -type Condition grp lat with db params from = - Expression grp lat with db params from ('Null 'PGbool) - --- | >>> printSQL true --- TRUE -true :: Expr (null 'PGbool) -true = UnsafeExpression "TRUE" - --- | >>> printSQL false --- FALSE -false :: Expr (null 'PGbool) -false = UnsafeExpression "FALSE" - --- | >>> printSQL $ not_ true --- (NOT TRUE) -not_ :: null 'PGbool --> null 'PGbool -not_ = unsafeLeftOp "NOT" - --- | >>> printSQL $ true .&& false --- (TRUE AND FALSE) -(.&&) :: Operator (null 'PGbool) (null 'PGbool) (null 'PGbool) -infixr 3 .&& -(.&&) = unsafeBinaryOp "AND" - --- | >>> printSQL $ true .|| false --- (TRUE OR FALSE) -(.||) :: Operator (null 'PGbool) (null 'PGbool) (null 'PGbool) -infixr 2 .|| -(.||) = unsafeBinaryOp "OR" - --- | >>> :{ --- let --- expression :: Expression grp lat with db params from (null 'PGint2) --- expression = caseWhenThenElse [(true, 1), (false, 2)] 3 --- in printSQL expression --- :} --- CASE WHEN TRUE THEN (1 :: int2) WHEN FALSE THEN (2 :: int2) ELSE (3 :: int2) END -caseWhenThenElse - :: [ ( Condition grp lat with db params from - , Expression grp lat with db params from ty - ) ] - -- ^ whens and thens - -> Expression grp lat with db params from ty - -- ^ else - -> Expression grp lat with db params from ty -caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat - [ "CASE" - , mconcat - [ mconcat - [ " WHEN ", renderSQL when_ - , " THEN ", renderSQL then_ - ] - | (when_,then_) <- whenThens - ] - , " ELSE ", renderSQL else_ - , " END" - ] - --- | >>> :{ --- let --- expression :: Expression grp lat with db params from (null 'PGint2) --- expression = ifThenElse true 1 0 --- in printSQL expression --- :} --- CASE WHEN TRUE THEN (1 :: int2) ELSE (0 :: int2) END -ifThenElse - :: Condition grp lat with db params from - -> Expression grp lat with db params from ty -- ^ then - -> Expression grp lat with db params from ty -- ^ else - -> Expression grp lat with db params from ty -ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_ diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Math.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Math.hs deleted file mode 100644 index f1d589a4..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Math.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Expression.Math -Description: math functions -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -math functions --} - -{-# LANGUAGE - DataKinds - , OverloadedStrings - , TypeOperators -#-} - -module Squeal.PostgreSQL.Expression.Math - ( -- * Math Function - atan2_ - , quot_ - , rem_ - , trunc - , round_ - , ceiling_ - ) where - -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL - --- | >>> :{ --- let --- expression :: Expr (null 'PGfloat4) --- expression = atan2_ (pi *: 2) --- in printSQL expression --- :} --- atan2(pi(), (2.0 :: float4)) -atan2_ :: float `In` PGFloating => '[ null float, null float] ---> null float -atan2_ = unsafeFunctionN "atan2" - - --- | integer division, truncates the result --- --- >>> :{ --- let --- expression :: Expression grp lat with db params from (null 'PGint2) --- expression = 5 `quot_` 2 --- in printSQL expression --- :} --- ((5 :: int2) / (2 :: int2)) -quot_ - :: int `In` PGIntegral - => Operator (null int) (null int) (null int) -quot_ = unsafeBinaryOp "/" - --- | remainder upon integer division --- --- >>> :{ --- let --- expression :: Expression grp lat with db params from (null 'PGint2) --- expression = 5 `rem_` 2 --- in printSQL expression --- :} --- ((5 :: int2) % (2 :: int2)) -rem_ - :: int `In` PGIntegral - => Operator (null int) (null int) (null int) -rem_ = unsafeBinaryOp "%" - --- | >>> :{ --- let --- expression :: Expression grp lat with db params from (null 'PGfloat4) --- expression = trunc pi --- in printSQL expression --- :} --- trunc(pi()) -trunc :: frac `In` PGFloating => null frac --> null frac -trunc = unsafeFunction "trunc" - --- | >>> :{ --- let --- expression :: Expression grp lat with db params from (null 'PGfloat4) --- expression = round_ pi --- in printSQL expression --- :} --- round(pi()) -round_ :: frac `In` PGFloating => null frac --> null frac -round_ = unsafeFunction "round" - --- | >>> :{ --- let --- expression :: Expression grp lat with db params from (null 'PGfloat4) --- expression = ceiling_ pi --- in printSQL expression --- :} --- ceiling(pi()) -ceiling_ :: frac `In` PGFloating => null frac --> null frac -ceiling_ = unsafeFunction "ceiling" diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Null.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Null.hs deleted file mode 100644 index 6f38dede..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Null.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Expression.Null -Description: null expressions and handlers -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -null expressions and handlers --} - -{-# LANGUAGE - DataKinds - , KindSignatures - , OverloadedStrings - , RankNTypes - , TypeFamilies - , TypeOperators -#-} - -module Squeal.PostgreSQL.Expression.Null - ( -- * Null - null_ - , notNull - , unsafeNotNull - , monoNotNull - , coalesce - , fromNull - , isNull - , isNotNull - , matchNull - , nullIf - , CombineNullity - ) where - -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Expression.Logic -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL - --- | analagous to `Nothing` --- --- >>> printSQL null_ --- NULL -null_ :: Expr ('Null ty) -null_ = UnsafeExpression "NULL" - --- | analagous to `Just` --- --- >>> printSQL $ notNull true --- TRUE -notNull :: 'NotNull ty --> 'Null ty -notNull = UnsafeExpression . renderSQL - --- | Analagous to `Data.Maybe.fromJust` inverse to `notNull`, --- useful when you know an `Expression` is `NotNull`, --- because, for instance, you've filtered out @NULL@ --- values in a column. -unsafeNotNull :: 'Null ty --> 'NotNull ty -unsafeNotNull = UnsafeExpression . renderSQL - --- | Some expressions are null polymorphic which may raise --- inference issues. Use `monoNotNull` to fix their --- nullity as `NotNull`. -monoNotNull - :: (forall null. Expression grp lat with db params from (null ty)) - -- ^ null polymorphic - -> Expression grp lat with db params from ('NotNull ty) -monoNotNull = id - --- | return the leftmost value which is not NULL --- --- >>> printSQL $ coalesce [null_, true] false --- COALESCE(NULL, TRUE, FALSE) -coalesce :: FunctionVar ('Null ty) (null ty) (null ty) -coalesce nullxs notNullx = UnsafeExpression $ - "COALESCE" <> parenthesized (commaSeparated - ((renderSQL <$> nullxs) <> [renderSQL notNullx])) - --- | analagous to `Data.Maybe.fromMaybe` using @COALESCE@ --- --- >>> printSQL $ fromNull true null_ --- COALESCE(NULL, TRUE) -fromNull - :: Expression grp lat with db params from ('NotNull ty) - -- ^ what to convert @NULL@ to - -> Expression grp lat with db params from ('Null ty) - -> Expression grp lat with db params from ('NotNull ty) -fromNull notNullx nullx = coalesce [nullx] notNullx - --- | >>> printSQL $ null_ & isNull --- NULL IS NULL -isNull :: 'Null ty --> null 'PGbool -isNull x = UnsafeExpression $ renderSQL x <+> "IS NULL" - --- | >>> printSQL $ null_ & isNotNull --- NULL IS NOT NULL -isNotNull :: 'Null ty --> null 'PGbool -isNotNull x = UnsafeExpression $ renderSQL x <+> "IS NOT NULL" - --- | analagous to `maybe` using @IS NULL@ --- --- >>> printSQL $ matchNull true not_ null_ --- CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END -matchNull - :: Expression grp lat with db params from (nullty) - -- ^ what to convert @NULL@ to - -> ( Expression grp lat with db params from ('NotNull ty) - -> Expression grp lat with db params from (nullty) ) - -- ^ function to perform when @NULL@ is absent - -> Expression grp lat with db params from ('Null ty) - -> Expression grp lat with db params from (nullty) -matchNull y f x = ifThenElse (isNull x) y - (f (UnsafeExpression (renderSQL x))) - -{-| right inverse to `fromNull`, if its arguments are equal then -`nullIf` gives @NULL@. - ->>> :set -XTypeApplications ->>> printSQL (nullIf (false *: param @1)) -NULLIF(FALSE, ($1 :: bool)) --} -nullIf :: '[ 'NotNull ty, 'NotNull ty] ---> 'Null ty -nullIf = unsafeFunctionN "NULLIF" - -{-| Make the return type of the type family `NotNull` if both arguments are, - or `Null` otherwise. --} -type family CombineNullity - (lhs :: PGType -> NullType) (rhs :: PGType -> NullType) :: PGType -> NullType where - CombineNullity 'NotNull 'NotNull = 'NotNull - CombineNullity _ _ = 'Null diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Parameter.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Parameter.hs deleted file mode 100644 index 8be9bca0..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Parameter.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Expression.Parameter -Description: out-of-line parameters -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -out-of-line parameters --} - -{-# LANGUAGE - AllowAmbiguousTypes - , DataKinds - , FlexibleContexts - , FlexibleInstances - , FunctionalDependencies - , GADTs - , KindSignatures - , MultiParamTypeClasses - , OverloadedStrings - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeFamilies - , TypeOperators - , UndecidableInstances -#-} - -module Squeal.PostgreSQL.Expression.Parameter - ( -- * Parameter - HasParameter (parameter) - , param - ) where - -import Data.Kind (Constraint) -import GHC.Exts (Any) -import GHC.TypeLits - -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Expression.Type -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL - -{- | A `HasParameter` constraint is used to indicate a value that is -supplied externally to a SQL statement. -`Squeal.PostgreSQL.Session.manipulateParams`, -`Squeal.PostgreSQL.Session.queryParams` and -`Squeal.PostgreSQL.Session.traversePrepared` support specifying data values -separately from the SQL command string, in which case `param`s are used to -refer to the out-of-line data values. --} -class KnownNat ix => HasParameter - (ix :: Nat) - (params :: [NullType]) - (ty :: NullType) - | ix params -> ty where - -- | `parameter` takes a `Nat` using type application and a `TypeExpression`. - -- - -- >>> printSQL (parameter @1 int4) - -- ($1 :: int4) - parameter - :: TypeExpression db ty - -> Expression grp lat with db params from ty - parameter ty = UnsafeExpression $ parenthesized $ - "$" <> renderNat @ix <+> "::" - <+> renderSQL ty - --- we could do the check for 0 in @HasParameter'@, but this way forces checking 'ix' before delegating, --- which has the nice effect of ambiguous 'ix' errors mentioning 'HasParameter' instead of @HasParameter'@ -instance {-# OVERLAPS #-} (TypeError ('Text "Tried to get the param at index 0, but params are 1-indexed"), x ~ Any) => HasParameter 0 params x -instance {-# OVERLAPS #-} (KnownNat ix, HasParameter' ix params ix params x) => HasParameter ix params x - --- | @HasParameter'@ is an implementation detail of 'HasParameter' allowing us to --- include the full parameter list in our errors. Generally speaking it shouldn't leak to users --- of the library -class KnownNat ix => HasParameter' - (originalIx :: Nat) - (allParams :: [NullType]) - (ix :: Nat) - (params :: [NullType]) - (ty :: NullType) - | ix params -> ty where -instance {-# OVERLAPS #-} - ( params ~ (y ': xs) - , y ~ x -- having a separate 'y' type variable is required for 'ParamTypeMismatchError' - , ParamOutOfBoundsError originalIx allParams params - , ParamTypeMismatchError originalIx allParams x y - ) => HasParameter' originalIx allParams 1 params x -instance {-# OVERLAPS #-} - ( KnownNat ix - , HasParameter' originalIx allParams (ix-1) xs x - , params ~ (y ': xs) - , ParamOutOfBoundsError originalIx allParams params - ) - => HasParameter' originalIx allParams ix params x - --- | @ParamOutOfBoundsError@ reports a nicer error with more context when we try to do an out-of-bounds lookup successfully do a lookup but --- find a different field than we expected, or when we find ourself out of bounds -type family ParamOutOfBoundsError (originalIx :: Nat) (allParams :: [NullType]) (params :: [NullType]) :: Constraint where - ParamOutOfBoundsError originalIx allParams '[] = TypeError - ('Text "Index " ':<>: 'ShowType originalIx ':<>: 'Text " is out of bounds in 1-indexed parameter list:" ':$$: 'ShowType allParams) - ParamOutOfBoundsError _ _ _ = () - --- | @ParamTypeMismatchError@ reports a nicer error with more context when we successfully do a lookup but --- find a different field than we expected, or when we find ourself out of bounds -type family ParamTypeMismatchError (originalIx :: Nat) (allParams :: [NullType]) (found :: NullType) (expected :: NullType) :: Constraint where - ParamTypeMismatchError _ _ found found = () - ParamTypeMismatchError originalIx allParams found expected = TypeError - ( 'Text "Type mismatch when looking up param at index " ':<>: 'ShowType originalIx - ':$$: 'Text "in 1-indexed parameter list:" - ':$$: 'Text " " ':<>: 'ShowType allParams - ':$$: 'Text "" - ':$$: 'Text "Expected: " ':<>: 'ShowType expected - ':$$: 'Text "But found: " ':<>: 'ShowType found - ':$$: 'Text "" - ) - --- | `param` takes a `Nat` using type application and for basic types, --- infers a `TypeExpression`. --- --- >>> printSQL (param @1 @('Null 'PGint4)) --- ($1 :: int4) -param - :: forall n ty lat with db params from grp - . (NullTyped db ty, HasParameter n params ty) - => Expression grp lat with db params from ty -- ^ param -param = parameter @n (nulltype @db) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Range.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Range.hs deleted file mode 100644 index 5c0aa315..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Range.hs +++ /dev/null @@ -1,227 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Expression.Range -Description: range types and functions -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -range types and functions --} - -{-# LANGUAGE - AllowAmbiguousTypes - , DataKinds - , DeriveAnyClass - , DeriveGeneric - , DeriveFoldable - , DerivingStrategies - , DeriveTraversable - , FlexibleContexts - , FlexibleInstances - , LambdaCase - , MultiParamTypeClasses - , OverloadedLabels - , OverloadedStrings - , PatternSynonyms - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeFamilies - , TypeOperators - , UndecidableInstances -#-} - -module Squeal.PostgreSQL.Expression.Range - ( -- * Range - Range (..) - , (<=..<=), (<..<), (<=..<), (<..<=) - , moreThan, atLeast, lessThan, atMost - , singleton, whole - , Bound (..) - -- * Range Function - -- ** Range Construction - , range - -- ** Range Operator - , (.<@) - , (@>.) - , (<<@) - , (@>>) - , (&<) - , (&>) - , (-|-) - , (@+) - , (@*) - , (@-) - -- ** Range Function - , lowerBound - , upperBound - , isEmpty - , lowerInc - , lowerInf - , upperInc - , upperInf - , rangeMerge - ) where - -import qualified GHC.Generics as GHC -import qualified Generics.SOP as SOP - -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Expression.Type hiding (bool) -import Squeal.PostgreSQL.Type.PG -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL (tstzrange, numrange, int4range, now, printSQL) - --- | Construct a `range` --- --- >>> printSQL $ range tstzrange (atLeast now) --- tstzrange(now(), NULL, '[)') --- >>> printSQL $ range numrange (0 <=..< 2*pi) --- numrange((0.0 :: numeric), ((2.0 :: numeric) * pi()), '[)') --- >>> printSQL $ range int4range Empty --- ('empty' :: int4range) -range - :: TypeExpression db (null ('PGrange ty)) - -- ^ range type - -> Range (Expression grp lat with db params from ('NotNull ty)) - -- ^ range of values - -> Expression grp lat with db params from (null ('PGrange ty)) -range ty = \case - Empty -> UnsafeExpression $ parenthesized - (emp <+> "::" <+> renderSQL ty) - NonEmpty l u -> UnsafeExpression $ renderSQL ty <> parenthesized - (commaSeparated (args l u)) - where - emp = singleQuote <> "empty" <> singleQuote - args l u = [arg l, arg u, singleQuote <> bra l <> ket u <> singleQuote] - singleQuote = "\'" - arg = \case - Infinite -> "NULL"; Closed x -> renderSQL x; Open x -> renderSQL x - bra = \case Infinite -> "("; Closed _ -> "["; Open _ -> "(" - ket = \case Infinite -> ")"; Closed _ -> "]"; Open _ -> ")" - --- | The type of `Bound` for a `Range`. -data Bound x - = Infinite -- ^ unbounded - | Closed x -- ^ inclusive - | Open x -- ^ exclusive - deriving - ( Eq, Ord, Show, Read, GHC.Generic - , Functor, Foldable, Traversable ) - --- | A `Range` datatype that comprises connected subsets of --- the real line. -data Range x = Empty | NonEmpty (Bound x) (Bound x) - deriving - ( Eq, Ord, Show, Read, GHC.Generic - , Functor, Foldable, Traversable ) - deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) --- | `PGrange` @(@`PG` @hask)@ -instance IsPG hask => IsPG (Range hask) where - type PG (Range hask) = 'PGrange (PG hask) - --- | Finite `Range` constructor -(<=..<=), (<..<), (<=..<), (<..<=) :: x -> x -> Range x -infix 4 <=..<=, <..<, <=..<, <..<= -x <=..<= y = NonEmpty (Closed x) (Closed y) -x <..< y = NonEmpty (Open x) (Open y) -x <=..< y = NonEmpty (Closed x) (Open y) -x <..<= y = NonEmpty (Open x) (Closed y) - --- | Half-infinite `Range` constructor -moreThan, atLeast, lessThan, atMost :: x -> Range x -moreThan x = NonEmpty (Open x) Infinite -atLeast x = NonEmpty (Closed x) Infinite -lessThan x = NonEmpty Infinite (Open x) -atMost x = NonEmpty Infinite (Closed x) - --- | A point on the line -singleton :: x -> Range x -singleton x = x <=..<= x - --- | The `whole` line -whole :: Range x -whole = NonEmpty Infinite Infinite - --- | range is contained by -(.<@) :: Operator ('NotNull ty) (null ('PGrange ty)) ('Null 'PGbool) -(.<@) = unsafeBinaryOp "<@" - --- | contains range -(@>.) :: Operator (null ('PGrange ty)) ('NotNull ty) ('Null 'PGbool) -(@>.) = unsafeBinaryOp "@>" - --- | strictly left of, --- return false when an empty range is involved -(<<@) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool) -(<<@) = unsafeBinaryOp "<<" - --- | strictly right of, --- return false when an empty range is involved -(@>>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool) -(@>>) = unsafeBinaryOp ">>" - --- | does not extend to the right of, --- return false when an empty range is involved -(&<) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool) -(&<) = unsafeBinaryOp "&<" - --- | does not extend to the left of, --- return false when an empty range is involved -(&>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool) -(&>) = unsafeBinaryOp "&>" - --- | is adjacent to, return false when an empty range is involved -(-|-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool) -(-|-) = unsafeBinaryOp "-|-" - --- | union, will fail if the resulting range would --- need to contain two disjoint sub-ranges -(@+) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty)) -(@+) = unsafeBinaryOp "+" - --- | intersection -(@*) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty)) -(@*) = unsafeBinaryOp "*" - --- | difference, will fail if the resulting range would --- need to contain two disjoint sub-ranges -(@-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty)) -(@-) = unsafeBinaryOp "-" - --- | lower bound of range -lowerBound :: null ('PGrange ty) --> 'Null ty -lowerBound = unsafeFunction "lower" - --- | upper bound of range -upperBound :: null ('PGrange ty) --> 'Null ty -upperBound = unsafeFunction "upper" - --- | is the range empty? -isEmpty :: null ('PGrange ty) --> 'Null 'PGbool -isEmpty = unsafeFunction "isempty" - --- | is the lower bound inclusive? -lowerInc :: null ('PGrange ty) --> 'Null 'PGbool -lowerInc = unsafeFunction "lower_inc" - --- | is the lower bound infinite? -lowerInf :: null ('PGrange ty) --> 'Null 'PGbool -lowerInf = unsafeFunction "lower_inf" - --- | is the upper bound inclusive? -upperInc :: null ('PGrange ty) --> 'Null 'PGbool -upperInc = unsafeFunction "upper_inc" - --- | is the upper bound infinite? -upperInf :: null ('PGrange ty) --> 'Null 'PGbool -upperInf = unsafeFunction "upper_inf" - --- | the smallest range which includes both of the given ranges -rangeMerge :: - '[null ('PGrange ty), null ('PGrange ty)] - ---> null ('PGrange ty) -rangeMerge = unsafeFunctionN "range_merge" diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Sort.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Sort.hs deleted file mode 100644 index 7d631e78..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Sort.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Expression.Sort -Description: sort expressions -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -sort expressions --} - -{-# LANGUAGE - DataKinds - , FlexibleInstances - , FunctionalDependencies - , GADTs - , LambdaCase - , MultiParamTypeClasses - , OverloadedStrings - , StandaloneDeriving -#-} - -module Squeal.PostgreSQL.Expression.Sort - ( -- * Sort - SortExpression (..) - , OrderBy (..) - ) where - -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema - --- | `SortExpression`s are used by `orderBy` to optionally sort the results --- of a `Squeal.PostgreSQL.Query.Query`. `Asc` or `Desc` --- set the sort direction of a `NotNull` result --- column to ascending or descending. Ascending order puts smaller values --- first, where "smaller" is defined in terms of the --- `Squeal.PostgreSQL.Expression.Comparison..<` operator. Similarly, --- descending order is determined with the --- `Squeal.PostgreSQL.Expression.Comparison..>` operator. `AscNullsFirst`, --- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to --- determine whether nulls appear before or after non-null values in the sort --- ordering of a `Null` result column. -data SortExpression grp lat with db params from where - Asc - :: Expression grp lat with db params from ('NotNull ty) - -- ^ sort by - -> SortExpression grp lat with db params from - Desc - :: Expression grp lat with db params from ('NotNull ty) - -- ^ sort by - -> SortExpression grp lat with db params from - AscNullsFirst - :: Expression grp lat with db params from ('Null ty) - -- ^ sort by - -> SortExpression grp lat with db params from - AscNullsLast - :: Expression grp lat with db params from ('Null ty) - -- ^ sort by - -> SortExpression grp lat with db params from - DescNullsFirst - :: Expression grp lat with db params from ('Null ty) - -- ^ sort by - -> SortExpression grp lat with db params from - DescNullsLast - :: Expression grp lat with db params from ('Null ty) - -- ^ sort by - -> SortExpression grp lat with db params from -deriving instance Show (SortExpression grp lat with db params from) -instance RenderSQL (SortExpression grp lat with db params from) where - renderSQL = \case - Asc expression -> renderSQL expression <+> "ASC" - Desc expression -> renderSQL expression <+> "DESC" - AscNullsFirst expression -> renderSQL expression - <+> "ASC NULLS FIRST" - DescNullsFirst expression -> renderSQL expression - <+> "DESC NULLS FIRST" - AscNullsLast expression -> renderSQL expression <+> "ASC NULLS LAST" - DescNullsLast expression -> renderSQL expression <+> "DESC NULLS LAST" -instance RenderSQL [SortExpression grp lat with db params from] where - renderSQL = \case - [] -> "" - srts -> " ORDER BY" - <+> commaSeparated (renderSQL <$> srts) - -{- | -The `orderBy` clause causes the result rows of a `Squeal.PostgreSQL.Query.TableExpression` -to be sorted according to the specified `SortExpression`(s). -If two rows are equal according to the leftmost expression, -they are compared according to the next expression and so on. -If they are equal according to all specified expressions, -they are returned in an implementation-dependent order. - -You can also control the order in which rows are processed by window functions -using `orderBy` within `Squeal.PostgreSQL.Query.Over`. --} -class OrderBy expr grp | expr -> grp where - orderBy - :: [SortExpression grp lat with db params from] - -- ^ sorts - -> expr lat with db params from - -> expr lat with db params from diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Subquery.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Subquery.hs deleted file mode 100644 index e16cf1b7..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Subquery.hs +++ /dev/null @@ -1,124 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Expression.Subquery -Description: subquery expressions -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -subquery expressions --} - -{-# LANGUAGE - DataKinds - , OverloadedStrings - , RankNTypes - , TypeOperators -#-} - -module Squeal.PostgreSQL.Expression.Subquery - ( -- * Subquery - exists - , in_ - , notIn - , subAll - , subAny - ) where - -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Expression.Logic -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Query -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL - -{- | -The argument of `exists` is an arbitrary subquery. The subquery is evaluated -to determine whether it returns any rows. If it returns at least one row, -the result of `exists` is `true`; if the subquery returns no rows, -the result of `exists` is `false`. - -The subquery can refer to variables from the surrounding query, -which will act as constants during any one evaluation of the subquery. - -The subquery will generally only be executed long enough to determine whether -at least one row is returned, not all the way to completion. --} -exists - :: Query (Join lat from) with db params row - -- ^ subquery - -> Expression grp lat with db params from (null 'PGbool) -exists query = UnsafeExpression $ "EXISTS" <+> parenthesized (renderSQL query) - -{- | -The right-hand side is a parenthesized subquery, which must return -exactly one column. The left-hand expression is evaluated and compared to each -row of the subquery result using the given `Operator`, -which must yield a Boolean result. The result of `subAll` is `true` -if all rows yield true (including the case where the subquery returns no rows). -The result is `false` if any `false` result is found. -The result is `Squeal.PostgreSQL.Expression.Null.null_` if - no comparison with a subquery row returns `false`, -and at least one comparison returns `Squeal.PostgreSQL.Expression.Null.null_`. - ->>> printSQL $ subAll true (.==) (values_ (true `as` #foo)) -(TRUE = ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))) --} -subAll - :: Expression grp lat with db params from ty1 -- ^ expression - -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator - -> Query (Join lat from) with db params '[col ::: ty2] -- ^ subquery - -> Condition grp lat with db params from -subAll expr (?) qry = expr ? - (UnsafeExpression $ "ALL" <+> parenthesized (renderSQL qry)) - -{- | -The right-hand side is a parenthesized subquery, which must return exactly one column. -The left-hand expression is evaluated and compared to each row of the subquery result -using the given `Operator`, which must yield a Boolean result. The result of `subAny` is `true` -if any `true` result is obtained. The result is `false` if no true result is found -(including the case where the subquery returns no rows). - ->>> printSQL $ subAny "foo" like (values_ ("foobar" `as` #foo)) -((E'foo' :: text) LIKE ANY (SELECT * FROM (VALUES ((E'foobar' :: text))) AS t ("foo"))) --} -subAny - :: Expression grp lat with db params from ty1 -- ^ expression - -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator - -> Query (Join lat from) with db params '[col ::: ty2] -- ^ subquery - -> Condition grp lat with db params from -subAny expr (?) qry = expr ? - (UnsafeExpression $ "ANY" <+> parenthesized (renderSQL qry)) - -{- | -The result is `true` if the left-hand expression's result is equal -to any of the right-hand expressions. - ->>> printSQL $ true `in_` [true, false, null_] -TRUE IN (TRUE, FALSE, NULL) --} -in_ - :: Expression grp lat with db params from ty -- ^ expression - -> [Expression grp lat with db params from ty] - -> Expression grp lat with db params from ('Null 'PGbool) -_ `in_` [] = false -expr `in_` exprs = UnsafeExpression $ renderSQL expr <+> "IN" - <+> parenthesized (commaSeparated (renderSQL <$> exprs)) - -{- | -The result is `true` if the left-hand expression's result is not equal -to any of the right-hand expressions. - ->>> printSQL $ true `notIn` [false, null_] -TRUE NOT IN (FALSE, NULL) --} -notIn - :: Expression grp lat with db params from ty -- ^ expression - -> [Expression grp lat with db params from ty] - -> Expression grp lat with db params from ('Null 'PGbool) -_ `notIn` [] = true -expr `notIn` exprs = UnsafeExpression $ renderSQL expr <+> "NOT IN" - <+> parenthesized (commaSeparated (renderSQL <$> exprs)) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Text.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Text.hs deleted file mode 100644 index 1d1dedc0..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Text.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Expression.Text -Description: text functions and operators -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -text functions and operators --} - -{-# LANGUAGE - DataKinds - , OverloadedStrings - , RankNTypes - , ScopedTypeVariables - , TypeOperators -#-} - -module Squeal.PostgreSQL.Expression.Text - ( -- * Text Function - lower - , upper - , charLength - , like - , ilike - , replace - , strpos - ) where - -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL - --- | >>> printSQL $ lower "ARRRGGG" --- lower((E'ARRRGGG' :: text)) -lower :: null 'PGtext --> null 'PGtext -lower = unsafeFunction "lower" - --- | >>> printSQL $ upper "eeee" --- upper((E'eeee' :: text)) -upper :: null 'PGtext --> null 'PGtext -upper = unsafeFunction "upper" - --- | >>> printSQL $ charLength "four" --- char_length((E'four' :: text)) -charLength :: null 'PGtext --> null 'PGint4 -charLength = unsafeFunction "char_length" - --- | The `like` expression returns true if the @string@ matches --- the supplied @pattern@. If @pattern@ does not contain percent signs --- or underscores, then the pattern only represents the string itself; --- in that case `like` acts like the equals operator. An underscore (_) --- in pattern stands for (matches) any single character; a percent sign (%) --- matches any sequence of zero or more characters. --- --- >>> printSQL $ "abc" `like` "a%" --- ((E'abc' :: text) LIKE (E'a%' :: text)) -like :: Operator (null 'PGtext) (null 'PGtext) ('Null 'PGbool) -like = unsafeBinaryOp "LIKE" - --- | The key word ILIKE can be used instead of LIKE to make the --- match case-insensitive according to the active locale. --- --- >>> printSQL $ "abc" `ilike` "a%" --- ((E'abc' :: text) ILIKE (E'a%' :: text)) -ilike :: Operator (null 'PGtext) (null 'PGtext) ('Null 'PGbool) -ilike = unsafeBinaryOp "ILIKE" - --- | Determines the location of the substring match using the `strpos` --- function. Returns the 1-based index of the first match, if no --- match exists the function returns (0). --- --- >>> printSQL $ strpos ("string" *: "substring") --- strpos((E'string' :: text), (E'substring' :: text)) -strpos - :: '[null 'PGtext, null 'PGtext] ---> null 'PGint4 -strpos = unsafeFunctionN "strpos" - --- | Over the string in the first argument, replace all occurrences of --- the second argument with the third and return the modified string. --- --- >>> printSQL $ replace ("string" :* "from" *: "to") --- replace((E'string' :: text), (E'from' :: text), (E'to' :: text)) -replace - :: '[ null 'PGtext, null 'PGtext, null 'PGtext ] ---> null 'PGtext -replace = unsafeFunctionN "replace" diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/TextSearch.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression/TextSearch.hs deleted file mode 100644 index 92e791ec..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/TextSearch.hs +++ /dev/null @@ -1,159 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Expression.TextSearch -Description: text search functions and operators -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -text search functions and operators --} - -{-# LANGUAGE - DataKinds - , OverloadedStrings - , TypeOperators -#-} - -module Squeal.PostgreSQL.Expression.TextSearch - ( -- * Text Search Operator - (@@) - , (.&) - , (.|) - , (.!) - , (<->) - -- * Text Search Function - , arrayToTSvector - , tsvectorLength - , numnode - , plainToTSquery - , phraseToTSquery - , websearchToTSquery - , queryTree - , toTSquery - , toTSvector - , setWeight - , strip - , jsonToTSvector - , jsonbToTSvector - , tsDelete - , tsFilter - , tsHeadline - ) where - -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Type.Schema - --- | `Squeal.PostgreSQL.Expression.Type.tsvector` matches tsquery ? -(@@) :: Operator (null 'PGtsvector) (null 'PGtsquery) ('Null 'PGbool) -(@@) = unsafeBinaryOp "@@" - --- | AND `Squeal.PostgreSQL.Expression.Type.tsquery`s together -(.&) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery) -(.&) = unsafeBinaryOp "&&" - --- | OR `Squeal.PostgreSQL.Expression.Type.tsquery`s together -(.|) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery) -(.|) = unsafeBinaryOp "||" - --- | negate a `Squeal.PostgreSQL.Expression.Type.tsquery` -(.!) :: null 'PGtsquery --> null 'PGtsquery -(.!) = unsafeLeftOp "!!" - --- | `Squeal.PostgreSQL.Expression.Type.tsquery` followed by --- `Squeal.PostgreSQL.Expression.Type.tsquery` -(<->) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery) -(<->) = unsafeBinaryOp "<->" - --- | convert array of lexemes to `Squeal.PostgreSQL.Expression.Type.tsvector` -arrayToTSvector - :: null ('PGvararray ('NotNull 'PGtext)) - --> null 'PGtsvector -arrayToTSvector = unsafeFunction "array_to_tsvector" - --- | number of lexemes in `Squeal.PostgreSQL.Expression.Type.tsvector` -tsvectorLength :: null 'PGtsvector --> null 'PGint4 -tsvectorLength = unsafeFunction "length" - --- | number of lexemes plus operators in `Squeal.PostgreSQL.Expression.Type.tsquery` -numnode :: null 'PGtsquery --> null 'PGint4 -numnode = unsafeFunction "numnode" - --- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` ignoring punctuation -plainToTSquery :: null 'PGtext --> null 'PGtsquery -plainToTSquery = unsafeFunction "plainto_tsquery" - --- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` that searches for a phrase, --- ignoring punctuation -phraseToTSquery :: null 'PGtext --> null 'PGtsquery -phraseToTSquery = unsafeFunction "phraseto_tsquery" - --- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` from a web search style query -websearchToTSquery :: null 'PGtext --> null 'PGtsquery -websearchToTSquery = unsafeFunction "websearch_to_tsquery" - --- | get indexable part of a `Squeal.PostgreSQL.Expression.Type.tsquery` -queryTree :: null 'PGtsquery --> null 'PGtext -queryTree = unsafeFunction "query_tree" - --- | normalize words and convert to `Squeal.PostgreSQL.Expression.Type.tsquery` -toTSquery :: null 'PGtext --> null 'PGtsquery -toTSquery = unsafeFunction "to_tsquery" - --- | reduce document text to `Squeal.PostgreSQL.Expression.Type.tsvector` -toTSvector - :: ty `In` '[ 'PGtext, 'PGjson, 'PGjsonb] - => null ty --> null 'PGtsvector -toTSvector = unsafeFunction "to_tsvector" - --- | assign weight to each element of `Squeal.PostgreSQL.Expression.Type.tsvector` -setWeight :: '[null 'PGtsvector, null ('PGchar 1)] ---> null 'PGtsvector -setWeight = unsafeFunctionN "set_weight" - --- | remove positions and weights from `Squeal.PostgreSQL.Expression.Type.tsvector` -strip :: null 'PGtsvector --> null 'PGtsvector -strip = unsafeFunction "strip" - --- | @jsonToTSvector (document *: filter)@ --- reduce each value in the document, specified by filter to a `Squeal.PostgreSQL.Expression.Type.tsvector`, --- and then concatenate those in document order to produce a single `Squeal.PostgreSQL.Expression.Type.tsvector`. --- filter is a `Squeal.PostgreSQL.Expression.Type.json` array, that enumerates what kind of elements --- need to be included into the resulting `Squeal.PostgreSQL.Expression.Type.tsvector`. --- Possible values for filter are "string" (to include all string values), --- "numeric" (to include all numeric values in the string format), --- "boolean" (to include all Boolean values in the string format "true"/"false"), --- "key" (to include all keys) or "all" (to include all above). --- These values can be combined together to include, e.g. all string and numeric values. -jsonToTSvector :: '[null 'PGjson, null 'PGjson] ---> null 'PGtsvector -jsonToTSvector = unsafeFunctionN "json_to_tsvector" - --- | @jsonbToTSvector (document *: filter)@ --- reduce each value in the document, specified by filter to a `Squeal.PostgreSQL.Expression.Type.tsvector`, --- and then concatenate those in document order to produce a single `Squeal.PostgreSQL.Expression.Type.tsvector`. --- filter is a `Squeal.PostgreSQL.Expression.Type.jsonb` array, that enumerates what kind of elements --- need to be included into the resulting `Squeal.PostgreSQL.Expression.Type.tsvector`. --- Possible values for filter are "string" (to include all string values), --- "numeric" (to include all numeric values in the string format), --- "boolean" (to include all Boolean values in the string format "true"/"false"), --- "key" (to include all keys) or "all" (to include all above). --- These values can be combined together to include, e.g. all string and numeric values. -jsonbToTSvector :: '[null 'PGjsonb, null 'PGjsonb] ---> null 'PGtsvector -jsonbToTSvector = unsafeFunctionN "jsonb_to_tsvector" - --- | remove given lexeme from `Squeal.PostgreSQL.Expression.Type.tsvector` -tsDelete :: - '[null 'PGtsvector, null ('PGvararray ('NotNull 'PGtext))] - ---> null 'PGtsvector -tsDelete = unsafeFunctionN "ts_delete" - --- | select only elements with given weights from `Squeal.PostgreSQL.Expression.Type.tsvector` -tsFilter :: - '[null 'PGtsvector, null ('PGvararray ('NotNull ('PGchar 1)))] - ---> null 'PGtsvector -tsFilter = unsafeFunctionN "ts_filter" - --- | display a `Squeal.PostgreSQL.Expression.Type.tsquery` match -tsHeadline - :: document `In` '[ 'PGtext, 'PGjson, 'PGjsonb] - => '[null document, null 'PGtsquery] ---> null 'PGtext -tsHeadline = unsafeFunctionN "ts_headline" diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Time.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Time.hs deleted file mode 100644 index 3552cb13..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Time.hs +++ /dev/null @@ -1,247 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Expression.Time -Description: date/time functions and operators -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -date/time functions and operators --} - -{-# LANGUAGE - DataKinds - , DeriveGeneric - , FunctionalDependencies - , LambdaCase - , MultiParamTypeClasses - , OverloadedStrings - , PolyKinds - , RankNTypes - , TypeFamilies - , TypeOperators - , UndecidableInstances -#-} - -module Squeal.PostgreSQL.Expression.Time - ( -- * Time Operation - TimeOp (..) - -- * Time Function - , currentDate - , currentTime - , currentTimestamp - , dateTrunc - , localTime - , localTimestamp - , now - , makeDate - , makeTime - , makeTimestamp - , makeTimestamptz - , atTimeZone - , PGAtTimeZone - -- * Interval - , interval_ - , TimeUnit (..) - ) where - -import Data.Fixed -import Data.String -import GHC.TypeLits - -import qualified GHC.Generics as GHC -import qualified Generics.SOP as SOP - -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL - --- | >>> printSQL currentDate --- CURRENT_DATE -currentDate :: Expr (null 'PGdate) -currentDate = UnsafeExpression "CURRENT_DATE" - --- | >>> printSQL currentTime --- CURRENT_TIME -currentTime :: Expr (null 'PGtimetz) -currentTime = UnsafeExpression "CURRENT_TIME" - --- | >>> printSQL currentTimestamp --- CURRENT_TIMESTAMP -currentTimestamp :: Expr (null 'PGtimestamptz) -currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP" - --- | >>> printSQL localTime --- LOCALTIME -localTime :: Expr (null 'PGtime) -localTime = UnsafeExpression "LOCALTIME" - --- | >>> printSQL localTimestamp --- LOCALTIMESTAMP -localTimestamp :: Expr (null 'PGtimestamp) -localTimestamp = UnsafeExpression "LOCALTIMESTAMP" - --- | Current date and time (equivalent to `currentTimestamp`) --- --- >>> printSQL now --- now() -now :: Expr (null 'PGtimestamptz) -now = UnsafeExpression "now()" - -{-| -Create date from year, month and day fields - ->>> printSQL (makeDate (1984 :* 7 *: 3)) -make_date((1984 :: int4), (7 :: int4), (3 :: int4)) --} -makeDate :: '[ null 'PGint4, null 'PGint4, null 'PGint4 ] ---> null 'PGdate -makeDate = unsafeFunctionN "make_date" - -{-| -Create time from hour, minute and seconds fields - ->>> printSQL (makeTime (8 :* 15 *: 23.5)) -make_time((8 :: int4), (15 :: int4), (23.5 :: float8)) --} -makeTime :: '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtime -makeTime = unsafeFunctionN "make_time" - -{-| -Create timestamp from year, month, day, hour, minute and seconds fields - ->>> printSQL (makeTimestamp (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5)) -make_timestamp((2013 :: int4), (7 :: int4), (15 :: int4), (8 :: int4), (15 :: int4), (23.5 :: float8)) --} -makeTimestamp :: - '[ null 'PGint4, null 'PGint4, null 'PGint4 - , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamp -makeTimestamp = unsafeFunctionN "make_timestamp" - -{-| -Create timestamp with time zone from -year, month, day, hour, minute and seconds fields; -the current time zone is used - ->>> printSQL (makeTimestamptz (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5)) -make_timestamptz((2013 :: int4), (7 :: int4), (15 :: int4), (8 :: int4), (15 :: int4), (23.5 :: float8)) --} -makeTimestamptz :: - '[ null 'PGint4, null 'PGint4, null 'PGint4 - , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamptz -makeTimestamptz = unsafeFunctionN "make_timestamptz" - -{-| -Truncate a timestamp with the specified precision - ->>> printSQL $ dateTrunc Quarter (makeTimestamp (2010 :* 5 :* 6 :* 14 :* 45 *: 11.4)) -date_trunc('quarter', make_timestamp((2010 :: int4), (5 :: int4), (6 :: int4), (14 :: int4), (45 :: int4), (11.4 :: float8))) --} -dateTrunc - :: time `In` '[ 'PGtimestamp, 'PGtimestamptz ] - => TimeUnit -> null time --> null time -dateTrunc tUnit args = unsafeFunctionN "date_trunc" (timeUnitExpr *: args) - where - timeUnitExpr :: forall grp lat with db params from null0. - Expression grp lat with db params from (null0 'PGtext) - timeUnitExpr = UnsafeExpression . singleQuotedUtf8 . renderSQL $ tUnit - --- | Calculate the return time type of the `atTimeZone` `Operator`. -type family PGAtTimeZone ty where - PGAtTimeZone 'PGtimestamptz = 'PGtimestamp - PGAtTimeZone 'PGtimestamp = 'PGtimestamptz - PGAtTimeZone 'PGtimetz = 'PGtimetz - PGAtTimeZone pg = TypeError - ( 'Text "Squeal type error: AT TIME ZONE cannot be applied to " - ':<>: 'ShowType pg ) - -{-| -Convert a timestamp, timestamp with time zone, or time of day with timezone to a different timezone using an interval offset or specific timezone denoted by text. When using the interval offset, the interval duration must be less than one day or 24 hours. - ->>> printSQL $ (makeTimestamp (2009 :* 7 :* 22 :* 19 :* 45 *: 11.4)) `atTimeZone` (interval_ 8 Hours) -(make_timestamp((2009 :: int4), (7 :: int4), (22 :: int4), (19 :: int4), (45 :: int4), (11.4 :: float8)) AT TIME ZONE (INTERVAL '8.000 hours')) - ->>> :{ - let - timezone :: Expr (null 'PGtext) - timezone = "EST" - in printSQL $ (makeTimestamptz (2015 :* 9 :* 15 :* 4 :* 45 *: 11.4)) `atTimeZone` timezone -:} -(make_timestamptz((2015 :: int4), (9 :: int4), (15 :: int4), (4 :: int4), (45 :: int4), (11.4 :: float8)) AT TIME ZONE (E'EST' :: text)) --} -atTimeZone - :: zone `In` '[ 'PGtext, 'PGinterval] - => Operator (null time) (null zone) (null (PGAtTimeZone time)) -atTimeZone = unsafeBinaryOp "AT TIME ZONE" - -{-| -Affine space operations on time types. --} -class TimeOp time diff | time -> diff where - {-| - >>> printSQL (makeDate (1984 :* 7 *: 3) !+ 365) - (make_date((1984 :: int4), (7 :: int4), (3 :: int4)) + (365 :: int4)) - -} - (!+) :: Operator (null time) (null diff) (null time) - (!+) = unsafeBinaryOp "+" - {-| - >>> printSQL (365 +! makeDate (1984 :* 7 *: 3)) - ((365 :: int4) + make_date((1984 :: int4), (7 :: int4), (3 :: int4))) - -} - (+!) :: Operator (null diff) (null time) (null time) - (+!) = unsafeBinaryOp "+" - {-| - >>> printSQL (makeDate (1984 :* 7 *: 3) !- 365) - (make_date((1984 :: int4), (7 :: int4), (3 :: int4)) - (365 :: int4)) - -} - (!-) :: Operator (null time) (null diff) (null time) - (!-) = unsafeBinaryOp "-" - {-| - >>> printSQL (makeDate (1984 :* 7 *: 3) !-! currentDate) - (make_date((1984 :: int4), (7 :: int4), (3 :: int4)) - CURRENT_DATE) - -} - (!-!) :: Operator (null time) (null time) (null diff) - (!-!) = unsafeBinaryOp "-" -instance TimeOp 'PGtimestamp 'PGinterval -instance TimeOp 'PGtimestamptz 'PGinterval -instance TimeOp 'PGtime 'PGinterval -instance TimeOp 'PGtimetz 'PGinterval -instance TimeOp 'PGinterval 'PGinterval -instance TimeOp 'PGdate 'PGint4 -infixl 6 !+ -infixl 6 +! -infixl 6 !- -infixl 6 !-! - --- | A `TimeUnit` to use in `interval_` construction. -data TimeUnit - = Years | Quarter | Months | Weeks | Days - | Hours | Minutes | Seconds - | Microseconds | Milliseconds - | Decades | Centuries | Millennia - deriving (Eq, Ord, Show, Read, Enum, GHC.Generic) -instance SOP.Generic TimeUnit -instance SOP.HasDatatypeInfo TimeUnit -instance RenderSQL TimeUnit where - renderSQL = \case - Years -> "years" - Quarter -> "quarter" - Months -> "months" - Weeks -> "weeks" - Days -> "days" - Hours -> "hours" - Minutes -> "minutes" - Seconds -> "seconds" - Microseconds -> "microseconds" - Milliseconds -> "milliseconds" - Decades -> "decades" - Centuries -> "centuries" - Millennia -> "millennia" - --- | >>> printSQL $ interval_ 7 Days --- (INTERVAL '7.000 days') -interval_ :: Milli -> TimeUnit -> Expr (null 'PGinterval) -interval_ num unit = UnsafeExpression . parenthesized $ "INTERVAL" <+> - "'" <> fromString (show num) <+> renderSQL unit <> "'" diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Type.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Type.hs deleted file mode 100644 index a0f59eaa..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Type.hs +++ /dev/null @@ -1,522 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Expression -Description: type expressions -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -type expressions --} - -{-# LANGUAGE - AllowAmbiguousTypes - , DataKinds - , DeriveGeneric - , DerivingStrategies - , FlexibleContexts - , FlexibleInstances - , GADTs - , GeneralizedNewtypeDeriving - , KindSignatures - , MultiParamTypeClasses - , OverloadedStrings - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeOperators - , UndecidableInstances -#-} - -module Squeal.PostgreSQL.Expression.Type - ( -- * Type Cast - cast - , astype - , inferredtype - -- * Type Expression - , TypeExpression (..) - , typedef - , typetable - , typeview - , typerow - , bool - , int2 - , smallint - , int4 - , int - , integer - , int8 - , bigint - , numeric - , float4 - , real - , float8 - , doublePrecision - , money - , text - , char - , character - , varchar - , characterVarying - , bytea - , timestamp - , timestampWithTimeZone - , timestamptz - , date - , time - , timeWithTimeZone - , timetz - , interval - , uuid - , inet - , json - , jsonb - , vararray - , fixarray - , tsvector - , tsquery - , oid - , int4range - , int8range - , numrange - , tsrange - , tstzrange - , daterange - , record - -- * Column Type - , ColumnTypeExpression (..) - , nullable - , notNullable - , default_ - , serial2 - , smallserial - , serial4 - , serial - , serial8 - , bigserial - -- * Type Inference - , PGTyped (..) - , pgtypeFrom - , NullTyped (..) - , nulltypeFrom - , ColumnTyped (..) - , columntypeFrom - , FieldTyped (..) - ) where - -import Control.DeepSeq -import Data.ByteString -import Data.String -import GHC.TypeLits - -import qualified Data.ByteString as ByteString -import qualified GHC.Generics as GHC -import qualified Generics.SOP as SOP - -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Type.PG -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL - --- When a `cast` is applied to an `Expression` of a known type, it --- represents a run-time type conversion. The cast will succeed only if a --- suitable type conversion operation has been defined. --- --- | >>> printSQL $ true & cast int4 --- (TRUE :: int4) -cast - :: TypeExpression db ty1 - -- ^ type to cast as - -> Expression grp lat with db params from ty0 - -- ^ value to convert - -> Expression grp lat with db params from ty1 -cast ty x = UnsafeExpression $ parenthesized $ - renderSQL x <+> "::" <+> renderSQL ty - --- | A safe version of `cast` which just matches a value with its type. --- --- >>> printSQL (1 & astype int) --- ((1 :: int4) :: int) -astype - :: TypeExpression db ty - -- ^ type to specify as - -> Expression grp lat with db params from ty - -- ^ value - -> Expression grp lat with db params from ty -astype = cast - --- | `inferredtype` will add a type annotation to an `Expression` --- which can be useful for fixing the storage type of a value. --- --- >>> printSQL (inferredtype true) --- (TRUE :: bool) -inferredtype - :: NullTyped db ty - => Expression lat common grp db params from ty - -- ^ value - -> Expression lat common grp db params from ty -inferredtype = astype nulltype - -{----------------------------------------- -type expressions ------------------------------------------} - --- | `TypeExpression`s are used in `cast`s and --- `Squeal.PostgreSQL.Definition.createTable` commands. -newtype TypeExpression (db :: SchemasType) (ty :: NullType) - = UnsafeTypeExpression { renderTypeExpression :: ByteString } - deriving stock (GHC.Generic,Show,Eq,Ord) - deriving newtype (NFData) -instance RenderSQL (TypeExpression db ty) where - renderSQL = renderTypeExpression - --- | The composite type corresponding to a relation can be expressed --- by its alias. A relation is either a composite type, a table or a view. --- It subsumes `typetable` and `typeview` and partly overlaps `typedef`. -typerow - :: ( relss ~ DbRelations db - , Has sch relss rels - , Has rel rels row - ) - => QualifiedAlias sch rel - -- ^ type alias - -> TypeExpression db (null ('PGcomposite row)) -typerow = UnsafeTypeExpression . renderSQL - --- | The enum or composite type in a `Typedef` can be expressed by its alias. -typedef - :: (Has sch db schema, Has td schema ('Typedef ty)) - => QualifiedAlias sch td - -- ^ type alias - -> TypeExpression db (null ty) -typedef = UnsafeTypeExpression . renderSQL - --- | The composite type corresponding to a `Table` definition can be expressed --- by its alias. -typetable - :: (Has sch db schema, Has tab schema ('Table table)) - => QualifiedAlias sch tab - -- ^ table alias - -> TypeExpression db (null ('PGcomposite (TableToRow table))) -typetable = UnsafeTypeExpression . renderSQL - --- | The composite type corresponding to a `View` definition can be expressed --- by its alias. -typeview - :: (Has sch db schema, Has vw schema ('View view)) - => QualifiedAlias sch vw - -- ^ view alias - -> TypeExpression db (null ('PGcomposite view)) -typeview = UnsafeTypeExpression . renderSQL - --- | logical Boolean (true/false) -bool :: TypeExpression db (null 'PGbool) -bool = UnsafeTypeExpression "bool" --- | signed two-byte integer -int2, smallint :: TypeExpression db (null 'PGint2) -int2 = UnsafeTypeExpression "int2" -smallint = UnsafeTypeExpression "smallint" --- | signed four-byte integer -int4, int, integer :: TypeExpression db (null 'PGint4) -int4 = UnsafeTypeExpression "int4" -int = UnsafeTypeExpression "int" -integer = UnsafeTypeExpression "integer" --- | signed eight-byte integer -int8, bigint :: TypeExpression db (null 'PGint8) -int8 = UnsafeTypeExpression "int8" -bigint = UnsafeTypeExpression "bigint" --- | arbitrary precision numeric type -numeric :: TypeExpression db (null 'PGnumeric) -numeric = UnsafeTypeExpression "numeric" --- | single precision floating-point number (4 bytes) -float4, real :: TypeExpression db (null 'PGfloat4) -float4 = UnsafeTypeExpression "float4" -real = UnsafeTypeExpression "real" --- | double precision floating-point number (8 bytes) -float8, doublePrecision :: TypeExpression db (null 'PGfloat8) -float8 = UnsafeTypeExpression "float8" -doublePrecision = UnsafeTypeExpression "double precision" --- | currency amount -money :: TypeExpression schema (null 'PGmoney) -money = UnsafeTypeExpression "money" --- | variable-length character string -text :: TypeExpression db (null 'PGtext) -text = UnsafeTypeExpression "text" --- | fixed-length character string -char, character - :: forall n db null. (KnownNat n, 1 <= n) - => TypeExpression db (null ('PGchar n)) -char = UnsafeTypeExpression $ "char(" <> renderNat @n <> ")" -character = UnsafeTypeExpression $ "character(" <> renderNat @n <> ")" --- | variable-length character string -varchar, characterVarying - :: forall n db null. (KnownNat n, 1 <= n) - => TypeExpression db (null ('PGvarchar n)) -varchar = UnsafeTypeExpression $ "varchar(" <> renderNat @n <> ")" -characterVarying = UnsafeTypeExpression $ - "character varying(" <> renderNat @n <> ")" --- | binary data ("byte array") -bytea :: TypeExpression db (null 'PGbytea) -bytea = UnsafeTypeExpression "bytea" --- | date and time (no time zone) -timestamp :: TypeExpression db (null 'PGtimestamp) -timestamp = UnsafeTypeExpression "timestamp" --- | date and time, including time zone -timestampWithTimeZone, timestamptz :: TypeExpression db (null 'PGtimestamptz) -timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone" -timestamptz = UnsafeTypeExpression "timestamptz" --- | calendar date (year, month, day) -date :: TypeExpression db (null 'PGdate) -date = UnsafeTypeExpression "date" --- | time of day (no time zone) -time :: TypeExpression db (null 'PGtime) -time = UnsafeTypeExpression "time" --- | time of day, including time zone -timeWithTimeZone, timetz :: TypeExpression db (null 'PGtimetz) -timeWithTimeZone = UnsafeTypeExpression "time with time zone" -timetz = UnsafeTypeExpression "timetz" --- | time span -interval :: TypeExpression db (null 'PGinterval) -interval = UnsafeTypeExpression "interval" --- | universally unique identifier -uuid :: TypeExpression db (null 'PGuuid) -uuid = UnsafeTypeExpression "uuid" --- | IPv4 or IPv6 host address -inet :: TypeExpression db (null 'PGinet) -inet = UnsafeTypeExpression "inet" --- | textual JSON data -json :: TypeExpression db (null 'PGjson) -json = UnsafeTypeExpression "json" --- | binary JSON data, decomposed -jsonb :: TypeExpression db (null 'PGjsonb) -jsonb = UnsafeTypeExpression "jsonb" --- | variable length array -vararray - :: TypeExpression db pg - -> TypeExpression db (null ('PGvararray pg)) -vararray ty = UnsafeTypeExpression $ renderSQL ty <> "[]" --- | fixed length array --- --- >>> renderSQL (fixarray @'[2] json) --- "json[2]" -fixarray - :: forall dims db null pg. SOP.All KnownNat dims - => TypeExpression db pg - -> TypeExpression db (null ('PGfixarray dims pg)) -fixarray ty = UnsafeTypeExpression $ - renderSQL ty <> renderDims @dims - where - renderDims :: forall ns. SOP.All KnownNat ns => ByteString - renderDims = - ("[" <>) - . (<> "]") - . ByteString.intercalate "][" - . SOP.hcollapse - $ SOP.hcmap (SOP.Proxy @KnownNat) - (SOP.K . fromString . show . natVal) - (SOP.hpure SOP.Proxy :: SOP.NP SOP.Proxy ns) --- | text search query -tsvector :: TypeExpression db (null 'PGtsvector) -tsvector = UnsafeTypeExpression "tsvector" --- | text search document -tsquery :: TypeExpression db (null 'PGtsquery) -tsquery = UnsafeTypeExpression "tsquery" --- | Object identifiers (OIDs) are used internally by PostgreSQL --- as primary keys for various system tables. -oid :: TypeExpression db (null 'PGoid) -oid = UnsafeTypeExpression "oid" --- | Range of integer -int4range :: TypeExpression db (null ('PGrange 'PGint4)) -int4range = UnsafeTypeExpression "int4range" --- | Range of bigint -int8range :: TypeExpression db (null ('PGrange 'PGint8)) -int8range = UnsafeTypeExpression "int8range" --- | Range of numeric -numrange :: TypeExpression db (null ('PGrange 'PGnumeric)) -numrange = UnsafeTypeExpression "numrange" --- | Range of timestamp without time zone -tsrange :: TypeExpression db (null ('PGrange 'PGtimestamp)) -tsrange = UnsafeTypeExpression "tsrange" --- | Range of timestamp with time zone -tstzrange :: TypeExpression db (null ('PGrange 'PGtimestamptz)) -tstzrange = UnsafeTypeExpression "tstzrange" --- | Range of date -daterange :: TypeExpression db (null ('PGrange 'PGdate)) -daterange = UnsafeTypeExpression "daterange" --- | Anonymous composite record -record :: TypeExpression db (null ('PGcomposite record)) -record = UnsafeTypeExpression "record" - --- | `pgtype` is a demoted version of a `PGType` -class PGTyped db (ty :: PGType) where pgtype :: TypeExpression db (null ty) -instance PGTyped db 'PGbool where pgtype = bool -instance PGTyped db 'PGint2 where pgtype = int2 -instance PGTyped db 'PGint4 where pgtype = int4 -instance PGTyped db 'PGint8 where pgtype = int8 -instance PGTyped db 'PGnumeric where pgtype = numeric -instance PGTyped db 'PGfloat4 where pgtype = float4 -instance PGTyped db 'PGfloat8 where pgtype = float8 -instance PGTyped db 'PGmoney where pgtype = money -instance PGTyped db 'PGtext where pgtype = text -instance (KnownNat n, 1 <= n) - => PGTyped db ('PGchar n) where pgtype = char @n -instance (KnownNat n, 1 <= n) - => PGTyped db ('PGvarchar n) where pgtype = varchar @n -instance PGTyped db 'PGbytea where pgtype = bytea -instance PGTyped db 'PGtimestamp where pgtype = timestamp -instance PGTyped db 'PGtimestamptz where pgtype = timestampWithTimeZone -instance PGTyped db 'PGdate where pgtype = date -instance PGTyped db 'PGtime where pgtype = time -instance PGTyped db 'PGtimetz where pgtype = timeWithTimeZone -instance PGTyped db 'PGinterval where pgtype = interval -instance PGTyped db 'PGuuid where pgtype = uuid -instance PGTyped db 'PGinet where pgtype = inet -instance PGTyped db 'PGjson where pgtype = json -instance PGTyped db 'PGjsonb where pgtype = jsonb -instance PGTyped db pg => PGTyped db ('PGvararray (null pg)) where - pgtype = vararray (pgtype @db @pg) -instance (SOP.All KnownNat dims, PGTyped db pg) - => PGTyped db ('PGfixarray dims (null pg)) where - pgtype = fixarray @dims (pgtype @db @pg) -instance PGTyped db 'PGtsvector where pgtype = tsvector -instance PGTyped db 'PGtsquery where pgtype = tsquery -instance PGTyped db 'PGoid where pgtype = oid -instance PGTyped db ('PGrange 'PGint4) where pgtype = int4range -instance PGTyped db ('PGrange 'PGint8) where pgtype = int8range -instance PGTyped db ('PGrange 'PGnumeric) where pgtype = numrange -instance PGTyped db ('PGrange 'PGtimestamp) where pgtype = tsrange -instance PGTyped db ('PGrange 'PGtimestamptz) where pgtype = tstzrange -instance PGTyped db ('PGrange 'PGdate) where pgtype = daterange -instance - ( relss ~ DbRelations db - , Has sch relss rels - , Has rel rels row - , FindQualified "no relation found with row: " relss row ~ '(sch,rel) - ) => PGTyped db ('PGcomposite row) where - pgtype = typerow (QualifiedAlias @sch @rel) -instance - ( enums ~ DbEnums db - , FindQualified "no enum found with labels: " enums labels ~ '(sch,td) - , Has sch db schema - , Has td schema ('Typedef ('PGenum labels)) - ) => PGTyped db ('PGenum labels) where - pgtype = typedef (QualifiedAlias @sch @td) - --- | Specify `TypeExpression` from a Haskell type. --- --- >>> printSQL $ pgtypeFrom @String --- text --- --- >>> printSQL $ pgtypeFrom @Double --- float8 -pgtypeFrom - :: forall hask db null. PGTyped db (PG hask) - => TypeExpression db (null (PG hask)) -pgtypeFrom = pgtype @db @(PG hask) - --- | Lift `PGTyped` to a field -class FieldTyped db ty where fieldtype :: Aliased (TypeExpression db) ty -instance (KnownSymbol alias, NullTyped db ty) - => FieldTyped db (alias ::: ty) where - fieldtype = nulltype `As` Alias - --- | `ColumnTypeExpression`s are used in --- `Squeal.PostgreSQL.Definition.createTable` commands. -newtype ColumnTypeExpression (db :: SchemasType) (ty :: ColumnType) - = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString } - deriving stock (GHC.Generic,Show,Eq,Ord) - deriving newtype (NFData) -instance RenderSQL (ColumnTypeExpression db ty) where - renderSQL = renderColumnTypeExpression - --- | used in `Squeal.PostgreSQL.Definition.createTable` --- commands as a column constraint to note that --- @NULL@ may be present in a column -nullable - :: TypeExpression db (null ty) - -- ^ type - -> ColumnTypeExpression db ('NoDef :=> 'Null ty) -nullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NULL" - --- | used in `Squeal.PostgreSQL.Definition.createTable` --- commands as a column constraint to ensure --- @NULL@ is not present in a column -notNullable - :: TypeExpression db (null ty) - -- ^ type - -> ColumnTypeExpression db ('NoDef :=> 'NotNull ty) -notNullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NOT NULL" - --- | used in `Squeal.PostgreSQL.Definition.createTable` --- commands as a column constraint to give a default -default_ - :: Expression 'Ungrouped '[] '[] db '[] '[] ty - -- ^ default value - -> ColumnTypeExpression db ('NoDef :=> ty) - -- ^ column type - -> ColumnTypeExpression db ('Def :=> ty) -default_ x ty = UnsafeColumnTypeExpression $ - renderSQL ty <+> "DEFAULT" <+> renderExpression x - --- | not a true type, but merely a notational convenience for creating --- unique identifier columns with type `PGint2` -serial2, smallserial - :: ColumnTypeExpression db ('Def :=> 'NotNull 'PGint2) -serial2 = UnsafeColumnTypeExpression "serial2" -smallserial = UnsafeColumnTypeExpression "smallserial" --- | not a true type, but merely a notational convenience for creating --- unique identifier columns with type `PGint4` -serial4, serial - :: ColumnTypeExpression db ('Def :=> 'NotNull 'PGint4) -serial4 = UnsafeColumnTypeExpression "serial4" -serial = UnsafeColumnTypeExpression "serial" --- | not a true type, but merely a notational convenience for creating --- unique identifier columns with type `PGint8` -serial8, bigserial - :: ColumnTypeExpression db ('Def :=> 'NotNull 'PGint8) -serial8 = UnsafeColumnTypeExpression "serial8" -bigserial = UnsafeColumnTypeExpression "bigserial" - --- | Like @PGTyped@ but also accounts for null. -class NullTyped db (ty :: NullType) where - nulltype :: TypeExpression db ty - -instance PGTyped db ty => NullTyped db (null ty) where - nulltype = pgtype @db @ty - --- | Specify null `TypeExpression` from a Haskell type. --- --- >>> printSQL $ nulltypeFrom @(Maybe String) --- text --- --- >>> printSQL $ nulltypeFrom @Double --- float8 -nulltypeFrom - :: forall hask db. NullTyped db (NullPG hask) - => TypeExpression db (NullPG hask) -nulltypeFrom = nulltype @db @(NullPG hask) - --- | Like @PGTyped@ but also accounts for null. -class ColumnTyped db (column :: ColumnType) where - columntype :: ColumnTypeExpression db column -instance NullTyped db ('Null ty) - => ColumnTyped db ('NoDef :=> 'Null ty) where - columntype = nullable (nulltype @db @('Null ty)) -instance NullTyped db ('NotNull ty) - => ColumnTyped db ('NoDef :=> 'NotNull ty) where - columntype = notNullable (nulltype @db @('NotNull ty)) - --- | Specify `ColumnTypeExpression` from a Haskell type. --- --- >>> printSQL $ columntypeFrom @(Maybe String) --- text NULL --- --- >>> printSQL $ columntypeFrom @Double --- float8 NOT NULL -columntypeFrom - :: forall hask db. (ColumnTyped db ('NoDef :=> NullPG hask)) - => ColumnTypeExpression db ('NoDef :=> NullPG hask) -columntypeFrom = columntype @db @('NoDef :=> NullPG hask) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Window.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Window.hs deleted file mode 100644 index 3d21c6c9..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Window.hs +++ /dev/null @@ -1,348 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Expression.Window -Description: window functions, arguments and definitions -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -window functions, arguments and definitions --} - -{-# LANGUAGE - DataKinds - , DeriveGeneric - , DerivingStrategies - , FlexibleContexts - , FlexibleInstances - , GADTs - , GeneralizedNewtypeDeriving - , KindSignatures - , LambdaCase - , MultiParamTypeClasses - , OverloadedStrings - , PatternSynonyms - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeOperators - , UndecidableInstances -#-} - -module Squeal.PostgreSQL.Expression.Window - ( -- * Window Definition - WindowDefinition (..) - , partitionBy - -- * Window Function - -- ** Types - , WindowFunction (..) - , WindowArg (..) - , pattern Window - , pattern Windows - , WinFun0 - , type (-#->) - , type (--#->) - -- ** Functions - , rank - , rowNumber - , denseRank - , percentRank - , cumeDist - , ntile - , lag - , lead - , firstValue - , lastValue - , nthValue - , unsafeWindowFunction1 - , unsafeWindowFunctionN - ) where - -import Control.DeepSeq -import Data.ByteString (ByteString) - -import qualified GHC.Generics as GHC -import qualified Generics.SOP as SOP - -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Expression.Aggregate -import Squeal.PostgreSQL.Expression.Logic -import Squeal.PostgreSQL.Expression.Sort -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema - -instance Aggregate (WindowArg grp) (WindowFunction grp) where - countStar = UnsafeWindowFunction "count(*)" - count = unsafeWindowFunction1 "count" - sum_ = unsafeWindowFunction1 "sum" - arrayAgg = unsafeWindowFunction1 "array_agg" - jsonAgg = unsafeWindowFunction1 "json_agg" - jsonbAgg = unsafeWindowFunction1 "jsonb_agg" - bitAnd = unsafeWindowFunction1 "bit_and" - bitOr = unsafeWindowFunction1 "bit_or" - boolAnd = unsafeWindowFunction1 "bool_and" - boolOr = unsafeWindowFunction1 "bool_or" - every = unsafeWindowFunction1 "every" - max_ = unsafeWindowFunction1 "max" - min_ = unsafeWindowFunction1 "min" - avg = unsafeWindowFunction1 "avg" - corr = unsafeWindowFunctionN "corr" - covarPop = unsafeWindowFunctionN "covar_pop" - covarSamp = unsafeWindowFunctionN "covar_samp" - regrAvgX = unsafeWindowFunctionN "regr_avgx" - regrAvgY = unsafeWindowFunctionN "regr_avgy" - regrCount = unsafeWindowFunctionN "regr_count" - regrIntercept = unsafeWindowFunctionN "regr_intercept" - regrR2 = unsafeWindowFunctionN "regr_r2" - regrSlope = unsafeWindowFunctionN "regr_slope" - regrSxx = unsafeWindowFunctionN "regr_sxx" - regrSxy = unsafeWindowFunctionN "regr_sxy" - regrSyy = unsafeWindowFunctionN "regr_syy" - stddev = unsafeWindowFunction1 "stddev" - stddevPop = unsafeWindowFunction1 "stddev_pop" - stddevSamp = unsafeWindowFunction1 "stddev_samp" - variance = unsafeWindowFunction1 "variance" - varPop = unsafeWindowFunction1 "var_pop" - varSamp = unsafeWindowFunction1 "var_samp" - --- | A `WindowDefinition` is a set of table rows that are somehow related --- to the current row -data WindowDefinition grp lat with db params from where - WindowDefinition - :: SOP.SListI bys - => NP (Expression grp lat with db params from) bys - -- ^ `partitionBy` clause - -> [SortExpression grp lat with db params from] - -- ^ `Squeal.PostgreSQL.Expression.Sort.orderBy` clause - -> WindowDefinition grp lat with db params from - -instance OrderBy (WindowDefinition grp) grp where - orderBy sortsR (WindowDefinition parts sortsL) - = WindowDefinition parts (sortsL ++ sortsR) - -instance RenderSQL (WindowDefinition grp lat with db params from) where - renderSQL (WindowDefinition part ord) = - renderPartitionByClause part <> renderSQL ord - where - renderPartitionByClause = \case - Nil -> "" - parts -> "PARTITION" <+> "BY" <+> renderCommaSeparated renderExpression parts - -{- | -The `partitionBy` clause within `Squeal.PostgreSQL.Query.Over` divides the rows into groups, -or partitions, that share the same values of the `partitionBy` `Expression`(s). -For each row, the window function is computed across the rows that fall into -the same partition as the current row. --} -partitionBy - :: SOP.SListI bys - => NP (Expression grp lat with db params from) bys -- ^ partitions - -> WindowDefinition grp lat with db params from -partitionBy bys = WindowDefinition bys [] - -{- | -A window function performs a calculation across a set of table rows -that are somehow related to the current row. This is comparable to the type -of calculation that can be done with an aggregate function. -However, window functions do not cause rows to become grouped into a single -output row like non-window aggregate calls would. -Instead, the rows retain their separate identities. -Behind the scenes, the window function is able to access more than -just the current row of the query result. --} -newtype WindowFunction - (grp :: Grouping) - (lat :: FromType) - (with :: FromType) - (db :: SchemasType) - (params :: [NullType]) - (from :: FromType) - (ty :: NullType) - = UnsafeWindowFunction { renderWindowFunction :: ByteString } - deriving stock (GHC.Generic,Show,Eq,Ord) - deriving newtype (NFData) - -{- | -`WindowArg`s are used for the input of `WindowFunction`s. --} -data WindowArg - (grp :: Grouping) - (args :: [NullType]) - (lat :: FromType) - (with :: FromType) - (db :: SchemasType) - (params :: [NullType]) - (from :: FromType) - = WindowArg - { windowArgs :: NP (Expression grp lat with db params from) args - -- ^ `Window` or `Windows` - , windowFilter :: [Condition grp lat with db params from] - -- ^ `filterWhere` - } deriving stock (GHC.Generic) - -instance (HasUnique tab (Join from lat) row, Has col row ty) - => IsLabel col (WindowArg 'Ungrouped '[ty] lat with db params from) where - fromLabel = Window (fromLabel @col) -instance (Has tab (Join from lat) row, Has col row ty) - => IsQualified tab col (WindowArg 'Ungrouped '[ty] lat with db params from) where - tab ! col = Window (tab ! col) -instance (HasUnique tab (Join from lat) row, Has col row ty, GroupedBy tab col bys) - => IsLabel col (WindowArg ('Grouped bys) '[ty] lat with db params from) where - fromLabel = Window (fromLabel @col) -instance (Has tab (Join from lat) row, Has col row ty, GroupedBy tab col bys) - => IsQualified tab col (WindowArg ('Grouped bys) '[ty] lat with db params from) where - tab ! col = Window (tab ! col) - -instance SOP.SListI args - => RenderSQL (WindowArg grp args lat with db params from) where - renderSQL (WindowArg args filters) = - parenthesized (renderCommaSeparated renderSQL args) - & renderFilters filters - where - renderFilter wh = "FILTER" <+> parenthesized ("WHERE" <+> wh) - renderFilters = \case - [] -> id - wh:whs -> (<+> renderFilter (renderSQL (foldr (.&&) wh whs))) - -instance FilterWhere (WindowArg grp) grp where - filterWhere wh (WindowArg args filters) = WindowArg args (wh : filters) - --- | `Window` invokes a `WindowFunction` on a single argument. -pattern Window - :: Expression grp lat with db params from arg - -- ^ argument - -> WindowArg grp '[arg] lat with db params from -pattern Window x = Windows (x :* Nil) - --- | `Windows` invokes a `WindowFunction` on multiple argument. -pattern Windows - :: NP (Expression grp lat with db params from) args - -- ^ arguments - -> WindowArg grp args lat with db params from -pattern Windows xs = WindowArg xs [] - -instance RenderSQL (WindowFunction grp lat with db params from ty) where - renderSQL = renderWindowFunction - -{- | -A @RankNType@ for window functions with no arguments. --} -type WinFun0 x - = forall grp lat with db params from - . WindowFunction grp lat with db params from x - -- ^ cannot reference aliases - -{- | -A @RankNType@ for window functions with 1 argument. --} -type (-#->) x y - = forall grp lat with db params from - . WindowArg grp '[x] lat with db params from - -- ^ input - -> WindowFunction grp lat with db params from y - -- ^ output - -{- | A @RankNType@ for window functions with a fixed-length -list of heterogeneous arguments. -Use the `*:` operator to end your argument lists. --} -type (--#->) xs y - = forall grp lat with db params from - . WindowArg grp xs lat with db params from - -- ^ inputs - -> WindowFunction grp lat with db params from y - -- ^ output - --- | escape hatch for defining window functions -unsafeWindowFunction1 :: ByteString -> x -#-> y -unsafeWindowFunction1 fun x - = UnsafeWindowFunction $ fun <> renderSQL x - --- | escape hatch for defining multi-argument window functions -unsafeWindowFunctionN :: SOP.SListI xs => ByteString -> xs --#-> y -unsafeWindowFunctionN fun xs = UnsafeWindowFunction $ fun <> renderSQL xs - -{- | rank of the current row with gaps; same as `rowNumber` of its first peer - ->>> printSQL rank -rank() --} -rank :: WinFun0 ('NotNull 'PGint8) -rank = UnsafeWindowFunction "rank()" - -{- | number of the current row within its partition, counting from 1 - ->>> printSQL rowNumber -row_number() --} -rowNumber :: WinFun0 ('NotNull 'PGint8) -rowNumber = UnsafeWindowFunction "row_number()" - -{- | rank of the current row without gaps; this function counts peer groups - ->>> printSQL denseRank -dense_rank() --} -denseRank :: WinFun0 ('NotNull 'PGint8) -denseRank = UnsafeWindowFunction "dense_rank()" - -{- | relative rank of the current row: (rank - 1) / (total partition rows - 1) - ->>> printSQL percentRank -percent_rank() --} -percentRank :: WinFun0 ('NotNull 'PGfloat8) -percentRank = UnsafeWindowFunction "percent_rank()" - -{- | cumulative distribution: (number of partition rows -preceding or peer with current row) / total partition rows - ->>> printSQL cumeDist -cume_dist() --} -cumeDist :: WinFun0 ('NotNull 'PGfloat8) -cumeDist = UnsafeWindowFunction "cume_dist()" - -{- | integer ranging from 1 to the argument value, -dividing the partition as equally as possible - ->>> printSQL $ ntile (Window 5) -ntile((5 :: int4)) --} -ntile :: 'NotNull 'PGint4 -#-> 'NotNull 'PGint4 -ntile = unsafeWindowFunction1 "ntile" - -{- | returns value evaluated at the row that is offset rows before the current -row within the partition; if there is no such row, instead return default -(which must be of the same type as value). Both offset and default are -evaluated with respect to the current row. --} -lag :: '[ty, 'NotNull 'PGint4, ty] --#-> ty -lag = unsafeWindowFunctionN "lag" - -{- | returns value evaluated at the row that is offset rows after the current -row within the partition; if there is no such row, instead return default -(which must be of the same type as value). Both offset and default are -evaluated with respect to the current row. --} -lead :: '[ty, 'NotNull 'PGint4, ty] --#-> ty -lead = unsafeWindowFunctionN "lead" - -{- | returns value evaluated at the row that is the -first row of the window frame --} -firstValue :: ty -#-> ty -firstValue = unsafeWindowFunction1 "first_value" - -{- | returns value evaluated at the row that is the -last row of the window frame --} -lastValue :: ty -#-> ty -lastValue = unsafeWindowFunction1 "last_value" - -{- | returns value evaluated at the row that is the nth -row of the window frame (counting from 1); null if no such row --} -nthValue :: '[null ty, 'NotNull 'PGint4] --#-> 'Null ty -nthValue = unsafeWindowFunctionN "nth_value" diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs deleted file mode 100644 index fbf9f5da..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs +++ /dev/null @@ -1,343 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Manipulation -Description: data manipulation language -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -data manipulation language --} - -{-# LANGUAGE - DeriveGeneric - , DerivingStrategies - , FlexibleContexts - , FlexibleInstances - , GADTs - , GeneralizedNewtypeDeriving - , LambdaCase - , MultiParamTypeClasses - , OverloadedStrings - , PatternSynonyms - , QuantifiedConstraints - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeFamilies - , TypeInType - , TypeOperators - , UndecidableInstances -#-} - -module Squeal.PostgreSQL.Manipulation - ( -- * Manipulation - Manipulation (..) - , Manipulation_ - , queryStatement - , ReturningClause (..) - , pattern Returning_ - , UsingClause (..) - ) where - -import Control.DeepSeq -import Data.ByteString hiding (foldr) -import Data.Kind (Type) -import Data.Quiver.Functor - -import qualified Generics.SOP as SOP -import qualified GHC.Generics as GHC - -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Type.PG -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Query -import Squeal.PostgreSQL.Query.From -import Squeal.PostgreSQL.Query.Select -import Squeal.PostgreSQL.Query.With -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL --- >>> import Data.Int --- >>> import Data.Time - -{- | -A `Manipulation` is a statement which may modify data in the database, -but does not alter its schemas. Examples are -`Squeal.PostgreSQL.Manipulation.Insert.insertInto`s, -`Squeal.PostgreSQL.Manipulation.Update.update`s and -`Squeal.PostgreSQL.Manipulation.Delete.deleteFrom`s. -A `queryStatement` is also considered a `Manipulation` even though it does not modify data. - -The general `Manipulation` type is parameterized by - -* @with :: FromType@ - scope for all `Squeal.PostgreSQL.Query.From.common` table expressions, -* @db :: SchemasType@ - scope for all `Squeal.PostgreSQL.Query.From.table`s and `Squeal.PostgreSQL.Query.From.view`s, -* @params :: [NullType]@ - scope for all `Squeal.Expression.Parameter.parameter`s, -* @row :: RowType@ - return type of the `Manipulation`. - -Let's see some examples of `Manipulation`s. - -simple insert: - ->>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint4, "col2" ::: 'Def :=> 'NotNull 'PGint4] ->>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] ->>> :{ -let - manp :: Manipulation with (Public Schema) '[] '[] - manp = - insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2)) -in printSQL manp -:} -INSERT INTO "tab" AS "tab" ("col1", "col2") VALUES ((2 :: int4), DEFAULT) - -out-of-line parameterized insert: - ->>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4] ->>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] ->>> :{ -let - manp :: Manipulation with (Public Schema) '[ 'NotNull 'PGint4] '[] - manp = - insertInto_ #tab $ Values_ - (Default `as` #col1 :* Set (param @1) `as` #col2) -in printSQL manp -:} -INSERT INTO "tab" AS "tab" ("col1", "col2") VALUES (DEFAULT, ($1 :: int4)) - -in-line parameterized insert: - ->>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4] ->>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] ->>> :{ -data Row = Row { col1 :: Optional SOP.I ('Def :=> Int32), col2 :: Int32 } - deriving stock (GHC.Generic) - deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) -:} - ->>> :{ -let - manp :: Row -> Row -> Manipulation with (Public Schema) '[] '[] - manp row1 row2 = insertInto_ #tab $ inlineValues row1 [row2] - row1 = Row {col1 = Default, col2 = 2 :: Int32} - row2 = Row {col1 = NotDefault (3 :: Int32), col2 = 4 :: Int32} -in printSQL (manp row1 row2) -:} -INSERT INTO "tab" AS "tab" ("col1", "col2") VALUES (DEFAULT, (2 :: int4)), ((3 :: int4), (4 :: int4)) - -returning insert: - ->>> :{ -let - manp :: Manipulation with (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4] - manp = - insertInto #tab (Values_ (Set 2 `as` #col1 :* Set 3 `as` #col2)) - OnConflictDoRaise (Returning #col1) -in printSQL manp -:} -INSERT INTO "tab" AS "tab" ("col1", "col2") VALUES ((2 :: int4), (3 :: int4)) RETURNING "col1" AS "col1" - -upsert: - ->>> type CustomersColumns = '["name" ::: 'NoDef :=> 'NotNull 'PGtext, "email" ::: 'NoDef :=> 'NotNull 'PGtext] ->>> type CustomersConstraints = '["uq" ::: 'Unique '["name"]] ->>> type CustomersSchema = '["customers" ::: 'Table (CustomersConstraints :=> CustomersColumns)] ->>> :{ -let - manp :: Manipulation with (Public CustomersSchema) '[] '[] - manp = - insertInto #customers - (Values_ (Set "John Smith" `as` #name :* Set "john@smith.com" `as` #email)) - (OnConflict (OnConstraint #uq) - (DoUpdate (Set (#excluded ! #email <> "; " <> #customers ! #email) `as` #email) [])) - (Returning_ Nil) -in printSQL manp -:} -INSERT INTO "customers" AS "customers" ("name", "email") VALUES ((E'John Smith' :: text), (E'john@smith.com' :: text)) ON CONFLICT ON CONSTRAINT "uq" DO UPDATE SET "email" = ("excluded"."email" || ((E'; ' :: text) || "customers"."email")) - -query insert: - ->>> :{ -let - manp :: Manipulation with (Public Schema) '[] '[] - manp = insertInto_ #tab (Subquery (select Star (from (table #tab)))) -in printSQL manp -:} -INSERT INTO "tab" AS "tab" SELECT * FROM "tab" AS "tab" - -update: - ->>> :{ -let - manp :: Manipulation with (Public Schema) '[] '[] - manp = update_ #tab (Set 2 `as` #col1) (#col1 ./= #col2) -in printSQL manp -:} -UPDATE "tab" AS "tab" SET "col1" = (2 :: int4) WHERE ("col1" <> "col2") - -delete: - ->>> :{ -let - manp :: Manipulation with (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4] - manp = deleteFrom #tab NoUsing (#col1 .== #col2) (Returning Star) -in printSQL manp -:} -DELETE FROM "tab" AS "tab" WHERE ("col1" = "col2") RETURNING * - -delete and using clause: - ->>> :{ -type Schema3 = - '[ "tab" ::: 'Table ('[] :=> Columns) - , "other_tab" ::: 'Table ('[] :=> Columns) - , "third_tab" ::: 'Table ('[] :=> Columns) ] -:} - ->>> :{ -let - manp :: Manipulation with (Public Schema3) '[] '[] - manp = - deleteFrom #tab (Using (table #other_tab & also (table #third_tab))) - ( (#tab ! #col2 .== #other_tab ! #col2) - .&& (#tab ! #col2 .== #third_tab ! #col2) ) - (Returning_ Nil) -in printSQL manp -:} -DELETE FROM "tab" AS "tab" USING "other_tab" AS "other_tab", "third_tab" AS "third_tab" WHERE (("tab"."col2" = "other_tab"."col2") AND ("tab"."col2" = "third_tab"."col2")) - -with manipulation: - ->>> type ProductsColumns = '["product" ::: 'NoDef :=> 'NotNull 'PGtext, "date" ::: 'Def :=> 'NotNull 'PGdate] ->>> type ProductsSchema = '["products" ::: 'Table ('[] :=> ProductsColumns), "products_deleted" ::: 'Table ('[] :=> ProductsColumns)] ->>> :{ -let - manp :: Manipulation with (Public ProductsSchema) '[ 'NotNull 'PGdate] '[] - manp = with - (deleteFrom #products NoUsing (#date .< param @1) (Returning Star) `as` #del) - (insertInto_ #products_deleted (Subquery (select Star (from (common #del))))) -in printSQL manp -:} -WITH "del" AS (DELETE FROM "products" AS "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" AS "products_deleted" SELECT * FROM "del" AS "del" --} -newtype Manipulation - (with :: FromType) - (db :: SchemasType) - (params :: [NullType]) - (columns :: RowType) - = UnsafeManipulation { renderManipulation :: ByteString } - deriving stock (GHC.Generic,Show,Eq,Ord) - deriving newtype (NFData) -instance RenderSQL (Manipulation with db params columns) where - renderSQL = renderManipulation -instance With Manipulation where - with Done manip = manip - with ctes manip = UnsafeManipulation $ - "WITH" <+> commaSeparated (qtoList renderSQL ctes) <+> renderSQL manip - -{- | -The `Manipulation_` type is parameterized by a @db@ `SchemasType`, -against which it is type-checked, an input @params@ Haskell `Type`, -and an ouput row Haskell `Type`. - -Generally, @params@ will be a Haskell tuple or record whose entries -may be referenced using positional -`Squeal.PostgreSQL.Expression.Parameter.param`s and @row@ will be a -Haskell record, whose entries will be targeted using overloaded labels. - -A `Manipulation_` can be run -using `Squeal.PostgreSQL.Session.manipulateParams`, or if @params = ()@ -using `Squeal.PostgreSQL.Session.manipulate`. - -`Manipulation_` is a type family which resolves into a `Manipulation`, -so don't be fooled by the input params and output row Haskell `Type`s, -which are converted into appropriate -Postgres @[@`NullType`@]@ params and `RowType` rows. -Use `Squeal.PostgreSQL.Session.Statement.manipulation` to -fix actual Haskell input params and output rows. - ->>> :set -XDeriveAnyClass -XDerivingStrategies ->>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint8, "col2" ::: 'Def :=> 'NotNull 'PGtext] ->>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] ->>> :{ -data Row = Row { col1 :: Maybe Int64, col2 :: String } - deriving stock (GHC.Generic) - deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) -:} - ->>> :{ -let - manp :: Manipulation_ (Public Schema) (Int64, Int64) Row - manp = deleteFrom #tab NoUsing (#col1 .== param @1 + param @2) (Returning Star) - stmt :: Statement (Public Schema) (Int64, Int64) Row - stmt = manipulation manp -:} - ->>> :type manp -manp - :: Manipulation - '[] - '["public" ::: '["tab" ::: 'Table ('[] :=> Columns)]] - '[ 'NotNull 'PGint8, 'NotNull 'PGint8] - '["col1" ::: 'Null 'PGint8, "col2" ::: 'NotNull 'PGtext] ->>> :type stmt -stmt - :: Statement - '["public" ::: '["tab" ::: 'Table ('[] :=> Columns)]] - (Int64, Int64) - Row --} -type family Manipulation_ (db :: SchemasType) (params :: Type) (row :: Type) where - Manipulation_ db params row = Manipulation '[] db (TuplePG params) (RowPG row) - --- | Convert a `Query` into a `Manipulation`. -queryStatement - :: Query '[] with db params columns - -- ^ `Query` to embed as a `Manipulation` - -> Manipulation with db params columns -queryStatement q = UnsafeManipulation $ renderSQL q - --- | A `ReturningClause` computes and returns value(s) based --- on each row actually inserted, updated or deleted. This is primarily --- useful for obtaining values that were supplied by defaults, such as a --- serial sequence number. However, any expression using the table's columns --- is allowed. Only rows that were successfully inserted or updated or --- deleted will be returned. For example, if a row was locked --- but not updated because an `Squeal.PostgreSQL.Manipulation.Insert.OnConflict` --- `Squeal.PostgreSQL.Manipulation.Insert.DoUpdate` condition was not satisfied, --- the row will not be returned. `Returning` `Star` will return all columns --- in the row. Use `Returning_` `Nil` in the common case where no return --- values are desired. -newtype ReturningClause with db params from row = - Returning (Selection 'Ungrouped '[] with db params from row) - -instance RenderSQL (ReturningClause with db params from row) where - renderSQL = \case - Returning (List Nil) -> "" - Returning selection -> " RETURNING" <+> renderSQL selection - --- | `Returning` a `List` -pattern Returning_ - :: SOP.SListI row - => NP (Aliased (Expression 'Ungrouped '[] with db params from)) row - -- ^ row of values - -> ReturningClause with db params from row -pattern Returning_ list = Returning (List list) - --- | Specify additional tables with `Using` --- an `also` list of table expressions, allowing columns --- from other tables to appear in the WHERE condition. --- This is similar to the list of tables that can be specified --- in the FROM Clause of a SELECT statement; --- for example, an alias for the table name can be specified. --- Do not repeat the target table in the `Using` list, --- unless you wish to set up a self-join. --- `NoUsing` if no additional tables are to be used. -data UsingClause with db params from where - NoUsing :: UsingClause with db params '[] - Using - :: FromClause '[] with db params from - -- ^ what to use - -> UsingClause with db params from diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation/Call.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation/Call.hs deleted file mode 100644 index e3bcc828..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation/Call.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Call -Description: call statements -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -call statements --} - -{-# LANGUAGE - DeriveGeneric - , DerivingStrategies - , FlexibleContexts - , FlexibleInstances - , GADTs - , GeneralizedNewtypeDeriving - , LambdaCase - , MultiParamTypeClasses - , OverloadedStrings - , PatternSynonyms - , QuantifiedConstraints - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeFamilies - , TypeInType - , TypeOperators - , UndecidableInstances -#-} - -module Squeal.PostgreSQL.Manipulation.Call - ( -- * Call - call - , unsafeCall - , callN - , unsafeCallN - ) where - -import Data.ByteString hiding (foldr) - -import Generics.SOP (SListI) - -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Manipulation -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL - -{- | ->>> printSQL $ unsafeCall "p" true -CALL p(TRUE) --} -unsafeCall - :: ByteString -- ^ procedure to call - -> Expression 'Ungrouped '[] with db params '[] x -- ^ arguments - -> Manipulation with db params '[] -unsafeCall pro x = UnsafeManipulation $ - "CALL" <+> pro <> parenthesized (renderSQL x) - -{- | Call a user defined procedure of one variable. - ->>> type Schema = '[ "p" ::: 'Procedure '[ 'NotNull 'PGint4 ] ] ->>> :{ -let - p :: Manipulation '[] (Public Schema) '[] '[] - p = call #p 1 -in - printSQL p -:} -CALL "p"((1 :: int4)) --} -call - :: ( Has sch db schema - , Has pro schema ('Procedure '[x]) ) - => QualifiedAlias sch pro -- ^ procedure to call - -> Expression 'Ungrouped '[] with db params '[] x -- ^ arguments - -> Manipulation with db params '[] -call = unsafeCall . renderSQL - - -{- | ->>> printSQL $ unsafeCallN "p" (true *: false) -CALL p(TRUE, FALSE) --} -unsafeCallN - :: SListI xs - => ByteString -- ^ procedure to call - -> NP (Expression 'Ungrouped '[] with db params '[]) xs -- ^ arguments - -> Manipulation with db params '[] -unsafeCallN pro xs = UnsafeManipulation $ - "CALL" <+> pro <> parenthesized (renderCommaSeparated renderSQL xs) - -{- | Call a user defined procedure. - ->>> type Schema = '[ "p" ::: 'Procedure '[ 'NotNull 'PGint4, 'NotNull 'PGtext ] ] ->>> :{ -let - p :: Manipulation '[] (Public Schema) '[] '[] - p = callN #p (1 *: "hi") -in - printSQL p -:} -CALL "p"((1 :: int4), (E'hi' :: text)) --} -callN - :: ( Has sch db schema - , Has pro schema ('Procedure xs) - , SListI xs ) - => QualifiedAlias sch pro -- ^ procedure to call - -> NP (Expression 'Ungrouped '[] with db params '[]) xs -- ^ arguments - -> Manipulation with db params '[] -callN = unsafeCallN . renderSQL diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation/Delete.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation/Delete.hs deleted file mode 100644 index 13f9dd44..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation/Delete.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Delete -Description: delete statements -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -delete statements --} - -{-# LANGUAGE - DeriveGeneric - , DerivingStrategies - , FlexibleContexts - , FlexibleInstances - , GADTs - , GeneralizedNewtypeDeriving - , LambdaCase - , MultiParamTypeClasses - , OverloadedStrings - , PatternSynonyms - , QuantifiedConstraints - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeFamilies - , TypeInType - , TypeOperators - , UndecidableInstances -#-} - -module Squeal.PostgreSQL.Manipulation.Delete - ( -- * Delete - deleteFrom - , deleteFrom_ - ) where - -import qualified Generics.SOP as SOP - -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Expression.Logic -import Squeal.PostgreSQL.Manipulation -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL - -{----------------------------------------- -DELETE statements ------------------------------------------} - -{- | Delete rows from a table. - ->>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4] ->>> type Schema = '["tab1" ::: 'Table ('[] :=> Columns), "tab2" ::: 'Table ('[] :=> Columns)] ->>> :{ -let - manp :: Manipulation with (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4] - manp = deleteFrom #tab1 (Using (table #tab2)) (#tab1 ! #col1 .== #tab2 ! #col2) (Returning (#tab1 & DotStar)) -in printSQL manp -:} -DELETE FROM "tab1" AS "tab1" USING "tab2" AS "tab2" WHERE ("tab1"."col1" = "tab2"."col2") RETURNING "tab1".* --} -deleteFrom - :: ( SOP.SListI row - , Has sch db schema - , Has tab0 schema ('Table table) ) - => Aliased (QualifiedAlias sch) (tab ::: tab0) -- ^ table to delete from - -> UsingClause with db params from - -> Condition 'Ungrouped '[] with db params (tab ::: TableToRow table ': from) - -- ^ condition under which to delete a row - -> ReturningClause with db params (tab ::: TableToRow table ': from) row - -- ^ results to return - -> Manipulation with db params row -deleteFrom (tab0 `As` tab) using wh returning = UnsafeManipulation $ - "DELETE FROM" - <+> renderSQL tab0 <+> "AS" <+> renderSQL tab - <> case using of - NoUsing -> "" - Using tables -> " USING" <+> renderSQL tables - <+> "WHERE" <+> renderSQL wh - <> renderSQL returning - -{- | Delete rows returning `Nil`. - ->>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4] ->>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] ->>> :{ -let - manp :: Manipulation with (Public Schema) '[ 'NotNull 'PGint4] '[] - manp = deleteFrom_ (#tab `as` #t) (#t ! #col1 .== param @1) -in printSQL manp -:} -DELETE FROM "tab" AS "t" WHERE ("t"."col1" = ($1 :: int4)) --} -deleteFrom_ - :: ( Has sch db schema - , Has tab0 schema ('Table table) ) - => Aliased (QualifiedAlias sch) (tab ::: tab0) -- ^ table to delete from - -> Condition 'Ungrouped '[] with db params '[tab ::: TableToRow table] - -- ^ condition under which to delete a row - -> Manipulation with db params '[] -deleteFrom_ tab wh = deleteFrom tab NoUsing wh (Returning_ Nil) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation/Insert.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation/Insert.hs deleted file mode 100644 index fc7eb881..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation/Insert.hs +++ /dev/null @@ -1,288 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Manipulation.Insert -Description: insert statements -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -insert statements --} - -{-# LANGUAGE - DeriveGeneric - , DerivingStrategies - , FlexibleContexts - , FlexibleInstances - , GADTs - , GeneralizedNewtypeDeriving - , LambdaCase - , MultiParamTypeClasses - , OverloadedStrings - , PatternSynonyms - , QuantifiedConstraints - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeFamilies - , TypeInType - , TypeOperators - , UndecidableInstances -#-} - -module Squeal.PostgreSQL.Manipulation.Insert - ( -- * Insert - insertInto - , insertInto_ - -- * Clauses - , QueryClause (..) - , pattern Values_ - , inlineValues - , inlineValues_ - , ConflictClause (..) - , ConflictTarget (..) - , ConflictAction (..) - ) where - -import Data.ByteString hiding (foldr) - -import qualified Generics.SOP as SOP -import qualified Generics.SOP.Record as SOP - -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Expression.Default -import Squeal.PostgreSQL.Expression.Inline -import Squeal.PostgreSQL.Expression.Logic -import Squeal.PostgreSQL.Manipulation -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Query -import Squeal.PostgreSQL.Query.Table -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL - -{----------------------------------------- -INSERT statements ------------------------------------------} - -{- | -When a table is created, it contains no data. The first thing to do -before a database can be of much use is to insert data. Data is -conceptually inserted one row at a time. Of course you can also insert -more than one row, but there is no way to insert less than one row. -Even if you know only some column values, a complete row must be created. - ->>> type CustomersColumns = '["name" ::: 'NoDef :=> 'NotNull 'PGtext, "email" ::: 'NoDef :=> 'NotNull 'PGtext] ->>> type CustomersConstraints = '["uq" ::: 'Unique '["name"]] ->>> type CustomersSchema = '["customers" ::: 'Table (CustomersConstraints :=> CustomersColumns)] ->>> :{ -let - manp :: Manipulation with (Public CustomersSchema) '[] '[] - manp = - insertInto #customers - (Values_ (Set "John Smith" `as` #name :* Set "john@smith.com" `as` #email)) - (OnConflict (OnConstraint #uq) - (DoUpdate (Set (#excluded ! #email <> "; " <> #customers ! #email) `as` #email) [])) - (Returning_ Nil) -in printSQL manp -:} -INSERT INTO "customers" AS "customers" ("name", "email") VALUES ((E'John Smith' :: text), (E'john@smith.com' :: text)) ON CONFLICT ON CONSTRAINT "uq" DO UPDATE SET "email" = ("excluded"."email" || ((E'; ' :: text) || "customers"."email")) --} -insertInto - :: ( Has sch db schema - , Has tab0 schema ('Table table) - , SOP.SListI (TableToColumns table) - , SOP.SListI row ) - => Aliased (QualifiedAlias sch) (tab ::: tab0) - -- ^ table - -> QueryClause with db params (TableToColumns table) - -- ^ what to insert - -> ConflictClause tab with db params table - -- ^ what to do in case of conflict - -> ReturningClause with db params '[tab ::: TableToRow table] row - -- ^ what to return - -> Manipulation with db params row -insertInto (tab0 `As` tab) qry conflict ret = UnsafeManipulation $ - "INSERT" <+> "INTO" - <+> renderSQL tab0 <+> "AS" <+> renderSQL tab - <+> renderSQL qry - <> renderSQL conflict - <> renderSQL ret - -{- | Like `insertInto` but with `OnConflictDoRaise` and no `ReturningClause`. - ->>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint4, "col2" ::: 'Def :=> 'NotNull 'PGint4] ->>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] ->>> :{ -let - manp :: Manipulation with (Public Schema) '[] '[] - manp = - insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2)) -in printSQL manp -:} -INSERT INTO "tab" AS "tab" ("col1", "col2") VALUES ((2 :: int4), DEFAULT) --} -insertInto_ - :: ( Has sch db schema - , Has tab0 schema ('Table table) - , SOP.SListI (TableToColumns table) ) - => Aliased (QualifiedAlias sch) (tab ::: tab0) - -- ^ table - -> QueryClause with db params (TableToColumns table) - -- ^ what to insert - -> Manipulation with db params '[] -insertInto_ tab qry = - insertInto tab qry OnConflictDoRaise (Returning_ Nil) - --- | A `QueryClause` describes what to `insertInto` a table. -data QueryClause with db params columns where - Values - :: SOP.SListI columns - => NP (Aliased (Optional (Expression 'Ungrouped '[] with db params from))) columns - -- ^ row of values - -> [NP (Aliased (Optional (Expression 'Ungrouped '[] with db params from))) columns] - -- ^ additional rows of values - -> QueryClause with db params columns - Select - :: SOP.SListI columns - => NP (Aliased (Optional (Expression grp '[] with db params from))) columns - -- ^ row of values - -> TableExpression grp '[] with db params from - -- ^ from a table expression - -> QueryClause with db params columns - Subquery - :: ColumnsToRow columns ~ row - => Query '[] with db params row - -- ^ subquery to insert - -> QueryClause with db params columns - -instance RenderSQL (QueryClause with db params columns) where - renderSQL = \case - Values row0 rows -> - parenthesized (renderCommaSeparated renderSQLPart row0) - <+> "VALUES" - <+> commaSeparated - ( parenthesized - . renderCommaSeparated renderValuePart <$> row0 : rows ) - Select row0 tab -> - parenthesized (renderCommaSeparatedMaybe renderSQLPartMaybe row0) - <+> "SELECT" - <+> renderCommaSeparatedMaybe renderValuePartMaybe row0 - <+> renderSQL tab - Subquery qry -> renderQuery qry - where - renderSQLPartMaybe, renderValuePartMaybe - :: Aliased (Optional (Expression grp '[] with db params from)) column - -> Maybe ByteString - renderSQLPartMaybe = \case - Default `As` _ -> Nothing - Set _ `As` name -> Just $ renderSQL name - renderValuePartMaybe = \case - Default `As` _ -> Nothing - Set value `As` _ -> Just $ renderExpression value - renderSQLPart, renderValuePart - :: Aliased (Optional (Expression grp '[] with db params from)) column - -> ByteString - renderSQLPart (_ `As` name) = renderSQL name - renderValuePart (value `As` _) = renderSQL value - --- | `Values_` describes a single `NP` list of `Aliased` `Optional` `Expression`s --- whose `ColumnsType` must match the tables'. -pattern Values_ - :: SOP.SListI columns - => NP (Aliased (Optional (Expression 'Ungrouped '[] with db params from))) columns - -- ^ row of values - -> QueryClause with db params columns -pattern Values_ vals = Values vals [] - --- | `inlineValues_` a Haskell record in `insertInto`. -inlineValues_ - :: ( SOP.IsRecord hask xs - , SOP.AllZip InlineColumn xs columns ) - => hask -- ^ record - -> QueryClause with db params columns -inlineValues_ = Values_ . inlineColumns - --- | `inlineValues` Haskell records in `insertInto`. -inlineValues - :: ( SOP.IsRecord hask xs - , SOP.AllZip InlineColumn xs columns ) - => hask -- ^ record - -> [hask] -- ^ more - -> QueryClause with db params columns -inlineValues hask hasks = Values (inlineColumns hask) (inlineColumns <$> hasks) - --- | A `ConflictClause` specifies an action to perform upon a constraint --- violation. `OnConflictDoRaise` will raise an error. --- `OnConflict` `DoNothing` simply avoids inserting a row. --- `OnConflict` `DoUpdate` updates the existing row that conflicts with the row --- proposed for insertion. -data ConflictClause tab with db params table where - OnConflictDoRaise :: ConflictClause tab with db params table - OnConflict - :: ConflictTarget table - -- ^ conflict target - -> ConflictAction tab with db params table - -- ^ conflict action - -> ConflictClause tab with db params table - --- | Render a `ConflictClause`. -instance SOP.SListI (TableToColumns table) - => RenderSQL (ConflictClause tab with db params table) where - renderSQL = \case - OnConflictDoRaise -> "" - OnConflict target action -> " ON CONFLICT" - <+> renderSQL target <+> renderSQL action - -{- | -`ConflictAction` specifies an alternative `OnConflict` action. -It can be either `DoNothing`, or a `DoUpdate` clause specifying -the exact details of the update action to be performed in case of a conflict. -The `Set` and WHERE `Condition`s in `OnConflict` `DoUpdate` have access to the -existing row using the table's name, and to rows proposed -for insertion using the special @#excluded@ row. -`OnConflict` `DoNothing` simply avoids inserting a row as its alternative action. -`OnConflict` `DoUpdate` updates the existing row that conflicts -with the row proposed for insertion as its alternative action. --} -data ConflictAction tab with db params table where - DoNothing :: ConflictAction tab with db params table - DoUpdate - :: ( row ~ TableToRow table - , from ~ '[tab ::: row, "excluded" ::: row] - , Updatable table updates ) - => NP (Aliased (Optional (Expression 'Ungrouped '[] with db params from))) updates - -> [Condition 'Ungrouped '[] with db params from] - -- ^ WHERE `Condition`s - -> ConflictAction tab with db params table - -instance RenderSQL (ConflictAction tab with db params table) where - renderSQL = \case - DoNothing -> "DO NOTHING" - DoUpdate updates whs' - -> "DO UPDATE SET" - <+> renderCommaSeparated renderUpdate updates - <> case whs' of - [] -> "" - wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs) - -renderUpdate - :: (forall x. RenderSQL (expr x)) - => Aliased (Optional expr) ty - -> ByteString -renderUpdate (expr `As` col) = renderSQL col <+> "=" <+> renderSQL expr - --- | A `ConflictTarget` specifies the constraint violation that triggers a --- `ConflictAction`. -data ConflictTarget table where - OnConstraint - :: Has con constraints constraint - => Alias con - -> ConflictTarget (constraints :=> columns) - --- | Render a `ConflictTarget` -instance RenderSQL (ConflictTarget constraints) where - renderSQL (OnConstraint con) = - "ON" <+> "CONSTRAINT" <+> renderSQL con diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation/Update.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation/Update.hs deleted file mode 100644 index af6b3351..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation/Update.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Update -Description: update statements -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -update statements --} - -{-# LANGUAGE - DeriveGeneric - , DerivingStrategies - , FlexibleContexts - , FlexibleInstances - , GADTs - , GeneralizedNewtypeDeriving - , LambdaCase - , MultiParamTypeClasses - , OverloadedStrings - , PatternSynonyms - , QuantifiedConstraints - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeFamilies - , TypeInType - , TypeOperators - , UndecidableInstances -#-} - -module Squeal.PostgreSQL.Manipulation.Update - ( -- * Update - update - , update_ - ) where - -import Data.ByteString hiding (foldr) -import GHC.TypeLits - -import qualified Generics.SOP as SOP - -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Expression.Default -import Squeal.PostgreSQL.Expression.Logic -import Squeal.PostgreSQL.Manipulation -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL - -renderUpdate - :: (forall x. RenderSQL (expr x)) - => Aliased (Optional expr) ty - -> ByteString -renderUpdate (expr `As` col) = renderSQL col <+> "=" <+> renderSQL expr - -{----------------------------------------- -UPDATE statements ------------------------------------------} - -{- | An `update` command changes the values of the specified columns -in all rows that satisfy the condition. - ->>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4] ->>> type Schema = '["tab1" ::: 'Table ('[] :=> Columns), "tab2" ::: 'Table ('[] :=> Columns)] ->>> :{ -let - manp :: Manipulation with (Public Schema) '[] - '["col1" ::: 'NotNull 'PGint4, - "col2" ::: 'NotNull 'PGint4] - manp = update - (#tab1 `as` #t1) - (Set (2 + #t2 ! #col2) `as` #col1) - (Using (table (#tab2 `as` #t2))) - (#t1 ! #col1 ./= #t2 ! #col2) - (Returning (#t1 & DotStar)) -in printSQL manp -:} -UPDATE "tab1" AS "t1" SET "col1" = ((2 :: int4) + "t2"."col2") FROM "tab2" AS "t2" WHERE ("t1"."col1" <> "t2"."col2") RETURNING "t1".* --} -update - :: ( Has sch db schema - , Has tab0 schema ('Table table) - , Updatable table updates - , SOP.SListI row ) - => Aliased (QualifiedAlias sch) (tab ::: tab0) -- ^ table to update - -> NP (Aliased (Optional (Expression 'Ungrouped '[] with db params (tab ::: TableToRow table ': from)))) updates - -- ^ update expressions, modified values to replace old values - -> UsingClause with db params from - -- ^ FROM A table expression allowing columns from other tables to appear - -- in the WHERE condition and update expressions. - -> Condition 'Ungrouped '[] with db params (tab ::: TableToRow table ': from) - -- ^ WHERE condition under which to perform update on a row - -> ReturningClause with db params (tab ::: TableToRow table ': from) row -- ^ results to return - -> Manipulation with db params row -update (tab0 `As` tab) columns using wh returning = UnsafeManipulation $ - "UPDATE" - <+> renderSQL tab0 <+> "AS" <+> renderSQL tab - <+> "SET" - <+> renderCommaSeparated renderUpdate columns - <> case using of - NoUsing -> "" - Using tables -> " FROM" <+> renderSQL tables - <+> "WHERE" <+> renderSQL wh - <> renderSQL returning - -{- | Update a row returning `Nil`. - ->>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4] ->>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] ->>> :{ -let - manp :: Manipulation with (Public Schema) '[] '[] - manp = update_ #tab (Set 2 `as` #col1) (#col1 ./= #col2) -in printSQL manp -:} -UPDATE "tab" AS "tab" SET "col1" = (2 :: int4) WHERE ("col1" <> "col2") --} -update_ - :: ( Has sch db schema - , Has tab0 schema ('Table table) - , KnownSymbol tab - , Updatable table updates ) - => Aliased (QualifiedAlias sch) (tab ::: tab0) -- ^ table to update - -> NP (Aliased (Optional (Expression 'Ungrouped '[] with db params '[tab ::: TableToRow table]))) updates - -- ^ modified values to replace old values - -> Condition 'Ungrouped '[] with db params '[tab ::: TableToRow table] - -- ^ condition under which to perform update on a row - -> Manipulation with db params '[] -update_ tab columns wh = update tab columns NoUsing wh (Returning_ Nil) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs deleted file mode 100644 index ca9715b6..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Query.hs +++ /dev/null @@ -1,417 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Query -Description: structured query language -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -structured query language --} - -{-# LANGUAGE - ConstraintKinds - , DeriveGeneric - , DerivingStrategies - , FlexibleContexts - , FlexibleInstances - , GADTs - , GeneralizedNewtypeDeriving - , LambdaCase - , MultiParamTypeClasses - , OverloadedLabels - , OverloadedStrings - , QuantifiedConstraints - , ScopedTypeVariables - , StandaloneDeriving - , TypeApplications - , TypeFamilies - , TypeInType - , TypeOperators - , RankNTypes - , UndecidableInstances - #-} - -module Squeal.PostgreSQL.Query - ( -- * Query - Query (..) - , Query_ - -- ** Set Operations - , union - , unionAll - , intersect - , intersectAll - , except - , exceptAll - ) where - -import Control.DeepSeq -import Data.ByteString (ByteString) -import Data.Kind (Type) - -import qualified GHC.Generics as GHC - -import Squeal.PostgreSQL.Type.PG -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL --- >>> import Data.Int (Int32, Int64) --- >>> import Data.Monoid (Sum (..)) --- >>> import Data.Text (Text) --- >>> import qualified Generics.SOP as SOP - -{- | -The process of retrieving or the command to retrieve data from -a database is called a `Query`. - -The general `Query` type is parameterized by - -* @lat :: FromType@ - scope for `Squeal.PostgreSQL.Query.From.Join.JoinLateral` and subquery expressions, -* @with :: FromType@ - scope for all `Squeal.PostgreSQL.Query.From.common` table expressions, -* @db :: SchemasType@ - scope for all `Squeal.PostgreSQL.Query.From.table`s and `Squeal.PostgreSQL.Query.From.view`s, -* @params :: [NullType]@ - scope for all `Squeal.Expression.Parameter.parameter`s, -* @row :: RowType@ - return type of the `Query`. - -Let's see some `Query` examples. - -simple query: - ->>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4] ->>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] ->>> :{ -let - qry :: Query lat with (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4] - qry = select Star (from (table #tab)) -in printSQL qry -:} -SELECT * FROM "tab" AS "tab" - -restricted query: - ->>> :{ -let - qry :: Query '[] with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4] - qry = - select_ ((#col1 + #col2) `as` #col1 :* #col1 `as` #col2) - ( from (table #tab) - & where_ (#col1 .> #col2) - & where_ (#col2 .> 0) ) -in printSQL qry -:} -SELECT ("col1" + "col2") AS "col1", "col1" AS "col2" FROM "tab" AS "tab" WHERE (("col1" > "col2") AND ("col2" > (0 :: int4))) - -subquery: - ->>> :{ -let - qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4] - qry = select Star (from (subquery (select Star (from (table #tab)) `as` #sub))) -in printSQL qry -:} -SELECT * FROM (SELECT * FROM "tab" AS "tab") AS "sub" - -limits and offsets: - ->>> :{ -let - qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4] - qry = select Star (from (table #tab) & limit 100 & offset 2 & limit 50 & offset 2) -in printSQL qry -:} -SELECT * FROM "tab" AS "tab" LIMIT 50 OFFSET 4 - -parameterized query: - ->>> :{ -let - qry :: Query '[] with (Public Schema) '[ 'NotNull 'PGint4] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4] - qry = select Star (from (table #tab) & where_ (#col1 .> param @1)) -in printSQL qry -:} -SELECT * FROM "tab" AS "tab" WHERE ("col1" > ($1 :: int4)) - -aggregation query: - ->>> :{ -let - qry :: Query '[] with (Public Schema) params '["col1" ::: 'NotNull 'PGint8, "col2" ::: 'NotNull 'PGint4] - qry = - select_ ((fromNull 0 (sum_ (All #col2))) `as` #col1 :* #col1 `as` #col2) - ( from (table (#tab `as` #table1)) - & groupBy #col1 - & having (sum_ (Distinct #col2) .> 1) ) -in printSQL qry -:} -SELECT COALESCE(sum(ALL "col2"), (0 :: int8)) AS "col1", "col1" AS "col2" FROM "tab" AS "table1" GROUP BY "col1" HAVING (sum(DISTINCT "col2") > (1 :: int8)) - -sorted query: - ->>> :{ -let - qry :: Query '[] with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4] - qry = select Star (from (table #tab) & orderBy [#col1 & Asc]) -in printSQL qry -:} -SELECT * FROM "tab" AS "tab" ORDER BY "col1" ASC - -joins: - ->>> :{ -type OrdersColumns = - '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4 - , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4 - , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4 - , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4 ] -:} - ->>> :{ -type OrdersConstraints = - '["pk_orders" ::: PrimaryKey '["id"] - ,"fk_customers" ::: ForeignKey '["customer_id"] "public" "customers" '["id"] - ,"fk_shippers" ::: ForeignKey '["shipper_id"] "public" "shippers" '["id"] ] -:} - ->>> type NamesColumns = '["id" ::: 'NoDef :=> 'NotNull 'PGint4, "name" ::: 'NoDef :=> 'NotNull 'PGtext] ->>> type CustomersConstraints = '["pk_customers" ::: PrimaryKey '["id"]] ->>> type ShippersConstraints = '["pk_shippers" ::: PrimaryKey '["id"]] ->>> :{ -type OrdersSchema = - '[ "orders" ::: 'Table (OrdersConstraints :=> OrdersColumns) - , "customers" ::: 'Table (CustomersConstraints :=> NamesColumns) - , "shippers" ::: 'Table (ShippersConstraints :=> NamesColumns) ] -:} - ->>> :{ -type OrderRow = - '[ "price" ::: 'NotNull 'PGfloat4 - , "customerName" ::: 'NotNull 'PGtext - , "shipperName" ::: 'NotNull 'PGtext - ] -:} - ->>> :{ -let - qry :: Query lat with (Public OrdersSchema) params OrderRow - qry = select_ - ( #o ! #price `as` #price :* - #c ! #name `as` #customerName :* - #s ! #name `as` #shipperName ) - ( from (table (#orders `as` #o) - & innerJoin (table (#customers `as` #c)) - (#o ! #customer_id .== #c ! #id) - & innerJoin (table (#shippers `as` #s)) - (#o ! #shipper_id .== #s ! #id)) ) -in printSQL qry -:} -SELECT "o"."price" AS "price", "c"."name" AS "customerName", "s"."name" AS "shipperName" FROM "orders" AS "o" INNER JOIN "customers" AS "c" ON ("o"."customer_id" = "c"."id") INNER JOIN "shippers" AS "s" ON ("o"."shipper_id" = "s"."id") - -self-join: - ->>> :{ -let - qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4] - qry = select - (#t1 & DotStar) - (from (table (#tab `as` #t1) & crossJoin (table (#tab `as` #t2)))) -in printSQL qry -:} -SELECT "t1".* FROM "tab" AS "t1" CROSS JOIN "tab" AS "t2" - -value queries: - ->>> :{ -let - qry :: Query lat with db params '["col1" ::: 'NotNull 'PGtext, "col2" ::: 'NotNull 'PGbool] - qry = values - ("true" `as` #col1 :* true `as` #col2) - ["false" `as` #col1 :* false `as` #col2] -in printSQL qry -:} -SELECT * FROM (VALUES ((E'true' :: text), TRUE), ((E'false' :: text), FALSE)) AS t ("col1", "col2") - -set operations: - ->>> :{ -let - qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4] - qry = select Star (from (table #tab)) `unionAll` select Star (from (table #tab)) -in printSQL qry -:} -(SELECT * FROM "tab" AS "tab") UNION ALL (SELECT * FROM "tab" AS "tab") - -with query: - ->>> :{ -let - qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4] - qry = with ( - select Star (from (table #tab)) `as` #cte1 :>> - select Star (from (common #cte1)) `as` #cte2 - ) (select Star (from (common #cte2))) -in printSQL qry -:} -WITH "cte1" AS (SELECT * FROM "tab" AS "tab"), "cte2" AS (SELECT * FROM "cte1" AS "cte1") SELECT * FROM "cte2" AS "cte2" - -window functions: - ->>> :{ -let - qry :: Query '[] with (Public Schema) db '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint8] - qry = select - (#col1 & Also (rank `as` #col2 `Over` (partitionBy #col1 & orderBy [#col2 & Asc]))) - (from (table #tab)) -in printSQL qry -:} -SELECT "col1" AS "col1", rank() OVER (PARTITION BY "col1" ORDER BY "col2" ASC) AS "col2" FROM "tab" AS "tab" - -correlated subqueries: - ->>> :{ -let - qry :: Query '[] with (Public Schema) params '["col1" ::: 'NotNull 'PGint4] - qry = - select #col1 (from (table (#tab `as` #t1)) - & where_ (exists ( - select Star (from (table (#tab `as` #t2)) - & where_ (#t2 ! #col2 .== #t1 ! #col1))))) -in printSQL qry -:} -SELECT "col1" AS "col1" FROM "tab" AS "t1" WHERE EXISTS (SELECT * FROM "tab" AS "t2" WHERE ("t2"."col2" = "t1"."col1")) --} -newtype Query - (lat :: FromType) - (with :: FromType) - (db :: SchemasType) - (params :: [NullType]) - (row :: RowType) - = UnsafeQuery { renderQuery :: ByteString } - deriving stock (GHC.Generic,Show,Eq,Ord) - deriving newtype (NFData) -instance RenderSQL (Query lat with db params row) where renderSQL = renderQuery - -{- | -The `Query_` type is parameterized by a @db@ `SchemasType`, -against which the query is type-checked, an input @params@ Haskell `Type`, -and an ouput row Haskell `Type`. - -A `Query_` can be run -using `Squeal.PostgreSQL.Session.runQueryParams`, or if @params = ()@ -using `Squeal.PostgreSQL.Session.runQuery`. - -Generally, @params@ will be a Haskell tuple or record whose entries -may be referenced using positional -`Squeal.PostgreSQL.Expression.Parameter.parameter`s and @row@ will be a -Haskell record, whose entries will be targeted using overloaded labels. - -`Query_` is a type family which resolves into a `Query`, -so don't be fooled by the input params and output row Haskell `Type`s, -which are converted into appropriate -Postgres @[@`NullType`@]@ params and `RowType` rows. -Use `Squeal.PostgreSQL.Session.Statement.query` to -fix actual Haskell input params and output rows. - ->>> :set -XDeriveAnyClass -XDerivingStrategies ->>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint8, "col2" ::: 'Def :=> 'NotNull 'PGtext] ->>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] ->>> :{ -data Row = Row { col1 :: Maybe Int64, col2 :: String } - deriving stock (GHC.Generic) - deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) -:} - ->>> :{ -let - qry :: Query_ (Public Schema) (Int64, Bool) Row - qry = select Star (from (table #tab) & where_ (#col1 .> param @1 .&& notNull (param @2))) - stmt :: Statement (Public Schema) (Int64, Bool) Row - stmt = query qry -:} - ->>> :type qry -qry - :: Query - '[] - '[] - '["public" ::: '["tab" ::: 'Table ('[] :=> Columns)]] - '[ 'NotNull 'PGint8, 'NotNull 'PGbool] - '["col1" ::: 'Null 'PGint8, "col2" ::: 'NotNull 'PGtext] ->>> :type stmt -stmt - :: Statement - '["public" ::: '["tab" ::: 'Table ('[] :=> Columns)]] - (Int64, Bool) - Row --} -type family Query_ - (db :: SchemasType) - (params :: Type) - (row :: Type) where - Query_ db params row = - Query '[] '[] db (TuplePG params) (RowPG row) - --- | The results of two queries can be combined using the set operation --- `union`. Duplicate rows are eliminated. -union - :: Query lat with db params columns -- ^ - -> Query lat with db params columns - -> Query lat with db params columns -q1 `union` q2 = UnsafeQuery $ - parenthesized (renderSQL q1) - <+> "UNION" - <+> parenthesized (renderSQL q2) - --- | The results of two queries can be combined using the set operation --- `unionAll`, the disjoint union. Duplicate rows are retained. -unionAll - :: Query lat with db params columns -- ^ - -> Query lat with db params columns - -> Query lat with db params columns -q1 `unionAll` q2 = UnsafeQuery $ - parenthesized (renderSQL q1) - <+> "UNION" <+> "ALL" - <+> parenthesized (renderSQL q2) - --- | The results of two queries can be combined using the set operation --- `intersect`, the intersection. Duplicate rows are eliminated. -intersect - :: Query lat with db params columns -- ^ - -> Query lat with db params columns - -> Query lat with db params columns -q1 `intersect` q2 = UnsafeQuery $ - parenthesized (renderSQL q1) - <+> "INTERSECT" - <+> parenthesized (renderSQL q2) - --- | The results of two queries can be combined using the set operation --- `intersectAll`, the intersection. Duplicate rows are retained. -intersectAll - :: Query lat with db params columns -- ^ - -> Query lat with db params columns - -> Query lat with db params columns -q1 `intersectAll` q2 = UnsafeQuery $ - parenthesized (renderSQL q1) - <+> "INTERSECT" <+> "ALL" - <+> parenthesized (renderSQL q2) - --- | The results of two queries can be combined using the set operation --- `except`, the set difference. Duplicate rows are eliminated. -except - :: Query lat with db params columns -- ^ - -> Query lat with db params columns - -> Query lat with db params columns -q1 `except` q2 = UnsafeQuery $ - parenthesized (renderSQL q1) - <+> "EXCEPT" - <+> parenthesized (renderSQL q2) - --- | The results of two queries can be combined using the set operation --- `exceptAll`, the set difference. Duplicate rows are retained. -exceptAll - :: Query lat with db params columns -- ^ - -> Query lat with db params columns - -> Query lat with db params columns -q1 `exceptAll` q2 = UnsafeQuery $ - parenthesized (renderSQL q1) - <+> "EXCEPT" <+> "ALL" - <+> parenthesized (renderSQL q2) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Query/From.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Query/From.hs deleted file mode 100644 index 860380de..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Query/From.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Query.From -Description: from clauses -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -from clauses --} - -{-# LANGUAGE - ConstraintKinds - , DeriveGeneric - , DerivingStrategies - , FlexibleContexts - , FlexibleInstances - , GADTs - , GeneralizedNewtypeDeriving - , LambdaCase - , MultiParamTypeClasses - , OverloadedLabels - , OverloadedStrings - , QuantifiedConstraints - , ScopedTypeVariables - , StandaloneDeriving - , TypeApplications - , TypeFamilies - , TypeInType - , TypeOperators - , RankNTypes - , UndecidableInstances - #-} - -module Squeal.PostgreSQL.Query.From - ( -- * From Clause - FromClause (..) - , table - , subquery - , view - , common - ) where - -import Control.DeepSeq -import Data.ByteString (ByteString) - -import qualified GHC.Generics as GHC - -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Query -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL - -{----------------------------------------- -FROM clauses ------------------------------------------} - -{- | -A `FromClause` can be a table name, or a derived table such -as a subquery, a @JOIN@ construct, or complex combinations of these. --} -newtype FromClause - (lat :: FromType) - (with :: FromType) - (db :: SchemasType) - (params :: [NullType]) - (from :: FromType) - = UnsafeFromClause { renderFromClause :: ByteString } - deriving stock (GHC.Generic,Show,Eq,Ord) - deriving newtype (NFData) -instance RenderSQL (FromClause lat with db params from) where - renderSQL = renderFromClause - --- | A real `table` is a table from the database. -table - :: (Has sch db schema, Has tab schema ('Table table)) - => Aliased (QualifiedAlias sch) (alias ::: tab) -- ^ (renamable) table alias - -> FromClause lat with db params '[alias ::: TableToRow table] -table (tab `As` alias) = UnsafeFromClause $ - renderSQL tab <+> "AS" <+> renderSQL alias - -{- | `subquery` derives a table from a `Query`. -The subquery may not reference columns provided by preceding `FromClause` items. -Use `Squeal.PostgreSQL.Query.From.Join.JoinLateral` -if the subquery must reference columns provided by preceding `FromClause` items. --} -subquery - :: Aliased (Query lat with db params) query - -- ^ aliased `Query` - -> FromClause lat with db params '[query] -subquery = UnsafeFromClause . renderAliased (parenthesized . renderSQL) - --- | `view` derives a table from a `View`. -view - :: (Has sch db schema, Has vw schema ('View view)) - => Aliased (QualifiedAlias sch) (alias ::: vw) -- ^ (renamable) view alias - -> FromClause lat with db params '[alias ::: view] -view (vw `As` alias) = UnsafeFromClause $ - renderSQL vw <+> "AS" <+> renderSQL alias - --- | `common` derives a table from a common table expression. -common - :: Has cte with common - => Aliased Alias (alias ::: cte) -- ^ (renamable) common table expression alias - -> FromClause lat with db params '[alias ::: common] -common (cte `As` alias) = UnsafeFromClause $ - renderSQL cte <+> "AS" <+> renderSQL alias - -instance Additional (FromClause lat with db params) where - also right left = UnsafeFromClause $ - renderSQL left <> ", " <> renderSQL right diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Query/From/Join.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Query/From/Join.hs deleted file mode 100644 index af651693..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Query/From/Join.hs +++ /dev/null @@ -1,294 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Query.From.Join -Description: Squeal joins -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -Squeal joins --} - -{-# LANGUAGE - ConstraintKinds - , DeriveGeneric - , DerivingStrategies - , FlexibleContexts - , FlexibleInstances - , GADTs - , GeneralizedNewtypeDeriving - , LambdaCase - , MultiParamTypeClasses - , OverloadedLabels - , OverloadedStrings - , QuantifiedConstraints - , ScopedTypeVariables - , StandaloneDeriving - , TypeApplications - , TypeFamilies - , TypeInType - , TypeOperators - , RankNTypes - , UndecidableInstances - #-} - -module Squeal.PostgreSQL.Query.From.Join - ( -- * Join - JoinItem (..) - , cross, crossJoin, crossJoinLateral - , inner, innerJoin, innerJoinLateral - , leftOuter, leftOuterJoin, leftOuterJoinLateral - , rightOuter, rightOuterJoin, rightOuterJoinLateral - , fullOuter, fullOuterJoin, fullOuterJoinLateral - ) where - -import Generics.SOP hiding (from) - -import qualified Generics.SOP as SOP - -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Expression.Logic -import Squeal.PostgreSQL.Query -import Squeal.PostgreSQL.Query.From -import Squeal.PostgreSQL.Query.From.Set -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL - -{- | -A `JoinItem` is the right hand side of a `cross`, -`inner`, `leftOuter`, `rightOuter`, `fullOuter` join of -`FromClause`s. --} -data JoinItem - (lat :: FromType) - (with :: FromType) - (db :: SchemasType) - (params :: [NullType]) - (left :: FromType) - (right :: FromType) where - Join - :: FromClause lat with db params right - -- ^ A standard `Squeal.PostgreSQL.Query.Join`. - -- It is not allowed to reference columns provided - -- by preceding `FromClause` items. - -> JoinItem lat with db params left right - JoinLateral - :: Aliased (Query (Join lat left) with db params) query - -- ^ Subqueries can be preceded by `JoinLateral`. - -- This allows them to reference columns provided - -- by preceding `FromClause` items. - -> JoinItem lat with db params left '[query] - JoinFunction - :: SetFun db arg set - -- ^ Set returning functions can be preceded by `JoinFunction`. - -- This allows them to reference columns provided - -- by preceding `FromClause` items. - -> Expression 'Ungrouped lat with db params left arg - -- ^ argument - -> JoinItem lat with db params left '[set] - JoinFunctionN - :: SListI args - => SetFunN db args set - -- ^ Set returning multi-argument functions - -- can be preceded by `JoinFunctionN`. - -- This allows them to reference columns provided - -- by preceding `FromClause` items. - -> NP (Expression 'Ungrouped lat with db params left) args - -- ^ arguments - -> JoinItem lat with db params left '[set] -instance RenderSQL (JoinItem lat with db params left right) where - renderSQL = \case - Join tab -> "JOIN" <+> renderSQL tab - JoinLateral qry -> "JOIN LATERAL" <+> - renderAliased (parenthesized . renderSQL) qry - JoinFunction fun x -> "JOIN" <+> - renderSQL (fun (UnsafeExpression (renderSQL x))) - JoinFunctionN fun xs -> "JOIN" <+> - renderSQL (fun (SOP.hmap (UnsafeExpression . renderSQL) xs)) - -{- | -@left & cross (Join right)@. For every possible combination of rows from -@left@ and @right@ (i.e., a Cartesian product), the joined table will contain -a row consisting of all columns in @left@ followed by all columns in @right@. -If the tables have @n@ and @m@ rows respectively, the joined table will -have @n * m@ rows. --} -cross - :: JoinItem lat with db params left right -- ^ right - -> FromClause lat with db params left -- ^ left - -> FromClause lat with db params (Join left right) -cross item tab = UnsafeFromClause $ - renderSQL tab <+> "CROSS" <+> renderSQL item - -{- | -@left & crossJoin right@. For every possible combination of rows from -@left@ and @right@ (i.e., a Cartesian product), the joined table will contain -a row consisting of all columns in @left@ followed by all columns in @right@. -If the tables have @n@ and @m@ rows respectively, the joined table will -have @n * m@ rows. --} -crossJoin - :: FromClause lat with db params right -- ^ right - -> FromClause lat with db params left -- ^ left - -> FromClause lat with db params (Join left right) -crossJoin = cross . Join - -{- | -Like `crossJoin` with a `subquery` but allowed to reference columns provided -by preceding `FromClause` items. --} -crossJoinLateral - :: Aliased (Query (Join lat left) with db params) query -- ^ right subquery - -> FromClause lat with db params left -- ^ left - -> FromClause lat with db params (Join left '[query]) -crossJoinLateral = cross . JoinLateral - -{- | @left & inner (Join right) on@. The joined table is filtered by -the @on@ condition. --} -inner - :: JoinItem lat with db params left right -- ^ right - -> Condition 'Ungrouped lat with db params (Join left right) -- ^ @ON@ condition - -> FromClause lat with db params left -- ^ left - -> FromClause lat with db params (Join left right) -inner item on tab = UnsafeFromClause $ - renderSQL tab <+> "INNER" <+> renderSQL item <+> "ON" <+> renderSQL on - -{- | @left & innerJoin right on@. The joined table is filtered by -the @on@ condition. --} -innerJoin - :: FromClause lat with db params right -- ^ right - -> Condition 'Ungrouped lat with db params (Join left right) -- ^ @ON@ condition - -> FromClause lat with db params left -- ^ left - -> FromClause lat with db params (Join left right) -innerJoin = inner . Join - -{- | -Like `innerJoin` with a `subquery` but allowed to reference columns provided -by preceding `FromClause` items. --} -innerJoinLateral - :: Aliased (Query (Join lat left) with db params) query -- ^ right subquery - -> Condition 'Ungrouped lat with db params (Join left '[query]) -- ^ @ON@ condition - -> FromClause lat with db params left -- ^ left - -> FromClause lat with db params (Join left '[query]) -innerJoinLateral = inner . JoinLateral - -{- | @left & leftOuter (Join right) on@. First, an inner join is performed. -Then, for each row in @left@ that does not satisfy the @on@ condition with -any row in @right@, a joined row is added with null values in columns of @right@. -Thus, the joined table always has at least one row for each row in @left@. --} -leftOuter - :: JoinItem lat with db params left right -- ^ right - -> Condition 'Ungrouped lat with db params (Join left right) -- ^ @ON@ condition - -> FromClause lat with db params left -- ^ left - -> FromClause lat with db params (Join left (NullifyFrom right)) -leftOuter item on tab = UnsafeFromClause $ - renderSQL tab <+> "LEFT OUTER" <+> renderSQL item <+> "ON" <+> renderSQL on - -{- | @left & leftOuterJoin right on@. First, an inner join is performed. -Then, for each row in @left@ that does not satisfy the @on@ condition with -any row in @right@, a joined row is added with null values in columns of @right@. -Thus, the joined table always has at least one row for each row in @left@. --} -leftOuterJoin - :: FromClause lat with db params right -- ^ right - -> Condition 'Ungrouped lat with db params (Join left right) -- ^ @ON@ condition - -> FromClause lat with db params left -- ^ left - -> FromClause lat with db params (Join left (NullifyFrom right)) -leftOuterJoin = leftOuter . Join - -{- | -Like `leftOuterJoin` with a `subquery` but allowed to reference columns provided -by preceding `FromClause` items. --} -leftOuterJoinLateral - :: Aliased (Query (Join lat left) with db params) query -- ^ right subquery - -> Condition 'Ungrouped lat with db params (Join left '[query]) -- ^ @ON@ condition - -> FromClause lat with db params left -- ^ left - -> FromClause lat with db params (Join left (NullifyFrom '[query])) -leftOuterJoinLateral = leftOuter . JoinLateral - -{- | @left & rightOuter (Join right) on@. First, an inner join is performed. -Then, for each row in @right@ that does not satisfy the @on@ condition with -any row in @left@, a joined row is added with null values in columns of @left@. -This is the converse of a left join: the result table will always -have a row for each row in @right@. --} -rightOuter - :: JoinItem lat with db params left right -- ^ right - -> Condition 'Ungrouped lat with db params (Join left right) -- ^ @ON@ condition - -> FromClause lat with db params left -- ^ left - -> FromClause lat with db params (Join (NullifyFrom left) right) -rightOuter item on tab = UnsafeFromClause $ - renderSQL tab <+> "RIGHT OUTER" <+> renderSQL item <+> "ON" <+> renderSQL on - -{- | @left & rightOuterJoin right on@. First, an inner join is performed. -Then, for each row in @right@ that does not satisfy the @on@ condition with -any row in @left@, a joined row is added with null values in columns of @left@. -This is the converse of a left join: the result table will always -have a row for each row in @right@. --} -rightOuterJoin - :: FromClause lat with db params right -- ^ right - -> Condition 'Ungrouped lat with db params (Join left right) -- ^ @ON@ condition - -> FromClause lat with db params left -- ^ left - -> FromClause lat with db params (Join (NullifyFrom left) right) -rightOuterJoin = rightOuter . Join - -{- | -Like `rightOuterJoin` with a `subquery` but allowed to reference columns provided -by preceding `FromClause` items. --} -rightOuterJoinLateral - :: Aliased (Query (Join lat left) with db params) query -- ^ right subquery - -> Condition 'Ungrouped lat with db params (Join left '[query]) -- ^ @ON@ condition - -> FromClause lat with db params left -- ^ left - -> FromClause lat with db params (Join (NullifyFrom left) '[query]) -rightOuterJoinLateral = rightOuter . JoinLateral - -{- | @left & fullOuter (Join right) on@. First, an inner join is performed. -Then, for each row in @left@ that does not satisfy the @on@ condition with -any row in @right@, a joined row is added with null values in columns of @right@. -Also, for each row of @right@ that does not satisfy the join condition -with any row in @left@, a joined row with null values in the columns of @left@ -is added. --} -fullOuter - :: JoinItem lat with db params left right -- ^ right - -> Condition 'Ungrouped lat with db params (Join left right) -- ^ @ON@ condition - -> FromClause lat with db params left -- ^ left - -> FromClause lat with db params (NullifyFrom (Join left right)) -fullOuter item on tab = UnsafeFromClause $ - renderSQL tab <+> "FULL OUTER" <+> renderSQL item <+> "ON" <+> renderSQL on - -{- | @left & fullOuterJoin right on@. First, an inner join is performed. -Then, for each row in @left@ that does not satisfy the @on@ condition with -any row in @right@, a joined row is added with null values in columns of @right@. -Also, for each row of @right@ that does not satisfy the join condition -with any row in @left@, a joined row with null values in the columns of @left@ -is added. --} -fullOuterJoin - :: FromClause lat with db params right -- ^ right - -> Condition 'Ungrouped lat with db params (Join left right) -- ^ @ON@ condition - -> FromClause lat with db params left -- ^ left - -> FromClause lat with db params (NullifyFrom (Join left right)) -fullOuterJoin = fullOuter . Join - -{- | -Like `fullOuterJoin` with a `subquery` but allowed to reference columns provided -by preceding `FromClause` items. --} -fullOuterJoinLateral - :: Aliased (Query (Join lat left) with db params) query -- ^ right subquery - -> Condition 'Ungrouped lat with db params (Join left '[query]) -- ^ @ON@ condition - -> FromClause lat with db params left -- ^ left - -> FromClause lat with db params (NullifyFrom (Join left '[query])) -fullOuterJoinLateral = fullOuter . JoinLateral diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Query/From/Set.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Query/From/Set.hs deleted file mode 100644 index a0697de5..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Query/From/Set.hs +++ /dev/null @@ -1,204 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Query.From.Set -Description: set returning functions -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -set returning functions --} - -{-# LANGUAGE - ConstraintKinds - , DeriveGeneric - , DerivingStrategies - , FlexibleContexts - , FlexibleInstances - , GADTs - , GeneralizedNewtypeDeriving - , LambdaCase - , MultiParamTypeClasses - , OverloadedLabels - , OverloadedStrings - , QuantifiedConstraints - , ScopedTypeVariables - , StandaloneDeriving - , TypeApplications - , TypeFamilies - , TypeInType - , TypeOperators - , RankNTypes - , UndecidableInstances - #-} - -module Squeal.PostgreSQL.Query.From.Set - ( -- * Set Functions - type (-|->) - , type (--|->) - , SetFun - , SetFunN - , generateSeries - , generateSeriesStep - , generateSeriesTimestamp - , unsafeSetFunction - , setFunction - , unsafeSetFunctionN - , setFunctionN - ) where - -import Data.ByteString (ByteString) -import Generics.SOP hiding (from) -import GHC.TypeLits - -import qualified Generics.SOP as SOP - -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Query.From -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Type.Schema - -{- | -A @RankNType@ for set returning functions with 1 argument. --} -type (-|->) arg set = forall db. SetFun db arg set - -{- | -A @RankNType@ for set returning functions with multiple argument. --} -type (--|->) arg set = forall db. SetFunN db arg set - -- ^ output - -{- | -Like `-|->` but depends on the schemas of the database --} -type SetFun db arg row - = forall lat with params - . Expression 'Ungrouped lat with db params '[] arg - -- ^ input - -> FromClause lat with db params '[row] - -- ^ output - -{- | -Like `--|->` but depends on the schemas of the database --} -type SetFunN db args set - = forall lat with params - . NP (Expression 'Ungrouped lat with db params '[]) args - -- ^ input - -> FromClause lat with db params '[set] - -- ^ output - --- $setup --- >>> import Squeal.PostgreSQL - --- | Escape hatch for a set returning function of a single variable -unsafeSetFunction - :: forall fun ty row. KnownSymbol fun - => ByteString - -> ty -|-> (fun ::: row) -- ^ set returning function -unsafeSetFunction fun x = UnsafeFromClause $ - fun <> parenthesized (renderSQL x) - -{- | Call a user defined set returning function of a single variable - ->>> type Fn = '[ 'Null 'PGbool] :=> 'ReturnsTable '["ret" ::: 'NotNull 'PGnumeric] ->>> type Schema = '["fn" ::: 'Function Fn] ->>> :{ -let - fn :: SetFun (Public Schema) ('Null 'PGbool) ("fn" ::: '["ret" ::: 'NotNull 'PGnumeric]) - fn = setFunction #fn -in - printSQL (fn true) -:} -"fn"(TRUE) --} -setFunction - :: ( Has sch db schema - , Has fun schema ('Function ('[ty] :=> 'ReturnsTable row)) ) - => QualifiedAlias sch fun -- ^ function alias - -> SetFun db ty (fun ::: row) -setFunction fun = unsafeSetFunction (renderSQL fun) - -{- | Escape hatch for a multivariable set returning function-} -unsafeSetFunctionN - :: forall fun tys row. (SOP.SListI tys, KnownSymbol fun) - => ByteString - -> tys --|-> (fun ::: row) -- ^ set returning function -unsafeSetFunctionN fun xs = UnsafeFromClause $ - fun <> parenthesized (renderCommaSeparated renderSQL xs) - -{- | Call a user defined multivariable set returning function - ->>> type Fn = '[ 'Null 'PGbool, 'Null 'PGtext] :=> 'ReturnsTable '["ret" ::: 'NotNull 'PGnumeric] ->>> type Schema = '["fn" ::: 'Function Fn] ->>> :{ -let - fn :: SetFunN (Public Schema) - '[ 'Null 'PGbool, 'Null 'PGtext] - ("fn" ::: '["ret" ::: 'NotNull 'PGnumeric]) - fn = setFunctionN #fn -in - printSQL (fn (true *: "hi")) -:} -"fn"(TRUE, (E'hi' :: text)) --} -setFunctionN - :: ( Has sch db schema - , Has fun schema ('Function (tys :=> 'ReturnsTable row)) - , SOP.SListI tys ) - => QualifiedAlias sch fun -- ^ function alias - -> SetFunN db tys (fun ::: row) -setFunctionN fun = unsafeSetFunctionN (renderSQL fun) - -{- | @generateSeries (start :* stop)@ - -Generate a series of values, -from @start@ to @stop@ with a step size of one - ->>> printSQL (generateSeries @'PGint4 (1 *: 10)) -generate_series((1 :: int4), (10 :: int4)) --} -generateSeries - :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric] - => '[ null ty, null ty] --|-> - ("generate_series" ::: '["generate_series" ::: null ty]) - -- ^ set returning function -generateSeries = unsafeSetFunctionN "generate_series" - -{- | @generateSeriesStep (start :* stop *: step)@ - -Generate a series of values, -from @start@ to @stop@ with a step size of @step@ - ->>> printSQL (generateSeriesStep @'PGint8 (2 :* 100 *: 2)) -generate_series((2 :: int8), (100 :: int8), (2 :: int8)) --} -generateSeriesStep - :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric] - => '[null ty, null ty, null ty] --|-> - ("generate_series" ::: '["generate_series" ::: null ty]) - -- ^ set returning function -generateSeriesStep = unsafeSetFunctionN "generate_series" - -{- | @generateSeriesTimestamp (start :* stop *: step)@ - -Generate a series of timestamps, -from @start@ to @stop@ with a step size of @step@ - ->>> :{ -let - start = now - stop = now !+ interval_ 10 Years - step = interval_ 1 Months -in printSQL (generateSeriesTimestamp (start :* stop *: step)) -:} -generate_series(now(), (now() + (INTERVAL '10.000 years')), (INTERVAL '1.000 months')) --} -generateSeriesTimestamp - :: ty `In` '[ 'PGtimestamp, 'PGtimestamptz] - => '[null ty, null ty, null 'PGinterval] --|-> - ("generate_series" ::: '["generate_series" ::: null ty]) - -- ^ set returning function -generateSeriesTimestamp = unsafeSetFunctionN "generate_series" diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Query/Select.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Query/Select.hs deleted file mode 100644 index d4c64de6..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Query/Select.hs +++ /dev/null @@ -1,252 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Query.Select -Description: select statements -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -select statements --} - -{-# LANGUAGE - ConstraintKinds - , DeriveGeneric - , DerivingStrategies - , FlexibleContexts - , FlexibleInstances - , GADTs - , GeneralizedNewtypeDeriving - , LambdaCase - , MultiParamTypeClasses - , OverloadedLabels - , OverloadedStrings - , QuantifiedConstraints - , ScopedTypeVariables - , StandaloneDeriving - , TypeApplications - , TypeFamilies - , TypeInType - , TypeOperators - , RankNTypes - , UndecidableInstances - #-} - -module Squeal.PostgreSQL.Query.Select - ( -- ** Select - select - , select_ - , selectDistinct - , selectDistinct_ - , selectDistinctOn - , selectDistinctOn_ - , Selection (..) - ) where - -import Data.ByteString (ByteString) -import Data.String -import Generics.SOP hiding (from) -import GHC.TypeLits - -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Expression.Sort -import Squeal.PostgreSQL.Expression.Window -import Squeal.PostgreSQL.Query -import Squeal.PostgreSQL.Query.Table -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL - -{----------------------------------------- -SELECT queries ------------------------------------------} - -{- | The simplest kinds of `Selection` are `Star` and `DotStar` which -emits all columns that a `TableExpression` produces. A select `List` -is a list of `Expression`s. A `Selection` could be a list of -`WindowFunction`s `Over` `WindowDefinition`. `Additional` `Selection`s can -be selected with `Also`. --} -data Selection grp lat with db params from row where - Star - :: HasUnique tab from row - => Selection 'Ungrouped lat with db params from row - -- ^ `HasUnique` table in the `Squeal.PostgreSQL.Query.From.FromClause` - DotStar - :: Has tab from row - => Alias tab - -- ^ `Has` table with `Alias` - -> Selection 'Ungrouped lat with db params from row - List - :: SListI row - => NP (Aliased (Expression grp lat with db params from)) row - -- ^ `NP` list of `Aliased` `Expression`s - -> Selection grp lat with db params from row - Over - :: SListI row - => NP (Aliased (WindowFunction grp lat with db params from)) row - -- ^ `NP` list of `Aliased` `WindowFunction`s - -> WindowDefinition grp lat with db params from - -> Selection grp lat with db params from row - Also - :: Selection grp lat with db params from right - -- ^ `Additional` `Selection` - -> Selection grp lat with db params from left - -> Selection grp lat with db params from (Join left right) -instance Additional (Selection grp lat with db params from) where - also = Also -instance (KnownSymbol col, row ~ '[col ::: ty]) - => Aliasable col - (Expression grp lat with db params from ty) - (Selection grp lat with db params from row) where - expr `as` col = List (expr `as` col) -instance (Has tab (Join from lat) row0, Has col row0 ty, row1 ~ '[col ::: ty]) - => IsQualified tab col - (Selection 'Ungrouped lat with db params from row1) where - tab ! col = tab ! col `as` col -instance - ( Has tab (Join from lat) row0 - , Has col row0 ty - , row1 ~ '[col ::: ty] - , GroupedBy tab col bys ) - => IsQualified tab col - (Selection ('Grouped bys) lat with db params from row1) where - tab ! col = tab ! col `as` col -instance (HasUnique tab (Join from lat) row0, Has col row0 ty, row1 ~ '[col ::: ty]) - => IsLabel col - (Selection 'Ungrouped lat with db params from row1) where - fromLabel = fromLabel @col `as` Alias -instance - ( HasUnique tab (Join from lat) row0 - , Has col row0 ty - , row1 ~ '[col ::: ty] - , GroupedBy tab col bys ) - => IsLabel col - (Selection ('Grouped bys) lat with db params from row1) where - fromLabel = fromLabel @col `as` Alias - -instance RenderSQL (Selection grp lat with db params from row) where - renderSQL = \case - List list -> renderCommaSeparated (renderAliased renderSQL) list - Star -> "*" - DotStar tab -> renderSQL tab <> ".*" - Also right left -> renderSQL left <> ", " <> renderSQL right - Over winFns winDef -> - let - renderOver - :: Aliased (WindowFunction grp lat with db params from) field - -> ByteString - renderOver (winFn `As` col) = renderSQL winFn - <+> "OVER" <+> parenthesized (renderSQL winDef) - <+> "AS" <+> renderSQL col - in - renderCommaSeparated renderOver winFns - -instance IsString - (Selection grp lat with db params from '["fromOnly" ::: 'NotNull 'PGtext]) where - fromString str = fromString str `as` Alias - --- | the `TableExpression` in the `select` command constructs an intermediate --- virtual table by possibly combining tables, views, eliminating rows, --- grouping, etc. This table is finally passed on to processing by --- the select list. The `Selection` determines which columns of --- the intermediate table are actually output. -select - :: (SListI row, row ~ (x ': xs)) - => Selection grp lat with db params from row - -- ^ selection - -> TableExpression grp lat with db params from - -- ^ intermediate virtual table - -> Query lat with db params row -select selection tabexpr = UnsafeQuery $ - "SELECT" - <+> renderSQL selection - <+> renderSQL tabexpr - --- | Like `select` but takes an `NP` list of `Expression`s instead --- of a general `Selection`. -select_ - :: (SListI row, row ~ (x ': xs)) - => NP (Aliased (Expression grp lat with db params from)) row - -- ^ select list - -> TableExpression grp lat with db params from - -- ^ intermediate virtual table - -> Query lat with db params row -select_ = select . List - --- | After the select list has been processed, the result table can --- be subject to the elimination of duplicate rows using `selectDistinct`. -selectDistinct - :: (SListI columns, columns ~ (col ': cols)) - => Selection grp lat with db params from columns - -- ^ selection - -> TableExpression grp lat with db params from - -- ^ intermediate virtual table - -> Query lat with db params columns -selectDistinct selection tabexpr = UnsafeQuery $ - "SELECT DISTINCT" - <+> renderSQL selection - <+> renderSQL tabexpr - --- | Like `selectDistinct` but takes an `NP` list of `Expression`s instead --- of a general `Selection`. -selectDistinct_ - :: (SListI columns, columns ~ (col ': cols)) - => NP (Aliased (Expression grp lat with db params from)) columns - -- ^ select list - -> TableExpression grp lat with db params from - -- ^ intermediate virtual table - -> Query lat with db params columns -selectDistinct_ = selectDistinct . List - -{-| -`selectDistinctOn` keeps only the first row of each set of rows where -the given expressions evaluate to equal. The DISTINCT ON expressions are -interpreted using the same rules as for ORDER BY. ORDER BY is used to -ensure that the desired row appears first. - -The DISTINCT ON expression(s) must match the leftmost ORDER BY expression(s). -The ORDER BY clause will normally contain additional expression(s) that -determine the desired precedence of rows within each DISTINCT ON group. - -In order to guarantee they match and reduce redundancy, this function -will prepend the The DISTINCT ON expressions to the ORDER BY clause. --} -selectDistinctOn - :: (SListI columns, columns ~ (col ': cols)) - => [SortExpression grp lat with db params from] - -- ^ DISTINCT ON expression(s) and prepended to ORDER BY clause - -> Selection grp lat with db params from columns - -- ^ selection - -> TableExpression grp lat with db params from - -- ^ intermediate virtual table - -> Query lat with db params columns -selectDistinctOn distincts selection tab = UnsafeQuery $ - "SELECT DISTINCT ON" - <+> parenthesized (commaSeparated (renderDistinctOn <$> distincts)) - <+> renderSQL selection - <+> renderSQL (tab {orderByClause = distincts <> orderByClause tab}) - where - renderDistinctOn = \case - Asc expression -> renderSQL expression - Desc expression -> renderSQL expression - AscNullsFirst expression -> renderSQL expression - DescNullsFirst expression -> renderSQL expression - AscNullsLast expression -> renderSQL expression - DescNullsLast expression -> renderSQL expression - --- | Like `selectDistinctOn` but takes an `NP` list of `Expression`s instead --- of a general `Selection`. -selectDistinctOn_ - :: (SListI columns, columns ~ (col ': cols)) - => [SortExpression grp lat with db params from] - -- ^ distinct on and return the first row in ordering - -> NP (Aliased (Expression grp lat with db params from)) columns - -- ^ selection - -> TableExpression grp lat with db params from - -- ^ intermediate virtual table - -> Query lat with db params columns -selectDistinctOn_ distincts = selectDistinctOn distincts . List diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Query/Table.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Query/Table.hs deleted file mode 100644 index 95803b76..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Query/Table.hs +++ /dev/null @@ -1,409 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Query.Table -Description: intermediate table expressions -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -intermediate table expressions --} - -{-# LANGUAGE - ConstraintKinds - , DeriveGeneric - , DerivingStrategies - , FlexibleContexts - , FlexibleInstances - , GADTs - , GeneralizedNewtypeDeriving - , LambdaCase - , MultiParamTypeClasses - , OverloadedLabels - , OverloadedStrings - , QuantifiedConstraints - , ScopedTypeVariables - , StandaloneDeriving - , TypeApplications - , TypeFamilies - , TypeInType - , TypeOperators - , RankNTypes - , UndecidableInstances - #-} - -module Squeal.PostgreSQL.Query.Table - ( -- * Table Expression - TableExpression (..) - , from - , where_ - , groupBy - , having - , limit - , offset - , lockRows - -- * Grouping - , By (..) - , GroupByClause (..) - , HavingClause (..) - -- * Row Locks - , LockingClause (..) - , LockStrength (..) - , Waiting (..) - ) where - -import Control.DeepSeq -import Data.ByteString (ByteString) -import Data.String -import Data.Word -import Generics.SOP hiding (from) -import GHC.TypeLits - -import qualified GHC.Generics as GHC - -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Expression.Logic -import Squeal.PostgreSQL.Expression.Sort -import Squeal.PostgreSQL.Query.From -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL - -{----------------------------------------- -Table Expressions ------------------------------------------} - --- | A `TableExpression` computes a table. The table expression contains --- a `fromClause` that is optionally followed by a `whereClause`, --- `groupByClause`, `havingClause`, `orderByClause`, `limitClause` --- `offsetClause` and `lockingClauses`. Trivial table expressions simply refer --- to a table on disk, a so-called base table, but more complex expressions --- can be used to modify or combine base tables in various ways. -data TableExpression - (grp :: Grouping) - (lat :: FromType) - (with :: FromType) - (db :: SchemasType) - (params :: [NullType]) - (from :: FromType) - = TableExpression - { fromClause :: FromClause lat with db params from - -- ^ A table reference that can be a table name, or a derived table such - -- as a subquery, a @JOIN@ construct, or complex combinations of these. - , whereClause :: [Condition 'Ungrouped lat with db params from] - -- ^ optional search coditions, combined with `.&&`. After the processing - -- of the `fromClause` is done, each row of the derived virtual table - -- is checked against the search condition. If the result of the - -- condition is true, the row is kept in the output table, - -- otherwise it is discarded. The search condition typically references - -- at least one column of the table generated in the `fromClause`; - -- this is not required, but otherwise the WHERE clause will - -- be fairly useless. - , groupByClause :: GroupByClause grp from - -- ^ The `groupByClause` is used to group together those rows in a table - -- that have the same values in all the columns listed. The order in which - -- the columns are listed does not matter. The effect is to combine each - -- set of rows having common values into one group row that represents all - -- rows in the group. This is done to eliminate redundancy in the output - -- and/or compute aggregates that apply to these groups. - , havingClause :: HavingClause grp lat with db params from - -- ^ If a table has been grouped using `groupBy`, but only certain groups - -- are of interest, the `havingClause` can be used, much like a - -- `whereClause`, to eliminate groups from the result. Expressions in the - -- `havingClause` can refer both to grouped expressions and to ungrouped - -- expressions (which necessarily involve an aggregate function). - , orderByClause :: [SortExpression grp lat with db params from] - -- ^ The `orderByClause` is for optional sorting. When more than one - -- `SortExpression` is specified, the later (right) values are used to sort - -- rows that are equal according to the earlier (left) values. - , limitClause :: [Word64] - -- ^ The `limitClause` is combined with `min` to give a limit count - -- if nonempty. If a limit count is given, no more than that many rows - -- will be returned (but possibly fewer, if the query itself yields - -- fewer rows). - , offsetClause :: [Word64] - -- ^ The `offsetClause` is combined with `Prelude.+` to give an offset count - -- if nonempty. The offset count says to skip that many rows before - -- beginning to return rows. The rows are skipped before the limit count - -- is applied. - , lockingClauses :: [LockingClause from] - -- ^ `lockingClauses` can be added to a table expression with `lockRows`. - } deriving (GHC.Generic) - --- | Render a `TableExpression` -instance RenderSQL (TableExpression grp lat with db params from) where - renderSQL - (TableExpression frm' whs' grps' hvs' srts' lims' offs' lks') = mconcat - [ "FROM ", renderSQL frm' - , renderWheres whs' - , renderSQL grps' - , renderSQL hvs' - , renderSQL srts' - , renderLimits lims' - , renderOffsets offs' - , renderLocks lks' ] - where - renderWheres = \case - [] -> "" - wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs) - renderLimits = \case - [] -> "" - lims -> " LIMIT" <+> fromString (show (minimum lims)) - renderOffsets = \case - [] -> "" - offs -> " OFFSET" <+> fromString (show (sum offs)) - renderLocks = foldr (\l b -> b <+> renderSQL l) "" - --- | A `from` generates a `TableExpression` from a table reference that can be --- a table name, or a derived table such as a subquery, a JOIN construct, --- or complex combinations of these. A `from` may be transformed by `where_`, --- `groupBy`, `having`, `orderBy`, `limit` and `offset`, --- using the `Data.Function.&` operator --- to match the left-to-right sequencing of their placement in SQL. -from - :: FromClause lat with db params from -- ^ table reference - -> TableExpression 'Ungrouped lat with db params from -from tab = TableExpression tab [] noGroups NoHaving [] [] [] [] - --- | A `where_` is an endomorphism of `TableExpression`s which adds a --- search condition to the `whereClause`. -where_ - :: Condition 'Ungrouped lat with db params from -- ^ filtering condition - -> TableExpression grp lat with db params from - -> TableExpression grp lat with db params from -where_ wh rels = rels {whereClause = wh : whereClause rels} - --- | A `groupBy` is a transformation of `TableExpression`s which switches --- its `Grouping` from `Ungrouped` to `Grouped`. Use @groupBy Nil@ to perform --- a "grand total" aggregation query. -groupBy - :: SListI bys - => NP (By from) bys -- ^ grouped columns - -> TableExpression 'Ungrouped lat with db params from - -> TableExpression ('Grouped bys) lat with db params from -groupBy bys rels = TableExpression - { fromClause = fromClause rels - , whereClause = whereClause rels - , groupByClause = group bys - , havingClause = Having [] - , orderByClause = [] - , limitClause = limitClause rels - , offsetClause = offsetClause rels - , lockingClauses = lockingClauses rels - } - --- | A `having` is an endomorphism of `TableExpression`s which adds a --- search condition to the `havingClause`. -having - :: Condition ('Grouped bys) lat with db params from -- ^ having condition - -> TableExpression ('Grouped bys) lat with db params from - -> TableExpression ('Grouped bys) lat with db params from -having hv rels = rels - { havingClause = case havingClause rels of Having hvs -> Having (hv:hvs) } - -instance OrderBy (TableExpression grp) grp where - orderBy srts rels = rels {orderByClause = orderByClause rels ++ srts} - --- | A `limit` is an endomorphism of `TableExpression`s which adds to the --- `limitClause`. -limit - :: Word64 -- ^ limit parameter - -> TableExpression grp lat with db params from - -> TableExpression grp lat with db params from -limit lim rels = rels {limitClause = lim : limitClause rels} - --- | An `offset` is an endomorphism of `TableExpression`s which adds to the --- `offsetClause`. -offset - :: Word64 -- ^ offset parameter - -> TableExpression grp lat with db params from - -> TableExpression grp lat with db params from -offset off rels = rels {offsetClause = off : offsetClause rels} - -{- | Add a `LockingClause` to a `TableExpression`. -Multiple `LockingClause`s can be written if it is necessary -to specify different locking behavior for different tables. -If the same table is mentioned (or implicitly affected) -by more than one locking clause, then it is processed -as if it was only specified by the strongest one. -Similarly, a table is processed as `NoWait` if that is specified -in any of the clauses affecting it. Otherwise, it is processed -as `SkipLocked` if that is specified in any of the clauses affecting it. -Further, a `LockingClause` cannot be added to a grouped table expression. --} -lockRows - :: LockingClause from -- ^ row-level lock - -> TableExpression 'Ungrouped lat with db params from - -> TableExpression 'Ungrouped lat with db params from -lockRows lck tab = tab {lockingClauses = lck : lockingClauses tab} - -{----------------------------------------- -Grouping ------------------------------------------} - --- | `By`s are used in `groupBy` to reference a list of columns which are then --- used to group together those rows in a table that have the same values --- in all the columns listed. @By \#col@ will reference an unambiguous --- column @col@; otherwise @By2 (\#tab \! \#col)@ will reference a table --- qualified column @tab.col@. -data By - (from :: FromType) - (by :: (Symbol,Symbol)) where - By1 - :: (HasUnique table from columns, Has column columns ty) - => Alias column - -> By from '(table, column) - By2 - :: (Has table from columns, Has column columns ty) - => Alias table - -> Alias column - -> By from '(table, column) -deriving instance Show (By from by) -deriving instance Eq (By from by) -deriving instance Ord (By from by) -instance RenderSQL (By from by) where - renderSQL = \case - By1 column -> renderSQL column - By2 rel column -> renderSQL rel <> "." <> renderSQL column - -instance (HasUnique rel rels cols, Has col cols ty, by ~ '(rel, col)) - => IsLabel col (By rels by) where fromLabel = By1 fromLabel -instance (HasUnique rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)]) - => IsLabel col (NP (By rels) bys) where fromLabel = By1 fromLabel :* Nil -instance (Has rel rels cols, Has col cols ty, by ~ '(rel, col)) - => IsQualified rel col (By rels by) where (!) = By2 -instance (Has rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)]) - => IsQualified rel col (NP (By rels) bys) where - rel ! col = By2 rel col :* Nil - --- | A `GroupByClause` indicates the `Grouping` of a `TableExpression`. -newtype GroupByClause grp from = UnsafeGroupByClause - { renderGroupByClause :: ByteString } - deriving stock (GHC.Generic,Show,Eq,Ord) - deriving newtype (NFData) -instance RenderSQL (GroupByClause grp from) where - renderSQL = renderGroupByClause -noGroups :: GroupByClause 'Ungrouped from -noGroups = UnsafeGroupByClause "" -group - :: SListI bys - => NP (By from) bys - -> GroupByClause ('Grouped bys) from -group bys = UnsafeGroupByClause $ case bys of - Nil -> "" - _ -> " GROUP BY" <+> renderCommaSeparated renderSQL bys - --- | A `HavingClause` is used to eliminate groups that are not of interest. --- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped` --- `TableExpression` must use `Having` whose conditions are combined with --- `.&&`. -data HavingClause grp lat with db params from where - NoHaving :: HavingClause 'Ungrouped lat with db params from - Having - :: [Condition ('Grouped bys) lat with db params from] - -> HavingClause ('Grouped bys) lat with db params from -deriving instance Show (HavingClause grp lat with db params from) -deriving instance Eq (HavingClause grp lat with db params from) -deriving instance Ord (HavingClause grp lat with db params from) - --- | Render a `HavingClause`. -instance RenderSQL (HavingClause grp lat with db params from) where - renderSQL = \case - NoHaving -> "" - Having [] -> "" - Having conditions -> - " HAVING" <+> commaSeparated (renderSQL <$> conditions) - -{- | -If specific tables are named in a locking clause, -then only rows coming from those tables are locked; -any other tables used in the `Squeal.PostgreSQL.Query.Select.select` are simply read as usual. -A locking clause with a `Nil` table list affects all tables used in the statement. -If a locking clause is applied to a `view` or `subquery`, -it affects all tables used in the `view` or `subquery`. -However, these clauses do not apply to `Squeal.PostgreSQL.Query.With.with` queries referenced by the primary query. -If you want row locking to occur within a `Squeal.PostgreSQL.Query.With.with` query, -specify a `LockingClause` within the `Squeal.PostgreSQL.Query.With.with` query. --} -data LockingClause from where - For - :: HasAll tabs from tables - => LockStrength -- ^ lock strength - -> NP Alias tabs -- ^ table list - -> Waiting -- ^ wait or not - -> LockingClause from -instance RenderSQL (LockingClause from) where - renderSQL (For str tabs wt) = - "FOR" <+> renderSQL str - <> case tabs of - Nil -> "" - _ -> " OF" <+> renderSQL tabs - <> renderSQL wt - -{- | -Row-level locks, which are listed as below with the contexts -in which they are used automatically by PostgreSQL. -Note that a transaction can hold conflicting locks on the same row, -even in different subtransactions; but other than that, -two transactions can never hold conflicting locks on the same row. -Row-level locks do not affect data querying; -they block only writers and lockers to the same row. -Row-level locks are released at transaction end or during savepoint rollback. --} -data LockStrength - = Update - {- ^ `For` `Update` causes the rows retrieved by the `Squeal.PostgreSQL.Query.Select.select` statement - to be locked as though for update. This prevents them from being locked, - modified or deleted by other transactions until the current transaction ends. - That is, other transactions that attempt `Squeal.PostgreSQL.Manipulation.Update.update`, `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom`, - `Squeal.PostgreSQL.Query.Select.select` `For` `Update`, `Squeal.PostgreSQL.Query.Select.select` `For` `NoKeyUpdate`, - `Squeal.PostgreSQL.Query.Select.select` `For` `Share` or `Squeal.PostgreSQL.Query.Select.select` `For` `KeyShare` of these rows will be blocked - until the current transaction ends; conversely, `Squeal.PostgreSQL.Query.Select.select` `For` `Update` will wait - for a concurrent transaction that has run any of those commands on the same row, - and will then lock and return the updated row (or no row, if the row was deleted). - Within a `Squeal.PostgreSQL.Session.Transaction.RepeatableRead` or `Squeal.PostgreSQL.Session.Transaction.Serializable` transaction, however, an error will be - thrown if a row to be locked has changed since the transaction started. - - The `For` `Update` lock mode is also acquired by any `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom` a row, - and also by an `Update` that modifies the values on certain columns. - Currently, the set of columns considered for the `Squeal.PostgreSQL.Manipulation.Update.update` case are those - that have a unique index on them that can be used in a foreign key - (so partial indexes and expressional indexes are not considered), - but this may change in the future.-} - | NoKeyUpdate - {- | Behaves similarly to `For` `Update`, except that the lock acquired is weaker: - this lock will not block `Squeal.PostgreSQL.Query.Select.select` `For` `KeyShare` commands that attempt to acquire - a lock on the same rows. This lock mode is also acquired by any `Squeal.PostgreSQL.Manipulation.Update.update` - that does not acquire a `For` `Update` lock.-} - | Share - {- | Behaves similarly to `For` `Share`, except that the lock is weaker: - `Squeal.PostgreSQL.Query.Select.select` `For` `Update` is blocked, but not `Squeal.PostgreSQL.Query.Select.select` `For` `NoKeyUpdate`. - A key-shared lock blocks other transactions from performing - `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom` or any `Squeal.PostgreSQL.Manipulation.Update.update` that changes the key values, - but not other `Update`, and neither does it prevent `Squeal.PostgreSQL.Query.Select.select` `For` `NoKeyUpdate`, - `Squeal.PostgreSQL.Query.Select.select` `For` `Share`, or `Squeal.PostgreSQL.Query.Select.select` `For` `KeyShare`.-} - | KeyShare - deriving (Eq, Ord, Show, Read, Enum, GHC.Generic) -instance RenderSQL LockStrength where - renderSQL = \case - Update -> "UPDATE" - NoKeyUpdate -> "NO KEY UPDATE" - Share -> "SHARE" - KeyShare -> "KEY SHARE" - --- | To prevent the operation from `Waiting` for other transactions to commit, --- use either the `NoWait` or `SkipLocked` option. -data Waiting - = Wait - -- ^ wait for other transactions to commit - | NoWait - -- ^ reports an error, rather than waiting - | SkipLocked - -- ^ any selected rows that cannot be immediately locked are skipped - deriving (Eq, Ord, Show, Read, Enum, GHC.Generic) -instance RenderSQL Waiting where - renderSQL = \case - Wait -> "" - NoWait -> " NOWAIT" - SkipLocked -> " SKIP LOCKED" diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Query/Values.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Query/Values.hs deleted file mode 100644 index 2d81fd03..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Query/Values.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Query.Values -Description: values statements -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -values statements --} - -{-# LANGUAGE - ConstraintKinds - , DeriveGeneric - , DerivingStrategies - , FlexibleContexts - , FlexibleInstances - , GADTs - , GeneralizedNewtypeDeriving - , LambdaCase - , MultiParamTypeClasses - , OverloadedLabels - , OverloadedStrings - , QuantifiedConstraints - , ScopedTypeVariables - , StandaloneDeriving - , TypeApplications - , TypeFamilies - , TypeInType - , TypeOperators - , RankNTypes - , UndecidableInstances - #-} - -module Squeal.PostgreSQL.Query.Values - ( -- ** Values - values - , values_ - ) where - -import Data.ByteString (ByteString) -import Generics.SOP hiding (from) - -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Expression -import Squeal.PostgreSQL.Query -import Squeal.PostgreSQL.Render - --- $setup --- >>> import Squeal.PostgreSQL - --- | `values` computes a row value or set of row values --- specified by value expressions. It is most commonly used --- to generate a “constant table” within a larger command, --- but it can be used on its own. --- --- >>> type Row = '["a" ::: 'NotNull 'PGint4, "b" ::: 'NotNull 'PGtext] --- >>> let query = values (1 `as` #a :* "one" `as` #b) [] :: Query lat with db '[] Row --- >>> printSQL query --- SELECT * FROM (VALUES ((1 :: int4), (E'one' :: text))) AS t ("a", "b") -values - :: SListI cols - => NP (Aliased (Expression 'Ungrouped lat with db params '[] )) cols - -> [NP (Aliased (Expression 'Ungrouped lat with db params '[] )) cols] - -- ^ When more than one row is specified, all the rows must - -- must have the same number of elements - -> Query lat with db params cols -values rw rws = UnsafeQuery $ "SELECT * FROM" - <+> parenthesized ( - "VALUES" - <+> commaSeparated - ( parenthesized - . renderCommaSeparated renderValuePart <$> rw:rws ) - ) <+> "AS t" - <+> parenthesized (renderCommaSeparated renderAliasPart rw) - where - renderAliasPart, renderValuePart - :: Aliased (Expression 'Ungrouped lat with db params '[] ) ty -> ByteString - renderAliasPart (_ `As` name) = renderSQL name - renderValuePart (value `As` _) = renderSQL value - --- | `values_` computes a row value or set of row values --- specified by value expressions. -values_ - :: SListI cols - => NP (Aliased (Expression 'Ungrouped lat with db params '[] )) cols - -- ^ one row of values - -> Query lat with db params cols -values_ rw = values rw [] diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Query/With.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Query/With.hs deleted file mode 100644 index 7e7ade72..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Query/With.hs +++ /dev/null @@ -1,245 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Query.With -Description: with statements -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -with statements --} - -{-# LANGUAGE - ConstraintKinds - , DeriveGeneric - , DerivingStrategies - , FlexibleContexts - , FlexibleInstances - , GADTs - , GeneralizedNewtypeDeriving - , LambdaCase - , MultiParamTypeClasses - , OverloadedLabels - , OverloadedStrings - , QuantifiedConstraints - , ScopedTypeVariables - , StandaloneDeriving - , TypeApplications - , TypeFamilies - , TypeInType - , TypeOperators - , RankNTypes - , UndecidableInstances - #-} - -module Squeal.PostgreSQL.Query.With - ( -- ** With - With (..) - , CommonTableExpression (..) - , withRecursive - , Materialization (..) - , materialized - , notMaterialized - ) where - -import Data.Quiver.Functor -import GHC.TypeLits - -import qualified GHC.Generics as GHC -import qualified Generics.SOP as SOP - -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Query -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL - -{- | `with` provides a way to write auxiliary statements for use in a larger query. -These statements, referred to as `CommonTableExpression`s, can be thought of as -defining temporary tables that exist just for one query. - -`with` can be used for a `Query`. Multiple `CommonTableExpression`s can be -chained together with the `Path` constructor `:>>`, and each `CommonTableExpression` -is constructed via overloaded `as`. - ->>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4] ->>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] ->>> :{ -let - qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4] - qry = with ( - select Star (from (table #tab)) `as` #cte1 :>> - select Star (from (common #cte1)) `as` #cte2 - ) (select Star (from (common #cte2))) -in printSQL qry -:} -WITH "cte1" AS (SELECT * FROM "tab" AS "tab"), "cte2" AS (SELECT * FROM "cte1" AS "cte1") SELECT * FROM "cte2" AS "cte2" - -You can use data-modifying statements in `with`. This allows you to perform several -different operations in the same query. An example is: - ->>> type ProductsColumns = '["product" ::: 'NoDef :=> 'NotNull 'PGtext, "date" ::: 'Def :=> 'NotNull 'PGdate] ->>> type ProductsSchema = '["products" ::: 'Table ('[] :=> ProductsColumns), "products_deleted" ::: 'Table ('[] :=> ProductsColumns)] ->>> :{ -let - manp :: Manipulation with (Public ProductsSchema) '[ 'NotNull 'PGdate] '[] - manp = with - (deleteFrom #products NoUsing (#date .< param @1) (Returning Star) `as` #del) - (insertInto_ #products_deleted (Subquery (select Star (from (common #del))))) -in printSQL manp -:} -WITH "del" AS (DELETE FROM "products" AS "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" AS "products_deleted" SELECT * FROM "del" AS "del" --} -class With statement where - with - :: Path (CommonTableExpression statement db params) with0 with1 - -- ^ common table expressions - -> statement with1 db params row - -- ^ larger query - -> statement with0 db params row -instance With (Query lat) where - with Done query = query - with ctes query = UnsafeQuery $ - "WITH" <+> commaSeparated (qtoList renderSQL ctes) <+> renderSQL query - -{- | A `withRecursive` `Query` can refer to its own output. -A very simple example is this query to sum the integers from 1 through 100: - ->>> import Data.Monoid (Sum (..)) ->>> import Data.Int (Int64) ->>> :{ - let - sum100 :: Statement db () (Sum Int64) - sum100 = query $ - withRecursive - ( values_ ((1 & astype int) `as` #n) - `unionAll` - select_ ((#n + 1) `as` #n) - (from (common #t) & where_ (#n .< 100)) `as` #t ) - ( select_ - (fromNull 0 (sum_ (All #n)) `as` #getSum) - (from (common #t) & groupBy Nil) ) - in printSQL sum100 -:} -WITH RECURSIVE "t" AS ((SELECT * FROM (VALUES (((1 :: int4) :: int))) AS t ("n")) UNION ALL (SELECT ("n" + (1 :: int4)) AS "n" FROM "t" AS "t" WHERE ("n" < (100 :: int4)))) SELECT COALESCE(sum(ALL "n"), (0 :: int8)) AS "getSum" FROM "t" AS "t" - -The general form of a recursive WITH query is always a non-recursive term, -then `union` (or `unionAll`), then a recursive term, where -only the recursive term can contain a reference to the query's own output. --} -withRecursive - :: Aliased (Query lat (recursive ': with) db params) recursive - -- ^ recursive query - -> Query lat (recursive ': with) db params row - -- ^ larger query - -> Query lat with db params row -withRecursive (recursive `As` cte) query = UnsafeQuery $ - "WITH RECURSIVE" <+> renderSQL cte - <+> "AS" <+> parenthesized (renderSQL recursive) - <+> renderSQL query - --- | Whether the contents of the WITH clause are materialized. --- If a WITH query is non-recursive and side-effect-free (that is, it is a SELECT containing no volatile functions) then it can be folded into the parent query, allowing joint optimization of the two query levels. --- --- Note: Use of `Materialized` or `NotMaterialized` requires PostgreSQL version 12 or higher. For earlier versions, use `DefaultMaterialization` which in those earlier versions of PostgreSQL behaves as `Materialized`. PostgreSQL 12 both changes the default behavior as well as adds options for customizing the materialization behavior. -data Materialization = - DefaultMaterialization -- ^ By default, folding happens if the parent query references the WITH query just once, but not if it references the WITH query more than once. Note: this is the behavior in PostgreSQL 12+. In PostgreSQL 11 and earlier, all CTEs are materialized. - | Materialized -- ^ You can override that decision by specifying MATERIALIZED to force separate calculation of the WITH query. Requires PostgreSQL 12+. - | NotMaterialized -- ^ or by specifying NOT MATERIALIZED to force it to be merged into the parent query. Requires PostgreSQL 12+. - deriving (Eq, Ord, Show, Read, Enum, GHC.Generic) -instance SOP.Generic Materialization -instance SOP.HasDatatypeInfo Materialization -instance RenderSQL Materialization where - renderSQL = \case - DefaultMaterialization -> "" - Materialized -> "MATERIALIZED" - NotMaterialized -> "NOT MATERIALIZED" - --- | A `CommonTableExpression` is an auxiliary statement in a `with` clause. -data CommonTableExpression statement - (db :: SchemasType) - (params :: [NullType]) - (with0 :: FromType) - (with1 :: FromType) where - CommonTableExpression - :: Aliased (statement with db params) (cte ::: common) - -- ^ aliased statement - -> Materialization - -- ^ materialization of the CTE output - -> CommonTableExpression statement db params with (cte ::: common ': with) -instance - ( KnownSymbol cte - , with1 ~ (cte ::: common ': with) - ) => Aliasable cte - (statement with db params common) - (CommonTableExpression statement db params with with1) where - statement `as` cte = CommonTableExpression (statement `as` cte) DefaultMaterialization -instance - ( KnownSymbol cte - , with1 ~ (cte ::: common ': with) - ) => Aliasable cte - (statement with db params common) - (Path (CommonTableExpression statement db params) with with1) where - statement `as` cte = qsingle (statement `as` cte) - -instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL - (CommonTableExpression statement db params with0 with1) where - renderSQL (CommonTableExpression (statement `As` cte) materialization) = - renderSQL cte - <+> "AS" - <+> renderSQL materialization - <> case materialization of - DefaultMaterialization -> "" - _ -> " " - <> parenthesized (renderSQL statement) - -{- | Force separate calculation of the WITH query. - ->>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4] ->>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] ->>> :{ -let - qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4] - qry = with ( - materialized (select Star (from (table #tab)) `as` #cte1) :>> - select Star (from (common #cte1)) `as` #cte2 - ) (select Star (from (common #cte2))) -in printSQL qry -:} -WITH "cte1" AS MATERIALIZED (SELECT * FROM "tab" AS "tab"), "cte2" AS (SELECT * FROM "cte1" AS "cte1") SELECT * FROM "cte2" AS "cte2" - -Note: if the last CTE has `materialized` or `notMaterialized` you must add `:>> Done`. - -Requires PostgreSQL 12 or higher. --} -materialized - :: Aliased (statement with db params) (cte ::: common) -- ^ CTE - -> CommonTableExpression statement db params with (cte ::: common ': with) -materialized stmt = CommonTableExpression stmt Materialized - -{- | Force the WITH query to be merged into the parent query. - ->>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4] ->>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] ->>> :{ -let - qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4] - qry = with ( - select Star (from (table #tab)) `as` #cte1 :>> - notMaterialized (select Star (from (common #cte1)) `as` #cte2) :>> - Done - ) (select Star (from (common #cte2))) -in printSQL qry -:} -WITH "cte1" AS (SELECT * FROM "tab" AS "tab"), "cte2" AS NOT MATERIALIZED (SELECT * FROM "cte1" AS "cte1") SELECT * FROM "cte2" AS "cte2" - -Note: if the last CTE has `materialized` or `notMaterialized` you must add `:>> Done` to finish the `Path`. - -Requires PostgreSQL 12 or higher. --} -notMaterialized - :: Aliased (statement with db params) (cte ::: common) -- ^ CTE - -> CommonTableExpression statement db params with (cte ::: common ': with) -notMaterialized stmt = CommonTableExpression stmt NotMaterialized diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Render.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Render.hs deleted file mode 100644 index 4c433ebc..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Render.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Render -Description: render functions -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -render functions --} - -{-# LANGUAGE - AllowAmbiguousTypes - , ConstraintKinds - , FlexibleContexts - , LambdaCase - , MagicHash - , OverloadedStrings - , PolyKinds - , RankNTypes - , ScopedTypeVariables - , TypeApplications -#-} - -module Squeal.PostgreSQL.Render - ( -- * Render - RenderSQL (..) - , printSQL - , escape - , parenthesized - , bracketed - , (<+>) - , commaSeparated - , doubleQuoted - , singleQuotedText - , singleQuotedUtf8 - , escapeQuotedString - , escapeQuotedText - , renderCommaSeparated - , renderCommaSeparatedConstraint - , renderCommaSeparatedMaybe - , renderNat - , renderSymbol - ) where - -import Control.Monad.IO.Class (MonadIO (..)) -import Data.ByteString (ByteString) -import Data.Maybe (catMaybes) -import Data.Text (Text) -import Generics.SOP -import GHC.Exts -import GHC.TypeLits hiding (Text) - -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 as Char8 - --- | Parenthesize a `ByteString`. -parenthesized :: ByteString -> ByteString -parenthesized str = "(" <> str <> ")" - --- | Square bracket a `ByteString` -bracketed :: ByteString -> ByteString -bracketed str = "[" <> str <> "]" - --- | Concatenate two `ByteString`s with a space between. -(<+>) :: ByteString -> ByteString -> ByteString -infixr 7 <+> -str1 <+> str2 = str1 <> " " <> str2 - --- | Comma separate a list of `ByteString`s. -commaSeparated :: [ByteString] -> ByteString -commaSeparated = ByteString.intercalate ", " - --- | Add double quotes around a `ByteString`. -doubleQuoted :: ByteString -> ByteString -doubleQuoted str = "\"" <> str <> "\"" - --- | Add single quotes around a `Text` and escape single quotes within it. -singleQuotedText :: Text -> ByteString -singleQuotedText str = - "'" <> Text.encodeUtf8 (Text.replace "'" "''" str) <> "'" - --- | Add single quotes around a `ByteString` and escape single quotes within it. -singleQuotedUtf8 :: ByteString -> ByteString -singleQuotedUtf8 = singleQuotedText . Text.decodeUtf8 - --- | Escape quote a string. -escapeQuotedString :: String -> ByteString -escapeQuotedString x = "E\'" <> Text.encodeUtf8 (fromString (escape =<< x)) <> "\'" - --- | Escape quote a string. -escapeQuotedText :: Text -> ByteString -escapeQuotedText x = - "E\'" <> Text.encodeUtf8 (Text.concatMap (fromString . escape) x) <> "\'" - --- | Comma separate the renderings of a heterogeneous list. -renderCommaSeparated - :: SListI xs - => (forall x. expression x -> ByteString) - -> NP expression xs -> ByteString -renderCommaSeparated render - = commaSeparated - . hcollapse - . hmap (K . render) - --- | Comma separate the renderings of a heterogeneous list. -renderCommaSeparatedConstraint - :: forall c xs expression. (All c xs, SListI xs) - => (forall x. c x => expression x -> ByteString) - -> NP expression xs -> ByteString -renderCommaSeparatedConstraint render - = commaSeparated - . hcollapse - . hcmap (Proxy @c) (K . render) - --- | Comma separate the `Maybe` renderings of a heterogeneous list, dropping --- `Nothing`s. -renderCommaSeparatedMaybe - :: SListI xs - => (forall x. expression x -> Maybe ByteString) - -> NP expression xs -> ByteString -renderCommaSeparatedMaybe render - = commaSeparated - . catMaybes - . hcollapse - . hmap (K . render) - --- | Render a promoted `Nat`. -renderNat :: forall n. KnownNat n => ByteString -renderNat = fromString (show (natVal' (proxy# :: Proxy# n))) - --- | Render a promoted `Symbol`. -renderSymbol :: forall s. KnownSymbol s => ByteString -renderSymbol = fromString (symbolVal' (proxy# :: Proxy# s)) - --- | A class for rendering SQL -class RenderSQL sql where renderSQL :: sql -> ByteString - --- | Print SQL. -printSQL :: (RenderSQL sql, MonadIO io) => sql -> io () -printSQL = liftIO . Char8.putStrLn . renderSQL - --- | `escape` a character to prevent injection -escape :: Char -> String -escape = \case - '\NUL' -> "" - '\'' -> "''" - '"' -> "\\\"" - '\b' -> "\\b" - '\n' -> "\\n" - '\r' -> "\\r" - '\t' -> "\\t" - '\\' -> "\\\\" - c -> [c] diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Session.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Session.hs deleted file mode 100644 index 6e29c502..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Session.hs +++ /dev/null @@ -1,362 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Session -Description: sessions -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -Using Squeal in your application will come down to defining -the @DB :: @`SchemasType` of your database and including @PQ DB DB@ in your -application's monad transformer stack, giving it an instance of `MonadPQ` @DB@. --} - -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -{-# LANGUAGE - DefaultSignatures - , FunctionalDependencies - , FlexibleContexts - , FlexibleInstances - , InstanceSigs - , OverloadedStrings - , PolyKinds - , QuantifiedConstraints - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeFamilies - , TypeInType - , TypeOperators - , UndecidableInstances -#-} - -module Squeal.PostgreSQL.Session - ( PQ (PQ, unPQ) - , runPQ - , execPQ - , evalPQ - , withConnection - ) where - -import Control.Category -import Control.Monad.Base (MonadBase(..)) -import Control.Monad.Catch -import Control.Monad.Except -import Control.Monad.Morph -import Control.Monad.Reader -import Control.Monad.Trans.Control (MonadBaseControl(..), MonadTransControl(..)) -import UnliftIO (MonadUnliftIO(..)) -import Data.ByteString (ByteString) -import Data.Foldable -import Data.Functor ((<&>)) -import Data.Kind -import Data.Traversable -import Generics.SOP -import PostgreSQL.Binary.Encoding (encodingBytes) -import Prelude hiding (id, (.)) - -import qualified Control.Monad.Fail as Fail -import qualified Database.PostgreSQL.LibPQ as LibPQ -import qualified PostgreSQL.Binary.Encoding as Encoding - -import Squeal.PostgreSQL.Definition -import Squeal.PostgreSQL.Manipulation -import Squeal.PostgreSQL.Session.Connection -import Squeal.PostgreSQL.Session.Encode -import Squeal.PostgreSQL.Session.Exception -import Squeal.PostgreSQL.Session.Indexed -import Squeal.PostgreSQL.Session.Oid -import Squeal.PostgreSQL.Session.Monad -import Squeal.PostgreSQL.Session.Result -import Squeal.PostgreSQL.Session.Statement -import Squeal.PostgreSQL.Type.Schema - --- | We keep track of the schema via an Atkey indexed state monad transformer, --- `PQ`. -newtype PQ - (db0 :: SchemasType) - (db1 :: SchemasType) - (m :: Type -> Type) - (x :: Type) = - PQ { unPQ :: K LibPQ.Connection db0 -> m (K x db1) } - -instance Monad m => Functor (PQ db0 db1 m) where - fmap f (PQ pq) = PQ $ \ conn -> do - K x <- pq conn - return $ K (f x) - --- | Run a `PQ` and keep the result and the `LibPQ.Connection`. -runPQ - :: Functor m - => PQ db0 db1 m x - -> K LibPQ.Connection db0 - -> m (x, K LibPQ.Connection db1) -runPQ (PQ pq) conn = (\ x -> (unK x, K (unK conn))) <$> pq conn - -- K x <- pq conn - -- return (x, K (unK conn)) - --- | Execute a `PQ` and discard the result but keep the `LibPQ.Connection`. -execPQ - :: Functor m - => PQ db0 db1 m x - -> K LibPQ.Connection db0 - -> m (K LibPQ.Connection db1) -execPQ (PQ pq) conn = mapKK (\ _ -> unK conn) <$> pq conn - --- | Evaluate a `PQ` and discard the `LibPQ.Connection` but keep the result. -evalPQ - :: Functor m - => PQ db0 db1 m x - -> K LibPQ.Connection db0 - -> m x -evalPQ (PQ pq) conn = unK <$> pq conn - -instance IndexedMonadTrans PQ where - - pqAp (PQ f) (PQ x) = PQ $ \ conn -> do - K f' <- f conn - K x' <- x (K (unK conn)) - return $ K (f' x') - - pqBind f (PQ x) = PQ $ \ conn -> do - K x' <- x conn - unPQ (f x') (K (unK conn)) - -instance IndexedMonadTransPQ PQ where - - define (UnsafeDefinition q) = PQ $ \ (K conn) -> liftIO $ do - resultMaybe <- LibPQ.exec conn q - case resultMaybe of - Nothing -> throwM $ ConnectionException "LibPQ.exec" - Just result -> K <$> okResult_ result - -instance (MonadIO io, db0 ~ db, db1 ~ db) => MonadPQ db (PQ db0 db1 io) where - - executeParams (Manipulation encode decode (UnsafeManipulation q)) x = - PQ $ \ kconn@(K conn) -> liftIO $ do - let - formatParam - :: forall param. OidOfNull db param - => K (Maybe Encoding.Encoding) param - -> IO (K (Maybe (LibPQ.Oid, ByteString, LibPQ.Format)) param) - formatParam (K maybeEncoding) = do - oid <- runReaderT (oidOfNull @db @param) kconn - return . K $ maybeEncoding <&> \encoding -> - (oid, encodingBytes encoding, LibPQ.Binary) - encodedParams <- runReaderT (runEncodeParams encode x) kconn - formattedParams <- hcollapse <$> - hctraverse' (Proxy @(OidOfNull db)) formatParam encodedParams - resultMaybe <- - LibPQ.execParams conn (q <> ";") formattedParams LibPQ.Binary - case resultMaybe of - Nothing -> throwM $ ConnectionException "LibPQ.execParams" - Just result -> do - okResult_ result - return $ K (Result decode result) - executeParams (Query encode decode q) x = - executeParams (Manipulation encode decode (queryStatement q)) x - - executePrepared (Manipulation encode decode (UnsafeManipulation q :: Manipulation '[] db params row)) list = - PQ $ \ kconn@(K conn) -> liftIO $ do - let - - temp = "temporary_statement" - - oidOfParam :: forall p. OidOfNull db p => (IO :.: K LibPQ.Oid) p - oidOfParam = Comp $ K <$> runReaderT (oidOfNull @db @p) kconn - oidsOfParams :: NP (IO :.: K LibPQ.Oid) params - oidsOfParams = hcpure (Proxy @(OidOfNull db)) oidOfParam - - prepare = do - oids <- hcollapse <$> hsequence' oidsOfParams - prepResultMaybe <- LibPQ.prepare conn temp (q <> ";") (Just oids) - case prepResultMaybe of - Nothing -> throwM $ ConnectionException "LibPQ.prepare" - Just prepResult -> okResult_ prepResult - - deallocate = do - deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";") - case deallocResultMaybe of - Nothing -> throwM $ ConnectionException "LibPQ.exec" - Just deallocResult -> okResult_ deallocResult - - execPrepared = for list $ \ params -> do - encodedParams <- runReaderT (runEncodeParams encode params) kconn - let - formatParam encoding = (encodingBytes encoding, LibPQ.Binary) - formattedParams = - [ formatParam <$> maybeParam - | maybeParam <- hcollapse encodedParams - ] - resultMaybe <- - LibPQ.execPrepared conn temp formattedParams LibPQ.Binary - case resultMaybe of - Nothing -> throwM $ ConnectionException "LibPQ.execPrepared" - Just result -> do - okResult_ result - return $ Result decode result - - liftIO (K <$> bracket_ prepare deallocate execPrepared) - - executePrepared (Query encode decode q) list = - executePrepared (Manipulation encode decode (queryStatement q)) list - - executePrepared_ (Manipulation encode _ (UnsafeManipulation q :: Manipulation '[] db params row)) list = - PQ $ \ kconn@(K conn) -> do - let - - temp = "temporary_statement" - - oidOfParam :: forall p. OidOfNull db p => (IO :.: K LibPQ.Oid) p - oidOfParam = Comp $ K <$> runReaderT (oidOfNull @db @p) kconn - oidsOfParams :: NP (IO :.: K LibPQ.Oid) params - oidsOfParams = hcpure (Proxy @(OidOfNull db)) oidOfParam - - prepare = do - oids <- hcollapse <$> hsequence' oidsOfParams - prepResultMaybe <- LibPQ.prepare conn temp (q <> ";") (Just oids) - case prepResultMaybe of - Nothing -> throwM $ ConnectionException "LibPQ.prepare" - Just prepResult -> okResult_ prepResult - - deallocate = do - deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";") - case deallocResultMaybe of - Nothing -> throwM $ ConnectionException "LibPQ.exec" - Just deallocResult -> okResult_ deallocResult - - execPrepared_ = for_ list $ \ params -> do - encodedParams <- runReaderT (runEncodeParams encode params) kconn - let - formatParam encoding = (encodingBytes encoding, LibPQ.Binary) - formattedParams = - [ formatParam <$> maybeParam - | maybeParam <- hcollapse encodedParams - ] - resultMaybe <- - LibPQ.execPrepared conn temp formattedParams LibPQ.Binary - case resultMaybe of - Nothing -> throwM $ ConnectionException "LibPQ.execPrepared" - Just result -> okResult_ result - - liftIO (K <$> bracket_ prepare deallocate execPrepared_) - - executePrepared_ (Query encode decode q) list = - executePrepared_ (Manipulation encode decode (queryStatement q)) list - -instance (Monad m, db0 ~ db1) - => Applicative (PQ db0 db1 m) where - pure x = PQ $ \ _conn -> pure (K x) - (<*>) = pqAp - -instance (Monad m, db0 ~ db1) - => Monad (PQ db0 db1 m) where - return = pure - (>>=) = flip pqBind - -instance (Monad m, db0 ~ db1) - => Fail.MonadFail (PQ db0 db1 m) where - fail = Fail.fail - -instance db0 ~ db1 => MFunctor (PQ db0 db1) where - hoist f (PQ pq) = PQ (f . pq) - -instance db0 ~ db1 => MonadTrans (PQ db0 db1) where - lift m = PQ $ \ _conn -> do - x <- m - return (K x) - -instance db0 ~ db1 => MMonad (PQ db0 db1) where - embed f (PQ pq) = PQ $ \ conn -> do - evalPQ (f (pq conn)) conn - -instance (MonadIO m, schema0 ~ schema1) - => MonadIO (PQ schema0 schema1 m) where - liftIO = lift . liftIO - -instance (MonadUnliftIO m, db0 ~ db1) - => MonadUnliftIO (PQ db0 db1 m) where - withRunInIO - :: ((forall a . PQ db0 schema1 m a -> IO a) -> IO b) - -> PQ db0 schema1 m b - withRunInIO inner = PQ $ \conn -> - withRunInIO $ \(run :: (forall x . m x -> IO x)) -> - K <$> inner (\pq -> run $ unK <$> unPQ pq conn) - -instance (MonadBase b m) - => MonadBase b (PQ schema schema m) where - liftBase = lift . liftBase - -instance db0 ~ db1 => MonadTransControl (PQ db0 db1) where - type StT (PQ db0 db1) a = a - liftWith f = PQ $ \conn -> K <$> (f $ \pq -> unK <$> unPQ pq conn) - restoreT ma = PQ . const $ K <$> ma - --- | A snapshot of the state of a `PQ` computation, used in MonadBaseControl Instance -type PQRun schema = - forall m x. Monad m => PQ schema schema m x -> m (K x schema) - -instance (MonadBaseControl b m, schema0 ~ schema1) - => MonadBaseControl b (PQ schema0 schema1 m) where - type StM (PQ schema0 schema1 m) x = StM m (K x schema0) - restoreM = PQ . const . restoreM - liftBaseWith f = - pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run - where - pqliftWith :: Functor m => (PQRun schema -> m a) -> PQ schema schema m a - pqliftWith g = PQ $ \ conn -> - fmap K (g $ \ pq -> unPQ pq conn) - -instance (MonadThrow m, db0 ~ db1) - => MonadThrow (PQ db0 db1 m) where - throwM = lift . throwM - -instance (MonadCatch m, db0 ~ db1) - => MonadCatch (PQ db0 db1 m) where - catch (PQ m) f = PQ $ \k -> m k `catch` \e -> unPQ (f e) k - -instance (MonadMask m, db0 ~ db1) - => MonadMask (PQ db0 db1 m) where - mask a = PQ $ \e -> mask $ \u -> unPQ (a $ q u) e - where q u (PQ b) = PQ (u . b) - - uninterruptibleMask a = - PQ $ \k -> uninterruptibleMask $ \u -> unPQ (a $ q u) k - where q u (PQ b) = PQ (u . b) - - generalBracket acquire release use = PQ $ \k -> - K <$> generalBracket - (unK <$> unPQ acquire k) - (\resource exitCase -> unK <$> unPQ (release resource exitCase) k) - (\resource -> unK <$> unPQ (use resource) k) - -instance (Monad m, Semigroup r, db0 ~ db1) => Semigroup (PQ db0 db1 m r) where - f <> g = pqAp (fmap (<>) f) g - -instance (Monad m, Monoid r, db0 ~ db1) => Monoid (PQ db0 db1 m r) where - mempty = pure mempty - --- | Do `connectdb` and `finish` before and after a computation. -withConnection - :: forall db0 db1 io x - . (MonadIO io, MonadMask io) - => ByteString - -> PQ db0 db1 io x - -> io x -withConnection connString action = - unK <$> bracket (connectdb connString) finish (unPQ action) - -okResult_ :: MonadIO io => LibPQ.Result -> io () -okResult_ result = liftIO $ do - status <- LibPQ.resultStatus result - case status of - LibPQ.CommandOk -> return () - LibPQ.TuplesOk -> return () - _ -> do - stateCodeMaybe <- LibPQ.resultErrorField result LibPQ.DiagSqlstate - case stateCodeMaybe of - Nothing -> throwM $ ConnectionException "LibPQ.resultErrorField" - Just stateCode -> do - msgMaybe <- LibPQ.resultErrorMessage result - case msgMaybe of - Nothing -> throwM $ ConnectionException "LibPQ.resultErrorMessage" - Just msg -> throwM . SQLException $ SQLState status stateCode msg diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Session/Connection.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Session/Connection.hs deleted file mode 100644 index 03d34727..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Session/Connection.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Session.Connection -Description: database connections -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -database connections --} - -{-# LANGUAGE - DataKinds - , PolyKinds - , RankNTypes - , TypeOperators -#-} - -module Squeal.PostgreSQL.Session.Connection - ( LibPQ.Connection - , connectdb - , finish - , lowerConnection - , SOP.K (..) - , SOP.unK - ) where - -import Control.Monad.IO.Class -import Data.ByteString (ByteString) - -import Squeal.PostgreSQL.Type.Schema - -import qualified Generics.SOP as SOP -import qualified Database.PostgreSQL.LibPQ as LibPQ - --- $setup --- >>> import Squeal.PostgreSQL - -{- | Makes a new connection to the database server. - -This function opens a new database connection using the parameters taken -from the string conninfo. - -The passed string can be empty to use all default parameters, or it can -contain one or more parameter settings separated by whitespace. -Each parameter setting is in the form keyword = value. Spaces around the equal -sign are optional. To write an empty value or a value containing spaces, -surround it with single quotes, e.g., keyword = 'a value'. Single quotes and -backslashes within the value must be escaped with a backslash, i.e., ' and \. - -To specify the schema you wish to connect with, use type application. - ->>> :set -XDataKinds ->>> :set -XPolyKinds ->>> :set -XTypeOperators ->>> type DB = '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint2])]] ->>> :set -XTypeApplications ->>> :set -XOverloadedStrings ->>> conn <- connectdb @DB "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" - -Note that, for now, squeal doesn't offer any protection from connecting -with the wrong schema! --} -connectdb - :: forall (db :: SchemasType) io - . MonadIO io - => ByteString -- ^ conninfo - -> io (SOP.K LibPQ.Connection db) -connectdb = fmap SOP.K . liftIO . LibPQ.connectdb - --- | Closes the connection to the server. -finish :: MonadIO io => SOP.K LibPQ.Connection db -> io () -finish = liftIO . LibPQ.finish . SOP.unK - --- | Safely `lowerConnection` to a smaller schema. -lowerConnection - :: SOP.K LibPQ.Connection (schema ': db) - -> SOP.K LibPQ.Connection db -lowerConnection (SOP.K conn) = SOP.K conn diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Session/Decode.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Session/Decode.hs deleted file mode 100644 index 86292395..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Session/Decode.hs +++ /dev/null @@ -1,603 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Session.Decode -Description: decoding of result values -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -decoding of result values --} - -{-# LANGUAGE - AllowAmbiguousTypes - , CPP - , DataKinds - , DerivingStrategies - , FlexibleContexts - , FlexibleInstances - , FunctionalDependencies - , GeneralizedNewtypeDeriving - , LambdaCase - , MultiParamTypeClasses - , OverloadedStrings - , PolyKinds - , ScopedTypeVariables - , TypeApplications - , TypeFamilies - , TypeOperators - , UndecidableInstances - , UndecidableSuperClasses -#-} - -module Squeal.PostgreSQL.Session.Decode - ( -- * Decode Types - FromPG (..) - , devalue - , rowValue - , enumValue - -- * Decode Rows - , DecodeRow (..) - , decodeRow - , runDecodeRow - , GenericRow (..) - , appendRows - , consRow - -- * Decoding Classes - , FromValue (..) - , FromField (..) - , FromArray (..) - , StateT (..) - , ExceptT (..) - ) where - -import BinaryParser -import Control.Applicative -import Control.Arrow -import Control.Monad -#if MIN_VERSION_base(4,13,0) -#else -import Control.Monad.Fail -#endif -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.State.Strict -import Control.Monad.Trans.Maybe -import Data.Bits -import Data.Coerce (coerce) -import Data.Functor.Constant (Constant(Constant)) -import Data.Int (Int16, Int32, Int64) -import Data.Kind -import Data.Scientific (Scientific) -import Data.String (fromString) -import Data.Text (Text) -import Data.Time (Day, TimeOfDay, TimeZone, LocalTime, UTCTime, DiffTime) -import Data.UUID.Types (UUID) -import Data.Vector (Vector) -import Database.PostgreSQL.LibPQ (Oid(Oid)) -import GHC.OverloadedLabels -import GHC.TypeLits -import Network.IP.Addr (NetAddr, IP) -import PostgreSQL.Binary.Decoding hiding (Composite) -import Unsafe.Coerce - -import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Lazy as Lazy (ByteString) -import qualified Data.ByteString as Strict (ByteString) -import qualified Data.Text.Lazy as Lazy (Text) -import qualified Data.Text as Strict (Text) -import qualified Data.Text as Strict.Text -import qualified Data.Vector as Vector -import qualified Generics.SOP as SOP -import qualified Generics.SOP.Record as SOP - -import Squeal.PostgreSQL.Expression.Range -import Squeal.PostgreSQL.Type -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Type.PG -import Squeal.PostgreSQL.Type.Schema - --- | Converts a `Value` type from @postgresql-binary@ for use in --- the `fromPG` method of `FromPG`. -devalue :: Value x -> StateT Strict.ByteString (Except Strict.Text) x -devalue = unsafeCoerce - -revalue :: StateT Strict.ByteString (Except Strict.Text) x -> Value x -revalue = unsafeCoerce - -{- | ->>> :set -XTypeFamilies ->>> :{ -data Complex = Complex - { real :: Double - , imaginary :: Double - } -instance IsPG Complex where - type PG Complex = 'PGcomposite '[ - "re" ::: 'NotNull 'PGfloat8, - "im" ::: 'NotNull 'PGfloat8] -instance FromPG Complex where - fromPG = rowValue $ do - re <- #re - im <- #im - return Complex {real = re, imaginary = im} -:} --} -rowValue - :: (PG y ~ 'PGcomposite row, SOP.SListI row) - => DecodeRow row y -- ^ fields - -> StateT Strict.ByteString (Except Strict.Text) y -rowValue decoder = devalue $ - let - -- - -- [for each field] - -- - -- [if value is NULL] - -- <-1: 4 bytes> - -- [else] - -- - -- bytes> - -- [end if] - -- [end for] - comp = valueParser $ do - unitOfSize 4 - SOP.hsequence' $ SOP.hpure $ SOP.Comp $ do - unitOfSize 4 - len :: Int32 <- sized 4 int - if len == -1 - then return (SOP.K Nothing) - else SOP.K . Just <$> bytesOfSize (fromIntegral len) - in fn (runDecodeRow decoder <=< comp) - --- | A `FromPG` constraint gives a parser from the binary format of --- a PostgreSQL `PGType` into a Haskell `Type`. -class IsPG y => FromPG y where - {- | - >>> :set -XMultiParamTypeClasses -XGeneralizedNewtypeDeriving -XDerivingStrategies -XDerivingVia -XUndecidableInstances - >>> import GHC.Generics as GHC - >>> :{ - newtype UserId = UserId { getId :: Int64 } - deriving newtype (IsPG, FromPG) - :} - - >>> :{ - data Complex = Complex - { real :: Double - , imaginary :: Double - } deriving stock GHC.Generic - deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) - deriving (IsPG, FromPG) via Composite Complex - :} - - >>> :{ - data Direction = North | South | East | West - deriving stock GHC.Generic - deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) - deriving (IsPG, FromPG) via Enumerated Direction - :} - - -} - fromPG :: StateT Strict.ByteString (Except Strict.Text) y -instance FromPG Bool where - fromPG = devalue bool -instance FromPG Int16 where - fromPG = devalue int -instance FromPG Int32 where - fromPG = devalue int -instance FromPG Int64 where - fromPG = devalue int -instance FromPG Oid where - fromPG = devalue $ Oid <$> int -instance FromPG Float where - fromPG = devalue float4 -instance FromPG Double where - fromPG = devalue float8 -instance FromPG Scientific where - fromPG = devalue numeric -instance FromPG Money where - fromPG = devalue $ Money <$> int -instance FromPG UUID where - fromPG = devalue uuid -instance FromPG (NetAddr IP) where - fromPG = devalue inet -instance FromPG Char where - fromPG = devalue char -instance FromPG Strict.Text where - fromPG = devalue text_strict -instance FromPG Lazy.Text where - fromPG = devalue text_lazy -instance FromPG String where - fromPG = devalue $ Strict.Text.unpack <$> text_strict -instance FromPG Strict.ByteString where - fromPG = devalue bytea_strict -instance FromPG Lazy.ByteString where - fromPG = devalue bytea_lazy -instance KnownNat n => FromPG (VarChar n) where - fromPG = devalue $ text_strict >>= \t -> - case varChar t of - Nothing -> throwError $ Strict.Text.pack $ concat - [ "Source for VarChar has wrong length" - , "; expected length " - , show (natVal (SOP.Proxy @n)) - , ", actual length " - , show (Strict.Text.length t) - , "." - ] - Just x -> pure x -instance KnownNat n => FromPG (FixChar n) where - fromPG = devalue $ text_strict >>= \t -> - case fixChar t of - Nothing -> throwError $ Strict.Text.pack $ concat - [ "Source for FixChar has wrong length" - , "; expected length " - , show (natVal (SOP.Proxy @n)) - , ", actual length " - , show (Strict.Text.length t) - , "." - ] - Just x -> pure x -instance FromPG x => FromPG (Const x tag) where - fromPG = coerce $ fromPG @x -instance FromPG x => FromPG (SOP.K x tag) where - fromPG = coerce $ fromPG @x -instance FromPG x => FromPG (Constant x tag) where - fromPG = coerce $ fromPG @x -instance FromPG Day where - fromPG = devalue date -instance FromPG TimeOfDay where - fromPG = devalue time_int -instance FromPG (TimeOfDay, TimeZone) where - fromPG = devalue timetz_int -instance FromPG LocalTime where - fromPG = devalue timestamp_int -instance FromPG UTCTime where - fromPG = devalue timestamptz_int -instance FromPG DiffTime where - fromPG = devalue interval_int -instance FromPG Aeson.Value where - fromPG = devalue json_ast -instance Aeson.FromJSON x => FromPG (Json x) where - fromPG = devalue $ Json <$> - json_bytes (left Strict.Text.pack . Aeson.eitherDecodeStrict) -instance Aeson.FromJSON x => FromPG (Jsonb x) where - fromPG = devalue $ Jsonb <$> - jsonb_bytes (left Strict.Text.pack . Aeson.eitherDecodeStrict) -instance (FromArray '[] ty y, ty ~ NullPG y) - => FromPG (VarArray (Vector y)) where - fromPG = - let - rep n x = VarArray <$> Vector.replicateM n x - in - devalue . array $ dimensionArray rep - (fromArray @'[] @(NullPG y)) -instance (FromArray '[] ty y, ty ~ NullPG y) - => FromPG (VarArray [y]) where - fromPG = - let - rep n x = VarArray <$> replicateM n x - in - devalue . array $ dimensionArray rep - (fromArray @'[] @(NullPG y)) -instance FromArray dims ty y => FromPG (FixArray y) where - fromPG = devalue $ FixArray <$> array (fromArray @dims @ty @y) -instance - ( SOP.IsEnumType y - , SOP.HasDatatypeInfo y - , LabelsPG y ~ labels - ) => FromPG (Enumerated y) where - fromPG = - let - greadConstructor - :: SOP.All ((~) '[]) xss - => NP SOP.ConstructorInfo xss - -> String - -> Maybe (SOP.SOP SOP.I xss) - greadConstructor Nil _ = Nothing - greadConstructor (constructor :* constructors) name = - if name == SOP.constructorName constructor - then Just (SOP.SOP (SOP.Z Nil)) - else SOP.SOP . SOP.S . SOP.unSOP <$> - greadConstructor constructors name - in - devalue - $ fmap Enumerated - . enum - $ fmap SOP.to - . greadConstructor - (SOP.constructorInfo (SOP.datatypeInfo (SOP.Proxy @y))) - . Strict.Text.unpack -instance - ( SOP.IsRecord y ys - , SOP.AllZip FromField row ys - , RowPG y ~ row - ) => FromPG (Composite y) where - fromPG = rowValue (Composite <$> genericRow) -instance FromPG y => FromPG (Range y) where - fromPG = devalue $ do - flag <- byte - if testBit flag 0 then return Empty else do - lower <- - if testBit flag 3 - then return Infinite - else do - len <- sized 4 int - l <- sized len (revalue fromPG) - return $ if testBit flag 1 then Closed l else Open l - upper <- - if testBit flag 4 - then return Infinite - else do - len <- sized 4 int - l <- sized len (revalue fromPG) - return $ if testBit flag 2 then Closed l else Open l - return $ NonEmpty lower upper - --- | A `FromValue` constraint lifts the `FromPG` parser --- to a decoding of a @NullityType@ to a `Type`, --- decoding `Null`s to `Maybe`s. You should not define instances for --- `FromValue`, just use the provided instances. -class FromValue (ty :: NullType) (y :: Type) where - fromValue :: Maybe Strict.ByteString -> Either Strict.Text y -instance (FromPG y, pg ~ PG y) => FromValue ('NotNull pg) y where - fromValue = \case - Nothing -> throwError "fromField: saw NULL when expecting NOT NULL" - Just bytestring -> valueParser (revalue fromPG) bytestring -instance (FromPG y, pg ~ PG y) => FromValue ('Null pg) (Maybe y) where - fromValue = \case - Nothing -> return Nothing - Just bytestring -> fmap Just $ valueParser (revalue fromPG) bytestring - --- | A `FromField` constraint lifts the `FromPG` parser --- to a decoding of a @(Symbol, NullityType)@ to a `Type`, --- decoding `Null`s to `Maybe`s. You should not define instances for --- `FromField`, just use the provided instances. -class FromField (field :: (Symbol, NullType)) (y :: (Symbol, Type)) where - fromField :: Maybe Strict.ByteString -> Either Strict.Text (SOP.P y) -instance (FromValue ty y, fld0 ~ fld1) - => FromField (fld0 ::: ty) (fld1 ::: y) where - fromField = fmap SOP.P . fromValue @ty - --- | A `FromArray` constraint gives a decoding to a Haskell `Type` --- from the binary format of a PostgreSQL fixed-length array. --- You should not define instances for --- `FromArray`, just use the provided instances. -class FromArray (dims :: [Nat]) (ty :: NullType) (y :: Type) where - fromArray :: Array y -instance (FromPG y, pg ~ PG y) => FromArray '[] ('NotNull pg) y where - fromArray = valueArray (revalue fromPG) -instance (FromPG y, pg ~ PG y) => FromArray '[] ('Null pg) (Maybe y) where - fromArray = nullableValueArray (revalue fromPG) -instance - ( SOP.IsProductType product ys - , Length ys ~ dim - , SOP.All ((~) y) ys - , FromArray dims ty y ) - => FromArray (dim ': dims) ty product where - fromArray = - let - rep _ = fmap (SOP.to . SOP.SOP . SOP.Z) . replicateMN - in - dimensionArray rep (fromArray @dims @ty @y) - -replicateMN - :: forall x xs m. (SOP.All ((~) x) xs, Monad m, SOP.SListI xs) - => m x -> m (SOP.NP SOP.I xs) -replicateMN mx = SOP.hsequence' $ - SOP.hcpure (SOP.Proxy :: SOP.Proxy ((~) x)) (SOP.Comp (SOP.I <$> mx)) - -{- | -`DecodeRow` describes a decoding of a PostgreSQL `RowType` -into a Haskell `Type`. - -`DecodeRow` has an interface given by the classes -`Functor`, `Applicative`, `Alternative`, `Monad`, -`MonadPlus`, `MonadError` `Strict.Text`, and `IsLabel`. - ->>> :set -XOverloadedLabels ->>> :{ -let - decode :: DecodeRow - '[ "fst" ::: 'NotNull 'PGint2, "snd" ::: 'NotNull ('PGchar 1)] - (Int16, Char) - decode = (,) <$> #fst <*> #snd -in runDecodeRow decode (SOP.K (Just "\NUL\SOH") :* SOP.K (Just "a") :* Nil) -:} -Right (1,'a') - -There is also an `IsLabel` instance for `MaybeT` `DecodeRow`s, useful -for decoding outer joined rows. - ->>> :{ -let - decode :: DecodeRow - '[ "fst" ::: 'Null 'PGint2, "snd" ::: 'Null ('PGchar 1)] - (Maybe (Int16, Char)) - decode = runMaybeT $ (,) <$> #fst <*> #snd -in runDecodeRow decode (SOP.K (Just "\NUL\SOH") :* SOP.K (Just "a") :* Nil) -:} -Right (Just (1,'a')) - --} -newtype DecodeRow (row :: RowType) (y :: Type) = DecodeRow - { unDecodeRow :: ReaderT - (SOP.NP (SOP.K (Maybe Strict.ByteString)) row) (Except Strict.Text) y } - deriving newtype - ( Functor - , Applicative - , Alternative - , Monad - , MonadPlus - , MonadError Strict.Text ) -instance MonadFail (DecodeRow row) where - fail = throwError . fromString - --- | Run a `DecodeRow`. -runDecodeRow - :: DecodeRow row y - -> SOP.NP (SOP.K (Maybe Strict.ByteString)) row - -> Either Strict.Text y -runDecodeRow = fmap runExcept . runReaderT . unDecodeRow - -{- | Append two row decoders with a combining function. - ->>> import GHC.Generics as GHC ->>> :{ -data L = L {fst :: Int16, snd :: Char} - deriving stock (GHC.Generic, Show) - deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) -data R = R {thrd :: Bool, frth :: Bool} - deriving stock (GHC.Generic, Show) - deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) -type Row = '[ - "fst" ::: 'NotNull 'PGint2, - "snd" ::: 'NotNull ('PGchar 1), - "thrd" ::: 'NotNull 'PGbool, - "frth" ::: 'NotNull 'PGbool] -:} - ->>> :{ -let - decode :: DecodeRow Row (L,R) - decode = appendRows (,) genericRow genericRow - row4 = - SOP.K (Just "\NUL\SOH") :* - SOP.K (Just "a") :* - SOP.K (Just "\NUL") :* - SOP.K (Just "\NUL") :* Nil -in runDecodeRow decode row4 -:} -Right (L {fst = 1, snd = 'a'},R {thrd = False, frth = False}) --} -appendRows - :: SOP.SListI left - => (l -> r -> z) -- ^ combining function - -> DecodeRow left l -- ^ left decoder - -> DecodeRow right r -- ^ right decoder - -> DecodeRow (Join left right) z -appendRows f decL decR = decodeRow $ \row -> case disjoin row of - (rowL, rowR) -> f <$> runDecodeRow decL rowL <*> runDecodeRow decR rowR - -{- | Cons a column and a row decoder with a combining function. - ->>> :{ -let - decode :: DecodeRow - '["fst" ::: 'NotNull 'PGtext, "snd" ::: 'NotNull 'PGint2, "thrd" ::: 'NotNull ('PGchar 1)] - (String, (Int16, Char)) - decode = consRow (,) #fst (consRow (,) #snd #thrd) -in runDecodeRow decode (SOP.K (Just "hi") :* SOP.K (Just "\NUL\SOH") :* SOP.K (Just "a") :* Nil) -:} -Right ("hi",(1,'a')) --} -consRow - :: FromValue head h - => (h -> t -> z) -- ^ combining function - -> Alias col -- ^ alias of head - -> DecodeRow tail t -- ^ tail decoder - -> DecodeRow (col ::: head ': tail) z -consRow f _ dec = decodeRow $ \case - (SOP.K h :: SOP.K (Maybe Strict.ByteString) (col ::: head)) :* t - -> f <$> fromValue @head h <*> runDecodeRow dec t - --- | Smart constructor for a `DecodeRow`. -decodeRow - :: (SOP.NP (SOP.K (Maybe Strict.ByteString)) row -> Either Strict.Text y) - -> DecodeRow row y -decodeRow dec = DecodeRow . ReaderT $ liftEither . dec -instance {-# OVERLAPPING #-} (KnownSymbol fld, FromValue ty y) - => IsLabel fld (DecodeRow (fld ::: ty ': row) y) where - fromLabel = decodeRow $ \(SOP.K b SOP.:* _) -> do - let - flderr = mconcat - [ "field name: " - , "\"", fromString (symbolVal (SOP.Proxy @fld)), "\"; " - ] - left (flderr <>) $ fromValue @ty b -instance {-# OVERLAPPABLE #-} IsLabel fld (DecodeRow row y) - => IsLabel fld (DecodeRow (field ': row) y) where - fromLabel = decodeRow $ \(_ SOP.:* bs) -> - runDecodeRow (fromLabel @fld) bs -instance {-# OVERLAPPING #-} (KnownSymbol fld, FromValue ty (Maybe y)) - => IsLabel fld (MaybeT (DecodeRow (fld ::: ty ': row)) y) where - fromLabel = MaybeT . decodeRow $ \(SOP.K b SOP.:* _) -> do - let - flderr = mconcat - [ "field name: " - , "\"", fromString (symbolVal (SOP.Proxy @fld)), "\"; " - ] - left (flderr <>) $ fromValue @ty b -instance {-# OVERLAPPABLE #-} IsLabel fld (MaybeT (DecodeRow row) y) - => IsLabel fld (MaybeT (DecodeRow (field ': row)) y) where - fromLabel = MaybeT . decodeRow $ \(_ SOP.:* bs) -> - runDecodeRow (runMaybeT (fromLabel @fld)) bs - --- | A `GenericRow` constraint to ensure that a Haskell type --- is a record type, --- has a `RowPG`, --- and all its fields and can be decoded from corresponding Postgres fields. -class - ( SOP.IsRecord y ys - , row ~ RowPG y - , SOP.AllZip FromField row ys - ) => GenericRow row y ys where - {- | Row decoder for `SOP.Generic` records. - - >>> import qualified GHC.Generics as GHC - >>> import qualified Generics.SOP as SOP - >>> data Two = Two {frst :: Int16, scnd :: String} deriving (Show, GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo) - >>> :{ - let - decode :: DecodeRow '[ "frst" ::: 'NotNull 'PGint2, "scnd" ::: 'NotNull 'PGtext] Two - decode = genericRow - in runDecodeRow decode (SOP.K (Just "\NUL\STX") :* SOP.K (Just "two") :* Nil) - :} - Right (Two {frst = 2, scnd = "two"}) - -} - genericRow :: DecodeRow row y -instance - ( row ~ RowPG y - , SOP.IsRecord y ys - , SOP.AllZip FromField row ys - ) => GenericRow row y ys where - genericRow - = DecodeRow - . ReaderT - $ fmap SOP.fromRecord - . SOP.hsequence' - . SOP.htrans (SOP.Proxy @FromField) (SOP.Comp . runField) - where - runField - :: forall ty z. FromField ty z - => SOP.K (Maybe Strict.ByteString) ty - -> Except Strict.Text (SOP.P z) - runField = liftEither . fromField @ty . SOP.unK - -{- | ->>> :{ -data Dir = North | East | South | West -instance IsPG Dir where - type PG Dir = 'PGenum '["north", "south", "east", "west"] -instance FromPG Dir where - fromPG = enumValue $ - label @"north" North :* - label @"south" South :* - label @"east" East :* - label @"west" West -:} --} -enumValue - :: (SOP.All KnownSymbol labels, PG y ~ 'PGenum labels) - => NP (SOP.K y) labels -- ^ labels - -> StateT Strict.ByteString (Except Strict.Text) y -enumValue = devalue . enum . labels - where - labels - :: SOP.All KnownSymbol labels - => NP (SOP.K y) labels - -> Text -> Maybe y - labels = \case - Nil -> \_ -> Nothing - ((y :: SOP.K y label) :* ys) -> \ str -> - if str == fromString (symbolVal (SOP.Proxy @label)) - then Just (SOP.unK y) - else labels ys str diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Session/Encode.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Session/Encode.hs deleted file mode 100644 index 0ccfc6fc..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Session/Encode.hs +++ /dev/null @@ -1,535 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Session.Encode -Description: encoding of statement parameters -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -encoding of statement parameters --} - -{-# LANGUAGE - AllowAmbiguousTypes - , ConstraintKinds - , DataKinds - , DefaultSignatures - , FlexibleContexts - , FlexibleInstances - , LambdaCase - , MultiParamTypeClasses - , PolyKinds - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeFamilies - , TypeOperators - , UndecidableInstances - , UndecidableSuperClasses -#-} - -module Squeal.PostgreSQL.Session.Encode - ( -- * Encode Parameters - EncodeParams (..) - , GenericParams (..) - , nilParams - , (.*) - , (*.) - , aParam - , appendParams - -- * Encoding Classes - , ToPG (..) - , ToParam (..) - , ToField (..) - , ToArray (..) - ) where - -import ByteString.StrictBuilder -import Control.Monad -import Control.Monad.Reader -import Data.Bits -import Data.ByteString as Strict (ByteString) -import Data.ByteString.Lazy as Lazy (ByteString) -import Data.Coerce (coerce) -import Data.Functor.Const (Const(Const)) -import Data.Functor.Constant (Constant(Constant)) -import Data.Functor.Contravariant -import Data.Int (Int16, Int32, Int64) -import Data.Kind -import Data.Scientific (Scientific) -import Data.Text as Strict (Text) -import Data.Text.Lazy as Lazy (Text) -import Data.Time (Day, TimeOfDay, TimeZone, LocalTime, UTCTime, DiffTime) -import Data.UUID.Types (UUID) -import Data.Vector (Vector) -import Data.Word (Word32) -import Foreign.C.Types (CUInt(CUInt)) -import GHC.TypeLits -import Network.IP.Addr (NetAddr, IP) -import PostgreSQL.Binary.Encoding - -import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Lazy as Lazy.ByteString -import qualified Data.Text as Strict.Text -import qualified Database.PostgreSQL.LibPQ as LibPQ -import qualified Generics.SOP as SOP -import qualified Generics.SOP.Record as SOP - -import Squeal.PostgreSQL.Expression.Range -import Squeal.PostgreSQL.Session.Oid -import Squeal.PostgreSQL.Type -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Type.PG -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL (connectdb, finish) - --- | A `ToPG` constraint gives an encoding of a Haskell `Type` into --- into the binary format of a PostgreSQL `PGType`. -class IsPG x => ToPG (db :: SchemasType) (x :: Type) where - -- | >>> :set -XTypeApplications -XDataKinds - -- >>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" - -- >>> runReaderT (toPG @'[] False) conn - -- "\NUL" - -- - -- >>> runReaderT (toPG @'[] (0 :: Int16)) conn - -- "\NUL\NUL" - -- - -- >>> runReaderT (toPG @'[] (0 :: Int32)) conn - -- "\NUL\NUL\NUL\NUL" - -- - -- >>> :set -XMultiParamTypeClasses -XGeneralizedNewtypeDeriving - -- >>> newtype UserId = UserId { getUserId :: Int64 } deriving newtype (IsPG, ToPG db) - -- >>> runReaderT (toPG @'[] (UserId 0)) conn - -- "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL" - -- - -- >>> finish conn - toPG :: x -> ReaderT (SOP.K LibPQ.Connection db) IO Encoding -instance ToPG db Bool where toPG = pure . bool -instance ToPG db Int16 where toPG = pure . int2_int16 -instance ToPG db Int32 where toPG = pure . int4_int32 -instance ToPG db Int64 where toPG = pure . int8_int64 -instance ToPG db Oid where toPG = pure . int4_word32 . getOid -instance ToPG db Float where toPG = pure . float4 -instance ToPG db Double where toPG = pure . float8 -instance ToPG db Scientific where toPG = pure . numeric -instance ToPG db Money where toPG = pure . int8_int64 . cents -instance ToPG db UUID where toPG = pure . uuid -instance ToPG db (NetAddr IP) where toPG = pure . inet -instance ToPG db Char where toPG = pure . char_utf8 -instance ToPG db Strict.Text where toPG = pure . text_strict -instance ToPG db Lazy.Text where toPG = pure . text_lazy -instance ToPG db String where - toPG = pure . text_strict . Strict.Text.pack -instance ToPG db Strict.ByteString where toPG = pure . bytea_strict -instance ToPG db Lazy.ByteString where toPG = pure . bytea_lazy -instance ToPG db (VarChar n) where toPG = pure . text_strict . getVarChar -instance ToPG db (FixChar n) where toPG = pure . text_strict . getFixChar -instance ToPG db x => ToPG db (Const x tag) where toPG = toPG @db @x . coerce -instance ToPG db x => ToPG db (SOP.K x tag) where toPG = toPG @db @x . coerce -instance ToPG db x => ToPG db (Constant x tag) where toPG = toPG @db @x . coerce -instance ToPG db Day where toPG = pure . date -instance ToPG db TimeOfDay where toPG = pure . time_int -instance ToPG db (TimeOfDay, TimeZone) where toPG = pure . timetz_int -instance ToPG db LocalTime where toPG = pure . timestamp_int -instance ToPG db UTCTime where toPG = pure . timestamptz_int -instance ToPG db DiffTime where toPG = pure . interval_int -instance ToPG db Aeson.Value where toPG = pure . json_ast -instance Aeson.ToJSON x => ToPG db (Json x) where - toPG = pure . json_bytes - . Lazy.ByteString.toStrict . Aeson.encode . getJson -instance Aeson.ToJSON x => ToPG db (Jsonb x) where - toPG = pure . jsonb_bytes - . Lazy.ByteString.toStrict . Aeson.encode . getJsonb -instance (NullPG x ~ ty, ToArray db '[] ty x, OidOfNull db ty) - => ToPG db (VarArray [x]) where - toPG (VarArray arr) = do - oid <- oidOfNull @db @ty - let - dims = [fromIntegral (length arr)] - nulls = arrayNulls @db @'[] @ty @x - payload <- dimArray foldM (arrayPayload @db @'[] @ty @x) arr - return $ encodeArray 1 nulls oid dims payload -instance (NullPG x ~ ty, ToArray db '[] ty x, OidOfNull db ty) - => ToPG db (VarArray (Vector x)) where - toPG (VarArray arr) = do - oid <- oidOfNull @db @ty - let - dims = [fromIntegral (length arr)] - nulls = arrayNulls @db @'[] @ty @x - payload <- dimArray foldM (arrayPayload @db @'[] @ty @x) arr - return $ encodeArray 1 nulls oid dims payload -instance (ToArray db dims ty x, OidOfNull db ty) - => ToPG db (FixArray x) where - toPG (FixArray arr) = do - oid <- oidOfNull @db @ty - payload <- arrayPayload @db @dims @ty arr - let - dims = arrayDims @db @dims @ty @x - nulls = arrayNulls @db @dims @ty @x - ndims = fromIntegral (length dims) - return $ encodeArray ndims nulls oid dims payload -instance - ( SOP.IsEnumType x - , SOP.HasDatatypeInfo x - , LabelsPG x ~ labels - ) => ToPG db (Enumerated x) where - toPG = - let - gshowConstructor - :: NP SOP.ConstructorInfo xss - -> SOP.SOP SOP.I xss - -> String - gshowConstructor Nil _ = "" - gshowConstructor (constructor :* _) (SOP.SOP (SOP.Z _)) = - SOP.constructorName constructor - gshowConstructor (_ :* constructors) (SOP.SOP (SOP.S xs)) = - gshowConstructor constructors (SOP.SOP xs) - in - pure - . text_strict - . Strict.Text.pack - . gshowConstructor - (SOP.constructorInfo (SOP.datatypeInfo (SOP.Proxy @x))) - . SOP.from - . getEnumerated -instance - ( SOP.SListI fields - , SOP.IsRecord x xs - , SOP.AllZip (ToField db) fields xs - , SOP.All (OidOfField db) fields - , RowPG x ~ fields - ) => ToPG db (Composite x) where - toPG (Composite x) = do - let - compositeSize - = int4_int32 - $ fromIntegral - $ SOP.lengthSList - $ SOP.Proxy @xs - each - :: OidOfField db field - => SOP.K (Maybe Encoding) field - -> ReaderT (SOP.K LibPQ.Connection db) IO Encoding - each (SOP.K field :: SOP.K (Maybe Encoding) field) = do - oid <- getOid <$> oidOfField @db @field - return $ int4_word32 oid <> maybe null4 sized field - fields :: NP (SOP.K (Maybe Encoding)) fields <- hctransverse - (SOP.Proxy @(ToField db)) (toField @db) (SOP.toRecord x) - compositePayload <- hcfoldMapM - (SOP.Proxy @(OidOfField db)) each fields - return $ compositeSize <> compositePayload -instance ToPG db x => ToPG db (Range x) where - toPG r = do - payload <- case r of - Empty -> return mempty - NonEmpty lower upper -> (<>) <$> putBound lower <*> putBound upper - return $ word8 (setFlags r 0) <> payload - where - putBound = \case - Infinite -> return mempty - Closed value -> sized <$> toPG @db value - Open value -> sized <$> toPG @db value - setFlags = \case - Empty -> (`setBit` 0) - NonEmpty lower upper -> - setLowerFlags lower . setUpperFlags upper - setLowerFlags = \case - Infinite -> (`setBit` 3) - Closed _ -> (`setBit` 1) - Open _ -> id - setUpperFlags = \case - Infinite -> (`setBit` 4) - Closed _ -> (`setBit` 2) - Open _ -> id - --- | A `ToParam` constraint gives an encoding of a Haskell `Type` into --- into the binary format of a PostgreSQL `NullType`. --- You should not define instances for `ToParam`, --- just use the provided instances. -class ToParam (db :: SchemasType) (ty :: NullType) (x :: Type) where - toParam :: x -> ReaderT (SOP.K LibPQ.Connection db) IO (Maybe Encoding) -instance (ToPG db x, pg ~ PG x) => ToParam db ('NotNull pg) x where - toParam = fmap Just . toPG @db -instance (ToPG db x, pg ~ PG x) => ToParam db ('Null pg) (Maybe x) where - toParam = maybe (pure Nothing) (fmap Just . toPG @db) - --- | A `ToField` constraint lifts the `ToPG` parser --- to an encoding of a @(Symbol, Type)@ to a @(Symbol, NullityType)@, --- encoding `Null`s to `Maybe`s. You should not define instances for --- `ToField`, just use the provided instances. -class ToField - (db :: SchemasType) - (field :: (Symbol, NullType)) - (x :: (Symbol, Type)) where - toField :: SOP.P x - -> ReaderT (SOP.K LibPQ.Connection db) IO (SOP.K (Maybe Encoding) field) -instance (fld0 ~ fld1, ToParam db ty x) - => ToField db (fld0 ::: ty) (fld1 ::: x) where - toField (SOP.P x) = SOP.K <$> toParam @db @ty x - --- | A `ToArray` constraint gives an encoding of a Haskell `Type` --- into the binary format of a PostgreSQL fixed-length array. --- You should not define instances for --- `ToArray`, just use the provided instances. -class ToArray - (db :: SchemasType) - (dims :: [Nat]) - (ty :: NullType) - (x :: Type) where - arrayPayload :: x -> ReaderT (SOP.K LibPQ.Connection db) IO Encoding - arrayDims :: [Int32] - arrayNulls :: Bool -instance (ToPG db x, pg ~ PG x) - => ToArray db '[] ('NotNull pg) x where - arrayPayload = fmap sized . toPG @db @x - arrayDims = [] - arrayNulls = False -instance (ToPG db x, pg ~ PG x) - => ToArray db '[] ('Null pg) (Maybe x) where - arrayPayload = maybe (pure null4) (fmap sized . toPG @db @x) - arrayDims = [] - arrayNulls = True -instance - ( SOP.IsProductType tuple xs - , Length xs ~ dim - , SOP.All ((~) x) xs - , ToArray db dims ty x - , KnownNat dim ) - => ToArray db (dim ': dims) ty tuple where - arrayPayload - = dimArray foldlNP (arrayPayload @db @dims @ty @x) - . SOP.unZ . SOP.unSOP . SOP.from - arrayDims - = fromIntegral (natVal (SOP.Proxy @dim)) - : arrayDims @db @dims @ty @x - arrayNulls = arrayNulls @db @dims @ty @x -foldlNP - :: (SOP.All ((~) x) xs, Monad m) - => (z -> x -> m z) -> z -> NP SOP.I xs -> m z -foldlNP f z = \case - Nil -> pure z - SOP.I x :* xs -> do - z' <- f z x - foldlNP f z' xs - -{- | -`EncodeParams` describes an encoding of a Haskell `Type` -into a list of parameter `NullType`s. - ->>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" ->>> :{ -let - encode :: EncodeParams '[] - '[ 'NotNull 'PGint2, 'NotNull ('PGchar 1), 'NotNull 'PGtext] - (Int16, (Char, String)) - encode = fst .* fst.snd *. snd.snd -in runReaderT (runEncodeParams encode (1,('a',"foo"))) conn -:} -K (Just "\NUL\SOH") :* K (Just "a") :* K (Just "foo") :* Nil - ->>> finish conn --} -newtype EncodeParams - (db :: SchemasType) - (tys :: [NullType]) - (x :: Type) = EncodeParams - { runEncodeParams :: x - -> ReaderT (SOP.K LibPQ.Connection db) IO (NP (SOP.K (Maybe Encoding)) tys) } -instance Contravariant (EncodeParams db tys) where - contramap f (EncodeParams g) = EncodeParams (g . f) - --- | A `GenericParams` constraint to ensure that a Haskell type --- is a product type, --- has a `TuplePG`, --- and all its terms have known Oids, --- and can be encoded to corresponding Postgres types. -class - ( SOP.IsProductType x xs - , params ~ TuplePG x - , SOP.All (OidOfNull db) params - , SOP.AllZip (ToParam db) params xs - ) => GenericParams db params x xs where - {- | Parameter encoding for `SOP.Generic` tuples and records. - - >>> import qualified GHC.Generics as GHC - >>> import qualified Generics.SOP as SOP - >>> data Two = Two Int16 String deriving (GHC.Generic, SOP.Generic) - >>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" - >>> :{ - let - encode :: EncodeParams '[] '[ 'NotNull 'PGint2, 'NotNull 'PGtext] Two - encode = genericParams - in runReaderT (runEncodeParams encode (Two 2 "two")) conn - :} - K (Just "\NUL\STX") :* K (Just "two") :* Nil - - >>> :{ - let - encode :: EncodeParams '[] '[ 'NotNull 'PGint2, 'NotNull 'PGtext] (Int16, String) - encode = genericParams - in runReaderT (runEncodeParams encode (2, "two")) conn - :} - K (Just "\NUL\STX") :* K (Just "two") :* Nil - - >>> finish conn - -} - genericParams :: EncodeParams db params x -instance - ( params ~ TuplePG x - , SOP.All (OidOfNull db) params - , SOP.IsProductType x xs - , SOP.AllZip (ToParam db) params xs - ) => GenericParams db params x xs where - genericParams = EncodeParams - $ hctransverse (SOP.Proxy @(ToParam db)) encodeNullParam - . SOP.unZ . SOP.unSOP . SOP.from - where - encodeNullParam - :: forall ty y. ToParam db ty y - => SOP.I y -> ReaderT (SOP.K LibPQ.Connection db) IO (SOP.K (Maybe Encoding) ty) - encodeNullParam = fmap SOP.K . toParam @db @ty . SOP.unI - --- | Encode 0 parameters. -nilParams :: EncodeParams db '[] x -nilParams = EncodeParams $ \ _ -> pure Nil - -{- | Cons a parameter encoding. - ->>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" ->>> :{ -let - encode :: EncodeParams '[] - '[ 'Null 'PGint4, 'NotNull 'PGtext] - (Maybe Int32, String) - encode = fst .* snd .* nilParams -in runReaderT (runEncodeParams encode (Nothing, "foo")) conn -:} -K Nothing :* K (Just "foo") :* Nil - ->>> finish conn --} -(.*) - :: forall db x0 ty x tys. (ToParam db ty x0, ty ~ NullPG x0) - => (x -> x0) -- ^ head - -> EncodeParams db tys x -- ^ tail - -> EncodeParams db (ty ': tys) x -f .* EncodeParams params = EncodeParams $ \x -> - (:*) <$> (SOP.K <$> toParam @db @ty (f x)) <*> params x -infixr 5 .* - -{- | End a parameter encoding. - ->>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" ->>> :{ -let - encode :: EncodeParams '[] - '[ 'Null 'PGint4, 'NotNull 'PGtext, 'NotNull ('PGchar 1)] - (Maybe Int32, String, Char) - encode = (\(x,_,_) -> x) .* (\(_,y,_) -> y) *. (\(_,_,z) -> z) -in runReaderT (runEncodeParams encode (Nothing, "foo", 'z')) conn -:} -K Nothing :* K (Just "foo") :* K (Just "z") :* Nil - ->>> finish conn --} -(*.) - :: forall db x x0 ty0 x1 ty1 - . ( ToParam db ty0 x0 - , ty0 ~ NullPG x0 - , ToParam db ty1 x1 - , ty1 ~ NullPG x1 - ) - => (x -> x0) -- ^ second to last - -> (x -> x1) -- ^ last - -> EncodeParams db '[ty0, ty1] x -f *. g = f .* g .* nilParams -infixl 8 *. - -{- | Encode 1 parameter. - ->>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" ->>> :{ -let - encode :: EncodeParams '[] '[ 'NotNull 'PGint4] Int32 - encode = aParam -in runReaderT (runEncodeParams encode 1776) conn -:} -K (Just "\NUL\NUL\ACK\240") :* Nil - ->>> finish conn --} -aParam - :: forall db x ty. (ToParam db ty x, ty ~ NullPG x) - => EncodeParams db '[ty] x -aParam = EncodeParams $ - fmap (\param -> SOP.K param :* Nil) . toParam @db @(NullPG x) - -{- | Append parameter encodings. - ->>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" ->>> :{ -let - encode :: EncodeParams '[] - '[ 'NotNull 'PGint4, 'NotNull 'PGint2] - (Int32, Int16) - encode = contramap fst aParam `appendParams` contramap snd aParam -in runReaderT (runEncodeParams encode (1776, 2)) conn -:} -K (Just "\NUL\NUL\ACK\240") :* K (Just "\NUL\STX") :* Nil - ->>> finish conn --} -appendParams - :: EncodeParams db params0 x -- ^ left - -> EncodeParams db params1 x -- ^ right - -> EncodeParams db (Join params0 params1) x -appendParams encode0 encode1 = EncodeParams $ \x -> also - <$> runEncodeParams encode1 x - <*> runEncodeParams encode0 x - -getOid :: LibPQ.Oid -> Word32 -getOid (LibPQ.Oid (CUInt oid)) = oid - -encodeArray :: Int32 -> Bool -> LibPQ.Oid -> [Int32] -> Encoding -> Encoding -encodeArray ndim nulls oid dimensions payload = mconcat - [ int4_int32 ndim - , if nulls then true4 else false4 - , int4_word32 (getOid oid) - , foldMap (\dimension -> int4_int32 dimension <> true4) dimensions - , payload ] - -dimArray - :: Functor m - => (forall b. (b -> a -> m b) -> b -> c -> m b) - -> (a -> m Encoding) -> c -> m Encoding -dimArray folder elementArray = folder step mempty - where - step builder element = (builder <>) <$> elementArray element - -null4, true4, false4 :: Encoding -null4 = int4_int32 (-1) -true4 = int4_word32 1 -false4 = int4_word32 0 - -sized :: Encoding -> Encoding -sized bs = int4_int32 (fromIntegral (builderLength bs)) <> bs - -hctransverse - :: (SOP.AllZip c ys xs, Applicative m) - => SOP.Proxy c - -> (forall y x. c y x => f x -> m (g y)) - -> NP f xs -> m (NP g ys) -hctransverse c f = \case - Nil -> pure Nil - x :* xs -> (:*) <$> f x <*> hctransverse c f xs - -hcfoldMapM - :: (Monoid r, Applicative m, SOP.All c xs) - => SOP.Proxy c - -> (forall x. c x => f x -> m r) - -> NP f xs -> m r -hcfoldMapM c f = \case - Nil -> pure mempty - x :* xs -> (<>) <$> f x <*> hcfoldMapM c f xs diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Session/Exception.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Session/Exception.hs deleted file mode 100644 index 18f7b57e..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Session/Exception.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Session.Exception -Description: exceptions -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -exceptions --} - -{-# LANGUAGE - OverloadedStrings - , PatternSynonyms -#-} - -module Squeal.PostgreSQL.Session.Exception - ( SquealException (..) - , pattern UniqueViolation - , pattern CheckViolation - , pattern SerializationFailure - , pattern DeadlockDetected - , SQLState (..) - , LibPQ.ExecStatus (..) - , catchSqueal - , handleSqueal - , trySqueal - , throwSqueal - ) where - -import Control.Monad.Catch -import Data.ByteString (ByteString) -import Data.Text (Text) - -import qualified Database.PostgreSQL.LibPQ as LibPQ - --- $setup --- >>> import Squeal.PostgreSQL - --- | the state of LibPQ -data SQLState = SQLState - { sqlExecStatus :: LibPQ.ExecStatus - , sqlStateCode :: ByteString - -- ^ https://www.postgresql.org/docs/current/static/errcodes-appendix.html - , sqlErrorMessage :: ByteString - } deriving (Eq, Show) - --- | `Exception`s that can be thrown by Squeal. -data SquealException - = SQLException SQLState - -- ^ SQL exception state - | ConnectionException Text - -- ^ `Database.PostgreSQL.LibPQ` function connection exception - | DecodingException Text Text - -- ^ decoding exception function and error message - | ColumnsException Text LibPQ.Column - -- ^ unexpected number of columns - | RowsException Text LibPQ.Row LibPQ.Row - -- ^ too few rows, expected at least and actual number of rows - deriving (Eq, Show) -instance Exception SquealException - --- | A pattern for unique violation exceptions. -pattern UniqueViolation :: ByteString -> SquealException -pattern UniqueViolation msg = - SQLException (SQLState LibPQ.FatalError "23505" msg) --- | A pattern for check constraint violation exceptions. -pattern CheckViolation :: ByteString -> SquealException -pattern CheckViolation msg = - SQLException (SQLState LibPQ.FatalError "23514" msg) --- | A pattern for serialization failure exceptions. -pattern SerializationFailure :: ByteString -> SquealException -pattern SerializationFailure msg = - SQLException (SQLState LibPQ.FatalError "40001" msg) --- | A pattern for deadlock detection exceptions. -pattern DeadlockDetected :: ByteString -> SquealException -pattern DeadlockDetected msg = - SQLException (SQLState LibPQ.FatalError "40P01" msg) - --- | Catch `SquealException`s. -catchSqueal - :: MonadCatch m - => m a - -> (SquealException -> m a) -- ^ handler - -> m a -catchSqueal = catch - --- | Handle `SquealException`s. -handleSqueal - :: MonadCatch m - => (SquealException -> m a) -- ^ handler - -> m a -> m a -handleSqueal = handle - --- | `Either` return a `SquealException` or a result. -trySqueal :: MonadCatch m => m a -> m (Either SquealException a) -trySqueal = try - --- | Throw `SquealException`s. -throwSqueal :: MonadThrow m => SquealException -> m a -throwSqueal = throwM diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Session/Indexed.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Session/Indexed.hs deleted file mode 100644 index e414fad1..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Session/Indexed.hs +++ /dev/null @@ -1,126 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Session.Indexed -Description: indexed session monad -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -`Squeal.PostgreSQL.Indexed` provides an indexed monad transformer -class and a class extending it to run `Definition`s. --} - -{-# LANGUAGE - DataKinds - , DefaultSignatures - , FlexibleContexts - , FlexibleInstances - , FunctionalDependencies - , PolyKinds - , MultiParamTypeClasses - , QuantifiedConstraints - , RankNTypes - , TypeApplications - , TypeFamilies - , UndecidableInstances -#-} - -module Squeal.PostgreSQL.Session.Indexed - ( IndexedMonadTrans (..) - , Indexed (..) - , IndexedMonadTransPQ (..) - , indexedDefine - ) where - -import Control.Category (Category (..)) -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans -import Data.Function ((&)) -import Prelude hiding (id, (.)) - -import Squeal.PostgreSQL.Definition - -{- | An [Atkey indexed monad] -(https://bentnib.org/paramnotions-jfp.pdf) -is a `Functor` [enriched category] -(https://ncatlab.org/nlab/show/enriched+category). -An indexed monad transformer transforms a `Monad` into an indexed monad, -and is a monad transformer when its source and target are the same, -enabling use of standard @do@ notation for endo-index operations. --} -class - ( forall i j m. Monad m => Functor (t i j m) - , forall i j m. (i ~ j, Monad m) => Monad (t i j m) - , forall i j. i ~ j => MonadTrans (t i j) - ) => IndexedMonadTrans t where - - {-# MINIMAL pqJoin | pqBind #-} - - -- | indexed analog of `<*>` - pqAp - :: Monad m - => t i j m (x -> y) - -> t j k m x - -> t i k m y - pqAp tf tx = pqBind (<$> tx) tf - - -- | indexed analog of `join` - pqJoin - :: Monad m - => t i j m (t j k m y) - -> t i k m y - pqJoin t = t & pqBind id - - -- | indexed analog of `=<<` - pqBind - :: Monad m - => (x -> t j k m y) - -> t i j m x - -> t i k m y - pqBind f t = pqJoin (f <$> t) - - -- | indexed analog of flipped `>>` - pqThen - :: Monad m - => t j k m y - -> t i j m x - -> t i k m y - pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2) - - -- | indexed analog of `<=<` - pqAndThen - :: Monad m - => (y -> t j k m z) - -> (x -> t i j m y) - -> x -> t i k m z - pqAndThen g f x = pqBind g (f x) - -{- | `Indexed` reshuffles the type parameters of an `IndexedMonadTrans`, -exposing its `Category` instance.-} -newtype Indexed t m r i j = Indexed {runIndexed :: t i j m r} -instance - ( IndexedMonadTrans t - , Monad m - , Monoid r - ) => Category (Indexed t m r) where - id = Indexed (pure mempty) - Indexed g . Indexed f = Indexed $ pqAp (fmap (<>) f) g - -{- | `IndexedMonadTransPQ` is a class for indexed monad transformers -that support running `Definition`s using `define` which acts functorially in effect. - -* @define id = return ()@ -* @define (statement1 >>> statement2) = define statement1 & pqThen (define statement2)@ --} -class IndexedMonadTrans pq => IndexedMonadTransPQ pq where - define :: MonadIO io => Definition db0 db1 -> pq db0 db1 io () - -{- | Run a pure SQL `Definition` functorially in effect - -* @indexedDefine id = id@ -* @indexedDefine (def1 >>> def2) = indexedDefine def1 >>> indexedDefine def2@ --} -indexedDefine - :: (IndexedMonadTransPQ pq, MonadIO io) - => Definition db0 db1 -> Indexed pq io () db0 db1 -indexedDefine = Indexed . define diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Session/Migration.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Session/Migration.hs deleted file mode 100644 index 050ea3db..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Session/Migration.hs +++ /dev/null @@ -1,456 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Session.Migration -Description: migrations -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -This module defines a `Migration` type to safely -change the schema of your database over time. Let's see an example! - -First turn on some extensions. - ->>> :set -XDataKinds -XOverloadedLabels ->>> :set -XOverloadedStrings -XFlexibleContexts -XTypeOperators - -Next, let's define our `TableType`s. - ->>> :{ -type UsersTable = - '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "name" ::: 'NoDef :=> 'NotNull 'PGtext - ] -:} - ->>> :{ -type EmailsTable = - '[ "pk_emails" ::: 'PrimaryKey '["id"] - , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"] - ] :=> - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 - , "email" ::: 'NoDef :=> 'Null 'PGtext - ] -:} - -Now we can define some `Migration`s to make our tables. - -`Migration`s are parameterized giving the option of a - -* pure one-way `Migration` `Definition` -* impure one-way `Migration` @(@`Indexed` `PQ` `IO`@)@ -* pure reversible `Migration` @(@`IsoQ` `Definition`@)@ -* impure reversible `Migration` @(@`IsoQ` @(@`Indexed` `PQ` `IO`@)@@)@ - -For this example, we'll use pure reversible `Migration`s. - ->>> :{ -let - makeUsers :: Migration (IsoQ Definition) - '["public" ::: '[]] - '["public" ::: '["users" ::: 'Table UsersTable]] - makeUsers = Migration "make users table" IsoQ - { up = createTable #users - ( serial `as` #id :* - notNullable text `as` #name ) - ( primaryKey #id `as` #pk_users ) - , down = dropTable #users - } -:} - ->>> :{ -let - makeEmails :: Migration (IsoQ Definition) - '["public" ::: '["users" ::: 'Table UsersTable]] - '["public" ::: '["users" ::: 'Table UsersTable, "emails" ::: 'Table EmailsTable]] - makeEmails = Migration "make emails table" IsoQ - { up = createTable #emails - ( serial `as` #id :* - notNullable int `as` #user_id :* - nullable text `as` #email ) - ( primaryKey #id `as` #pk_emails :* - foreignKey #user_id #users #id - (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_user_id ) - , down = dropTable #emails - } -:} - -Now that we have a couple migrations we can chain them together into a `Path`. - ->>> let migrations = makeUsers :>> makeEmails :>> Done - -Now run the migrations. - ->>> import Control.Monad.IO.Class ->>> :{ -withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ - manipulate_ (UnsafeManipulation "SET client_min_messages TO WARNING;") - -- suppress notices - & pqThen (liftIO (putStrLn "Migrate")) - & pqThen (migrateUp migrations) - & pqThen (liftIO (putStrLn "Rollback")) - & pqThen (migrateDown migrations) -:} -Migrate -Rollback - -We can also create a simple executable using `mainMigrateIso`. - ->>> let main = mainMigrateIso "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" migrations - ->>> withArgs [] main -Invalid command: "". Use: -migrate to run all available migrations -rollback to rollback all available migrations -status to display migrations run and migrations left to run - ->>> withArgs ["status"] main -Migrations already run: - None -Migrations left to run: - - make users table - - make emails table - ->>> withArgs ["migrate"] main -Migrations already run: - - make users table - - make emails table -Migrations left to run: - None - ->>> withArgs ["rollback"] main -Migrations already run: - None -Migrations left to run: - - make users table - - make emails table - -In addition to enabling `Migration`s using pure SQL `Definition`s for -the `up` and `down` migrations, you can also perform impure `IO` actions -by using a `Migration`s over the `Indexed` `PQ` `IO` category. --} - -{-# LANGUAGE - DataKinds - , DeriveGeneric - , FlexibleContexts - , FlexibleInstances - , FunctionalDependencies - , GADTs - , LambdaCase - , MultiParamTypeClasses - , OverloadedLabels - , OverloadedStrings - , PolyKinds - , QuantifiedConstraints - , RankNTypes - , TypeApplications - , TypeOperators -#-} - -module Squeal.PostgreSQL.Session.Migration - ( -- * Migration - Migration (..) - , Migratory (..) - , migrate - , migrateUp - , migrateDown - , MigrationsTable - -- * Executable - , mainMigrate - , mainMigrateIso - -- * Re-export - , IsoQ (..) - ) where - -import Control.Category -import Control.Category.Free -import Control.Monad -import Control.Monad.IO.Class -import Data.ByteString (ByteString) -import Data.Foldable (traverse_) -import Data.Function ((&)) -import Data.List ((\\)) -import Data.Quiver -import Data.Quiver.Functor -import Data.Text (Text) -import Data.Time (UTCTime) -import Prelude hiding ((.), id) -import System.Environment - -import qualified Data.Text.IO as Text (putStrLn) -import qualified Generics.SOP as SOP -import qualified GHC.Generics as GHC - -import Squeal.PostgreSQL.Definition -import Squeal.PostgreSQL.Definition.Constraint -import Squeal.PostgreSQL.Definition.Table -import Squeal.PostgreSQL.Expression.Comparison -import Squeal.PostgreSQL.Expression.Default -import Squeal.PostgreSQL.Expression.Parameter -import Squeal.PostgreSQL.Expression.Time -import Squeal.PostgreSQL.Expression.Type -import Squeal.PostgreSQL.Manipulation -import Squeal.PostgreSQL.Manipulation.Delete -import Squeal.PostgreSQL.Manipulation.Insert -import Squeal.PostgreSQL.Session -import Squeal.PostgreSQL.Session.Decode -import Squeal.PostgreSQL.Session.Encode -import Squeal.PostgreSQL.Session.Indexed -import Squeal.PostgreSQL.Session.Monad -import Squeal.PostgreSQL.Session.Result -import Squeal.PostgreSQL.Session.Statement -import Squeal.PostgreSQL.Session.Transaction.Unsafe -import Squeal.PostgreSQL.Query.From -import Squeal.PostgreSQL.Query.Select -import Squeal.PostgreSQL.Query.Table -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Type.Schema - --- | A `Migration` consists of a name and a migration definition. -data Migration def db0 db1 = Migration - { migrationName :: Text -- ^ The name of a `Migration`. - -- Each `migrationName` should be unique. - , migrationDef :: def db0 db1 -- ^ The migration of a `Migration`. - } deriving (GHC.Generic) -instance QFunctor Migration where - qmap f (Migration n i) = Migration n (f i) - -{- | -A `Migratory` `Category` can run or -possibly rewind a `Path` of `Migration`s. --} -class (Category def, Category run) => Migratory def run | def -> run where - {- | Run a `Path` of `Migration`s.-} - runMigrations :: Path (Migration def) db0 db1 -> run db0 db1 --- | impure migrations -instance Migratory (Indexed PQ IO ()) (Indexed PQ IO ()) where - runMigrations path = Indexed . unsafePQ . transactionally_ $ do - define createMigrations - qtoMonoid upMigration path - where - upMigration step = do - executed <- do - result <- executeParams selectMigration (migrationName step) - ntuples (result :: Result UTCTime) - unless (executed == 1) $ do - _ <- unsafePQ . runIndexed $ migrationDef step - executeParams_ insertMigration (migrationName step) --- | pure migrations -instance Migratory Definition (Indexed PQ IO ()) where - runMigrations = runMigrations . qmap (qmap ixDefine) --- | impure rewinds -instance Migratory (OpQ (Indexed PQ IO ())) (OpQ (Indexed PQ IO ())) where - runMigrations path = OpQ . Indexed . unsafePQ . transactionally_ $ do - define createMigrations - qtoMonoid @FoldPath downMigration (reversePath path) - where - downMigration (OpQ step) = do - executed <- do - result <- executeParams selectMigration (migrationName step) - ntuples (result :: Result UTCTime) - unless (executed == 0) $ do - _ <- unsafePQ . runIndexed . getOpQ $ migrationDef step - executeParams_ deleteMigration (migrationName step) --- | pure rewinds -instance Migratory (OpQ Definition) (OpQ (Indexed PQ IO ())) where - runMigrations = runMigrations . qmap (qmap (qmap ixDefine)) --- | impure rewindable migrations -instance Migratory - (IsoQ (Indexed PQ IO ())) - (IsoQ (Indexed PQ IO ())) where - runMigrations path = IsoQ - (runMigrations (qmap (qmap up) path)) - (getOpQ (runMigrations (qmap (qmap (OpQ . down)) path))) --- | pure rewindable migrations -instance Migratory (IsoQ Definition) (IsoQ (Indexed PQ IO ())) where - runMigrations = runMigrations . qmap (qmap (qmap ixDefine)) - -unsafePQ :: (Functor m) => PQ db0 db1 m x -> PQ db0' db1' m x -unsafePQ (PQ pq) = PQ $ fmap (SOP.K . SOP.unK) . pq . SOP.K . SOP.unK - --- | Run migrations. -migrate - :: Migratory def (Indexed PQ IO ()) - => Path (Migration def) db0 db1 - -> PQ db0 db1 IO () -migrate = runIndexed . runMigrations - --- | Run rewindable migrations. -migrateUp - :: Migratory def (IsoQ (Indexed PQ IO ())) - => Path (Migration def) db0 db1 - -> PQ db0 db1 IO () -migrateUp = runIndexed . up . runMigrations - --- | Rewind migrations. -migrateDown - :: Migratory def (IsoQ (Indexed PQ IO ())) - => Path (Migration def) db0 db1 - -> PQ db1 db0 IO () -migrateDown = runIndexed . down . runMigrations - -ixDefine :: Definition db0 db1 -> Indexed PQ IO () db0 db1 -ixDefine = indexedDefine - --- | The `TableType` for a Squeal migration. -type MigrationsTable = - '[ "migrations_unique_name" ::: 'Unique '["name"]] :=> - '[ "name" ::: 'NoDef :=> 'NotNull 'PGtext - , "executed_at" ::: 'Def :=> 'NotNull 'PGtimestamptz - ] - -data MigrationRow = - MigrationRow { name :: Text - , executed_at :: UTCTime } - deriving (GHC.Generic, Show) - -instance SOP.Generic MigrationRow -instance SOP.HasDatatypeInfo MigrationRow - -type MigrationsSchema = '["schema_migrations" ::: 'Table MigrationsTable] -type MigrationsSchemas = Public MigrationsSchema - --- | Creates a `MigrationsTable` if it does not already exist. -createMigrations :: Definition MigrationsSchemas MigrationsSchemas -createMigrations = - createTableIfNotExists #schema_migrations - ( (text & notNullable) `as` #name :* - (timestampWithTimeZone & notNullable & default_ currentTimestamp) - `as` #executed_at ) - ( unique #name `as` #migrations_unique_name ) - --- | Inserts a `Migration` into the `MigrationsTable`, returning --- the time at which it was inserted. -insertMigration :: Statement MigrationsSchemas Text () -insertMigration = Manipulation aParam genericRow $ - insertInto_ #schema_migrations $ - Values_ (Set (param @1) `as` #name :* Default `as` #executed_at) - --- | Deletes a `Migration` from the `MigrationsTable`, returning --- the time at which it was inserted. -deleteMigration :: Statement MigrationsSchemas Text () -deleteMigration = Manipulation aParam genericRow $ - deleteFrom_ #schema_migrations (#name .== param @1) - --- | Selects a `Migration` from the `MigrationsTable`, returning --- the time at which it was inserted. -selectMigration :: Statement MigrationsSchemas Text UTCTime -selectMigration = Query aParam #executed_at $ - select_ #executed_at - $ from (table (#schema_migrations)) - & where_ (#name .== param @1) - -selectMigrations :: Statement MigrationsSchemas () MigrationRow -selectMigrations = query $ select Star (from (table #schema_migrations)) - -{- | `mainMigrate` creates a simple executable -from a connection string and a `Path` of `Migration`s. -} -mainMigrate - :: Migratory p (Indexed PQ IO ()) - => ByteString - -- ^ connection string - -> Path (Migration p) db0 db1 - -- ^ migrations - -> IO () -mainMigrate connectTo migrations = do - command <- getArgs - performCommand command - - where - - performCommand :: [String] -> IO () - performCommand = \case - ["status"] -> withConnection connectTo $ - suppressNotices >> migrateStatus - ["migrate"] -> withConnection connectTo $ - suppressNotices - & pqThen (runIndexed (runMigrations migrations)) - & pqThen migrateStatus - args -> displayUsage args - - migrateStatus :: PQ schema schema IO () - migrateStatus = unsafePQ $ do - runNames <- getRunMigrationNames - let names = qtoList migrationName migrations - unrunNames = names \\ runNames - liftIO $ displayRunned runNames >> displayUnrunned unrunNames - - suppressNotices :: PQ schema schema IO () - suppressNotices = manipulate_ $ - UnsafeManipulation "SET client_min_messages TO WARNING;" - - displayUsage :: [String] -> IO () - displayUsage args = do - putStrLn $ "Invalid command: \"" <> unwords args <> "\". Use:" - putStrLn "migrate to run all available migrations" - putStrLn "rollback to rollback all available migrations" - -{- | `mainMigrateIso` creates a simple executable -from a connection string and a `Path` of `Migration` `IsoQ`s. -} -mainMigrateIso - :: Migratory (IsoQ def) (IsoQ (Indexed PQ IO ())) - => ByteString - -- ^ connection string - -> Path (Migration (IsoQ def)) db0 db1 - -- ^ migrations - -> IO () -mainMigrateIso connectTo migrations = performCommand =<< getArgs - - where - - performCommand :: [String] -> IO () - performCommand = \case - ["status"] -> withConnection connectTo $ - suppressNotices >> migrateStatus - ["migrate"] -> withConnection connectTo $ - suppressNotices - & pqThen (migrateUp migrations) - & pqThen migrateStatus - ["rollback"] -> withConnection connectTo $ - suppressNotices - & pqThen (migrateDown migrations) - & pqThen migrateStatus - args -> displayUsage args - - migrateStatus :: PQ schema schema IO () - migrateStatus = unsafePQ $ do - runNames <- getRunMigrationNames - let names = qtoList migrationName migrations - unrunNames = names \\ runNames - liftIO $ displayRunned runNames >> displayUnrunned unrunNames - - suppressNotices :: PQ schema schema IO () - suppressNotices = manipulate_ $ - UnsafeManipulation "SET client_min_messages TO WARNING;" - - displayUsage :: [String] -> IO () - displayUsage args = do - putStrLn $ "Invalid command: \"" <> unwords args <> "\". Use:" - putStrLn "migrate to run all available migrations" - putStrLn "rollback to rollback all available migrations" - putStrLn "status to display migrations run and migrations left to run" - -getRunMigrationNames :: PQ db0 db0 IO [Text] -getRunMigrationNames = - fmap name <$> - (unsafePQ (define createMigrations - & pqThen (execute selectMigrations)) >>= getRows) - -displayListOfNames :: [Text] -> IO () -displayListOfNames [] = Text.putStrLn " None" -displayListOfNames xs = - let singleName n = Text.putStrLn $ " - " <> n - in traverse_ singleName xs - -displayUnrunned :: [Text] -> IO () -displayUnrunned unrunned = - Text.putStrLn "Migrations left to run:" - >> displayListOfNames unrunned - -displayRunned :: [Text] -> IO () -displayRunned runned = - Text.putStrLn "Migrations already run:" - >> displayListOfNames runned diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Session/Monad.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Session/Monad.hs deleted file mode 100644 index e514abb3..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Session/Monad.hs +++ /dev/null @@ -1,654 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Session.Monad -Description: session monad -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -Run `Squeal.PostgreSQL.Session.Statement`s in the mtl-style -typeclass `MonadPQ`. --} -{-# LANGUAGE - DataKinds - , DefaultSignatures - , FlexibleContexts - , FlexibleInstances - , FunctionalDependencies - , GADTs - , PolyKinds - , MultiParamTypeClasses - , QuantifiedConstraints - , RankNTypes - , TypeApplications - , TypeFamilies - , UndecidableInstances -#-} - -module Squeal.PostgreSQL.Session.Monad where - -import Control.Category (Category (..)) -import Control.Monad -import Control.Monad.Morph -import Prelude hiding (id, (.)) - -import Squeal.PostgreSQL.Manipulation -import Squeal.PostgreSQL.Session.Decode -import Squeal.PostgreSQL.Session.Encode -import Squeal.PostgreSQL.Session.Result -import Squeal.PostgreSQL.Session.Statement -import Squeal.PostgreSQL.Query - --- For `MonadPQ` transformer instances -import Control.Monad.Trans.Cont -import Control.Monad.Trans.Identity -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.Reader -import qualified Control.Monad.Trans.State.Lazy as Lazy -import qualified Control.Monad.Trans.State.Strict as Strict -import qualified Control.Monad.Trans.Writer.Lazy as Lazy -import qualified Control.Monad.Trans.Writer.Strict as Strict -import qualified Control.Monad.Trans.RWS.Lazy as Lazy -import qualified Control.Monad.Trans.RWS.Strict as Strict - --- $setup --- >>> import Squeal.PostgreSQL - -{- | `MonadPQ` is an @mtl@ style constraint, similar to -`Control.Monad.State.Class.MonadState`, for using `Database.PostgreSQL.LibPQ` -to run `Statement`s. --} -class Monad pq => MonadPQ db pq | pq -> db where - - {- | - `executeParams` runs a `Statement` which takes out-of-line - `Squeal.PostgreSQL.Expression.Parameter.parameter`s. - - >>> import Data.Int (Int32, Int64) - >>> import Data.Monoid (Sum(Sum)) - >>> :{ - let - sumOf :: Statement db (Int32, Int32) (Sum Int32) - sumOf = query $ values_ $ - ( param @1 @('NotNull 'PGint4) + - param @2 @('NotNull 'PGint4) - ) `as` #getSum - in - withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ do - result <- executeParams sumOf (2,2) - firstRow result - :} - Just (Sum {getSum = 4}) - -} - executeParams - :: Statement db x y - -- ^ query or manipulation - -> x - -- ^ parameters - -> pq (Result y) - default executeParams - :: (MonadTrans t, MonadPQ db m, pq ~ t m) - => Statement db x y - -- ^ query or manipulation - -> x - -- ^ parameters - -> pq (Result y) - executeParams statement params = lift $ executeParams statement params - - {- | - `executeParams_` runs a returning-free `Statement`. - - >>> type Column = 'NoDef :=> 'NotNull 'PGint4 - >>> type Columns = '["col1" ::: Column, "col2" ::: Column] - >>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] - >>> type DB = Public Schema - >>> import Data.Int(Int32) - >>> :{ - let - insertion :: Statement DB (Int32, Int32) () - insertion = manipulation $ insertInto_ #tab $ Values_ $ - Set (param @1 @('NotNull 'PGint4)) `as` #col1 :* - Set (param @2 @('NotNull 'PGint4)) `as` #col2 - setup :: Definition (Public '[]) DB - setup = createTable #tab - ( notNullable int4 `as` #col1 :* - notNullable int4 `as` #col2 - ) Nil - teardown :: Definition DB (Public '[]) - teardown = dropTable #tab - in - withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ - define setup - & pqThen (executeParams_ insertion (2,2)) - & pqThen (define teardown) - :} - -} - executeParams_ - :: Statement db x () - -- ^ query or manipulation - -> x - -- ^ parameters - -> pq () - executeParams_ statement params = void $ executeParams statement params - - {- | `execute` runs a parameter-free `Statement`. - - >>> import Data.Int(Int32) - >>> :{ - let - two :: Expr ('NotNull 'PGint4) - two = 2 - twoPlusTwo :: Statement db () (Only Int32) - twoPlusTwo = query $ values_ $ (two + two) `as` #fromOnly - in - withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ do - result <- execute twoPlusTwo - firstRow result - :} - Just (Only {fromOnly = 4}) - -} - execute - :: Statement db () y - -- ^ query or manipulation - -> pq (Result y) - execute statement = executeParams statement () - - {- | `execute_` runs a parameter-free, returning-free `Statement`. - - >>> :{ - let - silence :: Statement db () () - silence = manipulation $ - UnsafeManipulation "Set client_min_messages TO WARNING" - in - withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ execute_ silence - :} - -} - execute_ :: Statement db () () -> pq () - execute_ = void . execute - - {- | - `executePrepared` runs a `Statement` on a `Traversable` - container by first preparing the statement, then running the prepared - statement on each element. - - >>> import Data.Int (Int32, Int64) - >>> import Data.Monoid (Sum(Sum)) - >>> :{ - let - sumOf :: Statement db (Int32, Int32) (Sum Int32) - sumOf = query $ values_ $ - ( param @1 @('NotNull 'PGint4) + - param @2 @('NotNull 'PGint4) - ) `as` #getSum - in - withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ do - results <- executePrepared sumOf [(2,2),(3,3),(4,4)] - traverse firstRow results - :} - [Just (Sum {getSum = 4}),Just (Sum {getSum = 6}),Just (Sum {getSum = 8})] - -} - executePrepared - :: Traversable list - => Statement db x y - -- ^ query or manipulation - -> list x - -- ^ list of parameters - -> pq (list (Result y)) - default executePrepared - :: (MonadTrans t, MonadPQ db m, pq ~ t m) - => Traversable list - => Statement db x y - -- ^ query or manipulation - -> list x - -- ^ list of parameters - -> pq (list (Result y)) - executePrepared statement x = lift $ executePrepared statement x - - {- | - `executePrepared_` runs a returning-free `Statement` on a `Foldable` - container by first preparing the statement, then running the prepared - statement on each element. - - >>> type Column = 'NoDef :=> 'NotNull 'PGint4 - >>> type Columns = '["col1" ::: Column, "col2" ::: Column] - >>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] - >>> type DB = Public Schema - >>> import Data.Int(Int32) - >>> :{ - let - insertion :: Statement DB (Int32, Int32) () - insertion = manipulation $ insertInto_ #tab $ Values_ $ - Set (param @1 @('NotNull 'PGint4)) `as` #col1 :* - Set (param @2 @('NotNull 'PGint4)) `as` #col2 - setup :: Definition (Public '[]) DB - setup = createTable #tab - ( notNullable int4 `as` #col1 :* - notNullable int4 `as` #col2 - ) Nil - teardown :: Definition DB (Public '[]) - teardown = dropTable #tab - in - withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ - define setup - & pqThen (executePrepared_ insertion [(2,2),(3,3),(4,4)]) - & pqThen (define teardown) - :} - -} - executePrepared_ - :: Foldable list - => Statement db x () - -- ^ query or manipulation - -> list x - -- ^ list of parameters - -> pq () - default executePrepared_ - :: (MonadTrans t, MonadPQ db m, pq ~ t m) - => Foldable list - => Statement db x () - -- ^ query or manipulation - -> list x - -- ^ list of parameters - -> pq () - executePrepared_ statement x = lift $ executePrepared_ statement x - -{- | -`manipulateParams` runs a `Squeal.PostgreSQL.Manipulation.Manipulation`. - ->>> type Column = 'NoDef :=> 'NotNull 'PGint4 ->>> type Columns = '["col1" ::: Column, "col2" ::: Column] ->>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] ->>> type DB = Public Schema ->>> import Control.Monad.IO.Class ->>> import Data.Int(Int32) ->>> :{ -let - insertAdd :: Manipulation_ DB (Int32, Int32) (Only Int32) - insertAdd = insertInto #tab - ( Values_ $ - Set (param @1 @('NotNull 'PGint4)) `as` #col1 :* - Set (param @2 @('NotNull 'PGint4)) `as` #col2 - ) OnConflictDoRaise - ( Returning_ ((#col1 + #col2) `as` #fromOnly) ) - setup :: Definition (Public '[]) DB - setup = createTable #tab - ( notNullable int4 `as` #col1 :* - notNullable int4 `as` #col2 - ) Nil - teardown :: Definition DB (Public '[]) - teardown = dropTable #tab -in - withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ - define setup - & pqThen - ( do - result <- manipulateParams insertAdd (2::Int32,2::Int32) - Just (Only answer) <- firstRow result - liftIO $ print (answer :: Int32) - ) - & pqThen (define teardown) -:} -4 --} -manipulateParams :: - ( MonadPQ db pq - , GenericParams db params x xs - , GenericRow row y ys - ) => Manipulation '[] db params row - -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto`, - -- `Squeal.PostgreSQL.Manipulation.Update.update`, - -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom`, and friends - -> x -> pq (Result y) -manipulateParams = executeParams . manipulation - -{- | -`manipulateParams_` runs a `Squeal.PostgreSQL.Manipulation.Manipulation`, -for a returning-free statement. - ->>> type Column = 'NoDef :=> 'NotNull 'PGint4 ->>> type Columns = '["col1" ::: Column, "col2" ::: Column] ->>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] ->>> type DB = Public Schema ->>> import Data.Int(Int32) ->>> :{ -let - insertion :: Manipulation_ DB (Int32, Int32) () - insertion = insertInto_ #tab $ Values_ $ - Set (param @1 @('NotNull 'PGint4)) `as` #col1 :* - Set (param @2 @('NotNull 'PGint4)) `as` #col2 - setup :: Definition (Public '[]) DB - setup = createTable #tab - ( notNullable int4 `as` #col1 :* - notNullable int4 `as` #col2 - ) Nil - teardown :: Definition DB (Public '[]) - teardown = dropTable #tab -in - withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ - define setup - & pqThen (manipulateParams_ insertion (2::Int32,2::Int32)) - & pqThen (define teardown) -:} --} -manipulateParams_ :: - ( MonadPQ db pq - , GenericParams db params x xs - ) => Manipulation '[] db params '[] - -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto_`, - -- `Squeal.PostgreSQL.Manipulation.Update.update_`, - -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom_`, and friends - -> x -> pq () -manipulateParams_ = executeParams_ . manipulation - -{- | -`manipulate` runs a `Squeal.PostgreSQL.Manipulation.Manipulation`, -for a parameter-free statement. - ->>> type Column = 'NoDef :=> 'NotNull 'PGint4 ->>> type Columns = '["col1" ::: Column, "col2" ::: Column] ->>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] ->>> type DB = Public Schema ->>> import Control.Monad.IO.Class ->>> import Data.Int(Int32) ->>> :{ -let - insertTwoPlusTwo :: Manipulation_ DB () (Only Int32) - insertTwoPlusTwo = insertInto #tab - (Values_ $ Set 2 `as` #col1 :* Set 2 `as` #col2) - OnConflictDoRaise - (Returning_ ((#col1 + #col2) `as` #fromOnly)) - setup :: Definition (Public '[]) DB - setup = createTable #tab - ( notNullable int4 `as` #col1 :* - notNullable int4 `as` #col2 - ) Nil - teardown :: Definition DB (Public '[]) - teardown = dropTable #tab -in - withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ - define setup - & pqThen - ( do - result <- manipulate insertTwoPlusTwo - Just (Only answer) <- firstRow result - liftIO $ print (answer :: Int32) - ) - & pqThen (define teardown) -:} -4 --} -manipulate - :: (MonadPQ db pq, GenericRow row y ys) - => Manipulation '[] db '[] row - -> pq (Result y) -manipulate = execute . manipulation - -{- | -`manipulate_` runs a `Squeal.PostgreSQL.Manipulation.Manipulation`, -for a returning-free, parameter-free statement. - ->>> :{ -let - silence :: Manipulation_ db () () - silence = UnsafeManipulation "Set client_min_messages TO WARNING" -in - withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ manipulate_ silence -:} --} -manipulate_ - :: MonadPQ db pq - => Manipulation '[] db '[] '[] - -> pq () -manipulate_ = execute_ . manipulation - -{- | -`runQueryParams` runs a `Squeal.PostgreSQL.Query.Query`. - ->>> import Data.Int (Int32, Int64) ->>> import Control.Monad.IO.Class ->>> import Data.Monoid (Sum(Sum)) ->>> :{ -let - sumOf :: Query_ db (Int32, Int32) (Sum Int32) - sumOf = values_ $ - ( param @1 @('NotNull 'PGint4) + - param @2 @('NotNull 'PGint4) - ) `as` #getSum -in - withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ do - result <- runQueryParams sumOf (2::Int32,2::Int32) - Just (Sum four) <- firstRow result - liftIO $ print (four :: Int32) -:} -4 --} -runQueryParams :: - ( MonadPQ db pq - , GenericParams db params x xs - , GenericRow row y ys - ) => Query '[] '[] db params row - -- ^ `Squeal.PostgreSQL.Query.Select.select` and friends - -> x -> pq (Result y) -runQueryParams = executeParams . query - -{- | -`runQuery` runs a `Squeal.PostgreSQL.Query.Query`, -for a parameter-free statement. - ->>> import Data.Int (Int32, Int64) ->>> import Control.Monad.IO.Class ->>> import Data.Monoid (Sum(Sum)) ->>> :{ -let - twoPlusTwo :: Query_ db () (Sum Int32) - twoPlusTwo = values_ $ (2 + 2) `as` #getSum -in - withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ do - result <- runQuery twoPlusTwo - Just (Sum four) <- firstRow result - liftIO $ print (four :: Int32) -:} -4 --} -runQuery - :: (MonadPQ db pq, GenericRow row y ys) - => Query '[] '[] db '[] row - -- ^ `Squeal.PostgreSQL.Query.Select.select` and friends - -> pq (Result y) -runQuery = execute . query - -{- | -`traversePrepared` runs a `Squeal.PostgreSQL.Manipulation.Manipulation` -on a `Traversable` container by first preparing the statement, -then running the prepared statement on each element. - ->>> type Column = 'NoDef :=> 'NotNull 'PGint4 ->>> type Columns = '["col1" ::: Column, "col2" ::: Column] ->>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] ->>> type DB = Public Schema ->>> import Control.Monad.IO.Class ->>> import Data.Int(Int32) ->>> :{ -let - insertAdd :: Manipulation_ DB (Int32, Int32) (Only Int32) - insertAdd = insertInto #tab - ( Values_ $ - Set (param @1 @('NotNull 'PGint4)) `as` #col1 :* - Set (param @2 @('NotNull 'PGint4)) `as` #col2 - ) OnConflictDoRaise - ( Returning_ ((#col1 + #col2) `as` #fromOnly) ) - setup :: Definition (Public '[]) DB - setup = createTable #tab - ( notNullable int4 `as` #col1 :* - notNullable int4 `as` #col2 - ) Nil - teardown :: Definition DB (Public '[]) - teardown = dropTable #tab -in - withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ - define setup - & pqThen - ( do - results <- traversePrepared insertAdd [(2::Int32,2::Int32),(3,3),(4,4)] - answers <- traverse firstRow results - liftIO $ print [answer :: Int32 | Just (Only answer) <- answers] - ) - & pqThen (define teardown) -:} -[4,6,8] --} -traversePrepared - :: ( MonadPQ db pq - , GenericParams db params x xs - , GenericRow row y ys - , Traversable list ) - => Manipulation '[] db params row - -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto`, - -- `Squeal.PostgreSQL.Manipulation.Update.update`, - -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom`, and friends - -> list x -> pq (list (Result y)) -traversePrepared = executePrepared . manipulation - -{- | -`forPrepared` is a flipped `traversePrepared` - ->>> type Column = 'NoDef :=> 'NotNull 'PGint4 ->>> type Columns = '["col1" ::: Column, "col2" ::: Column] ->>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] ->>> type DB = Public Schema ->>> import Control.Monad.IO.Class ->>> import Data.Int(Int32) ->>> :{ -let - insertAdd :: Manipulation_ DB (Int32, Int32) (Only Int32) - insertAdd = insertInto #tab - ( Values_ $ - Set (param @1 @('NotNull 'PGint4)) `as` #col1 :* - Set (param @2 @('NotNull 'PGint4)) `as` #col2 - ) OnConflictDoRaise - ( Returning_ ((#col1 + #col2) `as` #fromOnly) ) - setup :: Definition (Public '[]) DB - setup = createTable #tab - ( notNullable int4 `as` #col1 :* - notNullable int4 `as` #col2 - ) Nil - teardown :: Definition DB (Public '[]) - teardown = dropTable #tab -in - withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ - define setup - & pqThen - ( do - results <- forPrepared [(2::Int32,2::Int32),(3,3),(4,4)] insertAdd - answers <- traverse firstRow results - liftIO $ print [answer :: Int32 | Just (Only answer) <- answers] - ) - & pqThen (define teardown) -:} -[4,6,8] --} -forPrepared - :: ( MonadPQ db pq - , GenericParams db params x xs - , GenericRow row y ys - , Traversable list ) - => list x - -> Manipulation '[] db params row - -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto`, - -- `Squeal.PostgreSQL.Manipulation.Update.update`, - -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom`, and friends - -> pq (list (Result y)) -forPrepared = flip traversePrepared - -{- | -`traversePrepared_` runs a returning-free -`Squeal.PostgreSQL.Manipulation.Manipulation` on a `Foldable` -container by first preparing the statement, then running the prepared -statement on each element. - ->>> type Column = 'NoDef :=> 'NotNull 'PGint4 ->>> type Columns = '["col1" ::: Column, "col2" ::: Column] ->>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] ->>> type DB = Public Schema ->>> import Data.Int(Int32) ->>> :{ -let - insertion :: Manipulation_ DB (Int32, Int32) () - insertion = insertInto_ #tab $ Values_ $ - Set (param @1 @('NotNull 'PGint4)) `as` #col1 :* - Set (param @2 @('NotNull 'PGint4)) `as` #col2 - setup :: Definition (Public '[]) DB - setup = createTable #tab - ( notNullable int4 `as` #col1 :* - notNullable int4 `as` #col2 - ) Nil - teardown :: Definition DB (Public '[]) - teardown = dropTable #tab -in - withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ - define setup - & pqThen (traversePrepared_ insertion [(2::Int32,2::Int32),(3,3),(4,4)]) - & pqThen (define teardown) -:} --} -traversePrepared_ - :: ( MonadPQ db pq - , GenericParams db params x xs - , Foldable list ) - => Manipulation '[] db params '[] - -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto_`, - -- `Squeal.PostgreSQL.Manipulation.Update.update_`, - -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom_`, and friends - -> list x -> pq () -traversePrepared_ = executePrepared_ . manipulation - -{- | -`forPrepared_` is a flipped `traversePrepared_` - ->>> type Column = 'NoDef :=> 'NotNull 'PGint4 ->>> type Columns = '["col1" ::: Column, "col2" ::: Column] ->>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] ->>> type DB = Public Schema ->>> import Data.Int(Int32) ->>> :{ -let - insertion :: Manipulation_ DB (Int32, Int32) () - insertion = insertInto_ #tab $ Values_ $ - Set (param @1 @('NotNull 'PGint4)) `as` #col1 :* - Set (param @2 @('NotNull 'PGint4)) `as` #col2 - setup :: Definition (Public '[]) DB - setup = createTable #tab - ( notNullable int4 `as` #col1 :* - notNullable int4 `as` #col2 - ) Nil - teardown :: Definition DB (Public '[]) - teardown = dropTable #tab -in - withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ - define setup - & pqThen (forPrepared_ [(2::Int32,2::Int32),(3,3),(4,4)] insertion) - & pqThen (define teardown) -:} --} -forPrepared_ - :: ( MonadPQ db pq - , GenericParams db params x xs - , Foldable list ) - => list x - -> Manipulation '[] db params '[] - -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto_`, - -- `Squeal.PostgreSQL.Manipulation.Update.update_`, - -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom_`, and friends - -> pq () -forPrepared_ = flip traversePrepared_ - -instance MonadPQ db m => MonadPQ db (IdentityT m) -instance MonadPQ db m => MonadPQ db (ReaderT r m) -instance MonadPQ db m => MonadPQ db (Strict.StateT s m) -instance MonadPQ db m => MonadPQ db (Lazy.StateT s m) -instance (Monoid w, MonadPQ db m) => MonadPQ db (Strict.WriterT w m) -instance (Monoid w, MonadPQ db m) => MonadPQ db (Lazy.WriterT w m) -instance MonadPQ db m => MonadPQ db (MaybeT m) -instance MonadPQ db m => MonadPQ db (ExceptT e m) -instance (Monoid w, MonadPQ db m) => MonadPQ db (Strict.RWST r w s m) -instance (Monoid w, MonadPQ db m) => MonadPQ db (Lazy.RWST r w s m) -instance MonadPQ db m => MonadPQ db (ContT r m) diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Session/Oid.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Session/Oid.hs deleted file mode 100644 index 6b1c876e..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Session/Oid.hs +++ /dev/null @@ -1,233 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Session.Oid -Description: object identifiers -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -Object identifiers are used internally by PostgreSQL as -primary keys. They are needed to correctly encode -statement parameters. --} - -{-# LANGUAGE - AllowAmbiguousTypes - , DataKinds - , FlexibleContexts - , FlexibleInstances - , MultiParamTypeClasses - , OverloadedStrings - , PolyKinds - , ScopedTypeVariables - , TypeApplications - , TypeFamilies - , TypeOperators - , UndecidableInstances -#-} - -module Squeal.PostgreSQL.Session.Oid - ( -- * Oids - LibPQ.Oid - , OidOf (..) - , OidOfArray (..) - , OidOfNull (..) - , OidOfField (..) - ) where - -import Control.Monad.Catch -import Control.Monad.Reader -import Data.String -import GHC.TypeLits -import PostgreSQL.Binary.Decoding (valueParser, int) - -import qualified Data.ByteString as ByteString -import qualified Database.PostgreSQL.LibPQ as LibPQ -import qualified Generics.SOP as SOP - -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Session.Exception -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL - --- | The `LibPQ.Oid` of a `PGType` --- --- >>> :set -XTypeApplications --- >>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" --- >>> runReaderT (oidOf @'[] @'PGbool) conn --- Oid 16 --- --- >>> finish conn -class OidOf (db :: SchemasType) (pg :: PGType) where - oidOf :: ReaderT (SOP.K LibPQ.Connection db) IO LibPQ.Oid --- | The `LibPQ.Oid` of an array -class OidOfArray (db :: SchemasType) (pg :: PGType) where - oidOfArray :: ReaderT (SOP.K LibPQ.Connection db) IO LibPQ.Oid -instance OidOfArray db pg => OidOf db ('PGvararray (null pg)) where - oidOf = oidOfArray @db @pg -instance OidOfArray db pg => OidOf db ('PGfixarray dims (null pg)) where - oidOf = oidOfArray @db @pg --- | The `LibPQ.Oid` of a `NullType` -class OidOfNull (db :: SchemasType) (ty :: NullType) where - oidOfNull :: ReaderT (SOP.K LibPQ.Connection db) IO LibPQ.Oid -instance OidOf db pg => OidOfNull db (null pg) where - oidOfNull = oidOf @db @pg --- | The `LibPQ.Oid` of a field -class OidOfField (db :: SchemasType) (field :: (Symbol, NullType)) where - oidOfField :: ReaderT (SOP.K LibPQ.Connection db) IO LibPQ.Oid -instance OidOfNull db ty => OidOfField db (fld ::: ty) where - oidOfField = oidOfNull @db @ty - -instance OidOf db 'PGbool where oidOf = pure $ LibPQ.Oid 16 -instance OidOfArray db 'PGbool where oidOfArray = pure $ LibPQ.Oid 1000 -instance OidOf db 'PGint2 where oidOf = pure $ LibPQ.Oid 21 -instance OidOfArray db 'PGint2 where oidOfArray = pure $ LibPQ.Oid 1005 -instance OidOf db 'PGint4 where oidOf = pure $ LibPQ.Oid 23 -instance OidOfArray db 'PGint4 where oidOfArray = pure $ LibPQ.Oid 1007 -instance OidOf db 'PGint8 where oidOf = pure $ LibPQ.Oid 20 -instance OidOfArray db 'PGint8 where oidOfArray = pure $ LibPQ.Oid 1016 -instance OidOf db 'PGnumeric where oidOf = pure $ LibPQ.Oid 1700 -instance OidOfArray db 'PGnumeric where oidOfArray = pure $ LibPQ.Oid 1231 -instance OidOf db 'PGfloat4 where oidOf = pure $ LibPQ.Oid 700 -instance OidOfArray db 'PGfloat4 where oidOfArray = pure $ LibPQ.Oid 1021 -instance OidOf db 'PGfloat8 where oidOf = pure $ LibPQ.Oid 701 -instance OidOfArray db 'PGfloat8 where oidOfArray = pure $ LibPQ.Oid 1022 -instance OidOf db 'PGmoney where oidOf = pure $ LibPQ.Oid 790 -instance OidOfArray db 'PGmoney where oidOfArray = pure $ LibPQ.Oid 791 -instance OidOf db ('PGchar n) where oidOf = pure $ LibPQ.Oid 18 -instance OidOfArray db ('PGchar n) where oidOfArray = pure $ LibPQ.Oid 1002 -instance OidOf db ('PGvarchar n) where oidOf = pure $ LibPQ.Oid 1043 -instance OidOfArray db ('PGvarchar n) where oidOfArray = pure $ LibPQ.Oid 1015 -instance OidOf db 'PGtext where oidOf = pure $ LibPQ.Oid 25 -instance OidOfArray db 'PGtext where oidOfArray = pure $ LibPQ.Oid 1009 -instance OidOf db 'PGbytea where oidOf = pure $ LibPQ.Oid 17 -instance OidOfArray db 'PGbytea where oidOfArray = pure $ LibPQ.Oid 1001 -instance OidOf db 'PGtimestamp where oidOf = pure $ LibPQ.Oid 1114 -instance OidOfArray db 'PGtimestamp where oidOfArray = pure $ LibPQ.Oid 1115 -instance OidOf db 'PGtimestamptz where oidOf = pure $ LibPQ.Oid 1184 -instance OidOfArray db 'PGtimestamptz where oidOfArray = pure $ LibPQ.Oid 1185 -instance OidOf db 'PGdate where oidOf = pure $ LibPQ.Oid 1082 -instance OidOfArray db 'PGdate where oidOfArray = pure $ LibPQ.Oid 1182 -instance OidOf db 'PGtime where oidOf = pure $ LibPQ.Oid 1083 -instance OidOfArray db 'PGtime where oidOfArray = pure $ LibPQ.Oid 1183 -instance OidOf db 'PGtimetz where oidOf = pure $ LibPQ.Oid 1266 -instance OidOfArray db 'PGtimetz where oidOfArray = pure $ LibPQ.Oid 1270 -instance OidOf db 'PGinterval where oidOf = pure $ LibPQ.Oid 1186 -instance OidOfArray db 'PGinterval where oidOfArray = pure $ LibPQ.Oid 1187 -instance OidOf db 'PGuuid where oidOf = pure $ LibPQ.Oid 2950 -instance OidOfArray db 'PGuuid where oidOfArray = pure $ LibPQ.Oid 2951 -instance OidOf db 'PGinet where oidOf = pure $ LibPQ.Oid 869 -instance OidOfArray db 'PGinet where oidOfArray = pure $ LibPQ.Oid 1041 -instance OidOf db 'PGjson where oidOf = pure $ LibPQ.Oid 114 -instance OidOfArray db 'PGjson where oidOfArray = pure $ LibPQ.Oid 199 -instance OidOf db 'PGjsonb where oidOf = pure $ LibPQ.Oid 3802 -instance OidOfArray db 'PGjsonb where oidOfArray = pure $ LibPQ.Oid 3807 -instance OidOf db 'PGtsvector where oidOf = pure $ LibPQ.Oid 3614 -instance OidOfArray db 'PGtsvector where oidOfArray = pure $ LibPQ.Oid 3643 -instance OidOf db 'PGtsquery where oidOf = pure $ LibPQ.Oid 3615 -instance OidOfArray db 'PGtsquery where oidOfArray = pure $ LibPQ.Oid 3645 -instance OidOf db 'PGoid where oidOf = pure $ LibPQ.Oid 26 -instance OidOfArray db 'PGoid where oidOfArray = pure $ LibPQ.Oid 1028 -instance OidOf db ('PGrange 'PGint4) where oidOf = pure $ LibPQ.Oid 3904 -instance OidOfArray db ('PGrange 'PGint4) where oidOfArray = pure $ LibPQ.Oid 3905 -instance OidOf db ('PGrange 'PGint8) where oidOf = pure $ LibPQ.Oid 3926 -instance OidOfArray db ('PGrange 'PGint8) where oidOfArray = pure $ LibPQ.Oid 3927 -instance OidOf db ('PGrange 'PGnumeric) where oidOf = pure $ LibPQ.Oid 3906 -instance OidOfArray db ('PGrange 'PGnumeric) where oidOfArray = pure $ LibPQ.Oid 3907 -instance OidOf db ('PGrange 'PGtimestamp) where oidOf = pure $ LibPQ.Oid 3908 -instance OidOfArray db ('PGrange 'PGtimestamp) where oidOfArray = pure $ LibPQ.Oid 3909 -instance OidOf db ('PGrange 'PGtimestamptz) where oidOf = pure $ LibPQ.Oid 3910 -instance OidOfArray db ('PGrange 'PGtimestamptz) where oidOfArray = pure $ LibPQ.Oid 3911 -instance OidOf db ('PGrange 'PGdate) where oidOf = pure $ LibPQ.Oid 3912 -instance OidOfArray db ('PGrange 'PGdate) where oidOfArray = pure $ LibPQ.Oid 3913 -instance - ( KnownSymbol sch - , KnownSymbol td - , rels ~ DbRelations db - , FindQualified "no relation found with row: " rels row ~ '(sch,td) - ) => OidOf db ('PGcomposite row) where - oidOf = oidOfTypedef @sch @td -instance - ( KnownSymbol sch - , KnownSymbol td - , rels ~ DbRelations db - , FindQualified "no relation found with row: " rels row ~ '(sch,td) - ) => OidOfArray db ('PGcomposite row) where - oidOfArray = oidOfArrayTypedef @sch @td -instance - ( enums ~ DbEnums db - , FindQualified "no enum found with labels: " enums labels ~ '(sch,td) - , KnownSymbol sch - , KnownSymbol td - ) => OidOf db ('PGenum labels) where - oidOf = oidOfTypedef @sch @td -instance - ( enums ~ DbEnums db - , FindQualified "no enum found with labels: " enums labels ~ '(sch,td) - , KnownSymbol sch - , KnownSymbol td - ) => OidOfArray db ('PGenum labels) where - oidOfArray = oidOfArrayTypedef @sch @td - -oidOfTypedef - :: forall sch ty db. (KnownSymbol sch, KnownSymbol ty) - => ReaderT (SOP.K LibPQ.Connection db) IO LibPQ.Oid -oidOfTypedef = ReaderT $ \(SOP.K conn) -> do - resultMaybe <- LibPQ.execParams conn q [] LibPQ.Binary - case resultMaybe of - Nothing -> throwM $ ConnectionException oidErr - Just result -> do - numRows <- LibPQ.ntuples result - when (numRows /= 1) $ throwM $ RowsException oidErr 1 numRows - valueMaybe <- LibPQ.getvalue result 0 0 - case valueMaybe of - Nothing -> throwM $ ConnectionException oidErr - Just value -> case valueParser int value of - Left err -> throwM $ DecodingException oidErr err - Right oid -> return $ LibPQ.Oid oid - where - tyVal = symbolVal (SOP.Proxy @ty) - schVal = symbolVal (SOP.Proxy @sch) - oidErr = "oidOfTypedef " <> fromString (schVal <> "." <> tyVal) - q = ByteString.intercalate " " - [ "SELECT pg_type.oid" - , "FROM pg_type" - , "INNER JOIN pg_namespace" - , "ON pg_type.typnamespace = pg_namespace.oid" - , "WHERE pg_type.typname = " - , "\'" <> fromString tyVal <> "\'" - , "AND pg_namespace.nspname = " - , "\'" <> fromString schVal <> "\'" - , ";" ] - -oidOfArrayTypedef - :: forall sch ty db. (KnownSymbol sch, KnownSymbol ty) - => ReaderT (SOP.K LibPQ.Connection db) IO LibPQ.Oid -oidOfArrayTypedef = ReaderT $ \(SOP.K conn) -> do - resultMaybe <- LibPQ.execParams conn q [] LibPQ.Binary - case resultMaybe of - Nothing -> throwM $ ConnectionException oidErr - Just result -> do - numRows <- LibPQ.ntuples result - when (numRows /= 1) $ throwM $ RowsException oidErr 1 numRows - valueMaybe <- LibPQ.getvalue result 0 0 - case valueMaybe of - Nothing -> throwM $ ConnectionException oidErr - Just value -> case valueParser int value of - Left err -> throwM $ DecodingException oidErr err - Right oid -> return $ LibPQ.Oid oid - where - tyVal = symbolVal (SOP.Proxy @ty) - schVal = symbolVal (SOP.Proxy @sch) - oidErr = "oidOfArrayTypedef " <> fromString (schVal <> "." <> tyVal) - q = ByteString.intercalate " " - [ "SELECT pg_type.typelem" - , "FROM pg_type" - , "INNER JOIN pg_namespace" - , "ON pg_type.typnamespace = pg_namespace.oid" - , "WHERE pg_type.typname = " - , "\'" <> fromString tyVal <> "\'" - , "AND pg_namespace.nspname = " - , "\'" <> fromString schVal <> "\'" - , ";" ] diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Session/Pool.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Session/Pool.hs deleted file mode 100644 index 6a4b2aaf..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Session/Pool.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Pool -Description: connection pools -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -Connection pools. - -Typical use case would be to create your pool using `createConnectionPool` -and run anything that requires the pool connection with `usingConnectionPool`. - -Here's a simplified example: - ->>> import Squeal.PostgreSQL - ->>> :{ -do - let - qry :: Query_ (Public '[]) () (Only Char) - qry = values_ (inline 'a' `as` #fromOnly) - pool <- createConnectionPool "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" 1 0.5 10 - chr <- usingConnectionPool pool $ do - result <- runQuery qry - Just (Only a) <- firstRow result - return a - destroyConnectionPool pool - putChar chr -:} -a --} - -{-# LANGUAGE - DeriveFunctor - , FlexibleContexts - , FlexibleInstances - , InstanceSigs - , MultiParamTypeClasses - , PolyKinds - , RankNTypes - , ScopedTypeVariables - , TypeFamilies - , TypeInType - , UndecidableInstances -#-} - -module Squeal.PostgreSQL.Session.Pool - ( -- * Pool - Pool - , createConnectionPool - , usingConnectionPool - , destroyConnectionPool - ) where - -import Control.Monad.Catch -import Control.Monad.IO.Class -import Data.ByteString -import Data.Time -import Data.Pool - -import Squeal.PostgreSQL.Type.Schema -import Squeal.PostgreSQL.Session (PQ (..)) -import Squeal.PostgreSQL.Session.Connection - --- | Create a striped pool of connections. --- Although the garbage collector will destroy all idle connections when the pool is garbage collected it's recommended to manually `destroyConnectionPool` when you're done with the pool so that the connections are freed up as soon as possible. -createConnectionPool - :: forall (db :: SchemasType) io. MonadIO io - => ByteString - -- ^ The passed string can be empty to use all default parameters, or it can - -- contain one or more parameter settings separated by whitespace. - -- Each parameter setting is in the form keyword = value. Spaces around the equal - -- sign are optional. To write an empty value or a value containing spaces, - -- surround it with single quotes, e.g., keyword = 'a value'. Single quotes and - -- backslashes within the value must be escaped with a backslash, i.e., ' and \. - -> Int - -- ^ The number of stripes (distinct sub-pools) to maintain. The smallest acceptable value is 1. - -> NominalDiffTime - -- ^ Amount of time for which an unused connection is kept open. The smallest acceptable value is 0.5 seconds. - -- The elapsed time before destroying a connection may be a little longer than requested, as the reaper thread wakes at 1-second intervals. - -> Int - -- ^ Maximum number of connections to keep open per stripe. The smallest acceptable value is 1. - -- Requests for connections will block if this limit is reached on a single stripe, even if other stripes have idle connections available. - -> io (Pool (K Connection db)) -createConnectionPool conninfo stripes idle maxResrc = - liftIO $ createPool (connectdb conninfo) finish stripes idle maxResrc - -{-| -Temporarily take a connection from a `Pool`, perform an action with it, -and return it to the pool afterwards. - -If the pool has an idle connection available, it is used immediately. -Otherwise, if the maximum number of connections has not yet been reached, -a new connection is created and used. -If the maximum number of connections has been reached, this function blocks -until a connection becomes available. --} -usingConnectionPool - :: (MonadIO io, MonadMask io) - => Pool (K Connection db) -- ^ pool - -> PQ db db io x -- ^ session - -> io x -usingConnectionPool pool (PQ session) = mask $ \restore -> do - (conn, local) <- liftIO $ takeResource pool - ret <- restore (session conn) `onException` - liftIO (destroyResource pool local conn) - liftIO $ putResource local conn - return $ unK ret - -{- | -Destroy all connections in all stripes in the pool. -Note that this will ignore any exceptions in the destroy function. - -This function is useful when you detect that all connections -in the pool are broken. For example after a database has been -restarted all connections opened before the restart will be broken. -In that case it's better to close those connections so that -`usingConnectionPool` won't take a broken connection from the pool -but will open a new connection instead. - -Another use-case for this function is that when you know you are done -with the pool you can destroy all idle connections immediately -instead of waiting on the garbage collector to destroy them, -thus freeing up those connections sooner. --} -destroyConnectionPool - :: MonadIO io - => Pool (K Connection db) -- ^ pool - -> io () -destroyConnectionPool = liftIO . destroyAllResources diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Session/Result.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Session/Result.hs deleted file mode 100644 index 75bca67d..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Session/Result.hs +++ /dev/null @@ -1,223 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Session.Result -Description: results -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -Get values from a `Result`. --} - -{-# LANGUAGE - FlexibleContexts - , FlexibleInstances - , GADTs - , LambdaCase - , OverloadedStrings - , ScopedTypeVariables - , TypeApplications - , UndecidableInstances -#-} - -module Squeal.PostgreSQL.Session.Result - ( Result (..) - , MonadResult (..) - , liftResult - , nextRow - ) where - -import Control.Exception (throw) -import Control.Monad (when, (<=<)) -import Control.Monad.Catch -import Control.Monad.IO.Class -import Data.ByteString (ByteString) -import Data.Text (Text) -import Data.Traversable (for) -import Text.Read (readMaybe) - -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 as Char8 -import qualified Data.Text.Encoding as Text -import qualified Database.PostgreSQL.LibPQ as LibPQ -import qualified Generics.SOP as SOP - -import Squeal.PostgreSQL.Session.Decode -import Squeal.PostgreSQL.Session.Exception - -{- | `Result`s are generated by executing -`Squeal.PostgreSQL.Session.Statement`s -in a `Squeal.PostgreSQL.Session.Monad.MonadPQ`. - -They contain an underlying `LibPQ.Result` -and a `DecodeRow`. --} -data Result y where - Result - :: SOP.SListI row - => DecodeRow row y - -> LibPQ.Result - -> Result y -instance Functor Result where - fmap f (Result decode result) = Result (fmap f decode) result - -{- | A `MonadResult` operation extracts values -from the `Result` of a `Squeal.PostgreSQL.Session.Monad.MonadPQ` operation. -There is no need to define instances of `MonadResult`. -An instance of `MonadIO` implies an instance of `MonadResult`. -However, the constraint `MonadResult` -does not imply the constraint `MonadIO`. --} -class Monad m => MonadResult m where - -- | Get a row corresponding to a given row number from a `LibPQ.Result`, - -- throwing an exception if the row number is out of bounds. - getRow :: LibPQ.Row -> Result y -> m y - -- | Get all rows from a `LibPQ.Result`. - getRows :: Result y -> m [y] - -- | Get the first row if possible from a `LibPQ.Result`. - firstRow :: Result y -> m (Maybe y) - -- | Returns the number of rows (tuples) in the query result. - ntuples :: Result y -> m LibPQ.Row - -- | Returns the number of columns (fields) in the query result. - nfields :: Result y -> m LibPQ.Column - {- | - Returns the command status tag from the SQL command - that generated the `Result`. - Commonly this is just the name of the command, - but it might include additional data such as the number of rows processed. - -} - cmdStatus :: Result y -> m Text - {- | - Returns the number of rows affected by the SQL command. - This function returns `Just` the number of - rows affected by the SQL statement that generated the `Result`. - This function can only be used following the execution of a - SELECT, CREATE TABLE AS, INSERT, UPDATE, DELETE, MOVE, FETCH, - or COPY statement,or an EXECUTE of a prepared query that - contains an INSERT, UPDATE, or DELETE statement. - If the command that generated the PGresult was anything else, - `cmdTuples` returns `Nothing`. - -} - cmdTuples :: Result y -> m (Maybe LibPQ.Row) - -- | Returns the result status of the command. - resultStatus :: Result y -> m LibPQ.ExecStatus - -- | Check if a `Result`'s status is either `LibPQ.CommandOk` - -- or `LibPQ.TuplesOk` otherwise `throw` a `SQLException`. - okResult :: Result y -> m () - -- | Returns the error message most recently generated by an operation - -- on the connection. - resultErrorMessage :: Result y -> m (Maybe ByteString) - -- | Returns the error code most recently generated by an operation - -- on the connection. - -- - -- https://www.postgresql.org/docs/current/static/errcodes-appendix.html - resultErrorCode :: Result y -> m (Maybe ByteString) - -instance (Monad io, MonadIO io) => MonadResult io where - getRow r (Result decode result) = liftIO $ do - numRows <- LibPQ.ntuples result - numCols <- LibPQ.nfields result - when (numRows < r) $ throw $ RowsException "getRow" r numRows - row' <- traverse (LibPQ.getvalue result r) [0 .. numCols - 1] - case SOP.fromList row' of - Nothing -> throw $ ColumnsException "getRow" numCols - Just row -> case execDecodeRow decode row of - Left parseError -> throw $ DecodingException "getRow" parseError - Right y -> return y - - getRows (Result decode result) = liftIO $ do - numCols <- LibPQ.nfields result - numRows <- LibPQ.ntuples result - for [0 .. numRows - 1] $ \ r -> do - row' <- traverse (LibPQ.getvalue result r) [0 .. numCols - 1] - case SOP.fromList row' of - Nothing -> throw $ ColumnsException "getRows" numCols - Just row -> case execDecodeRow decode row of - Left parseError -> throw $ DecodingException "getRows" parseError - Right y -> return y - - firstRow (Result decode result) = liftIO $ do - numRows <- LibPQ.ntuples result - numCols <- LibPQ.nfields result - if numRows <= 0 then return Nothing else do - row' <- traverse (LibPQ.getvalue result 0) [0 .. numCols - 1] - case SOP.fromList row' of - Nothing -> throw $ ColumnsException "firstRow" numCols - Just row -> case execDecodeRow decode row of - Left parseError -> throw $ DecodingException "firstRow" parseError - Right y -> return $ Just y - - ntuples = liftResult LibPQ.ntuples - - nfields = liftResult LibPQ.nfields - - resultStatus = liftResult LibPQ.resultStatus - - cmdStatus = liftResult (getCmdStatus <=< LibPQ.cmdStatus) - where - getCmdStatus = \case - Nothing -> throwM $ ConnectionException "LibPQ.cmdStatus" - Just bytes -> return $ Text.decodeUtf8 bytes - - cmdTuples = liftResult (getCmdTuples <=< LibPQ.cmdTuples) - where - getCmdTuples = \case - Nothing -> throwM $ ConnectionException "LibPQ.cmdTuples" - Just bytes -> return $ - if ByteString.null bytes - then Nothing - else fromInteger <$> readMaybe (Char8.unpack bytes) - - okResult = liftResult okResult_ - - resultErrorMessage = liftResult LibPQ.resultErrorMessage - - resultErrorCode = liftResult (flip LibPQ.resultErrorField LibPQ.DiagSqlstate) - --- | Intended to be used for unfolding in streaming libraries, `nextRow` --- takes a total number of rows (which can be found with `ntuples`) --- and a `LibPQ.Result` and given a row number if it's too large returns `Nothing`, --- otherwise returning the row along with the next row number. -nextRow - :: MonadIO io - => LibPQ.Row -- ^ total number of rows - -> Result y -- ^ result - -> LibPQ.Row -- ^ row number - -> io (Maybe (LibPQ.Row, y)) -nextRow total (Result decode result) r - = liftIO $ if r >= total then return Nothing else do - numCols <- LibPQ.nfields result - row' <- traverse (LibPQ.getvalue result r) [0 .. numCols - 1] - case SOP.fromList row' of - Nothing -> throw $ ColumnsException "nextRow" numCols - Just row -> case execDecodeRow decode row of - Left parseError -> throw $ DecodingException "nextRow" parseError - Right y -> return $ Just (r+1, y) - -okResult_ :: MonadIO io => LibPQ.Result -> io () -okResult_ result = liftIO $ do - status <- LibPQ.resultStatus result - case status of - LibPQ.CommandOk -> return () - LibPQ.TuplesOk -> return () - _ -> do - stateCodeMaybe <- LibPQ.resultErrorField result LibPQ.DiagSqlstate - case stateCodeMaybe of - Nothing -> throw $ ConnectionException "LibPQ.resultErrorField" - Just stateCode -> do - msgMaybe <- LibPQ.resultErrorMessage result - case msgMaybe of - Nothing -> throw $ ConnectionException "LibPQ.resultErrorMessage" - Just msg -> throw . SQLException $ SQLState status stateCode msg - --- | Lifts actions on results from @LibPQ@. -liftResult - :: MonadIO io - => (LibPQ.Result -> IO x) - -> Result y -> io x -liftResult f (Result _ result) = liftIO $ f result - -execDecodeRow - :: DecodeRow row y - -> SOP.NP (SOP.K (Maybe ByteString)) row - -> Either Text y -execDecodeRow decode = runDecodeRow decode diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Session/Statement.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Session/Statement.hs deleted file mode 100644 index 707e67cb..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Session/Statement.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Session.Statement -Description: statements -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -A top-level `Statement` type wraps a `Squeal.PostgreSQL.Query.Query` -or `Squeal.PostgreSQL.Manipulation.Manipulation` -together with an `EncodeParams` and a `DecodeRow`. --} - -{-# LANGUAGE - DataKinds - , DeriveFunctor - , DeriveFoldable - , DeriveGeneric - , DeriveTraversable - , FlexibleContexts - , GADTs - , RankNTypes -#-} - -module Squeal.PostgreSQL.Session.Statement - ( Statement (..) - , query - , manipulation - ) where - -import Data.Functor.Contravariant -import Data.Profunctor (Profunctor (..)) - -import qualified Generics.SOP as SOP - -import Squeal.PostgreSQL.Manipulation -import Squeal.PostgreSQL.Session.Decode -import Squeal.PostgreSQL.Session.Encode -import Squeal.PostgreSQL.Session.Oid -import Squeal.PostgreSQL.Query -import Squeal.PostgreSQL.Render - --- | A `Statement` consists of a `Squeal.PostgreSQL.Statement.Manipulation` --- or a `Squeal.PostgreSQL.Session.Statement.Query` that can be run --- in a `Squeal.PostgreSQL.Session.Monad.MonadPQ`. -data Statement db x y where - -- | Constructor for a data manipulation language statement - Manipulation - :: (SOP.All (OidOfNull db) params, SOP.SListI row) - => EncodeParams db params x -- ^ encoding of parameters - -> DecodeRow row y -- ^ decoding of returned rows - -> Manipulation '[] db params row - -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto`, - -- `Squeal.PostgreSQL.Manipulation.Update.update`, - -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom`, ... - -> Statement db x y - -- | Constructor for a structured query language statement - Query - :: (SOP.All (OidOfNull db) params, SOP.SListI row) - => EncodeParams db params x -- ^ encoding of parameters - -> DecodeRow row y -- ^ decoding of returned rows - -> Query '[] '[] db params row - -- ^ `Squeal.PostgreSQL.Query.Select.select`, - -- `Squeal.PostgreSQL.Query.Values.values`, ... - -> Statement db x y - -instance Profunctor (Statement db) where - lmap f (Manipulation encode decode q) = - Manipulation (contramap f encode) decode q - lmap f (Query encode decode q) = - Query (contramap f encode) decode q - rmap f (Manipulation encode decode q) = - Manipulation encode (fmap f decode) q - rmap f (Query encode decode q) = - Query encode (fmap f decode) q - dimap f g (Manipulation encode decode q) = - Manipulation (contramap f encode) (fmap g decode) q - dimap f g (Query encode decode q) = - Query (contramap f encode) (fmap g decode) q - -instance Functor (Statement db x) where fmap = rmap - -instance RenderSQL (Statement db x y) where - renderSQL (Manipulation _ _ q) = renderSQL q - renderSQL (Query _ _ q) = renderSQL q - --- | Smart constructor for a structured query language statement -query :: - ( GenericParams db params x xs - , GenericRow row y ys - ) => Query '[] '[] db params row - -- ^ `Squeal.PostgreSQL.Query.Select.select`, - -- `Squeal.PostgreSQL.Query.Values.values`, ... - -> Statement db x y -query = Query genericParams genericRow - --- | Smart constructor for a data manipulation language statement -manipulation :: - ( GenericParams db params x xs - , GenericRow row y ys - ) => Manipulation '[] db params row - -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto`, - -- `Squeal.PostgreSQL.Manipulation.Update.update`, - -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom`, ... - -> Statement db x y -manipulation = Manipulation genericParams genericRow diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Session/Transaction.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Session/Transaction.hs deleted file mode 100644 index bcb64ddc..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Session/Transaction.hs +++ /dev/null @@ -1,156 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Session.Transaction -Description: transaction control language -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -transaction control language --} - -{-# LANGUAGE - MonoLocalBinds - , RankNTypes -#-} - -module Squeal.PostgreSQL.Session.Transaction - ( -- * Transaction - Transaction - , transactionally - , transactionally_ - , transactionallyRetry - , transactionallyRetry_ - , ephemerally - , ephemerally_ - , withSavepoint - -- * Transaction Mode - , TransactionMode (..) - , defaultMode - , longRunningMode - , retryMode - , IsolationLevel (..) - , AccessMode (..) - , DeferrableMode (..) - ) where - -import Control.Monad.Catch -import Data.ByteString - -import Squeal.PostgreSQL.Session.Monad -import Squeal.PostgreSQL.Session.Result -import Squeal.PostgreSQL.Session.Transaction.Unsafe - ( TransactionMode (..) - , defaultMode - , longRunningMode - , retryMode - , IsolationLevel (..) - , AccessMode (..) - , DeferrableMode (..) - ) -import qualified Squeal.PostgreSQL.Session.Transaction.Unsafe as Unsafe - -{- | A type of "safe" `Transaction`s, -do-blocks that permit only -database operations, pure functions, and synchronous exception handling -forbidding arbitrary `IO` operations. - -To permit arbitrary `IO`, - ->>> import qualified Squeal.PostgreSQL.Session.Transaction.Unsafe as Unsafe - -Then use the @Unsafe@ qualified form of the functions below. - -A safe `Transaction` can be run in two ways, - -1) it can be run directly in `IO` because as a - universally quantified type, - @Transaction db x@ permits interpretation in "subtypes" like - @(MonadPQ db m, MonadIO m, MonadCatch m) => m x@ - or - @PQ db db IO x@ - -2) it can be run in a transaction block, using - `transactionally`, `ephemerally`, - or `transactionallyRetry` --} -type Transaction db x = forall m. - ( MonadPQ db m - , MonadResult m - , MonadCatch m - ) => m x - -{- | Run a computation `transactionally`; -first `Unsafe.begin`, -then run the computation, -`onException` `Unsafe.rollback` and rethrow the exception, -otherwise `Unsafe.commit` and `return` the result. --} -transactionally - :: (MonadMask tx, MonadResult tx, MonadPQ db tx) - => TransactionMode - -> Transaction db x -- ^ run inside a transaction - -> tx x -transactionally = Unsafe.transactionally - --- | Run a computation `transactionally_`, in `defaultMode`. -transactionally_ - :: (MonadMask tx, MonadResult tx, MonadPQ db tx) - => Transaction db x -- ^ run inside a transaction - -> tx x -transactionally_ = Unsafe.transactionally_ - -{- | -`transactionallyRetry` a computation; - -* first `Unsafe.begin`, -* then `try` the computation, - - if it raises a serialization failure or deadloack detection, - then `Unsafe.rollback` and restart the transaction, - - if it raises any other exception then `Unsafe.rollback` and rethrow the exception, - - otherwise `Unsafe.commit` and `return` the result. --} -transactionallyRetry - :: (MonadMask tx, MonadResult tx, MonadPQ db tx) - => TransactionMode - -> Transaction db x -- ^ run inside a transaction - -> tx x -transactionallyRetry = Unsafe.transactionallyRetry - -{- | `transactionallyRetry` in `retryMode`. -} -transactionallyRetry_ - :: (MonadMask tx, MonadResult tx, MonadPQ db tx) - => Transaction db x -- ^ run inside a transaction - -> tx x -transactionallyRetry_ = Unsafe.transactionallyRetry_ - -{- | Run a computation `ephemerally`; -Like `transactionally` but always `Unsafe.rollback`, useful in testing. --} -ephemerally - :: (MonadMask tx, MonadResult tx, MonadPQ db tx) - => TransactionMode - -> Transaction db x -- ^ run inside an ephemeral transaction - -> tx x -ephemerally = Unsafe.ephemerally - -{- | Run a computation `ephemerally` in `defaultMode`. -} -ephemerally_ - :: (MonadMask tx, MonadResult tx, MonadPQ db tx) - => Transaction db x -- ^ run inside an ephemeral transaction - -> tx x -ephemerally_ = Unsafe.ephemerally_ - -{- | `withSavepoint`, used in a transaction block, -allows a form of nested transactions, -creating a savepoint, then running a transaction, -rolling back to the savepoint if it returned `Left`, -then releasing the savepoint and returning transaction's result. - -Make sure to run `withSavepoint` in a transaction block, -not directly or you will provoke a SQL exception. --} -withSavepoint - :: ByteString -- ^ savepoint name - -> Transaction db (Either e x) - -> Transaction db (Either e x) -withSavepoint = Unsafe.withSavepoint diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Session/Transaction/Unsafe.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Session/Transaction/Unsafe.hs deleted file mode 100644 index c84dcf30..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Session/Transaction/Unsafe.hs +++ /dev/null @@ -1,299 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Session.Transaction.Unsafe -Description: unsafe transaction control language -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -transaction control language permitting arbitrary `IO` --} - -{-# LANGUAGE - DataKinds - , FlexibleContexts - , LambdaCase - , OverloadedStrings - , TypeInType -#-} - -module Squeal.PostgreSQL.Session.Transaction.Unsafe - ( -- * Transaction - transactionally - , transactionally_ - , transactionallyRetry - , transactionallyRetry_ - , ephemerally - , ephemerally_ - , begin - , commit - , rollback - , withSavepoint - -- * Transaction Mode - , TransactionMode (..) - , defaultMode - , retryMode - , longRunningMode - , IsolationLevel (..) - , AccessMode (..) - , DeferrableMode (..) - ) where - -import Control.Monad -import Control.Monad.Catch -import Data.ByteString -import Data.Either - -import Squeal.PostgreSQL.Manipulation -import Squeal.PostgreSQL.Render -import Squeal.PostgreSQL.Session.Exception -import Squeal.PostgreSQL.Session.Monad - -{- | Run a computation `transactionally`; -first `begin`, -then run the computation, -`onException` `rollback` and rethrow the exception, -otherwise `commit` and `return` the result. --} -transactionally - :: (MonadMask tx, MonadPQ db tx) - => TransactionMode - -> tx x -- ^ run inside a transaction - -> tx x -transactionally mode tx = mask $ \restore -> do - manipulate_ $ begin mode - result <- restore tx `onException` manipulate_ rollback - manipulate_ commit - return result - --- | Run a computation `transactionally_`, in `defaultMode`. -transactionally_ - :: (MonadMask tx, MonadPQ db tx) - => tx x -- ^ run inside a transaction - -> tx x -transactionally_ = transactionally defaultMode - -{- | -`transactionallyRetry` a computation; - -* first `begin`, -* then `try` the computation, - - if it raises a serialization failure or deadlock detection, - then `rollback` and restart the transaction, - - if it raises any other exception then `rollback` and rethrow the exception, - - otherwise `commit` and `return` the result. --} -transactionallyRetry - :: (MonadMask tx, MonadPQ db tx) - => TransactionMode - -> tx x -- ^ run inside a transaction - -> tx x -transactionallyRetry mode tx = mask $ \restore -> - loop . try $ do - x <- restore tx - manipulate_ commit - return x - where - loop attempt = do - manipulate_ $ begin mode - attempt >>= \case - Left (SerializationFailure _) -> do - manipulate_ rollback - loop attempt - Left (DeadlockDetected _) -> do - manipulate_ rollback - loop attempt - Left err -> do - manipulate_ rollback - throwM err - Right x -> return x - -{- | `transactionallyRetry` in `retryMode`. -} -transactionallyRetry_ - :: (MonadMask tx, MonadPQ db tx) - => tx x -- ^ run inside a transaction - -> tx x -transactionallyRetry_ = transactionallyRetry retryMode - -{- | Run a computation `ephemerally`; -Like `transactionally` but always `rollback`, useful in testing. --} -ephemerally - :: (MonadMask tx, MonadPQ db tx) - => TransactionMode - -> tx x -- ^ run inside an ephemeral transaction - -> tx x -ephemerally mode tx = mask $ \restore -> do - manipulate_ $ begin mode - result <- restore tx `onException` (manipulate_ rollback) - manipulate_ rollback - return result - -{- | Run a computation `ephemerally` in `defaultMode`. -} -ephemerally_ - :: (MonadMask tx, MonadPQ db tx) - => tx x -- ^ run inside an ephemeral transaction - -> tx x -ephemerally_ = ephemerally defaultMode - --- | @BEGIN@ a transaction. -begin :: TransactionMode -> Manipulation_ db () () -begin mode = UnsafeManipulation $ "BEGIN" <+> renderSQL mode - --- | @COMMIT@ a transaction. -commit :: Manipulation_ db () () -commit = UnsafeManipulation "COMMIT" - --- | @ROLLBACK@ a transaction. -rollback :: Manipulation_ db () () -rollback = UnsafeManipulation "ROLLBACK" - -{- | `withSavepoint`, used in a transaction block, -allows a form of nested transactions, -creating a savepoint, then running a transaction, -rolling back to the savepoint if it returned `Left`, -then releasing the savepoint and returning transaction's result. - -Make sure to run `withSavepoint` in a transaction block, -not directly or you will provoke a SQL exception. --} -withSavepoint - :: MonadPQ db tx - => ByteString -- ^ savepoint name - -> tx (Either e x) - -> tx (Either e x) -withSavepoint savepoint tx = do - let svpt = "SAVEPOINT" <+> savepoint - manipulate_ $ UnsafeManipulation $ svpt - e_x <- tx - when (isLeft e_x) $ - manipulate_ $ UnsafeManipulation $ "ROLLBACK TO" <+> svpt - manipulate_ $ UnsafeManipulation $ "RELEASE" <+> svpt - return e_x - --- | The available transaction characteristics are the transaction `IsolationLevel`, --- the transaction `AccessMode` (`ReadWrite` or `ReadOnly`), and the `DeferrableMode`. -data TransactionMode = TransactionMode - { isolationLevel :: IsolationLevel - , accessMode :: AccessMode - , deferrableMode :: DeferrableMode - } deriving (Show, Eq) - --- | `TransactionMode` with a `ReadCommitted` `IsolationLevel`, --- `ReadWrite` `AccessMode` and `NotDeferrable` `DeferrableMode`. -defaultMode :: TransactionMode -defaultMode = TransactionMode ReadCommitted ReadWrite NotDeferrable - --- | `TransactionMode` with a `Serializable` `IsolationLevel`, --- `ReadWrite` `AccessMode` and `NotDeferrable` `DeferrableMode`, --- appropriate for short-lived queries or manipulations. -retryMode :: TransactionMode -retryMode = TransactionMode Serializable ReadWrite NotDeferrable - --- | `TransactionMode` with a `Serializable` `IsolationLevel`, --- `ReadOnly` `AccessMode` and `Deferrable` `DeferrableMode`. --- This mode is well suited for long-running reports or backups. -longRunningMode :: TransactionMode -longRunningMode = TransactionMode Serializable ReadOnly Deferrable - --- | Render a `TransactionMode`. -instance RenderSQL TransactionMode where - renderSQL mode = - "ISOLATION LEVEL" - <+> renderSQL (isolationLevel mode) - <+> renderSQL (accessMode mode) - <+> renderSQL (deferrableMode mode) - --- | The SQL standard defines four levels of transaction isolation. --- The most strict is `Serializable`, which is defined by the standard in a paragraph --- which says that any concurrent execution of a set of `Serializable` transactions is --- guaranteed to produce the same effect as running them one at a time in some order. --- The other three levels are defined in terms of phenomena, resulting from interaction --- between concurrent transactions, which must not occur at each level. --- The phenomena which are prohibited at various levels are: --- --- __Dirty read__: A transaction reads data written by a concurrent uncommitted transaction. --- --- __Nonrepeatable read__: A transaction re-reads data it has previously read and finds that data --- has been modified by another transaction (that committed since the initial read). --- --- __Phantom read__: A transaction re-executes a query returning a set of rows that satisfy --- a search condition and finds that the set of rows satisfying the condition --- has changed due to another recently-committed transaction. --- --- __Serialization anomaly__: The result of successfully committing a group of transactions is inconsistent --- with all possible orderings of running those transactions one at a time. --- --- In PostgreSQL, you can request any of the four standard transaction --- isolation levels, but internally only three distinct isolation levels are implemented, --- i.e. PostgreSQL's `ReadUncommitted` mode behaves like `ReadCommitted`. --- This is because it is the only sensible way to map the standard isolation levels to --- PostgreSQL's multiversion concurrency control architecture. -data IsolationLevel - = Serializable - -- ^ Dirty read is not possible. - -- Nonrepeatable read is not possible. - -- Phantom read is not possible. - -- Serialization anomaly is not possible. - | RepeatableRead - -- ^ Dirty read is not possible. - -- Nonrepeatable read is not possible. - -- Phantom read is not possible. - -- Serialization anomaly is possible. - | ReadCommitted - -- ^ Dirty read is not possible. - -- Nonrepeatable read is possible. - -- Phantom read is possible. - -- Serialization anomaly is possible. - | ReadUncommitted - -- ^ Dirty read is not possible. - -- Nonrepeatable read is possible. - -- Phantom read is possible. - -- Serialization anomaly is possible. - deriving (Show, Eq) - --- | Render an `IsolationLevel`. -instance RenderSQL IsolationLevel where - renderSQL = \case - Serializable -> "SERIALIZABLE" - ReadCommitted -> "READ COMMITTED" - ReadUncommitted -> "READ UNCOMMITTED" - RepeatableRead -> "REPEATABLE READ" - --- | The transaction access mode determines whether the transaction is `ReadWrite` or `ReadOnly`. --- `ReadWrite` is the default. When a transaction is `ReadOnly`, --- the following SQL commands are disallowed: --- @INSERT@, @UPDATE@, @DELETE@, and @COPY FROM@ --- if the table they would write to is not a temporary table; --- all @CREATE@, @ALTER@, and @DROP@ commands; --- @COMMENT@, @GRANT@, @REVOKE@, @TRUNCATE@; --- and @EXPLAIN ANALYZE@ and @EXECUTE@ if the command they would execute is among those listed. --- This is a high-level notion of `ReadOnly` that does not prevent all writes to disk. -data AccessMode - = ReadWrite - | ReadOnly - deriving (Show, Eq) - --- | Render an `AccessMode`. -instance RenderSQL AccessMode where - renderSQL = \case - ReadWrite -> "READ WRITE" - ReadOnly -> "READ ONLY" - --- | The `Deferrable` transaction property has no effect --- unless the transaction is also `Serializable` and `ReadOnly`. --- When all three of these properties are selected for a transaction, --- the transaction may block when first acquiring its snapshot, --- after which it is able to run without the normal overhead of a --- `Serializable` transaction and without any risk of contributing --- to or being canceled by a serialization failure. --- This `longRunningMode` is well suited for long-running reports or backups. -data DeferrableMode - = Deferrable - | NotDeferrable - deriving (Show, Eq) - --- | Render a `DeferrableMode`. -instance RenderSQL DeferrableMode where - renderSQL = \case - Deferrable -> "DEFERRABLE" - NotDeferrable -> "NOT DEFERRABLE" diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Type.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Type.hs deleted file mode 100644 index a9ec0ea8..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Type.hs +++ /dev/null @@ -1,201 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Type -Description: types -Copyright: (c) Eitan Chatav, 2010 -Maintainer: eitan@morphism.tech -Stability: experimental - -storage newtypes --} -{-# LANGUAGE - AllowAmbiguousTypes - , DeriveAnyClass - , DeriveFoldable - , DeriveFunctor - , DeriveGeneric - , DeriveTraversable - , DerivingStrategies - , DefaultSignatures - , FlexibleContexts - , FlexibleInstances - , FunctionalDependencies - , GADTs - , LambdaCase - , MultiParamTypeClasses - , OverloadedStrings - , ScopedTypeVariables - , TypeApplications - , TypeFamilies - , TypeInType - , TypeOperators - , UndecidableInstances - , UndecidableSuperClasses -#-} - -module Squeal.PostgreSQL.Type - ( -- * Storage newtypes - Money (..) - , Json (..) - , Jsonb (..) - , Composite (..) - , Enumerated (..) - , VarArray (..) - , FixArray (..) - , VarChar, varChar, getVarChar - , FixChar, fixChar, getFixChar - , Only (..) - ) where - -import Data.Proxy -import Data.Int (Int64) -import GHC.TypeLits - -import qualified Data.Text as Strict (Text) -import qualified Data.Text as Strict.Text -import qualified GHC.Generics as GHC -import qualified Generics.SOP as SOP - --- $setup --- >>> import Squeal.PostgreSQL - -{- | The `Money` newtype stores a monetary value in terms -of the number of cents, i.e. @$2,000.20@ would be expressed as -@Money { cents = 200020 }@. - ->>> :kind! PG Money -PG Money :: PGType -= 'PGmoney --} -newtype Money = Money { cents :: Int64 } - deriving stock (Eq, Ord, Show, Read, GHC.Generic) - deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic) - -{- | The `Json` newtype is an indication that the Haskell -type it's applied to should be stored as a -`Squeal.PostgreSQL.Type.Schema.PGjson`. - ->>> :kind! PG (Json [String]) -PG (Json [String]) :: PGType -= 'PGjson --} -newtype Json hask = Json {getJson :: hask} - deriving stock (Eq, Ord, Show, Read, GHC.Generic) - deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic) - -{- | The `Jsonb` newtype is an indication that the Haskell -type it's applied to should be stored as a -`Squeal.PostgreSQL.Type.Schema.PGjsonb`. - ->>> :kind! PG (Jsonb [String]) -PG (Jsonb [String]) :: PGType -= 'PGjsonb --} -newtype Jsonb hask = Jsonb {getJsonb :: hask} - deriving stock (Eq, Ord, Show, Read, GHC.Generic) - deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic) - -{- | The `Composite` newtype is an indication that the Haskell -type it's applied to should be stored as a -`Squeal.PostgreSQL.Type.Schema.PGcomposite`. - ->>> :{ -data Complex = Complex - { real :: Double - , imaginary :: Double - } deriving stock GHC.Generic - deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) -:} - ->>> :kind! PG (Composite Complex) -PG (Composite Complex) :: PGType -= 'PGcomposite - '["real" ::: 'NotNull 'PGfloat8, - "imaginary" ::: 'NotNull 'PGfloat8] --} -newtype Composite record = Composite {getComposite :: record} - deriving stock (Eq, Ord, Show, Read, GHC.Generic) - deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic) - -{- | The `Enumerated` newtype is an indication that the Haskell -type it's applied to should be stored as a -`Squeal.PostgreSQL.Type.Schema.PGenum`. - ->>> :kind! PG (Enumerated Ordering) -PG (Enumerated Ordering) :: PGType -= 'PGenum '["LT", "EQ", "GT"] --} -newtype Enumerated enum = Enumerated {getEnumerated :: enum} - deriving stock (Eq, Ord, Show, Read, GHC.Generic) - deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic) - -{- | The `VarArray` newtype is an indication that the Haskell -type it's applied to should be stored as a -`Squeal.PostgreSQL.Type.Schema.PGvararray`. - ->>> import Data.Vector ->>> :kind! PG (VarArray (Vector Double)) -PG (VarArray (Vector Double)) :: PGType -= 'PGvararray ('NotNull 'PGfloat8) --} -newtype VarArray arr - = VarArray {getVarArray :: arr} - deriving stock (Eq, Ord, Show, Read, GHC.Generic) - deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic) - -{- | The `FixArray` newtype is an indication that the Haskell -type it's applied to should be stored as a -`Squeal.PostgreSQL.Type.Schema.PGfixarray`. - ->>> :kind! PG (FixArray ((Double, Double), (Double, Double))) -PG (FixArray ((Double, Double), (Double, Double))) :: PGType -= 'PGfixarray '[2, 2] ('NotNull 'PGfloat8) --} -newtype FixArray arr = FixArray {getFixArray :: arr} - deriving stock (Eq, Ord, Show, Read, GHC.Generic) - deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic) - --- | `Only` is a 1-tuple type, useful for encoding or decoding a singleton -newtype Only x = Only { fromOnly :: x } - deriving (Functor,Foldable,Traversable,Eq,Ord,Read,Show,GHC.Generic) -instance SOP.Generic (Only x) -instance SOP.HasDatatypeInfo (Only x) - -{- | Variable-length text type with limit - ->>> :kind! PG (VarChar 4) -PG (VarChar 4) :: PGType -= 'PGvarchar 4 --} -newtype VarChar (n :: Nat) = VarChar Strict.Text - deriving (Eq,Ord,Read,Show) - --- | Constructor for `VarChar` -varChar :: forall n . KnownNat n => Strict.Text -> Maybe (VarChar n) -varChar t = - if Strict.Text.length t <= fromIntegral (natVal @n Proxy) - then Just $ VarChar t - else Nothing - --- | Access the `Strict.Text` of a `VarChar` -getVarChar :: VarChar n -> Strict.Text -getVarChar (VarChar t) = t - -{- | Fixed-length, blank padded - ->>> :kind! PG (FixChar 4) -PG (FixChar 4) :: PGType -= 'PGchar 4 --} -newtype FixChar (n :: Nat) = FixChar Strict.Text - deriving (Eq,Ord,Read,Show) - --- | Constructor for `FixChar` -fixChar :: forall n . KnownNat n => Strict.Text -> Maybe (FixChar n) -fixChar t = - if Strict.Text.length t == fromIntegral (natVal @n Proxy) - then Just $ FixChar t - else Nothing - --- | Access the `Strict.Text` of a `FixChar` -getFixChar :: FixChar n -> Strict.Text -getFixChar (FixChar t) = t diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Type/Alias.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Type/Alias.hs deleted file mode 100644 index f7bd43da..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Type/Alias.hs +++ /dev/null @@ -1,345 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Type.Alias -Description: aliases -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -This module embeds Postgres's alias system in Haskell in -a typesafe fashion. Thanks to GHC's @OverloadedLabels@ extension, -Squeal can reference aliases by prepending with a @#@. --} - -{-# LANGUAGE - AllowAmbiguousTypes - , ConstraintKinds - , DeriveAnyClass - , DeriveGeneric - , FlexibleContexts - , FlexibleInstances - , FunctionalDependencies - , GADTs - , LambdaCase - , OverloadedStrings - , QuantifiedConstraints - , RankNTypes - , ScopedTypeVariables - , StandaloneDeriving - , TypeApplications - , TypeFamilyDependencies - , TypeInType - , TypeOperators - , UndecidableInstances - , UndecidableSuperClasses -#-} - -module Squeal.PostgreSQL.Type.Alias - ( -- * Aliases - (:::) - , Alias (..) - , IsLabel (..) - , Aliased (As) - , Aliasable (as) - , renderAliased - , mapAliased - , Has - , HasUnique - , HasErr - , HasAll - , HasIn - -- * Error reporting - , LookupFailedError - , PrettyPrintHaystack - , PrettyPrintInfo(..) - , MismatchError - -- * Qualified Aliases - , QualifiedAlias (..) - , IsQualified (..) - -- * Grouping - , Grouping (..) - , GroupedBy - ) where - -import Control.DeepSeq -import Data.ByteString (ByteString) -import Data.String (fromString) -import GHC.Exts (Any, Constraint) -import GHC.OverloadedLabels -import GHC.TypeLits - -import qualified Generics.SOP as SOP -import qualified GHC.Generics as GHC - -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Render - --- $setup --- >>> import Squeal.PostgreSQL - --- | The alias operator `:::` is like a promoted version of `As`, --- a type level pair between an alias and some type. -type (:::) (alias :: Symbol) ty = '(alias,ty) -infixr 6 ::: - - --- | `Grouping` is an auxiliary namespace, created by --- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.groupBy`), and used --- for typesafe aggregation -data Grouping - = Ungrouped -- ^ no aggregation permitted - | Grouped [(Symbol,Symbol)] -- ^ aggregation required for any column which is not grouped - -{- | A `GroupedBy` constraint indicates that a table qualified column is -a member of the auxiliary namespace created by @GROUP BY@ clauses and thus, -may be called in an output `Squeal.PostgreSQL.Expression.Expression` without aggregating. --} -class (KnownSymbol table, KnownSymbol column) - => GroupedBy table column bys where -instance {-# OVERLAPPING #-} (KnownSymbol table, KnownSymbol column) - => GroupedBy table column ('(table,column) ': bys) -instance {-# OVERLAPPABLE #-} - ( KnownSymbol table - , KnownSymbol column - , GroupedBy table column bys - ) => GroupedBy table column (tabcol ': bys) - --- | `Alias`es are proxies for a type level string or `Symbol` --- and have an `IsLabel` instance so that with @-XOverloadedLabels@ --- --- >>> :set -XOverloadedLabels --- >>> #foobar :: Alias "foobar" --- Alias -data Alias (alias :: Symbol) = Alias - deriving (Eq,GHC.Generic,Ord,Show,NFData) -instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where - fromLabel = Alias -instance aliases ~ '[alias] => IsLabel alias (NP Alias aliases) where - fromLabel = fromLabel SOP.:* Nil --- | >>> printSQL (#jimbob :: Alias "jimbob") --- "jimbob" -instance KnownSymbol alias => RenderSQL (Alias alias) where - renderSQL = doubleQuoted . fromString . symbolVal - --- >>> printSQL (#jimbob :* #kandi :: NP Alias '["jimbob", "kandi"]) --- "jimbob", "kandi" -instance SOP.All KnownSymbol aliases => RenderSQL (NP Alias aliases) where - renderSQL - = commaSeparated - . SOP.hcollapse - . SOP.hcmap (SOP.Proxy @KnownSymbol) (SOP.K . renderSQL) - --- | The `As` operator is used to name an expression. `As` is like a demoted --- version of `:::`. --- --- >>> Just "hello" `As` #hi :: Aliased Maybe ("hi" ::: String) --- As (Just "hello") Alias -data Aliased expression aliased where - As - :: KnownSymbol alias - => expression ty - -> Alias alias - -> Aliased expression (alias ::: ty) -deriving instance Show (expression ty) - => Show (Aliased expression (alias ::: ty)) -deriving instance Eq (expression ty) - => Eq (Aliased expression (alias ::: ty)) -deriving instance Ord (expression ty) - => Ord (Aliased expression (alias ::: ty)) -instance (alias0 ~ alias1, alias0 ~ alias2, KnownSymbol alias2) - => IsLabel alias0 (Aliased Alias (alias1 ::: alias2)) where - fromLabel = fromLabel @alias2 `As` fromLabel @alias1 - --- | The `Aliasable` class provides a way to scrap your `Nil`s --- in an `NP` list of `Aliased` expressions. -class KnownSymbol alias => Aliasable alias expression aliased - | aliased -> expression - , aliased -> alias - where as :: expression -> Alias alias -> aliased -instance (KnownSymbol alias, aliased ~ (alias ::: ty)) => Aliasable alias - (expression ty) - (Aliased expression aliased) - where - as = As -instance (KnownSymbol alias, tys ~ '[alias ::: ty]) => Aliasable alias - (expression ty) - (NP (Aliased expression) tys) - where - expression `as` alias = expression `As` alias SOP.:* Nil - --- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just") --- >>> renderAliased renderMaybe (Just (3::Int) `As` #an_int) --- "Just AS \"an_int\"" -renderAliased - :: (forall ty. expression ty -> ByteString) - -> Aliased expression aliased - -> ByteString -renderAliased render (expression `As` alias) = - render expression <> " AS " <> renderSQL alias - --- | Map a function over an `Aliased` expression. -mapAliased - :: (expr x -> expr y) - -> Aliased expr (alias ::: x) - -> Aliased expr (alias ::: y) -mapAliased f (x `As` alias) = f x `As` alias - --- | @HasUnique alias fields field@ is a constraint that proves that --- @fields@ is a singleton of @alias ::: field@. -type HasUnique alias fields field = fields ~ '[alias ::: field] - --- | @Has alias fields field@ is a constraint that proves that --- @fields@ has a field of @alias ::: field@, inferring @field@ --- from @alias@ and @fields@. -class (KnownSymbol alias) => Has (alias :: Symbol) (fields :: [(Symbol, kind)]) (field :: kind) | alias fields -> field --- having these instances forces 'Has' to inspect 'alias' and 'fields' and thereby fail before delegating to --- 'HasErr', which means 'Has' shows up in error messages instead of 'HasErr' -instance {-# OVERLAPPING #-} (KnownSymbol alias, HasErr (alias ::: field0 ': fields) alias (alias ::: field0 ': fields) field1) - => Has alias (alias ::: field0 ': fields) field1 -instance {-# OVERLAPPABLE #-} (KnownSymbol alias, HasErr (field' ': fields) alias (field' ': fields) field) - => Has alias (field' ': fields) field -instance (KnownSymbol alias, HasErr '[] alias '[] field) - => Has alias '[] field - -{- | 'HasErr' is like `Has` except it also retains the original -list of fields being searched, so that error messages are more -useful. --} -class KnownSymbol alias => - HasErr (allFields :: [(Symbol, kind)]) (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind) - | alias fields -> field where -instance {-# OVERLAPPING #-} (KnownSymbol alias, field0 ~ field1, MismatchError alias allFields field0 field1) - => HasErr allFields alias (alias ::: field0 ': fields) field1 -instance {-# OVERLAPPABLE #-} (KnownSymbol alias, HasErr allFields alias fields field) - => HasErr allFields alias (field' ': fields) field -instance ( KnownSymbol alias - , LookupFailedError alias allFields -- report a nicer error - , field ~ Any -- required to satisfy the fundep - ) => HasErr allFields alias '[] field - --- | @MismatchError@ reports a nicer error with more context when we successfully do a lookup but --- find a different field than we expected. As a type family, it ensures that we only do the (expensive) --- calculation of coming up with our pretty printing information when we actually have a mismatch -type family MismatchError (alias :: Symbol) (fields :: [(Symbol, kind)]) (found :: kind) (expected :: kind) :: Constraint where - MismatchError _ _ found found = () - MismatchError alias fields found expected = MismatchError' (MismatchError' () (DefaultPrettyPrinter fields) alias fields found expected) (PrettyPrintHaystack fields) alias fields found expected - --- | @MismatchError'@ is the workhorse behind @MismatchError@, but taking an additional type as the first argument. We can put another type error --- in there which will only show if @MismatchError'@ is stuck; this allows us to fall back to @DefaultPrettyPrinter@ when a @PrettyPrintHaystack@ instance --- is missing -type family MismatchError' (err :: Constraint) (ppInfo :: PrettyPrintInfo) (alias :: Symbol) (fields :: [(Symbol, kind)]) (found :: kind) (expected :: kind) :: Constraint where - MismatchError' _ ('PrettyPrintInfo needleName haystackName _) alias fields found expected = TypeError - ( 'Text "Type mismatch when looking up " ':<>: needleName ':<>: 'Text " named " ':<>: 'ShowType alias - ':$$: 'Text "in " ':<>: haystackName ':<>: 'Text ":" - -- we don't use a pretty haystack because we want to show the values - ':$$: 'ShowType fields - ':$$: 'Text "" - ':$$: 'Text "Expected: " ':<>: 'ShowType expected - ':$$: 'Text "But found: " ':<>: 'ShowType found - ':$$: 'Text "" - ) - --- | @LookupFailedError@ reports a nicer error when we fail to look up some @needle@ in some @haystack@ -type LookupFailedError needle haystack = LookupFailedError' (LookupFailedError' () (DefaultPrettyPrinter haystack) needle haystack) (PrettyPrintHaystack haystack) needle haystack - --- | @LookupFailedError'@ is the workhorse behind @LookupFailedError@, but taking an additional type as the first argument. We can put another type error --- in there which will only show if @LookupFailedError'@ is stuck; this allows us to fall back to @DefaultPrettyPrinter@ when a @PrettyPrintHaystack@ instance --- is missing -type family LookupFailedError' (fallbackForUnknownKind :: Constraint) (prettyPrintInfo :: PrettyPrintInfo) (needle :: Symbol) (haystack :: [(Symbol, k)]) :: Constraint where - LookupFailedError' _ ('PrettyPrintInfo needleName haystackName prettyHaystack) needle rawHaystack = TypeError - ( 'Text "Could not find " ':<>: needleName ':<>: 'Text " named " ':<>: 'ShowType needle - ':$$: 'Text "in " ':<>: haystackName ':<>: 'Text ":" - ':$$: prettyHaystack - ':$$: 'Text "" - ':$$: 'Text "*Raw " ':<>: haystackName ':<>: 'Text "*:" - ':$$: 'ShowType rawHaystack - ':$$: 'Text "" - ) - --- | @PrettyPrintInfo@ is a data type intended to be used at the type level --- which describes how to pretty print a haystack in our custom errors. The general intention is we use @PrettyPrintHaystack@ --- to define a more specific way of pretty printing our error information for each kind that we care about -data PrettyPrintInfo = PrettyPrintInfo - { _needleName :: ErrorMessage - , _haystackName :: ErrorMessage - , _haystackPrettyPrint :: ErrorMessage - } - --- | 'PrettyPrintHaystack' allows us to use the kind of our haystack to come up --- with nicer errors. It is implemented as an open type family for dependency reasons -type family PrettyPrintHaystack (haystack :: [(Symbol, k)]) :: PrettyPrintInfo - --- | @DefaultPrettyPrinter@ provides a default we can use for kinds that don't provide an instance of @PrettyPrintInfo@, --- although that should generally only be accidental -type family DefaultPrettyPrinter (haystack :: [(Symbol, k)]) :: PrettyPrintInfo where - DefaultPrettyPrinter (haystack :: [(Symbol, k)]) = 'PrettyPrintInfo - ('Text "some kind without a PrettyPrintHaystack instance (" ':<>: 'ShowType k ':<>: 'Text ")") - ('Text "associative list of that kind ([(Symbol, " ':<>: 'ShowType k ':<>: 'Text ")])") - ('ShowType (Sort (MapFst haystack))) - -{-| @HasIn fields (alias ::: field)@ is a constraint that proves that -@fields@ has a field of @alias ::: field@. It is used in @UPDATE@s to -choose which subfields to update. --} -class HasIn fields field where -instance (Has alias fields field) => HasIn fields (alias ::: field) where - --- | `HasAll` extends `Has` to take lists of @aliases@ and @fields@ and infer --- a list of @subfields@. -class - ( SOP.All KnownSymbol aliases - ) => HasAll - (aliases :: [Symbol]) - (fields :: [(Symbol,kind)]) - (subfields :: [(Symbol,kind)]) - | aliases fields -> subfields where -instance {-# OVERLAPPING #-} HasAll '[] fields '[] -instance {-# OVERLAPPABLE #-} - (Has alias fields field, HasAll aliases fields subfields) - => HasAll (alias ': aliases) fields (alias ::: field ': subfields) - --- | Analagous to `IsLabel`, the constraint --- `IsQualified` defines `!` for a column alias qualified --- by a table alias. -class IsQualified qualifier alias expression where - (!) :: Alias qualifier -> Alias alias -> expression - infixl 9 ! -instance IsQualified qualifier alias (Alias qualifier, Alias alias) where - (!) = (,) - -{-| `QualifiedAlias`es enables multi-schema support by allowing a reference -to a `Squeal.PostgreSQL.Type.Schema.Table`, `Squeal.PostgreSQL.Type.Schema.Typedef` -or `Squeal.PostgreSQL.Type.Schema.View` to be qualified by their schemas. By default, -a qualifier of @public@ is provided. - ->>> :{ -let - alias1 :: QualifiedAlias "sch" "tab" - alias1 = #sch ! #tab - alias2 :: QualifiedAlias "public" "vw" - alias2 = #vw -in printSQL alias1 >> printSQL alias2 -:} -"sch"."tab" -"vw" --} -data QualifiedAlias (qualifier :: Symbol) (alias :: Symbol) = QualifiedAlias - deriving (Eq,GHC.Generic,Ord,Show,NFData) -instance (q ~ q', a ~ a') => IsQualified q a (QualifiedAlias q' a') where - _ ! _ = QualifiedAlias -instance (q' ~ "public", a ~ a') => IsLabel a (QualifiedAlias q' a') where - fromLabel = QualifiedAlias -instance (q0 ~ q1, a0 ~ a1, a1 ~ a2, KnownSymbol a2) => - IsQualified q0 a0 (Aliased (QualifiedAlias q1) (a1 ::: a2)) where - _ ! _ = QualifiedAlias `As` Alias -instance (q ~ "public", a0 ~ a1, a1 ~ a2, KnownSymbol a2) => - IsLabel a0 (Aliased (QualifiedAlias q) (a1 ::: a2)) where - fromLabel = QualifiedAlias `As` Alias - -instance (KnownSymbol q, KnownSymbol a) - => RenderSQL (QualifiedAlias q a) where - renderSQL _ = - let - qualifier = renderSQL (Alias @q) - alias = renderSQL (Alias @a) - in - if qualifier == "\"public\"" then alias else qualifier <> "." <> alias diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Type/List.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Type/List.hs deleted file mode 100644 index f3ce37e1..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Type/List.hs +++ /dev/null @@ -1,199 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Type.List -Description: list related types and functions -Copyright: (c) Eitan Chatav, 2019 -Maintainer: eitan@morphism.tech -Stability: experimental - -Haskell singly-linked lists are very powerful. This module -provides functionality for type-level lists, heterogeneous -lists and type aligned lists. --} - -{-# LANGUAGE - DataKinds - , FlexibleContexts - , GADTs - , LambdaCase - , MultiParamTypeClasses - , OverloadedStrings - , PolyKinds - , QuantifiedConstraints - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeFamilies - , TypeOperators - , UndecidableInstances -#-} - -module Squeal.PostgreSQL.Type.List - ( -- * Heterogeneous List - SOP.NP (..) - , (*:) - , one - , Join - , disjoin - , Additional (..) - -- * Path - , Path (..) - -- * Type Level List - , Elem - , In - , Length - , MapFst - , Sort - , SubList - , SubsetList - ) where - -import Control.Category.Free -import Data.Function ((&)) -import Data.Kind -import Data.Type.Bool -import GHC.TypeLits - -import Generics.SOP as SOP - --- | `Join` is simply promoted `++` and is used in @JOIN@s in --- `Squeal.PostgreSQL.Query.FromClause`s. -type family Join xs ys where - Join '[] ys = ys - Join (x ': xs) ys = x ': Join xs ys - --- | `disjoin` is a utility function for splitting an `NP` list into pieces. -disjoin - :: forall xs ys expr. SListI xs - => NP expr (Join xs ys) - -> (NP expr xs, NP expr ys) -disjoin = case sList @xs of - SNil -> \ys -> (Nil, ys) - SCons -> \(x :* xsys) -> - case disjoin xsys of (xs,ys) -> (x :* xs, ys) - --- | The `Additional` class is for appending --- type-level list parameterized constructors such as `NP`, --- `Squeal.PostgreSQL.Query.Selection`, and `Squeal.PostgreSQL.Query.FromClause`. -class Additional expr where - also :: expr ys -> expr xs -> expr (Join xs ys) -instance Additional (NP expr) where - also ys = \case - Nil -> ys - x :* xs -> x :* (xs & also ys) - --- | A useful operator for ending an `NP` list of length --- at least 2 without `Nil` -(*:) :: f x -> f y -> NP f '[x,y] -x *: y = x :* y :* Nil -infixl 8 *: - --- | A list of length `one`. -one :: f x -> NP f '[x] -one f = f :* Nil - --- | @Elem@ is a promoted `Data.List.elem`. -type family Elem x xs where - Elem x '[] = 'False - Elem x (x ': _) = 'True - Elem x (_ ': xs) = Elem x xs - --- | @In x xs@ is a constraint that proves that @x@ is in @xs@. -type family In x xs :: Constraint where - In x xs = If (Elem x xs) (() :: Constraint) - (TypeError ('ShowType x ':<>: 'Text " is not in " ':<>: 'ShowType xs)) - -{- | Calculate the `Length` of a type level list - ->>> :kind! Length '[Char,String,Bool,Double] -Length '[Char,String,Bool,Double] :: Nat -= 4 --} -type family Length (xs :: [k]) :: Nat where - Length '[] = 0 - Length (_ : xs) = 1 + Length xs - -{- | `SubList` checks that one type level list is a sublist of another, -with the same ordering. - ->>> :kind! SubList '[1,2,3] '[4,5,6] -SubList '[1,2,3] '[4,5,6] :: Bool -= 'False ->>> :kind! SubList '[1,2,3] '[1,2,3,4] -SubList '[1,2,3] '[1,2,3,4] :: Bool -= 'True ->>> :kind! SubList '[1,2,3] '[0,1,0,2,0,3] -SubList '[1,2,3] '[0,1,0,2,0,3] :: Bool -= 'True ->>> :kind! SubList '[1,2,3] '[3,2,1] -SubList '[1,2,3] '[3,2,1] :: Bool -= 'False --} -type family SubList (xs :: [k]) (ys :: [k]) :: Bool where - SubList '[] ys = 'True - SubList (x ': xs) '[] = 'False - SubList (x ': xs) (x ': ys) = SubList xs ys - SubList (x ': xs) (y ': ys) = SubList (x ': xs) ys - -{- | `SubsetList` checks that one type level list is a subset of another, -regardless of ordering and repeats. - ->>> :kind! SubsetList '[1,2,3] '[4,5,6] -SubsetList '[1,2,3] '[4,5,6] :: Bool -= 'False ->>> :kind! SubsetList '[1,2,3] '[1,2,3,4] -SubsetList '[1,2,3] '[1,2,3,4] :: Bool -= 'True ->>> :kind! SubsetList '[1,2,3] '[0,1,0,2,0,3] -SubsetList '[1,2,3] '[0,1,0,2,0,3] :: Bool -= 'True ->>> :kind! SubsetList '[1,2,3] '[3,2,1] -SubsetList '[1,2,3] '[3,2,1] :: Bool -= 'True ->>> :kind! SubsetList '[1,1,1] '[3,2,1] -SubsetList '[1,1,1] '[3,2,1] :: Bool -= 'True --} -type family SubsetList (xs :: [k]) (ys :: [k]) :: Bool where - SubsetList '[] ys = 'True - SubsetList (x ': xs) ys = Elem x ys && SubsetList xs ys - --- | 'Sort' sorts a type level list of 'Symbol's in ascending lexicographic order -type Sort ls = MergeSort (Twos ls) - --- | 'MergeSort' is the workhorse behind 'Sort' -type family MergeSort (ls :: [[Symbol]]) :: [Symbol] where - MergeSort '[] = '[] - MergeSort '[x] = x - MergeSort ls = MergeSort (FoldMerge ls) - --- | @Two@s splits a type-level list into a list of sorted lists of length 2 (with a singelton list potentially at the end) --- It is required for implementing 'MergeSort' -type family Twos (ls :: [k]) :: [[k]] where - Twos (x ': y ': rs) = Merge '[x] '[y] ': Twos rs - Twos '[x] = '[ '[x]] - Twos '[] = '[] - --- | 'Merge' two sorted lists into one list -type family Merge (ls :: [Symbol]) (rs :: [Symbol]) :: [Symbol] where - Merge '[] r = r - Merge l '[] = l - Merge (l ': ls) (r ': rs) = If (Leq l r) (l ': Merge ls (r ': rs)) (r ': Merge (l ': ls) rs) - --- | 'FoldMerge' folds over a list of sorted lists, merging them into a single sorted list -type family FoldMerge (ls :: [[Symbol]]) :: [[Symbol]] where - FoldMerge (x ': y ': rs) = (Merge x y ': FoldMerge rs) - FoldMerge '[x] = '[x] - FoldMerge '[] = '[] - -type Leq l r = OrderingIsLeq (CmpSymbol l r) - -type family OrderingIsLeq (o :: Ordering) :: Bool where - OrderingIsLeq 'LT = 'True - OrderingIsLeq 'EQ = 'True - OrderingIsLeq 'GT = 'False - --- | 'MapFst' takes the first value of each tuple of a type level list of tuples. Useful for getting --- only the names in associatve lists -type family MapFst (ls :: [(j, k)]) :: [j] where - MapFst ('(j, _) ': rest) = j ': MapFst rest - MapFst '[] = '[] diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Type/PG.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Type/PG.hs deleted file mode 100644 index af29cac3..00000000 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Type/PG.hs +++ /dev/null @@ -1,336 +0,0 @@ -{-| -Module: Squeal.PostgreSQL.Type.PG -Description: embedding of Haskell types into Postgres type system -Copyright: (c) Eitan Chatav, 2010 -Maintainer: eitan@morphism.tech -Stability: experimental - -Provides type families for turning Haskell `Type`s -into corresponding Postgres types. --} -{-# LANGUAGE - AllowAmbiguousTypes - , DeriveAnyClass - , DeriveFoldable - , DeriveFunctor - , DeriveGeneric - , DeriveTraversable - , DerivingStrategies - , DefaultSignatures - , FlexibleContexts - , FlexibleInstances - , FunctionalDependencies - , GADTs - , LambdaCase - , MultiParamTypeClasses - , OverloadedStrings - , ScopedTypeVariables - , TypeApplications - , TypeFamilies - , TypeInType - , TypeOperators - , UndecidableInstances - , UndecidableSuperClasses -#-} - -module Squeal.PostgreSQL.Type.PG - ( -- * PG - IsPG (..) - , NullPG - , TuplePG - , RowPG - -- * Type families - , LabelsPG - , DimPG - , FixPG - , TupleOf - , TupleCodeOf - , RowOf - , ConstructorsOf - , ConstructorNameOf - , ConstructorNamesOf - ) where - -import Data.Aeson (Value) -import Data.Functor.Const (Const) -import Data.Functor.Constant (Constant) -import Data.Kind (Type) -import Data.Int (Int16, Int32, Int64) -import Data.Scientific (Scientific) -import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime) -import Data.Vector (Vector) -import Data.UUID.Types (UUID) -import GHC.TypeLits -import Network.IP.Addr (NetAddr, IP) - -import qualified Data.ByteString.Lazy as Lazy (ByteString) -import qualified Data.ByteString as Strict (ByteString) -import qualified Data.Text.Lazy as Lazy (Text) -import qualified Data.Text as Strict (Text) -import qualified Database.PostgreSQL.LibPQ as LibPQ -import qualified Generics.SOP as SOP -import qualified Generics.SOP.Record as SOP -import qualified Generics.SOP.Type.Metadata as Type - -import Squeal.PostgreSQL.Type -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Type.Schema - --- $setup --- >>> import Squeal.PostgreSQL --- >>> import Data.Text (Text) --- >>> import qualified GHC.Generics as GHC - -{- | The `PG` type family embeds a subset of Haskell types -as Postgres types. As an open type family, `PG` is extensible. - ->>> :kind! PG LocalTime -PG LocalTime :: PGType -= 'PGtimestamp - -The preferred way to generate `PG`s of your own type is through -generalized newtype deriving or via deriving. - ->>> newtype UserId = UserId {getUserId :: UUID} deriving newtype IsPG - ->>> :kind! PG UserId -PG UserId :: PGType -= 'PGuuid - ->>> :{ -data Answer = Yes | No - deriving stock GHC.Generic - deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) - deriving IsPG via Enumerated Answer -:} - ->>> :kind! PG Answer -PG Answer :: PGType -= 'PGenum '["Yes", "No"] - ->>> :{ -data Complex = Complex {real :: Double, imaginary :: Double} - deriving stock GHC.Generic - deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) - deriving IsPG via Composite Complex -:} - ->>> :kind! PG Complex -PG Complex :: PGType -= 'PGcomposite - '["real" ::: 'NotNull 'PGfloat8, - "imaginary" ::: 'NotNull 'PGfloat8] --} -class IsPG (hask :: Type) where type PG hask :: PGType --- | `PGbool` -instance IsPG Bool where type PG Bool = 'PGbool --- | `PGint2` -instance IsPG Int16 where type PG Int16 = 'PGint2 --- | `PGint4` -instance IsPG Int32 where type PG Int32 = 'PGint4 --- | `PGint8` -instance IsPG Int64 where type PG Int64 = 'PGint8 --- | `PGint2` -instance IsPG LibPQ.Oid where type PG LibPQ.Oid = 'PGoid --- | `PGnumeric` -instance IsPG Scientific where type PG Scientific = 'PGnumeric --- | `PGfloat4` -instance IsPG Float where type PG Float = 'PGfloat4 --- | `PGfloat8` -instance IsPG Double where type PG Double = 'PGfloat8 --- | `PGchar` @1@ -instance IsPG Char where type PG Char = 'PGchar 1 --- | `PGtext` -instance IsPG Strict.Text where type PG Strict.Text = 'PGtext --- | `PGtext` -instance IsPG Lazy.Text where type PG Lazy.Text = 'PGtext --- | `PGtext` -instance IsPG String where type PG String = 'PGtext --- | `PGbytea` -instance IsPG Strict.ByteString where type PG Strict.ByteString = 'PGbytea --- | `PGbytea` -instance IsPG Lazy.ByteString where type PG Lazy.ByteString = 'PGbytea --- | `PGtimestamp` -instance IsPG LocalTime where type PG LocalTime = 'PGtimestamp --- | `PGtimestamptz` -instance IsPG UTCTime where type PG UTCTime = 'PGtimestamptz --- | `PGdate` -instance IsPG Day where type PG Day = 'PGdate --- | `PGtime` -instance IsPG TimeOfDay where type PG TimeOfDay = 'PGtime --- | `PGtimetz` -instance IsPG (TimeOfDay, TimeZone) where type PG (TimeOfDay, TimeZone) = 'PGtimetz --- | `PGinterval` -instance IsPG DiffTime where type PG DiffTime = 'PGinterval --- | `PGuuid` -instance IsPG UUID where type PG UUID = 'PGuuid --- | `PGinet` -instance IsPG (NetAddr IP) where type PG (NetAddr IP) = 'PGinet --- | `PGjson` -instance IsPG Value where type PG Value = 'PGjson --- | `PGvarchar` -instance IsPG (VarChar n) where type PG (VarChar n) = 'PGvarchar n --- | `PGvarchar` -instance IsPG (FixChar n) where type PG (FixChar n) = 'PGchar n --- | `PG hask` -instance IsPG hask => IsPG (Const hask tag) where type PG (Const hask tag) = PG hask --- | `PG hask` -instance IsPG hask => IsPG (SOP.K hask tag) where type PG (SOP.K hask tag) = PG hask --- | `PG hask` -instance IsPG hask => IsPG (Constant hask tag) where type PG (Constant hask tag) = PG hask - --- | `PGmoney` -instance IsPG Money where type PG Money = 'PGmoney --- | `PGjson` -instance IsPG (Json hask) where type PG (Json hask) = 'PGjson --- | `PGjsonb` -instance IsPG (Jsonb hask) where type PG (Jsonb hask) = 'PGjsonb --- | `PGcomposite` @(@`RowPG` @hask)@ -instance IsPG (Composite hask) where - type PG (Composite hask) = 'PGcomposite (RowPG hask) --- | `PGenum` @(@`LabelsPG` @hask)@ -instance IsPG (Enumerated hask) where - type PG (Enumerated hask) = 'PGenum (LabelsPG hask) --- | `PGvararray` @(@`NullPG` @x)@ -instance IsPG (VarArray (Vector x)) where - type PG (VarArray (Vector x)) = 'PGvararray (NullPG x) --- | `PGvararray` @(@`NullPG` @x)@ -instance IsPG (VarArray [x]) where - type PG (VarArray [x]) = 'PGvararray (NullPG x) --- | `PGfixarray` @(@`DimPG` @hask) (@`FixPG` @hask)@ -instance IsPG (FixArray hask) where - type PG (FixArray hask) = 'PGfixarray (DimPG hask) (FixPG hask) - -{-| The `LabelsPG` type family calculates the constructors of a -Haskell enum type. - ->>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic ->>> instance SOP.Generic Schwarma ->>> instance SOP.HasDatatypeInfo Schwarma ->>> :kind! LabelsPG Schwarma -LabelsPG Schwarma :: [Type.ConstructorName] -= '["Beef", "Lamb", "Chicken"] --} -type family LabelsPG (hask :: Type) :: [Type.ConstructorName] where - LabelsPG hask = - ConstructorNamesOf (ConstructorsOf (SOP.DatatypeInfoOf hask)) - -{- | -`RowPG` turns a Haskell `Type` into a `RowType`. - -`RowPG` may be applied to normal Haskell record types provided they -have `SOP.Generic` and `SOP.HasDatatypeInfo` instances; - ->>> data Person = Person { name :: Strict.Text, age :: Int32 } deriving GHC.Generic ->>> instance SOP.Generic Person ->>> instance SOP.HasDatatypeInfo Person ->>> :kind! RowPG Person -RowPG Person :: [(Symbol, NullType)] -= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4] --} -type family RowPG (hask :: Type) :: RowType where - RowPG hask = RowOf (SOP.RecordCodeOf hask) - --- | `RowOf` applies `NullPG` to the fields of a list. -type family RowOf (record :: [(Symbol, Type)]) :: RowType where - RowOf (col ::: ty ': record) = col ::: NullPG ty ': RowOf record - RowOf '[] = '[] - -{- | `NullPG` turns a Haskell type into a `NullType`. - ->>> :kind! NullPG Double -NullPG Double :: NullType -= 'NotNull 'PGfloat8 ->>> :kind! NullPG (Maybe Double) -NullPG (Maybe Double) :: NullType -= 'Null 'PGfloat8 --} -type family NullPG (hask :: Type) :: NullType where - NullPG (Maybe hask) = 'Null (PG hask) - NullPG hask = 'NotNull (PG hask) - -{- | `TuplePG` turns a Haskell tuple type (including record types) into -the corresponding list of `NullType`s. - ->>> :kind! TuplePG (Double, Maybe Char) -TuplePG (Double, Maybe Char) :: [NullType] -= '[ 'NotNull 'PGfloat8, 'Null ('PGchar 1)] --} -type family TuplePG (hask :: Type) :: [NullType] where - TuplePG hask = TupleOf (TupleCodeOf hask (SOP.Code hask)) - --- | `TupleOf` turns a list of Haskell `Type`s into a list of `NullType`s. -type family TupleOf (tuple :: [Type]) :: [NullType] where - TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple - TupleOf '[] = '[] - --- | `TupleCodeOf` takes the `SOP.Code` of a haskell `Type` --- and if it's a simple product returns it, otherwise giving a `TypeError`. -type family TupleCodeOf (hask :: Type) (code :: [[Type]]) :: [Type] where - TupleCodeOf hask '[tuple] = tuple - TupleCodeOf hask '[] = - TypeError - ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type." - ':$$: 'Text "It is a void type with no constructors." - ) - TupleCodeOf hask (_ ': _ ': _) = - TypeError - ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type." - ':$$: 'Text "It is a sum type with more than one constructor." - ) - --- | Calculates constructors of a datatype. -type family ConstructorsOf (datatype :: Type.DatatypeInfo) - :: [Type.ConstructorInfo] where - ConstructorsOf ('Type.ADT _module _datatype constructors _strictness) = - constructors - ConstructorsOf ('Type.Newtype _module _datatype constructor) = - '[constructor] - --- | Calculates the name of a nullary constructor, otherwise --- generates a type error. -type family ConstructorNameOf (constructor :: Type.ConstructorInfo) - :: Type.ConstructorName where - ConstructorNameOf ('Type.Constructor name) = name - ConstructorNameOf ('Type.Infix name _assoc _fix) = TypeError - ('Text "ConstructorNameOf error: non-nullary constructor " - ':<>: 'Text name) - ConstructorNameOf ('Type.Record name _fields) = TypeError - ('Text "ConstructorNameOf error: non-nullary constructor " - ':<>: 'Text name) - --- | Calculate the names of nullary constructors. -type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo]) - :: [Type.ConstructorName] where - ConstructorNamesOf '[] = '[] - ConstructorNamesOf (constructor ': constructors) = - ConstructorNameOf constructor ': ConstructorNamesOf constructors - --- | `DimPG` turns Haskell nested homogeneous tuples into a list of lengths, --- up to a depth of 10 for each dimension. -type family DimPG (hask :: Type) :: [Nat] where - DimPG (x,x) = 2 ': DimPG x - DimPG (x,x,x) = 3 ': DimPG x - DimPG (x,x,x,x) = 4 ': DimPG x - DimPG (x,x,x,x,x) = 5 ': DimPG x - DimPG (x,x,x,x,x,x) = 6 ': DimPG x - DimPG (x,x,x,x,x,x,x) = 7 ': DimPG x - DimPG (x,x,x,x,x,x,x,x) = 8 ': DimPG x - DimPG (x,x,x,x,x,x,x,x,x) = 9 ': DimPG x - DimPG (x,x,x,x,x,x,x,x,x,x) = 10 ': DimPG x - DimPG x = '[] - --- | `FixPG` extracts `NullPG` of the base type of nested homogeneous tuples, --- up to a depth of 10 for each dimension. -type family FixPG (hask :: Type) :: NullType where - FixPG (x,x) = FixPG x - FixPG (x,x,x) = FixPG x - FixPG (x,x,x,x) = FixPG x - FixPG (x,x,x,x,x) = FixPG x - FixPG (x,x,x,x,x,x) = FixPG x - FixPG (x,x,x,x,x,x,x) = FixPG x - FixPG (x,x,x,x,x,x,x,x) = FixPG x - FixPG (x,x,x,x,x,x,x,x,x) = FixPG x - FixPG (x,x,x,x,x,x,x,x,x,x) = FixPG x - FixPG (x,x,x,x,x,x,x,x,x,x,x) = FixPG x - FixPG x = NullPG x diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Type/Schema.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Type/Schema.hs index 7657ffbb..260ef86a 100644 --- a/squeal-postgresql/src/Squeal/PostgreSQL/Type/Schema.hs +++ b/squeal-postgresql/src/Squeal/PostgreSQL/Type/Schema.hs @@ -10,128 +10,14 @@ tables, schema, constraints, and more. It also defines useful type families to operate on these. -} -{-# LANGUAGE - AllowAmbiguousTypes - , ConstraintKinds - , DeriveAnyClass - , DeriveGeneric - , FlexibleContexts - , FlexibleInstances - , FunctionalDependencies - , GADTs - , LambdaCase - , OverloadedStrings - , QuantifiedConstraints - , RankNTypes - , ScopedTypeVariables - , StandaloneDeriving - , TypeApplications - , TypeFamilyDependencies - , TypeInType - , TypeOperators - , UndecidableInstances - , UndecidableSuperClasses -#-} - module Squeal.PostgreSQL.Type.Schema ( -- * Postgres Type PGType (..) - , NullType (..) - , RowType - , FromType - -- * Schema Type - , ColumnType - , ColumnsType - , TableType - , SchemumType (..) - , IndexType (..) - , FunctionType - , ReturnsType (..) - , SchemaType - , SchemasType - , PrettyPrintPartitionedSchema - , Public - , PartitionedSchema(..) - , PartitionSchema - , SchemaFunctions - , SchemaIndexes - , SchemaProcedures - , SchemaTables - , SchemaTypes - , SchemaUnsafes - , SchemaViews - -- * Database Subsets - , SubDB - , SubsetDB - , ElemDB - -- * Constraint - , (:=>) - , Optionality (..) - , TableConstraint (..) - , TableConstraints - , Uniquely - -- * Enumerated Label - , IsPGlabel (..) - , PGlabel (..) - -- * Data Definition - , Create - , CreateIfNotExists - , CreateOrReplace - , Drop - , DropSchemum - , DropIfExists - , DropSchemumIfExists - , Alter - , AlterIfExists - , Rename - , RenameIfExists - , SetSchema - , ConstraintInvolves - , DropIfConstraintsInvolve - -- * Type Classification - , PGNum - , PGIntegral - , PGFloating - , PGJsonType - , PGJsonKey - , SamePGType - , AllNotNull - , NotAllNull - -- * Nullification - , NullifyType - , NullifyRow - , NullifyFrom - -- * Table Conversion - , TableToColumns - , ColumnsToRow - , TableToRow - -- * Updatable - , Updatable - , AllUnique - , IsNotElem - -- * User Type Lookup - , DbEnums - , DbRelations - , FindQualified ) where -import Control.Category -import Data.Kind -import Data.Monoid hiding (All) -import Data.Type.Bool -import Generics.SOP -import GHC.TypeLits -import Prelude hiding (id, (.)) - -import Squeal.PostgreSQL.Type.Alias -import Squeal.PostgreSQL.Type.List -import Squeal.PostgreSQL.Render - --- $setup --- >>> import Squeal.PostgreSQL - -- | `PGType` is the promoted datakind of PostgreSQL types. -- +-- >>> :set -XDataKinds -- >>> :kind 'PGbool -- 'PGbool :: PGType data PGType @@ -140,675 +26,3 @@ data PGType | PGint4 -- ^ signed four-byte integer | PGint8 -- ^ signed eight-byte integer | PGnumeric -- ^ arbitrary precision numeric type - | PGfloat4 -- ^ single precision floating-point number (4 bytes) - | PGfloat8 -- ^ double precision floating-point number (8 bytes) - | PGmoney -- ^ currency amount - | PGchar Nat -- ^ fixed-length character string - | PGvarchar Nat -- ^ variable-length character string - | PGtext -- ^ variable-length character string - | PGbytea -- ^ binary data ("byte array") - | PGtimestamp -- ^ date and time (no time zone) - | PGtimestamptz -- ^ date and time, including time zone - | PGdate -- ^ calendar date (year, month, day) - | PGtime -- ^ time of day (no time zone) - | PGtimetz -- ^ time of day, including time zone - | PGinterval -- ^ time span - | PGuuid -- ^ universally unique identifier - | PGinet -- ^ IPv4 or IPv6 host address - | PGjson -- ^ textual JSON data - | PGjsonb -- ^ binary JSON data, decomposed - | PGvararray NullType -- ^ variable length array - | PGfixarray [Nat] NullType -- ^ fixed length array - | PGenum [Symbol] -- ^ enumerated (enum) types are data types that comprise a static, ordered set of values. - | PGcomposite RowType -- ^ a composite type represents the structure of a row or record; it is essentially just a list of field names and their data types. - | PGtsvector -- ^ A tsvector value is a sorted list of distinct lexemes, which are words that have been normalized to merge different variants of the same word. - | PGtsquery -- ^ A tsquery value stores lexemes that are to be searched for. - | PGoid -- ^ Object identifiers (OIDs) are used internally by PostgreSQL as primary keys for various system tables. - | PGrange PGType -- ^ Range types are data types representing a range of values of some element type (called the range's subtype). - | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types - --- | `NullType` encodes the potential presence or definite absence of a --- @NULL@ allowing operations which are sensitive to such to be well typed. --- --- >>> :kind 'Null 'PGint4 --- 'Null 'PGint4 :: NullType --- >>> :kind 'NotNull ('PGvarchar 50) --- 'NotNull ('PGvarchar 50) :: NullType -data NullType - = Null PGType -- ^ @NULL@ may be present - | NotNull PGType -- ^ @NULL@ is absent - --- | The constraint operator, `:=>` is a type level pair --- between a "constraint" and some type, for use in pairing --- an `Optionality` with a `NullType` to produce a `ColumnType` --- or a `TableConstraints` and a `ColumnsType` to produce a `TableType`. -type (:=>) constraint ty = '(constraint,ty) -infixr 7 :=> - --- | `Optionality` encodes the availability of @DEFAULT@ for inserts and updates. --- A column can be assigned a default value. --- A data `Squeal.PostgreSQL.Manipulations.Manipulation` command can also --- request explicitly that a column be set to its default value, --- without having to know what that value is. -data Optionality - = Def -- ^ @DEFAULT@ is available for inserts and updates - | NoDef -- ^ @DEFAULT@ is unavailable for inserts and updates - --- | `ColumnType` encodes the allowance of @DEFAULT@ and @NULL@ and the --- base `PGType` for a column. --- --- >>> :set -XTypeFamilies -XTypeInType --- >>> import GHC.TypeLits --- >>> type family IdColumn :: ColumnType where IdColumn = 'Def :=> 'NotNull 'PGint4 --- >>> type family EmailColumn :: ColumnType where EmailColumn = 'NoDef :=> 'Null 'PGtext -type ColumnType = (Optionality,NullType) - --- | `ColumnsType` is a row of `ColumnType`s. --- --- >>> :{ --- type family UsersColumns :: ColumnsType where --- UsersColumns = --- '[ "name" ::: 'NoDef :=> 'NotNull 'PGtext --- , "id" ::: 'Def :=> 'NotNull 'PGint4 --- ] --- :} -type ColumnsType = [(Symbol,ColumnType)] - -type instance PrettyPrintHaystack (haystack :: ColumnsType) = - 'PrettyPrintInfo ('Text "column definition (ColumnType)") ('Text "table (ColumnsType)") ('ShowType (Sort (MapFst haystack))) - --- | `TableConstraint` encodes various forms of data constraints --- of columns in a table. --- `TableConstraint`s give you as much control over the data in your tables --- as you wish. If a user attempts to store data in a column that would --- violate a constraint, an error is raised. This applies --- even if the value came from the default value definition. -data TableConstraint - = Check [Symbol] - | Unique [Symbol] - | PrimaryKey [Symbol] - | ForeignKey [Symbol] Symbol Symbol [Symbol] - -{- | A `TableConstraints` is a row of `TableConstraint`s. - ->>> :{ -type family UsersConstraints :: TableConstraints where - UsersConstraints = '[ "pk_users" ::: 'PrimaryKey '["id"] ] -:} --} -type TableConstraints = [(Symbol,TableConstraint)] - -type instance PrettyPrintHaystack (haystack :: TableConstraints) = - 'PrettyPrintInfo ('Text "constraint (TableConstraint)") ('Text "table (TableConstraints)") ('ShowType (Sort (MapFst haystack))) - --- | A `ForeignKey` must reference columns that either are --- a `PrimaryKey` or form a `Unique` constraint. -type family Uniquely - (key :: [Symbol]) - (constraints :: TableConstraints) :: Constraint where - Uniquely key (uq ::: 'Unique key ': constraints) = () - Uniquely key (pk ::: 'PrimaryKey key ': constraints) = () - Uniquely key (_ ': constraints) = Uniquely key constraints - --- | `TableType` encodes a row of constraints on a table as well as the types --- of its columns. --- --- >>> :{ --- type family UsersTable :: TableType where --- UsersTable = --- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> --- '[ "id" ::: 'Def :=> 'NotNull 'PGint4 --- , "name" ::: 'NoDef :=> 'NotNull 'PGtext --- ] --- :} -type TableType = (TableConstraints,ColumnsType) - -{- | A `RowType` is a row of `NullType`s. They correspond to Haskell -record types by means of `Squeal.PostgreSQL.Binary.RowPG` and are used in many places. - ->>> :{ -type family PersonRow :: RowType where - PersonRow = - '[ "name" ::: 'NotNull 'PGtext - , "age" ::: 'NotNull 'PGint4 - , "dateOfBirth" ::: 'Null 'PGdate - ] -:} --} -type RowType = [(Symbol,NullType)] - -type instance PrettyPrintHaystack (haystack :: RowType) = - 'PrettyPrintInfo ('Text "column (NullType)") ('Text "row (RowType)") ('ShowType (Sort (MapFst haystack))) - -{- | `FromType` is a row of `RowType`s. It can be thought of as -a product, or horizontal gluing and is used in `Squeal.PostgreSQL.Query.From.FromClause`s -and `Squeal.PostgreSQL.Query.Table.TableExpression`s. --} -type FromType = [(Symbol,RowType)] - -type instance PrettyPrintHaystack (haystack :: FromType) = - 'PrettyPrintInfo ('Text "row (RowType)") ('Text "from clause (FromType)") ('ShowType (Sort (MapFst haystack))) - --- | `ColumnsToRow` removes column constraints. -type family ColumnsToRow (columns :: ColumnsType) :: RowType where - ColumnsToRow (column ::: _ :=> ty ': columns) = - column ::: ty ': ColumnsToRow columns - ColumnsToRow '[] = '[] - --- | `TableToColumns` removes table constraints. -type family TableToColumns (table :: TableType) :: ColumnsType where - TableToColumns (constraints :=> columns) = columns - --- | Convert a table to a row type. -type family TableToRow (table :: TableType) :: RowType where - TableToRow tab = ColumnsToRow (TableToColumns tab) - --- | Numeric Postgres types. -type PGNum = - '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8] - --- | Floating Postgres types. -type PGFloating = '[ 'PGfloat4, 'PGfloat8, 'PGnumeric] - --- | Integral Postgres types. -type PGIntegral = '[ 'PGint2, 'PGint4, 'PGint8] - --- | Equality constraint on the underlying `PGType` of two columns. -class SamePGType - (ty0 :: (Symbol,ColumnType)) (ty1 :: (Symbol,ColumnType)) where -instance ty0 ~ ty1 => SamePGType - (alias0 ::: def0 :=> null0 ty0) - (alias1 ::: def1 :=> null1 ty1) - --- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s. -type family AllNotNull (columns :: ColumnsType) :: Constraint where - AllNotNull (_ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns - AllNotNull '[] = () - --- | `NotAllNull` is a constraint that proves a `ColumnsType` has some --- @NOT NULL@. -type family NotAllNull (columns :: ColumnsType) :: Constraint where - NotAllNull (_ ::: _ :=> 'NotNull _ ': _) = () - NotAllNull (_ ::: _ :=> 'Null _ ': columns) = NotAllNull columns - --- | `NullifyType` is an idempotent that nullifies a `NullType`. -type family NullifyType (ty :: NullType) :: NullType where - NullifyType (null ty) = 'Null ty - --- | `NullifyRow` is an idempotent that nullifies a `RowType`. -type family NullifyRow (columns :: RowType) :: RowType where - NullifyRow (column ::: ty ': columns) = - column ::: NullifyType ty ': NullifyRow columns - NullifyRow '[] = '[] - --- | `NullifyFrom` is an idempotent that nullifies a `FromType` --- used to nullify the left or right hand side of an outer join --- in a `Squeal.PostgreSQL.Query.From.FromClause`. -type family NullifyFrom (tables :: FromType) :: FromType where - NullifyFrom (table ::: columns ': tables) = - table ::: NullifyRow columns ': NullifyFrom tables - NullifyFrom '[] = '[] - --- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in --- `Squeal.PostgreSQL.Definition.Table.createTable` statements and in @ALTER TABLE@ --- `Squeal.PostgreSQL.Definition.Table.addColumn`. -type family Create alias x xs where - Create alias x '[] = '[alias ::: x] - Create alias x (alias ::: y ': xs) = TypeError - ('Text "Create: alias " - ':<>: 'ShowType alias - ':<>: 'Text "already exists") - Create alias y (x ': xs) = x ': Create alias y xs - -{-| Similar to `Create` but no error on pre-existence-} -type family CreateIfNotExists alias x xs where - CreateIfNotExists alias x '[] = '[alias ::: x] - CreateIfNotExists alias x (alias ::: y ': xs) = alias ::: y ': xs - CreateIfNotExists alias y (x ': xs) = x ': CreateIfNotExists alias y xs - -{-| Similar to `Create` but used to replace values -with the same type.-} -type family CreateOrReplace alias x xs where - CreateOrReplace alias x '[] = '[alias ::: x] - CreateOrReplace alias x (alias ::: x ': xs) = alias ::: x ': xs - CreateOrReplace alias x (alias ::: y ': xs) = TypeError - ('Text "CreateOrReplace: expected type " - ':<>: 'ShowType x - ':<>: 'Text " but alias " - ':<>: 'ShowType alias - ':<>: 'Text " has type " - ':<>: 'ShowType y) - CreateOrReplace alias y (x ': xs) = x ': CreateOrReplace alias y xs - --- | @Drop alias xs@ removes the type associated with @alias@ in @xs@ --- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements --- and in @ALTER TABLE@ `Squeal.PostgreSQL.Definition.dropColumn` statements. -type family Drop alias xs where - Drop alias '[] = TypeError - ('Text "Drop: alias " - ':<>: 'ShowType alias - ':<>: 'Text " does not exist" ) - Drop alias (alias ::: x ': xs) = xs - Drop alias (x ': xs) = x ': Drop alias xs - --- | Drop a particular flavor of schemum type -type family DropSchemum alias sch xs where - DropSchemum alias sch '[] = TypeError - ('Text "DropSchemum: alias " - ':<>: 'ShowType alias - ':<>: 'Text " does not exist" ) - DropSchemum alias sch (alias ::: sch x ': xs) = xs - DropSchemum alias sch0 (alias ::: sch1 x ': xs) = TypeError - ('Text "DropSchemum: expected schemum " - ':<>: 'ShowType sch0 - ':<>: 'Text " but alias " - ':<>: 'ShowType alias - ':<>: 'Text " has schemum " - ':<>: 'ShowType sch1) - DropSchemum alias sch (x ': xs) = x ': DropSchemum alias sch xs - --- | Similar to `Drop` but no error on non-existence -type family DropIfExists alias xs where - DropIfExists alias '[] = '[] - DropIfExists alias (alias ::: x ': xs) = xs - DropIfExists alias (x ': xs) = x ': DropIfExists alias xs - --- | Similar to `DropSchemum` but no error on non-existence -type family DropSchemumIfExists alias sch xs where - DropSchemumIfExists alias sch '[] = '[] - DropSchemumIfExists alias sch (alias ::: sch x ': xs) = xs - DropSchemumIfExists alias sch0 (alias ::: sch1 x ': xs) = TypeError - ('Text "DropSchemumIfExists: expected schemum " - ':<>: 'ShowType sch1 - ':<>: 'Text " but alias " - ':<>: 'ShowType alias - ':<>: 'Text " has schemum " - ':<>: 'ShowType sch0) - DropSchemumIfExists alias sch (x ': xs) = x ': DropSchemumIfExists alias sch xs - --- | @Alter alias x xs@ replaces the type associated with an @alias@ in @xs@ --- with the type @x@ and is used in `Squeal.PostgreSQL.Definition.alterTable` --- and `Squeal.PostgreSQL.Definition.alterColumn`. -type family Alter alias x xs where - Alter alias x '[] = TypeError - ('Text "Alter: alias " - ':<>: 'ShowType alias - ':<>: 'Text " does not exist" ) - Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs - Alter alias x1 (x0 ': xs) = x0 ': Alter alias x1 xs - --- | Similar to `Alter` but no error on non-existence -type family AlterIfExists alias x xs where - AlterIfExists alias x '[] = '[] - AlterIfExists alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs - AlterIfExists alias x1 (x0 ': xs) = x0 ': AlterIfExists alias x1 xs - --- | @Rename alias0 alias1 xs@ replaces the alias @alias0@ by @alias1@ in @xs@ --- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and --- `Squeal.PostgreSQL.Definition.renameColumn`. -type family Rename alias0 alias1 xs where - Rename alias0 alias1 '[] = TypeError - ('Text "Rename: alias " - ':<>: 'ShowType alias0 - ':<>: 'Text " does not exist" ) - Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs - Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs - --- | Similar to `Rename` but no error on non-existence -type family RenameIfExists alias0 alias1 xs where - RenameIfExists alias x '[] = '[] - RenameIfExists alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs - RenameIfExists alias0 alias1 (x ': xs) = x ': RenameIfExists alias0 alias1 xs - --- | Move an object from one schema to another -type family SetSchema sch0 sch1 schema0 schema1 obj srt ty db where - SetSchema sch0 sch1 schema0 schema1 obj srt ty db = Alter sch1 - (Create obj (srt ty) schema1) - (Alter sch0 (DropSchemum obj srt schema0) db) - -{- | `SubDB` checks that one `SchemasType` is a sublist of another, -with the same ordering. - ->>> :kind! SubDB '["a" ::: '["b" ::: 'View '[]]] '["a" ::: '["b" ::: 'View '[], "c" ::: 'Typedef 'PGint4]] -SubDB '["a" ::: '["b" ::: 'View '[]]] '["a" ::: '["b" ::: 'View '[], "c" ::: 'Typedef 'PGint4]] :: Bool -= 'True --} -type family SubDB (db0 :: SchemasType) (db1 :: SchemasType) :: Bool where - SubDB '[] db1 = 'True - SubDB (sch ': db0) '[] = 'False - SubDB (sch ::: schema0 ': db0) (sch ::: schema1 ': db1) = - If (SubList schema0 schema1) - (SubDB db0 db1) - (SubDB (sch ::: schema0 ': db0) db1) - SubDB db0 (sch1 ': db1) = SubDB db0 db1 - -{- | `SubsetDB` checks that one `SchemasType` is a subset of another, -regardless of ordering. - ->>> :kind! SubsetDB '["a" ::: '["d" ::: 'Typedef 'PGint2, "b" ::: 'View '[]]] '["a" ::: '["b" ::: 'View '[], "c" ::: 'Typedef 'PGint4, "d" ::: 'Typedef 'PGint2]] -SubsetDB '["a" ::: '["d" ::: 'Typedef 'PGint2, "b" ::: 'View '[]]] '["a" ::: '["b" ::: 'View '[], "c" ::: 'Typedef 'PGint4, "d" ::: 'Typedef 'PGint2]] :: Bool -= 'True --} -type family SubsetDB (db0 :: SchemasType) (db1 :: SchemasType) :: Bool where - SubsetDB '[] db1 = 'True - SubsetDB (sch ': db0) db1 = ElemDB sch db1 && SubsetDB db0 db1 - -{- | `ElemDB` checks that a schema may be found as a subset of another in a database, -regardless of ordering. --} -type family ElemDB (sch :: (Symbol, SchemaType)) (db :: SchemasType) :: Bool where - ElemDB sch '[] = 'False - ElemDB (sch ::: schema0) (sch ::: schema1 ': _) = SubsetList schema0 schema1 - ElemDB sch (_ ': schs) = ElemDB sch schs - --- | Check if a `TableConstraint` involves a column -type family ConstraintInvolves column constraint where - ConstraintInvolves column ('Check columns) = column `Elem` columns - ConstraintInvolves column ('Unique columns) = column `Elem` columns - ConstraintInvolves column ('PrimaryKey columns) = column `Elem` columns - ConstraintInvolves column ('ForeignKey columns sch tab refcolumns) - = column `Elem` columns - --- | Drop all `TableConstraint`s that involve a column -type family DropIfConstraintsInvolve column constraints where - DropIfConstraintsInvolve column '[] = '[] - DropIfConstraintsInvolve column (alias ::: constraint ': constraints) - = If (ConstraintInvolves column constraint) - (DropIfConstraintsInvolve column constraints) - (alias ::: constraint ': DropIfConstraintsInvolve column constraints) - --- | A `SchemumType` is a user-created type, like a `Table`, --- `View` or `Typedef`. -data SchemumType - = Table TableType - | View RowType - | Typedef PGType - | Index IndexType - | Function FunctionType - | Procedure [NullType] - | UnsafeSchemum Symbol - -{- | Use `:=>` to pair the parameter types with the return -type of a function. - ->>> :{ -type family Fn :: FunctionType where - Fn = '[ 'NotNull 'PGint4] :=> 'Returns ('NotNull 'PGint4) -:} --} -type FunctionType = ([NullType], ReturnsType) - -{- | -PostgreSQL provides several index types: -B-tree, Hash, GiST, SP-GiST, GIN and BRIN. -Each index type uses a different algorithm -that is best suited to different types of queries. --} -data IndexType - = Btree - -- ^ B-trees can handle equality and range queries on data - -- that can be sorted into some ordering. - | Hash - -- ^ Hash indexes can only handle simple equality comparisons. - | Gist - -- ^ GiST indexes are not a single kind of index, - -- but rather an infrastructure within which many different - -- indexing strategies can be implemented. - | Spgist - -- ^ SP-GiST indexes, like GiST indexes, - -- offer an infrastructure that supports various kinds of searches. - | Gin - -- ^ GIN indexes are “inverted indexes” which are appropriate for - -- data values that contain multiple component values, such as arrays. - | Brin - -- ^ BRIN indexes (a shorthand for Block Range INdexes) store summaries - -- about the values stored in consecutive physical block ranges of a table. - -{- | Return type of a function-} -data ReturnsType - = Returns NullType -- ^ function - | ReturnsTable RowType -- ^ set returning function - -{- | A schema of a database consists of a list of aliased, -user-defined `SchemumType`s. - ->>> :{ -type family Schema :: SchemaType where - Schema = - '[ "users" ::: 'Table ( - '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "name" ::: 'NoDef :=> 'NotNull 'PGtext - ]) - , "emails" ::: 'Table ( - '[ "pk_emails" ::: 'PrimaryKey '["id"] - , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"] - ] :=> - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 - , "email" ::: 'NoDef :=> 'Null 'PGtext - ]) - ] -:} --} -type SchemaType = [(Symbol,SchemumType)] - --- | A @PartitionedSchema@ is a @SchemaType@ where each constructor of @SchemumType@ has --- been separated into its own list -data PartitionedSchema = PartitionedSchema - { _tables :: [(Symbol, TableType)] - , _views :: [(Symbol, RowType)] - , _types :: [(Symbol, PGType)] - , _indexes :: [(Symbol, IndexType)] - , _functions :: [(Symbol, FunctionType)] - , _procedures :: [(Symbol, [NullType])] - , _unsafes :: [(Symbol, Symbol)] - } - --- | @PartitionSchema@ partitions a @SchemaType@ into a @PartitionedSchema@ -type PartitionSchema schema = PartitionSchema' schema ('PartitionedSchema '[] '[] '[] '[] '[] '[] '[]) - -type family PartitionSchema' (remaining :: SchemaType) (acc :: PartitionedSchema) :: PartitionedSchema where - PartitionSchema' '[] ps = ps - PartitionSchema' ('(s, 'Table table) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe) - = PartitionSchema' rest ('PartitionedSchema ('(s, table) ': tables) views types indexes functions procedures unsafe) - PartitionSchema' ('(s, 'View view) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe) - = PartitionSchema' rest ('PartitionedSchema tables ('(s, view) ': views) types indexes functions procedures unsafe) - PartitionSchema' ('(s, 'Typedef typ) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe) - = PartitionSchema' rest ('PartitionedSchema tables views ('(s, typ) ': types) indexes functions procedures unsafe) - PartitionSchema' ('(s, 'Index ix) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe) - = PartitionSchema' rest ('PartitionedSchema tables views types ('(s, ix) ': indexes) functions procedures unsafe) - PartitionSchema' ('(s, 'Function f) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe) - = PartitionSchema' rest ('PartitionedSchema tables views types indexes ('(s, f) ': functions) procedures unsafe) - PartitionSchema' ('(s, 'Procedure p) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe) - = PartitionSchema' rest ('PartitionedSchema tables views types indexes functions ('(s, p) ': procedures) unsafe) - PartitionSchema' ('(s, 'UnsafeSchemum u) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe) - = PartitionSchema' rest ('PartitionedSchema tables views types indexes functions procedures ('(s, u) ': unsafe)) - --- | Get the tables from a @PartitionedSchema@ -type family SchemaTables (schema :: PartitionedSchema) :: [(Symbol, TableType)] where - SchemaTables ('PartitionedSchema tables _ _ _ _ _ _) = tables --- | Get the views from a @PartitionedSchema@ -type family SchemaViews (schema :: PartitionedSchema) :: [(Symbol, RowType)] where - SchemaViews ('PartitionedSchema _ views _ _ _ _ _) = views --- | Get the typedefs from a @PartitionedSchema@ -type family SchemaTypes (schema :: PartitionedSchema) :: [(Symbol, PGType)] where - SchemaTypes ('PartitionedSchema _ _ types _ _ _ _) = types --- | Get the indexes from a @PartitionedSchema@ -type family SchemaIndexes (schema :: PartitionedSchema) :: [(Symbol, IndexType)] where - SchemaIndexes ('PartitionedSchema _ _ _ indexes _ _ _) = indexes --- | Get the functions from a @PartitionedSchema@ -type family SchemaFunctions (schema :: PartitionedSchema) :: [(Symbol, FunctionType)] where - SchemaFunctions ('PartitionedSchema _ _ _ _ functions _ _) = functions --- | Get the procedured from a @PartitionedSchema@ -type family SchemaProcedures (schema :: PartitionedSchema) :: [(Symbol, [NullType])] where - SchemaProcedures ('PartitionedSchema _ _ _ _ _ procedures _) = procedures --- | Get the unsafe schema types from a @PartitionedSchema@ -type family SchemaUnsafes (schema :: PartitionedSchema) :: [(Symbol, Symbol)] where - SchemaUnsafes ('PartitionedSchema _ _ _ _ _ _ unsafes) = unsafes - --- | @PrettyPrintPartitionedSchema@ makes a nice @ErrorMessage@ showing a @PartitionedSchema@, --- only including the names of the things in it and not the values. Additionally, empty --- fields are omitted -type family PrettyPrintPartitionedSchema (schema :: PartitionedSchema) :: ErrorMessage where - PrettyPrintPartitionedSchema schema = IntersperseNewlines (FilterNonEmpty - [ FieldIfNonEmpty "Tables" (SchemaTables schema) - , FieldIfNonEmpty "Views" (SchemaViews schema) - , FieldIfNonEmpty "Types" (SchemaTypes schema) - , FieldIfNonEmpty "Indexes" (SchemaIndexes schema) - , FieldIfNonEmpty "Functions" (SchemaFunctions schema) - , FieldIfNonEmpty "Procedures" (SchemaProcedures schema) - , FieldIfNonEmpty "Unsafe schema items" (SchemaUnsafes schema) - ]) - -type family FieldIfNonEmpty (fieldName :: Symbol) (value :: [(Symbol, k)]) :: ErrorMessage where - FieldIfNonEmpty _ '[] = 'Text "" - FieldIfNonEmpty n xs = 'Text " " ':<>: 'Text n ':<>: 'Text ":" ':$$: 'Text " " ':<>: 'ShowType (Sort (MapFst xs)) - -type family FilterNonEmpty (ls :: [ErrorMessage]) :: [ErrorMessage] where - FilterNonEmpty ('Text "" ': rest) = FilterNonEmpty rest - FilterNonEmpty (x ': rest) = x ': FilterNonEmpty rest - FilterNonEmpty '[] = '[] - -type family IntersperseNewlines (ls :: [ErrorMessage]) :: ErrorMessage where - IntersperseNewlines (x ': y ': '[]) = x ':$$: y - IntersperseNewlines (x ': xs) = x ':$$: IntersperseNewlines xs - IntersperseNewlines '[] = 'Text "" - -type instance PrettyPrintHaystack (haystack :: SchemaType) = - 'PrettyPrintInfo ('Text "table, view, typedef, index, function, or procedure (SchemumType)") ('Text "schema (SchemaType)") - ( PrettyPrintPartitionedSchema (PartitionSchema haystack) - ) - -{- | -A database contains one or more named schemas, which in turn contain tables. -The same object name can be used in different schemas without conflict; -for example, both schema1 and myschema can contain tables named mytable. -Unlike databases, schemas are not rigidly separated: -a user can access objects in any of the schemas in the database they are connected to, -if they have privileges to do so. - -There are several reasons why one might want to use schemas: - - * To allow many users to use one database without interfering with each other. - * To organize database objects into logical groups to make them more manageable. - * Third-party applications can be put into separate schemas - so they do not collide with the names of other objects. --} -type SchemasType = [(Symbol,SchemaType)] - -type instance PrettyPrintHaystack (haystack :: SchemasType) = - 'PrettyPrintInfo ('Text "schema (SchemaType)") ('Text "database (SchemasType)") ('Text " " ':<>: 'ShowType (Sort (MapFst haystack))) - --- | A type family to use for a single schema database. -type family Public (schema :: SchemaType) :: SchemasType - where Public schema = '["public" ::: schema] - --- | `IsPGlabel` looks very much like the `IsLabel` class. Whereas --- the overloaded label, `fromLabel` is used for column references, --- `label`s are used for enum terms. A `label` is called with --- type application like `label` @"beef". -class IsPGlabel (label :: Symbol) expr where label :: expr -instance label ~ label1 - => IsPGlabel label (PGlabel label1) where label = PGlabel -instance labels ~ '[label] - => IsPGlabel label (NP PGlabel labels) where label = PGlabel :* Nil -instance IsPGlabel label (y -> K y label) where label = K -instance IsPGlabel label (y -> NP (K y) '[label]) where label y = K y :* Nil --- | A `PGlabel` unit type with an `IsPGlabel` instance -data PGlabel (label :: Symbol) = PGlabel -instance KnownSymbol label => RenderSQL (PGlabel label) where - renderSQL _ = "\'" <> renderSymbol @label <> "\'" -instance All KnownSymbol labels => RenderSQL (NP PGlabel labels) where - renderSQL - = commaSeparated - . hcollapse - . hcmap (Proxy @KnownSymbol) (K . renderSQL) - --- | Is a type a valid JSON key? -type PGJsonKey = '[ 'PGint2, 'PGint4, 'PGtext ] - --- | Is a type a valid JSON type? -type PGJsonType = '[ 'PGjson, 'PGjsonb ] - --- | Utility class for `AllUnique` to provide nicer error messages. -class IsNotElem x isElem where -instance IsNotElem x 'False where -instance (TypeError ( 'Text "Cannot assign to " - ':<>: 'ShowType alias - ':<>: 'Text " more than once")) - => IsNotElem '(alias, a) 'True where - --- | No elem of @xs@ appears more than once, in the context of assignment. -class AllUnique (xs :: [(Symbol, a)]) where -instance AllUnique '[] where -instance (IsNotElem x (Elem x xs), AllUnique xs) => AllUnique (x ': xs) where - --- | Updatable lists of columns -type Updatable table columns = - ( All (HasIn (TableToColumns table)) columns - , AllUnique columns - , SListI (TableToColumns table) ) - -type family SchemaEnums schema where - SchemaEnums '[] = '[] - SchemaEnums (enum ::: 'Typedef ('PGenum labels) ': schema) = - enum ::: labels ': SchemaEnums schema - SchemaEnums (_ ': schema) = SchemaEnums schema - -{- | Filters schemas down to labels of all enum typedefs. --} -type family DbEnums db where - DbEnums '[] = '[] - DbEnums (sch ::: schema ': schemas) = - sch ::: SchemaEnums schema ': DbEnums schemas - -type family SchemaRelations schema where - SchemaRelations '[] = '[] - SchemaRelations (tab ::: 'Table table ': schema) = - tab ::: TableToRow table ': SchemaRelations schema - SchemaRelations (vw ::: 'View row ': schema) = - vw ::: row ': SchemaRelations schema - SchemaRelations (ty ::: 'Typedef ('PGcomposite row) ': schema) = - ty ::: row ': SchemaRelations schema - SchemaRelations (_ ': schema) = SchemaRelations schema - -{- | Filters schemas down to rows of relations; -all composites, tables and views. --} -type family DbRelations db where - DbRelations '[] = '[] - DbRelations (sch ::: schema ': schemas) = - sch ::: SchemaRelations schema ': DbRelations schemas - -type family FindName xs x where - FindName '[] xs = 'Nothing - FindName ( '(name, x) ': _) x = 'Just name - FindName (_ ': xs) x = FindName xs x - -type family FindNamespace err nsp name xss x where - FindNamespace err _ 'Nothing xss x = FindQualified err xss x - FindNamespace _ nsp ('Just name) _ _ = '(nsp, name) - -{- | Find fully qualified name with a type error if lookup fails. -This is used to find the qualified name of a user defined type. - ->>> :kind! FindQualified "my error message: " -FindQualified "my error message: " :: [(k1, [(k2, k3)])] - -> k3 -> (k1, k2) -= FindQualified "my error message: " - ->>> :kind! FindQualified "couldn't find type: " '[ "foo" ::: '["bar" ::: Double]] Double -FindQualified "couldn't find type: " '[ "foo" ::: '["bar" ::: Double]] Double :: (Symbol, - Symbol) -= '("foo", "bar") - ->>> :kind! FindQualified "couldn't find type: " '[ "foo" ::: '["bar" ::: Double]] Bool -FindQualified "couldn't find type: " '[ "foo" ::: '["bar" ::: Double]] Bool :: (Symbol, - Symbol) -= (TypeError ...) --} -type family FindQualified err xss x where - FindQualified err '[] x = TypeError ('Text err ':<>: 'ShowType x) - FindQualified err ( '(nsp, xs) ': xss) x = - FindNamespace err nsp (FindName xs x) xss x diff --git a/squeal-postgresql/test/Property.hs b/squeal-postgresql/test/Property.hs deleted file mode 100644 index 7ae5bea7..00000000 --- a/squeal-postgresql/test/Property.hs +++ /dev/null @@ -1,316 +0,0 @@ -{-# LANGUAGE - DataKinds - , DeriveAnyClass - , DeriveGeneric - , DerivingStrategies - , DerivingVia - , FlexibleContexts - , FlexibleInstances - , GADTs - , LambdaCase - , MultiParamTypeClasses - , OverloadedLabels - , OverloadedStrings - , ScopedTypeVariables - , StandaloneDeriving - , TypeApplications - , TypeOperators - , UndecidableInstances -#-} - -module Main (main) where - -import Control.Monad.Trans -import Data.ByteString (ByteString) -import Data.ByteString.Char8 (unpack) -import Data.Function (on) -import Data.Functor.Contravariant (contramap) -import Data.Int (Int16) -import Data.Scientific (fromFloatDigits) -import Data.Fixed (Fixed(MkFixed), Micro, Pico) -import Data.String (IsString(fromString)) -import Data.Time -import Hedgehog hiding (Range) -import Main.Utf8 -import Squeal.PostgreSQL hiding (check) -import qualified Generics.SOP as SOP -import qualified GHC.Generics as GHC -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Main as Main -import qualified Hedgehog.Range as Range -import Data.List (sort) - -main :: IO () -main = withUtf8 $ do - withConnection connectionString $ define createDB - Main.defaultMain [checkSequential roundtrips] - withConnection connectionString $ define dropDB - -roundtrips :: Group -roundtrips = Group "roundtrips" - [ roundtrip int2 genInt16 - , roundtrip int4 genInt32 - , roundtrip int8 genInt64 - , roundtrip bool Gen.bool - , roundtrip numeric genScientific - , roundtrip float4 genFloat - , roundtrip float8 genDouble - , roundtripOn normalizeAscii text genStringAscii - , roundtripOn normalizeUtf8 text genStringUnicode - -- , roundtripOn normalizeUtf8 text genStringAll - , roundtripOn normalizeTimeOfDay time genTimeOfDay - -- , roundtrip timetz genTimeWithZone - , roundtripOn normalizeLocalTime timestamp genLocalTime - , roundtrip timestamptz genUTCTime - , roundtrip date genDay - , roundtrip interval genDiffTime - , roundtripOn normalizeIntRange int4range (genRange genInt32) - , roundtripOn normalizeIntRange int8range (genRange genInt64) - , roundtrip numrange (genRange genScientific) - , roundtripOn (fmap normalizeLocalTime) tsrange (genRange genLocalTime) - , roundtrip tstzrange (genRange genUTCTime) - , roundtripOn normalizeIntRange daterange (genRange genDay) - , roundtrip (typedef #schwarma) genSchwarma - , roundtrip (vararray (typedef #schwarma)) genSchwarmaArray - , roundtrip (typerow #tab) genRow - , roundtrip (vararray (typetable #tab)) genRowArray - , ("table insert", roundtripTable) - ] - where - genInt16 = Gen.int16 Range.exponentialBounded - genInt32 = Gen.int32 Range.exponentialBounded - genInt64 = Gen.int64 Range.exponentialBounded - genScientific = fromFloatDigits <$> genFloat - genPosFloat = Gen.float - (Range.exponentialFloatFrom 1 minPosFloat maxPosFloat) - genFloat = Gen.prune $ Gen.choice - [ genPosFloat - , negate <$> genPosFloat - , Gen.element [0,1/0,-1/0] - ] - genPosDouble = Gen.double - (Range.exponentialFloatFrom 1 minPosFloat maxPosFloat) - genDouble = Gen.prune $ Gen.choice - [ genPosDouble - , negate <$> genPosDouble - , Gen.element [0,1/0,-1/0] - ] - genStringAscii = Gen.string (Range.linear 0 100) Gen.ascii - -- genStringLatin1 = Gen.string (Range.linear 0 100) Gen.latin1 - genStringUnicode = Gen.string (Range.linear 0 100) Gen.unicode - -- genStringAll = Gen.string (Range.linear 0 100) Gen.unicodeAll - genRange gen = do - lb <- gen - ub <- Gen.filter (lb <) gen - Gen.element - [ Empty, singleton lb, whole - , lb <=..<= ub , lb <=..< ub, lb <..<= ub, lb <..< ub - , atLeast lb, moreThan lb, atMost ub, lessThan ub ] - genDay = do - y <- toInteger <$> Gen.int (Range.constant 2000 2019) - m <- Gen.int (Range.constant 1 12) - d <- Gen.int (Range.constant 1 28) - return $ fromGregorian y m d - genDiffTime = do - secs <- secondsToDiffTime . toInteger <$> - Gen.int (Range.constant 0 86401) - picos <- picosecondsToDiffTime . (* 1000000) . toInteger <$> - Gen.int (Range.constant 0 (1000000 - 1)) - return $ secs + picos - genUTCTime = UTCTime <$> genDay <*> genDiffTime - genTimeOfDay = do - h <- Gen.int (Range.constant 0 23) - m <- Gen.int (Range.constant 0 59) - s <- MkFixed . toInteger <$> Gen.int (Range.constant 0 59) - return $ TimeOfDay h m s - genLocalTime = LocalTime <$> genDay <*> genTimeOfDay - -- genTimeZone = Gen.element $ map (read @TimeZone) - -- [ "UTC", "UT", "GMT", "EST", "EDT", "CST" - -- , "CDT", "MST", "MDT", "PST", "PDT" ] - genSchwarma = Gen.enumBounded @_ @Schwarma - genSchwarmaArray = VarArray <$> Gen.list (Range.constant 1 10) genSchwarma - genRow = HaskRow - <$> genInt16 - <*> Gen.enumBounded - <*> Gen.bool - genRowArray = VarArray <$> Gen.list (Range.constant 1 10) genRow - -roundtrip - :: forall x - . ( ToPG DB x, FromPG x, Inline x - , OidOf DB (PG x), PGTyped DB (PG x) - , Show x, Eq x, NullPG x ~ 'NotNull (PG x) ) - => TypeExpression DB ('NotNull (PG x)) - -> Gen x - -> (PropertyName, Property) -roundtrip = roundtripOn id - -roundtripOn - :: forall x - . ( ToPG DB x, FromPG x, Inline x - , OidOf DB (PG x), PGTyped DB (PG x) - , Show x, Eq x, NullPG x ~ 'NotNull (PG x) ) - => (x -> x) - -> TypeExpression DB ('NotNull (PG x)) - -> Gen x - -> (PropertyName, Property) -roundtripOn norm ty gen = propertyWithName $ do - x <- forAll gen - Just (Only y) <- lift . withConnection connectionString $ - firstRow =<< runQueryParams - (values_ (parameter @1 ty `as` #fromOnly)) (Only x) - Just (Only z) <- lift . withConnection connectionString $ - firstRow =<< runQuery - (values_ (inline @x @'NotNull x `as` #fromOnly)) - y === z - norm x === y - where - propertyWithName prop = - (fromString (unpack (renderSQL ty)), property prop) - -maxPosFloat :: RealFloat a => a -maxPosFloat = x - where - n = floatDigits x - b = floatRadix x - (_, u) = floatRange x - x = encodeFloat (b^n - 1) (u - n) - -minPosFloat :: RealFloat a => a -minPosFloat = x - where - n = floatDigits x - b = floatRadix x - (l, _) = floatRange x - x = encodeFloat (b^n - 1) (l - n - 1) - -connectionString :: ByteString -connectionString = "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" - -normalizeIntRange :: (Enum int, Ord int) => Range int -> Range int -normalizeIntRange = \case - Empty -> Empty - NonEmpty l u -> - let - l' = normalizeL l - u' = normalizeU u - in if emptyNormalized l' u' then Empty else NonEmpty l' u' - where - normalizeL = \case - Open l -> Closed (succ l) - normalized -> normalized - normalizeU = \case - Closed u -> Open (succ u) - normalized -> normalized - emptyNormalized (Closed l) (Open u) = l >= u - emptyNormalized _ _ = False - -normalizeTimeOfDay :: TimeOfDay -> TimeOfDay -normalizeTimeOfDay (TimeOfDay h m s) = TimeOfDay h m - . fromRational @Pico - . toRational @Micro - . fromRational @Micro - . toRational @Pico - $ s - -normalizeLocalTime :: LocalTime -> LocalTime -normalizeLocalTime (LocalTime d t) = LocalTime d (normalizeTimeOfDay t) - --- normalizeTimeWithZone :: (TimeOfDay, TimeZone) -> (TimeOfDay, TimeZone) --- normalizeTimeWithZone (t, z) = (normalizeTimeOfDay t, z) - -normalizeAscii :: String -> String -normalizeAscii = (stripped =<<) - where - stripped = \case - '\NUL' -> "" - ch -> [ch] - -normalizeUtf8 :: String -> String -normalizeUtf8 = (stripped =<<) - where - stripped = \case - '\NUL' -> "" - ch -> [ch] - -data Schwarma = Chicken | Lamb | Beef - deriving stock (Eq, Ord, Show, Bounded, Enum, GHC.Generic) - deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) - deriving (IsPG, FromPG, ToPG db, Inline) via Enumerated Schwarma - -data HaskRow = HaskRow {foo :: Int16, bar :: Schwarma, baz :: Bool} - deriving stock (Eq, Ord, Show, GHC.Generic) - deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) - deriving (IsPG, FromPG, Inline) via Composite HaskRow -deriving via Composite HaskRow - instance db ~ DB => ToPG db HaskRow - -type Schema = '[ - "schwarma" ::: 'Typedef (PG Schwarma), - "tab" ::: 'Table ('[] :=> PGRow)] - -type DB = Public Schema - -type DB0 = Public '[] - -createDB :: Definition DB0 DB -createDB = - createTypeEnumFrom @Schwarma #schwarma >>> - createTable #tab - ( notNullable int2 `as` #foo :* - notNullable (typedef #schwarma) `as` #bar :* - notNullable bool `as` #baz - ) Nil - -dropDB :: Definition DB DB0 -dropDB = dropTable #tab >>> dropType #schwarma - -type PGRow = '[ - "foo" ::: 'NoDef :=> 'NotNull 'PGint2, - "bar" ::: 'NoDef :=> 'NotNull (PG Schwarma), - "baz" ::: 'NoDef :=> 'NotNull 'PGbool] - -insertTabInline :: [HaskRow] -> Statement DB () () -insertTabInline = \case - [] -> error "needs at least 1 row" - rw:rows -> manipulation $ insertInto_ #tab (inlineValues rw rows) - -insertTabParams :: Statement DB HaskRow () -insertTabParams = manipulation . insertInto_ #tab . Values_ $ - Set (param @1) `as` #foo :* - Set (param @2) `as` #bar :* - Set (param @3) `as` #baz - -insertTabUnnest :: Statement DB [HaskRow] () -insertTabUnnest = Manipulation enc dec sql - where - enc = contramap VarArray aParam - dec = return () - sql = insertInto_ #tab unnested - unnested = Select fields (from (unnest (param @1))) - fields = - Set (#unnest & field #tab #foo) `as` #foo :* - Set (#unnest & field #tab #bar) `as` #bar :* - Set (#unnest & field #tab #baz) `as` #baz - -selectTab :: Statement DB () HaskRow -selectTab = query $ select Star (from (table #tab)) - -roundtripTable :: Property -roundtripTable = property $ do - let - genInt16 = Gen.int16 Range.exponentialBounded - genRow = HaskRow - <$> genInt16 - <*> Gen.enumBounded - <*> Gen.bool - genRows = Gen.list (Range.constant 1 100) genRow - rows1 <- forAll genRows - rows2 <- forAll genRows - rows3 <- forAll genRows - tabRows <- lift . withConnection connectionString $ ephemerally_ $ do - execute_ (insertTabInline rows1) - executePrepared_ insertTabParams rows2 - executeParams_ insertTabUnnest rows3 - getRows =<< execute selectTab - ((===) `on` sort) tabRows (rows1 ++ rows2 ++ rows3) diff --git a/squeal-postgresql/test/Spec.hs b/squeal-postgresql/test/Spec.hs deleted file mode 100644 index 112a662a..00000000 --- a/squeal-postgresql/test/Spec.hs +++ /dev/null @@ -1,250 +0,0 @@ -{-# LANGUAGE - DataKinds - , DeriveAnyClass - , DeriveGeneric - , DerivingStrategies - , DerivingVia - , DuplicateRecordFields - , FlexibleContexts - , FlexibleInstances - , MultiParamTypeClasses - , OverloadedLabels - , OverloadedStrings - , RankNTypes - , StandaloneDeriving - , TypeApplications - , TypeFamilies - , TypeSynonymInstances - , TypeInType - , TypeOperators - , UndecidableInstances -#-} - -module Main (main) where - -import Control.Concurrent.Async (replicateConcurrently) -import Data.ByteString (ByteString) -import Data.Int (Int32) -import Data.Text (Text) -import Test.Hspec - -import qualified Data.ByteString.Char8 as Char8 (unlines) -import qualified Generics.SOP as SOP -import qualified GHC.Generics as GHC - -import Squeal.PostgreSQL - -main :: IO () -main = hspec spec - -type UsersConstraints = - '[ "pk_users" ::: 'PrimaryKey '["id"] - , "unique_names" ::: 'Unique '["name"] ] - -type UsersColumns = - '[ "id" ::: 'Def :=> 'NotNull 'PGint4 - , "name" ::: 'NoDef :=> 'NotNull 'PGtext ] - -type Schema = - '[ "users" ::: 'Table (UsersConstraints :=> UsersColumns) - , "person" ::: 'Typedef (PG Person) ] - -type DB = '[ "public" ::: Schema ] - -data User = User - { userName :: Text - } deriving stock (Eq, Show, GHC.Generic) - deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) - -insertUser :: Manipulation_ DB User () -insertUser = insertInto_ #users - (Values_ (Default `as` #id :* Set (param @1) `as` #name)) - -insertUsers :: Text -> [Text] -> Statement DB () () -insertUsers name1 names = manipulation $ insertInto_ #users $ Values - (Default `as` #id :* Set (inline name1) `as` #name) - [Default `as` #id :* Set (inline namei) `as` #name | namei <- names] - -deleteUser :: Text -> Statement DB () () -deleteUser name1 = manipulation $ deleteFrom_ #users (#name .== inline name1) - -setup :: Definition (Public '[]) DB -setup = - createTable #users - ( serial `as` #id :* - notNullable text `as` #name ) - ( primaryKey #id `as` #pk_users :* - unique #name `as` #unique_names ) >>> - createTypeCompositeFrom @Person #person - -teardown :: Definition DB (Public '[]) -teardown = dropType #person >>> dropTable #users - -silent :: Statement db () () -silent = manipulation $ UnsafeManipulation "Set client_min_messages TO WARNING" - -silence :: MonadPQ db pq => pq () -silence = execute_ silent - -setupDB :: IO () -setupDB = withConnection connectionString $ - silence & pqThen (define setup) - -dropDB :: IO () -dropDB = withConnection connectionString $ - silence & pqThen (define teardown) - -connectionString :: ByteString -connectionString = "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" - -data Person = Person { name :: Maybe String, age :: Maybe Int32 } - deriving (Eq, Show, GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo) - deriving (IsPG, FromPG, ToPG db, Inline) via (Composite Person) - -spec :: Spec -spec = before_ setupDB . after_ dropDB $ do - - describe "Exceptions" $ do - - let - testUser = User "TestUser" - newUser :: User -> Transaction DB () - newUser = manipulateParams_ insertUser - insertUserTwice :: Transaction DB () - insertUserTwice = newUser testUser >> newUser testUser - err23505 = UniqueViolation $ Char8.unlines - [ "ERROR: duplicate key value violates unique constraint \"unique_names\"" - , "DETAIL: Key (name)=(TestUser) already exists." ] - - it "should be thrown for constraint violation" $ - withConnection connectionString insertUserTwice - `shouldThrow` (== err23505) - - it "should be rethrown for constraint violation in a transaction" $ - withConnection connectionString (transactionally_ insertUserTwice) - `shouldThrow` (== err23505) - - describe "Pools" $ - - it "should manage concurrent transactions" $ do - pool <- createConnectionPool - "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" 1 0.5 10 - let - qry :: Query_ (Public '[]) () (Only Char) - qry = values_ (inline 'a' `as` #fromOnly) - session = usingConnectionPool pool $ transactionally_ $ - firstRow =<< runQuery qry - chrs <- replicateConcurrently 10 session - chrs `shouldSatisfy` all (== Just (Only 'a')) - - describe "Ranges" $ - - it "should correctly decode ranges" $ do - - rangesOut <- withConnection connectionString $ do - let - qry :: Query_ (Public '[]) () (Only (Range Int32)) - qry = values - ( range int4range (atLeast 3) `as` #fromOnly ) - [ range int4range (3 <=..< 5) `as` #fromOnly - , range int4range Empty `as` #fromOnly - , range int4range whole `as` #fromOnly ] - getRows =<< runQuery qry - (fromOnly <$> rangesOut :: [Range Int32]) `shouldBe` - [ atLeast 3, 3 <=..< 5, Empty, whole ] - - describe "Parameters" $ do - - it "should run queries that don't reference all their parameters" $ do - - out <- withConnection connectionString $ do - let - qry :: Query_ (Public '[]) (Char,Int32) (Only Int32) - qry = values_ (param @2 `as` #fromOnly) - firstRow =<< runQueryParams qry ('a', 3 :: Int32) - (fromOnly <$> out :: Maybe Int32) `shouldBe` Just 3 - - describe "Composite types" $ do - - it "should be embeddible" $ do - - let - - roundtrip :: Query_ DB (Only Person) (Only Person) - roundtrip = values_ (param @1 `as` #fromOnly) - - roundtrip_inline :: Person -> Query_ DB () (Only Person) - roundtrip_inline person = values_ (inline person `as` #fromOnly) - - roundtrip_array :: Query_ DB - (Only (VarArray [Person])) (Only (VarArray [Person])) - roundtrip_array = values_ (param @1 `as` #fromOnly) - - oneway :: Query_ DB () (Only Person) - oneway = values_ (row ("Adam" `as` #name :* 6000 `as` #age) `as` #fromOnly) - - oneway_array :: Query_ DB () (Only (VarArray [Person])) - oneway_array = values_ $ array - [ row ("Adam" `as` #name :* 6000 `as` #age) - , row ("Lucy" `as` #name :* 2420000 `as` #age) - ] `as` #fromOnly - - unsafeQ :: Query_ DB () (Only (VarArray [Composite Person])) - unsafeQ = UnsafeQuery "select array[row(\'Adam\', 6000)]" - - nothingQ :: Query_ DB () (Only Person) - nothingQ = values_ (row (null_ `as` #name :* null_ `as` #age) `as` #fromOnly) - - adam = Person (Just "Adam") (Just 6000) - lucy = Person (Just "Lucy") (Just 2420000) - people = VarArray [adam, lucy] - - out <- withConnection connectionString $ - firstRow =<< runQueryParams roundtrip (Only adam) - out_inline <- withConnection connectionString $ - firstRow =<< runQuery (roundtrip_inline adam) - out_array <- withConnection connectionString $ - firstRow =<< runQueryParams roundtrip_array (Only people) - out2 <- withConnection connectionString $ - firstRow =<< runQuery oneway - out2_array <- withConnection connectionString $ - firstRow =<< runQuery oneway_array - unsafe_array <- withConnection connectionString $ - firstRow =<< runQuery unsafeQ - nothings <- withConnection connectionString $ - firstRow =<< runQuery nothingQ - - out `shouldBe` Just (Only adam) - out_inline `shouldBe` Just (Only adam) - out_array `shouldBe` Just (Only people) - out2 `shouldBe` Just (Only adam) - out2_array `shouldBe` Just (Only people) - unsafe_array `shouldBe` Just (Only (VarArray [Composite adam])) - nothings `shouldBe` Just (Only (Person Nothing Nothing)) - - describe "cmdStatus and cmdTuples" $ do - - let - statusAndTuples stmnt = withConnection connectionString $ do - result <- execute stmnt - status <- cmdStatus result - tuples <- cmdTuples result - return (status, tuples) - - it "should tell you about the command and the number of rows effected" $ do - - (status1, tuples1) <- statusAndTuples (insertUsers "Jonah" ["Isaiah"]) - status1 `shouldBe` "INSERT 0 2" - tuples1 `shouldBe` Just 2 - - (status2, tuples2) <- statusAndTuples (deleteUser "Noah") - status2 `shouldBe` "DELETE 0" - tuples2 `shouldBe` Just 0 - - (status3, tuples3) <- statusAndTuples (deleteUser "Jonah") - status3 `shouldBe` "DELETE 1" - tuples3 `shouldBe` Just 1 - - (status4, tuples4) <- statusAndTuples silent - status4 `shouldBe` "SET" - tuples4 `shouldBe` Nothing diff --git a/squeal-presentation-raveline.md b/squeal-presentation-raveline.md deleted file mode 100644 index 034d9ded..00000000 --- a/squeal-presentation-raveline.md +++ /dev/null @@ -1,794 +0,0 @@ -# Squeal - -_A bridge between SQL and Haskell_ - -by [@Raveline](https://github.com/raveline) - ---- - -# Rationale - -Using `postgresql-simple` you have a typical "Trial, error, despair" workflow: - -- Write query manually or semi-automatically - -- Write haskell code using the query - -- Pray that the query syntax is correct - -- Pray that it returns what you want - -- Realize the inefficiency of prayer when it comes to SQL - -- Iterate till it works - ---- - -![Can't take this anymore](http://gif.eraveline.eu/static/img/0x16e.gif) - ---- - -# Use your best friend: GHC - -Squeal provides several eDSL to make your SQL typesafe: - -- Type level eDSL to express schema; - -- Value level eDSL to manipulate schema (plus migration, yeehaw !); - -- Type level eDSL to express queries; - -- Value level eDSL to perform queries - -However, it's not an ORM. There's no caching, lazy loading - you retain control over your memory. Also, joins - and mostly aggregation after joins - have to be handled manually. - ---- - -# Part I. Schema & migration - ---- - -# The Schema - -- The schema will be used to validate _everything_: migration, queries, etc. - -- A schema is mostly a collection of tables. - -- In this presentation, we will create a very basic database modeling a parliament. We will store _members of parliament_ and _parliamentary groups_. - -- A simple Schema to represent a Parliament could be: - -```haskell -type Schema = '[ "mp" ::: 'Table MemberOfParliament - , "groupp" ::: 'Table ParliamentGroup ] -``` - ---- - -> _note_ We need the `DataKinds` extension to be able to express heterogenous lists containing -> specific types like this one. - -> You can perfectly call your table "group" and not "groupp" even though it is a -> keyword in SQL - Squeal queries will be properly escaped. - ---- - -# A small example - -```haskell -type ParliamentaryGroup = - '[ "pk_groupp" ::: 'PrimaryKey '["groupp_id"]] - :=> - '[ "groupp_id" ::: 'NoDef :=> 'NotNull 'PGuuid - , "name" ::: 'NoDef :=> 'NotNull 'PGtext - ] -``` - -- That's a whole simple table defined in one go. - -- `:::` lets us define a column or a constraint. - -- `:=>` associates the constraints to the column. - -- Let's split constraints and column to study the syntax a bit more. - ---- - -> _note_ We are using `:::` and `:=>` to quickly express associations when writing -> our schema. We need the `TypeOperators` extension.] - ---- - -![What does this means ?!](http://gif.eraveline.eu/static/img/0x27e.gif) - ---- - -# Defining a table - -```haskell -type MemberOfParliament = - '[ "pk_mp" ::: 'PrimaryKey '["mp_id"] - , "fk_mp_groupp" ::: 'ForeignKey '["mp_group"] "public" "groupp" '["groupp_id"] - ] :=> MpCols -``` - -- A table is a collection of constraints associated to a collection of columns. - -- We defined a table named "mp". - -- It has a constraint named "pk_mp", defining its primary key on column "mp_id". - -- It has a constraint named "fk_mp_groupp" defining a foreign key on column "mg_group", connected to the column "groupp_id" of table "groupp". - -- These constraints will be associated to the columns defined in `MpCols`. - ---- - -# Defining columns - -```haskell -type MpCols = - '[ "mp_id" ::: 'NoDef :=> 'NotNull 'PGuuid - , "first_name" ::: 'NoDef :=> 'NotNull 'PGtext - , "last_name" ::: 'NoDef :=> 'NotNull 'PGtext - ] -``` - -- A listing of column associate, for each element: - - * a name; - - * the mention of an eventual default value; - - * the nullability; - - * the type (obviously). - ---- - -> _note_ GHC is already helping. If I named the "mp_id" column differently, -> GHC would yell because I promised a primary key constraint on a column named `mp_id`, so there must be one.] - ---- - -# Implementating the schema - -- We will carry this schema type pretty much everywhere. - -- But before we play with this schema, we need to implement it. - ---- - -```haskell -setup :: Definition '[] Schema -setup = - createTable #groupp - ( notNullable uuid `as` #groupp_id - :* notNullable text `as` #name) - ( primaryKey #groupp_id `as` #pk_groupp ) - >>> createTable #mp - ( notNullable uuid `as` #mp_id - :* notNullable text `as` #first_name - :* notNullable text `as` #last_name - :* notNullable text `as` #mp_group) - ( primaryKey #mp_id `as` #pk_mp - :* foreignKey #mp_group #groupp #groupp_id - OnDeleteCascade OnUpdateCascade - `as` #fk_mp_groupp) -``` - ---- - -# Damn, that's verbose - -- Yes. But you need verbosity to get type safety. - -- On the plus side, it's fairly straightforward. - -- You use `:*` to compose the element of the heterogenous list of columns. - -- You use `>>>` to compose table creation. - -> _note_ The compiler will catch any mistype between Schema and -> definition; wrong nullability, wrong type, wrong name, etc. - ---- - -> _note_ You'll also need `OverloadedLabels`, for naming stuff. -> This is mostly to avoid having to write manual proxies all -> the time and for convenience. - ---- - -# Setting up the schema - -- Squeal comes with a very good migration manager, handling _upgrades_ AND -_downgrades_. - -- A migration is a simple type: - -```haskell -Migration io schema0 schema1 -``` - -- The first parameter is a BaseMonad (typically, IO). - -- The second parameter is "the current schema of your DB". - -- The last one is "what you will migrate to". - -- The `Definition` type used to define upgrade and downgrade functions use the - same logic (from one schema to the other). - ---- - -# Defining our first migration - -- We have the setup bit, we need the teardown: - -```haskell -tearDown :: Definition Schema '[] -tearDown = dropTable #mp >>> dropTable #groupp -``` - -> _note_ GHC will also detect the _proper_ order of what you typed in -> downgrade and upgrade should there be any conflict (with foreign keys). - -```haskell -initDB :: Migration IO '[] Schema -initDB = - Migration { name = "Schema creation" - , up = void $ define setup - , down = void $ define tearDown } -``` - ---- - -# Simple migrator example - -```haskell -main :: IO () -main = do - printSQL setup - void $ withConnection connectionString $ - migrateUp $ single initDB -``` - -- We print the migration query; you can do this for all queries generated through Squeal. - -- We use `migrateUp` to perform the migration. - -- You can run several migration at the same time, to run only one use `single`. - ---- - -![That was easy](http://gif.eraveline.eu/static/img/0x47f.gif) - ---- - -# Part II. Insertions - ---- - -# Manipulations & Queries - -Besides the specific case of migration, you will mostly perform: - -- `Manipulation` : inserting, updating and deleting data. - -- `Query` : fetching data. - -- Both types are parametric over the same things: - - * A schema - - * Input parameters - - * Output - -- Simplified, they look like this: - -```haskell -Manipulation schema params columns - -Query schema params columns -``` - - ---- - -# Our Haskell model - -```haskell -type Parliament = [Group] - -data Group = - Group { name :: Text - , members :: [MemberOfParliament] } - -data MemberOfParliament = - MemberOfParliament { firstName :: Text - , lastName :: Text } -``` - -> _note_ We didn't use anything from Squeal. -> The model can be entirely separated from the persistence layer. - ---- - -# Inserting a Parliamentary Group - -- A group is very simple: it's a uuid and a name. Let's define our params: - -```haskell -type GroupInsertionParams = '[ 'NotNull 'PGuuid - , 'NotNull 'PGtext ] -``` - -- Params are not named, but they are indexed. You just need nullability and type. - ---- - -```haskell -groupInsertion :: Manipulation Schema GroupInsertionParams '[] -groupInsertion = - insertRow_ #groupp ( Set (param @1) `as` #groupp_id - :* Set (param @2) `as` #name ) -``` - ---- - -- `TypeApplication` lets us use the index of parameters (counting from 1). - -- Once again: all this is checked by the compiler. Wrong name, wrong type... you'll get a compile error. - -- `insertRow_` is a simplified version of `insertRow`. `insertRow` lets you express a `RETURNING` clause and the expected behaviour in case of conflict. - ---- - -_Inserting a Member of Parliament_ -# Doing an INSERT INTO ... SELECT - -- We could create a naive query that takes MP uuid, first name, last name and group uuid... - ---- - -- But that's boring. So let's use the `INSERT INTO ... SELECT`. - ---- - -- We will build a query that will return as constants our MP's uuid, first name and last name... - ---- - -- ... and fetch the uuid of a group given the name of the group. - ---- - -- There's a `insertQuery` utility function for that. All we have to do is write the `select` ! - -```haskell -mpInsertion :: Manipulation Schema MpParams '[] -mpInsertion = - insertQuery_ #mp selectGroup -- we just have to write selectGroup ! -``` - ---- - -_Inserting a Member of Parliament_ -# The query type - -- A query looks just like a `Manipulation`: - -```haskell -Query schema params returns -``` - -- Returns use a special syntax, that demands names, nullability and types: - -```haskell -type ExampleReturnType = '[ "some_column" ::: 'NotNull 'PGuuid - , "other_column" ::: 'Null 'PGtext ] -``` - -- It is not the same as the column definition we used in the schema. That one also expects that you specify, for each column, an eventual default: - -```haskell -type ExampleSchemaCols = - '[ "some_column" ::: 'NoDef :=> 'NotNull 'PGuuid - , "other_column" ::: 'NoDef :=> 'Null 'PGtext ] -``` - ---- - -_Inserting a Member of Parliament_ -# Don't rewrite column definitions - -- We want our return type to be "all columns from table MP expressed as return type". - -- But we cannot reuse our neat `MpCols` alias, since the type do not match as we've just seen. - -- Hopefully, there's a neat Type Family that will let you convert any table you defined to the type of the equivalent row: `TableToRow`. - -- We finally have the signature for our SELECT query. - -```haskell -selectGroup :: Query Schema MpParams (TableToRow MemberOfParliament) -``` - ---- - -_Inserting a Member of Parliament_ -# Our final Select query - -- Our intermediate query looks like this: - -```haskell -selectGroup = - select - ( param @1 `as` #mp_id - :* param @2 `as` #first_name - :* param @3 `as` #last_name - :* #groupp ! #groupp_id `as` #mp_group - ) - ( from (table #groupp) - & where_ ( #groupp ! #name .== param @4 ) - ) -``` - -- The first three columns are constant defined through our params; - -- ... we alias the column name using `as`... - -- ... and when we need the result from the table we use the `#table ! #column` syntax. - -- We'll go back to the "from" block later. - ---- - -# Dealing with the connection context - -- Queries are runned in a connection context: - - * When dealing with a single-connection context, use the type `PQ`. - - * When dealing with a pool of connection, use the type `PoolPQ`. - -- Or get rid of the context and use `mtl` style, with the typeclass `MonadPQ`. - -- We'll use that to demonstrate how to actually run our queries. - ---- - -# Inserting a whole group - -```haskell -insertGroup :: (MonadPQ Schema m, MonadBaseControl IO m) => Group -> m () -insertGroup g@(Group name _) = do - uuid' <- liftBase nextRandom - void $ manipulateParams groupInsertion (uuid', name) - insertMps g -``` - -- Remember that we defined a group as a name and a list of MPs. - -- We are in `MonadBaseControl`, so we cannot use `liftIO`, we need `liftBase`. - -- To perform a simple insertion, use `manipulateParams`. It takes into parameter -instances of `ToParam`, but you will typically use tuples or Generic-SOP. - ---- - -# Inserting a bunch of MPs - -```haskell -insertMps :: (MonadPQ Schema m, MonadBaseControl IO m) => Group -> m () -insertMps (Group groupName mps) = - let tuplify Mp{..} = (, firstName, lastName, groupName) <$> nextRandom - params = traverse tuplify mps - in void $ liftBase params >>= traversePrepared mpInsertion -``` - -- This time, we want to do a `preparedStatement`. We'll use `traversePrepare` -which behaves like `manipulateParams`, but expect a list of `ToParam` -instances. - -- We build our tuple manually again, mostly because we want to generate UUID on -the fly and we don't want to have them in our model. - ---- - -# Inserting a whole parliament - -```haskell -insertParliament :: - (MonadPQ Schema m, MonadBaseControl IO m) => Parliament -> m () -insertParliament = traverse_ insertGroup -``` - -- That's simple enough ! - -- If we want to be a bit safer, though, we can wrap this call in a -`transactionally_` function, which will put all that in a transaction. - ---- - -![Very simple](https://media1.tenor.com/images/0188c63209aced59f1583e1ca94e509e/tenor.gif?itemid=3550689) - - ---- - -# Part III. Selects - ---- - -# Composable queries - -- Building basic queries is easy, and is well documented. - -- However, the real interest of a tool like Squeal is in DRYness, and the documentation is still lacking in "how-to" related to composability. - -- I'll build an example showing how column selections and from clause can be factorized. - -- We want to write two queries: - - * One to get all members of a specific group. - - * One to get all the parliament. - ---- - -# Decomposing a `Query` - -- A query typically stars with `select` (variants are available). - -- It then takes: - - * A heterogenous list of fields with a scary signature; - - * A virtual table (the from clause and filter clauses), called a `TableExpression`. - -- And return fields. Ours will look like this: - -```haskell -type GroupRowResult = - '[ "groupName" ::: 'NotNull 'PGtext - , "firstName" ::: 'NotNull 'PGtext - , "lastName" ::: 'NotNull 'PGtext ] -``` - ---- - -# The Table Expression - -- It necessarily contains a `fromClause` (table, view or subquery, plus optional joins). - -- You can add where, groups, "HAVING" clause, order, etc. - -- `from` creates a basic `TableExpression` that you extend through various function to add clauses. - -- For our queries, we will share a common `FromClause`. - ---- - -# The From Clause - -``` -FromClause schema params from -``` - -- We need Schema, input parameters and a `FromType` giving the available fields of the expression. - -- In our case, we'll join the table `mp` and the table `groupp`, meaning the `from` will be all fields of these tables. - -- We can use `TableToRow` to be more DRY: - -```haskell -type BaseParliamentSelection = - '[ "g" ::: TableToRow GroupCols - , "m" ::: TableToRow MpCols ] -``` - -> _note_ We've also put everything with table aliases: "g" and "m". - ---- - -# Writing our from clause - -```haskell -baseParliamentTables :: - FromClause Schema (param :: [NullType]) BaseParliamentSelection -baseParliamentTables = - table - (#groupp `as` #g) - & innerJoin - (table (#mp `as` #m)) - (#m ! #mp_group .== #g ! #groupp_id) -``` - -- When picking "from" something, you need to specify the type with a function: `table` for a table, `view` for a view, etc. - -- All joins are available. `innerJoin` is the most basic one. It takes the joined table and the joining condition. - -- We have to specifiy the type of `param` (current limitation of the lib), even though _any_ params will be compatible with this, so we can plug `where` clauses depending on params should we need to ! - ---- - -# Typing the common selection - -- Both our querie will need the same fields. This has to be factorized too. - -- The scary signature of selection fields: - -```haskell -NP (Aliased (Expression schema from grouping params)) cols -``` - -- `NP` is for heterogenous lists ("n-ary product"). - -- `from` is the virtual table type, so our `BaseParliamentSelection`. - -- `grouping` is there to make a distinction between aggregated / unaggregated queries. - -- And finally, cols is the return type. - ---- - -# Our common selection - -```haskell -groupSelection :: - NP (Aliased (Expression Schema BaseParliamentSelection 'Ungrouped param)) - GroupRowResult -groupSelection = - #g ! #name `as` #groupName - :* #m ! #first_name `as` #firstName - :* #m ! #last_name `as` #lastName -``` - -- I hope you like big signatures. - -- But it's what let GHC checks that all alias and columns are available. - -- And that you're returning what you really intend to return. - ---- - -# Putting it all together - -```haskell -selectParliament :: Query Schema '[] GroupRowResult -selectParliament = - select groupSelection (from baseParliamentTables) -``` - -```haskell -selectGroupMembers :: Query Schema '[ 'NotNull 'PGtext] GroupRowResult -selectGroupMembers = - select groupSelection - (from baseParliamentTables - & where_ (#g ! #name .== param @1)) -``` - -- That is fairly DRY. And _entirely typesafe_. - ---- - -# Actually fetching the data - -- We'll build an intermediary datatype representing our rows. - -- We'll make it match our row. - -- And we'll add generic-SOP so that we can build them from query results. - -```haskell -type GroupRowResult = - '[ "groupName" ::: 'NotNull 'PGtext - , "firstName" ::: 'NotNull 'PGtext - , "lastName" ::: 'NotNull 'PGtext ] -``` - -```haskell -data GroupRow = - GroupRow { groupName :: Text - , firstName :: Text - , lastName :: Text } - deriving (Generic) - -instance SOP.Generic GroupRow -instance SOP.HasDatatypeInfo GroupRow -``` - ---- - -# Aggregate result logic - -- We will get tabular, SQL data. - -- Our results will be `[GroupRow]`. - -- We'll build `Groups` from this: - -```haskell -buildGroup :: NE.NonEmpty GroupRow -> Group -buildGroup grs = - let buildMP (GroupRow _ f l) = Mp f l - name = groupName . NE.head $ grs - members = NE.toList (buildMP <$> grs) - in Group{..} - -rowToGroups :: [GroupRow] -> [Group] -rowToGroups = - let grouped = fmap NE.fromList . L.groupBy ((==) `on` groupName) - in fmap buildGroup . grouped -``` - ---- - -# Finally calling our queries - -- Query with params will use `runQueryParams`. - -- Query without params will use `runQuery`. - -- Result is inside a `MonadPQ` and of type `K` from generic-sop. - -- You get your actual result using `getRows`. Exemple: - -```haskell -getParliament :: (MonadPQ Schema m, MonadBaseControl IO m) => m [Group] -getParliament = do - res <- runQuery selectParliament - rows <- getRows res - pure $ rowToGroups rows -``` - -- In real life of course you'll write: - -```haskell -getParliament = - rowToGroups <$> (runQuery selectParliament >>= getRows) -``` - ---- - -# Our query with params - -```haskell -getGroupMembers :: - (MonadPQ Schema m, MonadBaseControl IO m) => Text -> m (Maybe Group) -getGroupMembers = - listToMaybe . rowToGroups <$> - (runQueryParams selectGroupMembers (Only t) >>= getRows) -``` - -- And that's it. - ---- - -![Eazy](https://media.tenor.com/images/8fc7c4077efe11b4a3a3b9ae4e643e87/tenor.gif) - ---- - -# Conclusion - ---- - -# Pros & Cons - -- Not everything is included: some cool stuff like array_agg and window functions are not available yet. - -- But development is _very_ active. `IN` clauses were missing but were added in the 4.0 released recently. - -- It's bleeding edge. You need latest LTS to be comfortable and psql >= 9.5. - -- It's Postgres-only but I would say that's a feature. Multi-DB tools are even more complex. - -- The author & maintainer is <3. - -- Typesafe. 'nuff said. - ---- - -# Thank you ! diff --git a/squeal-presentation.pdf b/squeal-presentation.pdf deleted file mode 100644 index 523904e3..00000000 Binary files a/squeal-presentation.pdf and /dev/null differ diff --git a/squeal.gif b/squeal.gif deleted file mode 100644 index e2e62d7e..00000000 Binary files a/squeal.gif and /dev/null differ diff --git a/stack-ghc8_10.yaml b/stack-ghc8_10.yaml new file mode 100644 index 00000000..3561eb09 --- /dev/null +++ b/stack-ghc8_10.yaml @@ -0,0 +1,3 @@ +resolver: lts-18.20 +packages: +- squeal-postgresql diff --git a/stack-ghc8_8.yaml b/stack-ghc8_8.yaml new file mode 100644 index 00000000..3561eb09 --- /dev/null +++ b/stack-ghc8_8.yaml @@ -0,0 +1,3 @@ +resolver: lts-18.20 +packages: +- squeal-postgresql diff --git a/stack.yaml b/stack.yaml index 94846b4b..55e132ba 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,5 +1,3 @@ -resolver: lts-16.16 +resolver: nightly-2021-12-16 packages: - squeal-postgresql -- squeal-postgresql-ltree -- squeal-postgresql-uuid-ossp